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

   1 ;;; Copyright (C) 2010, 2014-2015 Rocky Bernstein <rocky@gnu.org>
   2 (eval-when-compile (require 'cl))
   3
   4 (require 'load-relative)
   5 (require-relative-list '("../../common/track" "../../common/core") "realgud-")
   6 (require-relative-list '("init") "realgud:kshdb-")
   7
   8 (declare-function realgud:expand-file-name-if-exists 'realgud-core)
   9 (declare-function realgud-parse-command-arg  'realgud-core)
  10 (declare-function realgud-query-cmdline      'realgud-core)
  11 (declare-function realgud-suggest-invocation 'realgud-core)
  12
  13 ;; FIXME: I think the following could be generalized and moved to
  14 ;; realgud-... probably via a macro.
  15 (defvar realgud:kshdb-minibuffer-history nil
  16   "minibuffer history list for the command `kshdb'.")
  17
  18 (easy-mmode-defmap kshdb-minibuffer-local-map
  19   '(("\C-i" . comint-dynamic-complete-filename))
  20   "Keymap for minibuffer prompting of gud startup command."
  21   :inherit minibuffer-local-map)
  22
  23 ;; FIXME: I think this code and the keymaps and history
  24 ;; variable chould be generalized, perhaps via a macro.
  25 (defun kshdb-query-cmdline (&optional opt-debugger)
  26   (realgud-query-cmdline
  27    'kshdb-suggest-invocation
  28    kshdb-minibuffer-local-map
  29    'realgud:kshdb-minibuffer-history
  30    opt-debugger))
  31
  32 ;;; FIXME: DRY this with other *-parse-cmd-args routines
  33 (defun kshdb-parse-cmd-args (orig-args)
  34   "Parse command line ARGS for the annotate level and name of script to debug.
  35
  36 ARGS should contain a tokenized list of the command line to run.
  37
  38 We return the a list containing
  39 - the command processor (e.g. kshdb) and it's arguments if any - a list of strings
  40 - the name of the debugger given (e.g. kshdb) and its arguments - a list of strings
  41 - the script name and its arguments - list of strings
  42 - whether the annotate or emacs option was given ('-A', '--annotate' or '--emacs) - a boolean
  43
  44 For example for the following input
  45   (map 'list 'symbol-name
  46    '(ksh -W -C /tmp kshdb --emacs ./gcd.rb a b))
  47
  48 we might return:
  49    ((ksh -W -C) (kshdb --emacs) (./gcd.rb a b) 't)
  50
  51 NOTE: the above should have each item listed in quotes.
  52 "
  53
  54   ;; Parse the following kind of pattern:
  55   ;;  [ksh ksh-options] kshdb kshdb-options script-name script-options
  56   (let (
  57         (args orig-args)
  58         (pair)          ;; temp return from
  59         ;; ksh doesn't have any optional two-arg options
  60         (ksh-opt-two-args '())
  61         (ksh-two-args '("o" "c"))
  62
  63         ;; One dash is added automatically to the below, so
  64         ;; h is really -h and -host is really --host.
  65         (kshdb-two-args '("A" "-annotate" "l" "-library"
  66                           "-highlight" "-no-highlight"
  67                            "c" "-command" "-t" "-tty"
  68                            "x" "-eval-command"))
  69         (kshdb-opt-two-args '())
  70         (interp-regexp
  71          (if (member system-type (list 'windows-nt 'cygwin 'msdos))
  72              "^ksh*\\(.exe\\)?$"
  73            "^ksh*$"))
  74
  75         ;; Things returned
  76         (script-name nil)
  77         (debugger-name nil)
  78         (interpreter-args '())
  79         (debugger-args '())
  80         (script-args '())
  81         (annotate-p nil))
  82
  83     (if (not (and args))
  84         ;; Got nothing: return '(nil, nil)
  85         (list interpreter-args debugger-args script-args annotate-p)
  86       ;; else
  87       ;; Strip off optional "ruby" or "ruby182" etc.
  88       (when (string-match interp-regexp
  89                           (file-name-sans-extension
  90                            (file-name-nondirectory (car args))))
  91         (setq interpreter-args (list (pop args)))
  92
  93         ;; Strip off Ruby-specific options
  94         (while (and args
  95                     (string-match "^-" (car args)))
  96           (setq pair (realgud-parse-command-arg
  97                       args ksh-two-args ksh-opt-two-args))
  98           (nconc interpreter-args (car pair))
  99           (setq args (cadr pair))))
 100
 101       ;; Remove "kshdb" from "kshdb --kshdb-options script
 102       ;; --script-options"
 103       (setq debugger-name (file-name-sans-extension
 104                            (file-name-nondirectory (car args))))
 105       (unless (string-match "^kshdb$" debugger-name)
 106         (message
 107          "Expecting debugger name `%s' to be `kshdb'"
 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            ;; Annotation or emacs option with level number.
 116            ((or (member arg '("--annotate" "-A"))
 117                 (equal arg "--emacs"))
 118             (setq annotate-p t)
 119             (nconc debugger-args (list (pop args))))
 120            ;; Combined annotation and level option.
 121            ((string-match "^--annotate=[0-9]" arg)
 122             (nconc debugger-args (list (pop args)) )
 123             (setq annotate-p t))
 124            ;; Options with arguments.
 125            ((string-match "^-" arg)
 126             (setq pair (realgud-parse-command-arg
 127                         args kshdb-two-args kshdb-opt-two-args))
 128             (nconc debugger-args (car pair))
 129             (setq args (cadr pair)))
 130            ;; Anything else must be the script to debug.
 131            (t (setq script-name (realgud:expand-file-name-if-exists arg))
 132                (setq script-args (cons script-name (cdr args))))
 133            )))
 134       (list interpreter-args debugger-args script-args annotate-p))))
 135
 136 ;;To silence Warning: reference to free variable
 137 (defvar realgud:kshdb-command-name)
 138
 139 (defun kshdb-suggest-invocation (debugger-name)
 140   "Suggest a kshdb command invocation via `realgud-suggest-invocaton'"
 141   (realgud-suggest-invocation realgud:kshdb-command-name
 142                               realgud:kshdb-minibuffer-history
 143                               "sh" "\\.\\(?:k\\)?sh$"))
 144
 145 (defun kshdb-reset ()
 146   "Kshdb cleanup - remove debugger's internal buffers (frame,
 147 breakpoints, etc.)."
 148   (interactive)
 149   ;; (kshdb-breakpoint-remove-all-icons)
 150   (dolist (buffer (buffer-list))
 151     (when (string-match "\\*kshdb-[a-z]+\\*" (buffer-name buffer))
 152       (let ((w (get-buffer-window buffer)))
 153         (when w
 154           (delete-window w)))
 155       (kill-buffer buffer))))
 156
 157 ;; (defun kshdb-reset-keymaps()
 158 ;;   "This unbinds the special debugger keys of the source buffers."
 159 ;;   (interactive)
 160 ;;   (setcdr (assq 'kshdb-debugger-support-minor-mode minor-mode-map-alist)
 161 ;;        kshdb-debugger-support-minor-mode-map-when-deactive))
 162
 163
 164 (defun realgud:kshdb-customize ()
 165   "Use `customize' to edit the settings of the `kshdb' debugger."
 166   (interactive)
 167   (customize-group 'realgud:kshdb))
 168
 169 (provide-me "realgud:kshdb-")