code.delx.au - gnu-emacs-elpa/blob - packages/realgud/realgud/debugger/perldb/core.el

   1 ;;; Copyright (C) 2011, 2013-2014 Rocky Bernstein <rocky@gnu.org>
   2 (eval-when-compile (require 'cl))
   3
   4 (require 'load-relative)
   5 (require-relative-list '("../../common/track"
   6                          "../../common/core"
   7                          "../../common/lang")
   8                        "realgud-")
   9 (require-relative-list '("init") "realgud:perldb-")
  10
  11 (declare-function realgud-lang-mode?         'realgud-lang)
  12 (declare-function realgud:expand-file-name-if-exists 'realgud-core)
  13 (declare-function realgud-parse-command-arg  'realgud-core)
  14 (declare-function realgud-query-cmdline      'realgud-core)
  15 (declare-function realgud-suggest-invocation 'realgud-core)
  16
  17 ;; FIXME: I think the following could be generalized and moved to
  18 ;; realgud-... probably via a macro.
  19 (defvar realgud:perldb-minibuffer-history nil
  20   "minibuffer history list for the command `perldb'.")
  21
  22 (easy-mmode-defmap realgud:perldb-minibuffer-local-map
  23   '(("\C-i" . comint-dynamic-complete-filename))
  24   "Keymap for minibuffer prompting of perldb startup command."
  25   :inherit minibuffer-local-map)
  26
  27 ;; FIXME: I think this code and the keymaps and history
  28 ;; variable chould be generalized, perhaps via a macro.
  29 (defun realgud:perldb-query-cmdline (&optional opt-debugger)
  30   (realgud-query-cmdline
  31    'realgud:perldb-suggest-invocation
  32    realgud:perldb-minibuffer-local-map
  33    'realgud:perldb-minibuffer-history
  34    opt-debugger))
  35
  36 ;;; FIXME: DRY this with other *-parse-cmd-args routines
  37 (defun realgud:perldb-parse-cmd-args (orig-args)
  38   "Parse command line ARGS for the annotate level and name of script to debug.
  39
  40 ORIG-ARGS should contain a tokenized list of the command line to run.
  41
  42 We return the a list containing
  43
  44 * the command processor (e.g. perl) and it's arguments if any - a
  45   list of strings
  46
  47 * the script name and its arguments - list of strings
  48
  49 For example for the following input:
  50   (map 'list 'symbol-name
  51    '(perl -W -C /tmp -d ./gcd.pl a b))
  52
  53 we might return:
  54    ((\"perl\" \"-W\" \"-C\" \"-d\") nil (\"/tmp/gcd.pl\" \"a\" \"b\"))
  55
  56 Note that path elements have been expanded via `realgud:expand-file-name-if-exists'.
  57 "
  58
  59   ;; Parse the following kind of pattern:
  60   ;;  [perl perl-options] perldb perldb-options script-name script-options
  61   (let (
  62         (args orig-args)
  63         (pair)          ;; temp return from
  64         (perl-opt-two-args '("0" "C" "D" "i" "l" "m" "-module" "x"))
  65         ;; Perl doesn't have mandatory 2-arg options in our sense,
  66         ;; since the two args can be run together, e.g. "-C/tmp" or "-C /tmp"
  67         ;;
  68         (perl-two-args '())
  69         ;; One dash is added automatically to the below, so
  70         ;; h is really -h and -host is really --host.
  71         (perldb-two-args '("e" "E"))
  72         (perldb-opt-two-args '())
  73         (interp-regexp
  74          (if (member system-type (list 'windows-nt 'cygwin 'msdos))
  75              "^perl\\(?:5[0-9.]*\\)\\(.exe\\)?$"
  76            "^perl\\(?:5[0-9.]*\\)?$"))
  77
  78         ;; Things returned
  79         (script-name nil)
  80         (debugger-name nil)
  81         (interpreter-args '())
  82         (script-args '())
  83         )
  84
  85     (if (not (and args))
  86         ;; Got nothing
  87         (list interpreter-args nil script-args)
  88       ;; else
  89       ;; Remove "perl" or "perl5.10.1" etc.
  90       (when (string-match interp-regexp
  91                           (file-name-sans-extension
  92                            (file-name-nondirectory (car args))))
  93         (setq interpreter-args (list (pop args)))
  94
  95         ;; Skip to the first non-option argument
  96         (while (and args (not script-name))
  97           (let ((arg (car args)))
  98             (cond
  99              ;; Options with arguments.
 100              ((string-match "^-" (car args))
 101               (setq pair (realgud-parse-command-arg
 102                           args perl-two-args perl-opt-two-args))
 103               (nconc interpreter-args (car pair))
 104               (setq args (cadr pair)))
 105              ;; Anything else must be the script to debug.
 106              (t (setq script-name (realgud:expand-file-name-if-exists arg))
 107                 (setq script-args (cons script-name (cdr args))))
 108              )))
 109         (list interpreter-args nil script-args)))
 110     ))
 111
 112 ; # To silence Warning: reference to free variable
 113 (defvar realgud:perldb-command-name)
 114
 115 (defun realgud:perldb-suggest-invocation (debugger-name)
 116   "Suggest a perldb command invocation via `realgud-suggest-invocaton'"
 117   (realgud-suggest-invocation realgud:perldb-command-name
 118                               realgud:perldb-minibuffer-history
 119                               "perl" "\\.pl$"))
 120
 121 (defun realgud:perldb-reset ()
 122   "Perldb cleanup - remove debugger's internal buffers (frame,
 123 breakpoints, etc.)."
 124   (interactive)
 125   ;; (perldb-breakpoint-remove-all-icons)
 126   (dolist (buffer (buffer-list))
 127     (when (string-match "\\*perldb-[a-z]+\\*" (buffer-name buffer))
 128       (let ((w (get-buffer-window buffer)))
 129         (when w
 130           (delete-window w)))
 131       (kill-buffer buffer))))
 132
 133 ;; (defun perldb-reset-keymaps()
 134 ;;   "This unbinds the special debugger keys of the source buffers."
 135 ;;   (interactive)
 136 ;;   (setcdr (assq 'perldb-debugger-support-minor-mode minor-mode-map-alist)
 137 ;;        perldb-debugger-support-minor-mode-map-when-deactive))
 138
 139
 140 (defun realgud:perldb-customize ()
 141   "Use `customize' to edit the settings of the `perldb' debugger."
 142   (interactive)
 143   (customize-group 'realgud:perldb))
 144
 145 (provide-me "realgud:perldb-")