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

   1 ;;; Copyright (C) 2010, 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
  10 (declare-function realgud:expand-file-name-if-exists 'realgud-core)
  11 (declare-function realgud-lang-mode? 'realgud-lang)
  12 (declare-function realgud-parse-command-arg 'realgud-core)
  13 (declare-function realgud-query-cmdline 'realgud-core)
  14
  15 ;; FIXME: I think the following could be generalized and moved to
  16 ;; realgud-... probably via a macro.
  17 (defvar realgud:gdb-minibuffer-history nil
  18   "minibuffer history list for the command `gdb'.")
  19
  20 (easy-mmode-defmap realgud:gdb-minibuffer-local-map
  21   '(("\C-i" . comint-dynamic-complete-filename))
  22   "Keymap for minibuffer prompting of gud 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 realgud:gdb-query-cmdline (&optional opt-debugger)
  28   (realgud-query-cmdline
  29    'realgud:gdb-suggest-invocation
  30    realgud:gdb-minibuffer-local-map
  31    'realgud:gdb-minibuffer-history
  32    opt-debugger))
  33
  34 (defun realgud:gdb-parse-cmd-args (orig-args)
  35   "Parse command line ARGS for the annotate level and name of script to debug.
  36
  37 ORIG_ARGS should contain a tokenized list of the command line to run.
  38
  39 We return the a list containing
  40 * the name of the debugger given (e.g. gdb) and its arguments - a list of strings
  41 * nil (a placehoder in other routines of this ilk for a debugger
  42 * the script name and its arguments - list of strings
  43 * whether the annotate or emacs option was given ('-A', '--annotate' or '--emacs) - a boolean
  44
  45 For example for the following input
  46   (map 'list 'symbol-name
  47    '(gdb --tty /dev/pts/1 -cd ~ --emacs ./gcd.py a b))
  48
  49 we might return:
  50    ((\"gdb\" \"--tty\" \"/dev/pts/1\" \"-cd\" \"home/rocky\' \"--emacs\") nil \"(/tmp/gcd.py a b\") 't\")
  51
  52 Note that path elements have been expanded via `expand-file-name'.
  53 "
  54
  55   ;; Parse the following kind of pattern:
  56   ;;  gdb gdb-options script-name script-options
  57   (let (
  58         (args orig-args)
  59         (pair)          ;; temp return from
  60
  61         ;; One dash is added automatically to the below, so
  62         ;; h is really -h and -host is really --host.
  63         (gdb-two-args '("x" "-command" "b" "-exec"
  64                         "cd" "-pid"  "-core" "-directory"
  65                         "-annotate"
  66                         "se" "-symbols" "-tty"))
  67         ;; gdb doesn't optionsl 2-arg options.
  68         (gdb-opt-two-args '())
  69
  70         ;; Things returned
  71         (script-name nil)
  72         (debugger-name nil)
  73         (debugger-args '())
  74         (script-args '())
  75         (annotate-p nil))
  76
  77     (if (not (and args))
  78         ;; Got nothing: return '(nil nil nil nil)
  79         (list debugger-args nil script-args annotate-p)
  80       ;; else
  81       (progn
  82
  83         ;; Remove "gdb" from "gdb --gdb-options script
  84         ;; --script-options"
  85         (setq debugger-name (file-name-sans-extension
  86                              (file-name-nondirectory (car args))))
  87         (unless (string-match "^gdb.*" debugger-name)
  88           (message
  89            "Expecting debugger name `%s' to be `gdb'"
  90            debugger-name))
  91         (setq debugger-args (list (pop args)))
  92
  93         ;; Skip to the first non-option argument.
  94         (while (and args (not script-name))
  95           (let ((arg (car args)))
  96             (cond
  97              ;; Annotation or emacs option with level number.
  98              ((or (member arg '("--annotate" "-A"))
  99                   (equal arg "--emacs"))
 100               (setq annotate-p t)
 101               (nconc debugger-args (list (pop args) (pop args))))
 102              ;; Combined annotation and level option.
 103              ((string-match "^--annotate=[0-9]" arg)
 104               (nconc debugger-args (list (pop args) (pop args)) )
 105               (setq annotate-p t))
 106              ;; path-argument ooptions
 107              ((member arg '("-cd" ))
 108               (setq arg (pop args))
 109               (nconc debugger-args
 110                      (list arg (realgud:expand-file-name-if-exists
 111                                 (pop args)))))
 112              ;; Options with arguments.
 113              ((string-match "^-" arg)
 114               (setq pair (realgud-parse-command-arg
 115                           args gdb-two-args gdb-opt-two-args))
 116               (nconc debugger-args (car pair))
 117               (setq args (cadr pair)))
 118              ;; Anything else must be the script to debug.
 119              (t (setq script-name arg)
 120                 (setq script-args args))
 121              )))
 122         (list debugger-args nil script-args annotate-p)))))
 123
 124 (defvar realgud:gdb-command-name)
 125
 126 (defun realgud:gdb-executable (file-name)
 127 "Return a priority for wehther file-name is likely we can run gdb on"
 128   (let ((output (shell-command-to-string (format "file %s" file-name))))
 129     (cond
 130      ((string-match "ASCII" output) 2)
 131      ((string-match "ELF" output) 7)
 132      ((string-match "executable" output) 6)
 133      ('t 5))))
 134
 135
 136 (defun realgud:gdb-suggest-invocation (&optional debugger-name)
 137   "Suggest a gdb command invocation. Here is the priority we use:
 138 * an executable file with the name of the current buffer stripped of its extension
 139 * any executable file in the current directory with no extension
 140 * the last invocation in gdb:minibuffer-history
 141 * any executable in the current directory
 142 When all else fails return the empty string."
 143   (let* ((file-list (directory-files default-directory))
 144          (priority 2)
 145          (best-filename nil)
 146          (try-filename (file-name-base (or (buffer-file-name) "gdb"))))
 147     (when (member try-filename (directory-files default-directory))
 148         (setq best-filename try-filename)
 149         (setq priority (+ (realgud:gdb-executable try-filename) 2)))
 150
 151     ;; FIXME: I think a better test would be to look for
 152     ;; c-mode in the buffer that have a corresponding executable
 153     (while (and (setq try-filename (car-safe file-list)) (< priority 8))
 154       (setq file-list (cdr file-list))
 155       (if (and (file-executable-p try-filename)
 156                (not (file-directory-p try-filename)))
 157           (if (equal try-filename (file-name-sans-extension try-filename))
 158               (progn
 159                 (setq best-filename try-filename)
 160                 (setq priority (1+ (realgud:gdb-executable best-filename))))
 161             ;; else
 162             (progn
 163               (setq best-filename try-filename)
 164               (setq priority (realgud:gdb-executable best-filename))
 165               ))
 166         ))
 167     (if (< priority 8)
 168         (cond
 169          (realgud:gdb-minibuffer-history
 170           (car realgud:gdb-minibuffer-history))
 171          ((equal priority 7)
 172           (concat "gdb " best-filename))
 173          (t "gdb "))
 174       ;; else
 175       (concat "gdb " best-filename))
 176     ))
 177
 178 (defun realgud:gdb-reset ()
 179   "Gdb cleanup - remove debugger's internal buffers (frame,
 180 breakpoints, etc.)."
 181   (interactive)
 182   ;; (gdb-breakpoint-remove-all-icons)
 183   (dolist (buffer (buffer-list))
 184     (when (string-match "\\*gdb-[a-z]+\\*" (buffer-name buffer))
 185       (let ((w (get-buffer-window buffer)))
 186         (when w
 187           (delete-window w)))
 188       (kill-buffer buffer))))
 189
 190 ;; (defun gdb-reset-keymaps()
 191 ;;   "This unbinds the special debugger keys of the source buffers."
 192 ;;   (interactive)
 193 ;;   (setcdr (assq 'gdb-debugger-support-minor-mode minor-mode-map-alist)
 194 ;;        gdb-debugger-support-minor-mode-map-when-deactive))
 195
 196
 197 (defun realgud:gdb-customize ()
 198   "Use `customize' to edit the settings of the `realgud:gdb' debugger."
 199   (interactive)
 200   (customize-group 'realgud:gdb))
 201
 202 (provide-me "realgud:gdb-")