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

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