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

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