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

   1 ;;; Copyright (C) 2010-2015 Rocky Bernstein <rocky@gnu.org>
   2 ; (require 'term)
   3 (if (< emacs-major-version 24)
   4     (error
   5      "You need at least Emacs 24 or greater to run this - you have version %d"
   6      emacs-major-version))
   7
   8 (require 'comint)
   9 (require 'load-relative)
  10 (require 'loc-changes)
  11 (require-relative-list '("fringe" "helper" "lang" "reset")
  12                        "realgud-")
  13 (require-relative-list '("buffer/command" "buffer/source") "realgud-buffer-")
  14
  15 (declare-function comint-exec  'comint)
  16 (declare-function comint-mode  'comint)
  17 (declare-function realgud-bp-remove-icons             'realgud-bp)
  18 (declare-function realgud:suggest-file-from-buffer    'realgud-lang)
  19 (declare-function realgud-cmdbuf-args=                'realgud-buffer-command)
  20 (declare-function realgud-cmdbuf-command-string       'realgud-buffer-command)
  21 (declare-function realgud-cmdbuf-debugger-name        'realgud-buffer-command)
  22 (declare-function realgud-cmdbuf-info-bp-list=        'realgud-buffer-command)
  23 (declare-function realgud-cmdbuf-info-in-debugger?=   'realgud-buffer-command)
  24 (declare-function realgud-cmdbuf-mode-line-update     'realgud-buffer-command)
  25 (declare-function realgud-cmdbuf?                     'realgud-helper)
  26 (declare-function realgud-command-string              'realgud-buffer-command)
  27 (declare-function realgud-fringe-erase-history-arrows 'realgud-buffer-command)
  28 (declare-function realgud-get-cmdbuf                  'realgud-helper)
  29 (declare-function realgud:reset                       'realgud-reset)
  30 (declare-function realgud-short-key-mode-setup        'realgud-shortkey)
  31 (declare-function realgud-srcbuf-command-string       'realgud-buffer-source)
  32 (declare-function realgud-srcbuf-debugger-name        'realgud-buffer-source)
  33 (declare-function realgud-srcbuf-init                 'realgud-buffer-source)
  34 (declare-function realgud-srcbuf?                     'realgud-buffer-source)
  35 (declare-function realgud-suggest-lang-file           'realgud-lang)
  36
  37 (defvar realgud-srcbuf-info)
  38
  39 (defun realgud:expand-file-name-if-exists (filename)
  40   "Return FILENAME expanded using `expand-file-name' if that name exists.
  41 Otherwise, just return FILENAME."
  42   (let* ((expanded-filename (expand-file-name filename))
  43          (result (cond ((file-exists-p expanded-filename)
  44                           expanded-filename)
  45                          ('t filename))))
  46     result)
  47 )
  48
  49 (defun realgud-suggest-invocation
  50   (debugger-name minibuffer-history lang-str lang-ext-regexp
  51                  &optional last-resort)
  52   "Suggest a debugger command invocation. If the current buffer
  53 is a source file or process buffer previously set, then use the
  54 value of that the command invocations found by buffer-local
  55 variables. Next, try to use the first value of MINIBUFFER-HISTORY
  56 if that exists.  Finally we try to find a suitable program file
  57 using LANG-STR and LANG-EXT-REGEXP."
  58   (let* ((buf (current-buffer))
  59          (filename)
  60          (cmd-str-cmdbuf (realgud-cmdbuf-command-string buf))
  61          )
  62     (cond
  63      ((and cmd-str-cmdbuf (equal debugger-name (realgud-cmdbuf-debugger-name buf)))
  64       cmd-str-cmdbuf)
  65      ((and minibuffer-history (listp minibuffer-history))
  66       (car minibuffer-history))
  67      ((setq filename (realgud:suggest-file-from-buffer lang-str))
  68       (concat debugger-name " " filename))
  69      (t (concat debugger-name " "
  70                 (realgud-suggest-lang-file lang-str lang-ext-regexp last-resort)))
  71      )))
  72
  73 (defun realgud-query-cmdline
  74   (suggest-invocation-fn
  75    minibuffer-local-map
  76    minibuffer-history
  77    &optional opt-debugger)
  78   "Prompt for a debugger command invocation to run.
  79 Analogous to `gud-query-cmdline'.
  80
  81 If you happen to be in a debugger process buffer, the last command invocation
  82 for that first one suggested. Failing that, some amount of guessing is done
  83 to find a suitable file via SUGGEST-INVOCATION-FN.
  84
  85 We also set filename completion and use a history of the prior
  86 dbgr invocations "
  87   (let ((debugger (or opt-debugger
  88                    (realgud-sget 'srcbuf-info 'debugger-name))))
  89     (read-from-minibuffer
  90      (format "Run %s (like this): " debugger)  ;; prompt string
  91      (funcall suggest-invocation-fn debugger)  ;; initial value
  92      minibuffer-local-map                      ;; keymap
  93      nil                                       ;; read - use default value
  94      minibuffer-history                        ;; history variable
  95      )))
  96
  97 (defun realgud-parse-command-arg (args two-args opt-two-args)
  98   "Return a cons node where the car is a list containing the
  99 entire first option and the cdr is the remaining arguments from ARGS.
 100
 101 We determine if an option has length one or two using the lists
 102 TWO-ARGS and OPT-TWO-ARGS. Both of these are list of 'options',
 103 that is strings without the leading dash. TWO-ARGS takes a
 104 mandatory additional argument. OPT-TWO-ARGS might take two
 105 arguments. The rule for an optional argument that we use is if
 106 the next parameter starts with a dash ('-'), it is not part of
 107 the preceeding parameter when that parameter is optional.
 108
 109 NOTE: we don't check whether the first arguments of ARGS is an
 110 option by testing to see if it starts say with a dash. So on
 111 return the first argument is always removed.
 112 "
 113   (let ((arg (car args))
 114         (d-two-args (mapcar (lambda(x) (concat "-" x)) two-args))
 115         (d-opt-two-args (mapcar (lambda(x) (concat "-" x)) opt-two-args))
 116         (remaining (cdr args)))
 117     (cond
 118      ((member arg d-two-args)
 119       (if (not remaining)
 120             (progn
 121               (message "Expecting an argument after %s. Continuing anyway."
 122                        arg)
 123               (cons (list arg) (list remaining)))
 124         (cons (list arg (car remaining)) (list (cdr remaining)))))
 125      ((member arg d-opt-two-args)
 126       (if (and remaining (not (string-match "^-" (car remaining))))
 127           (cons (list arg (car remaining)) (list (cdr remaining)))
 128         (cons (list arg) (list remaining))))
 129      (t (cons (list arg) (list remaining))))))
 130
 131 (defun realgud:terminate-srcbuf (&optional srcbuf)
 132   "Resets source buffer."
 133   (interactive "bsource buffer: ")
 134   (if (stringp srcbuf) (setq srcbuf (get-buffer srcbuf)))
 135   (with-current-buffer srcbuf
 136     (realgud-fringe-erase-history-arrows)
 137     (realgud-bp-remove-icons (point-min) (point-max))
 138     (when (realgud-srcbuf?)
 139       (realgud-short-key-mode-setup nil)
 140       (redisplay)
 141       )
 142     (loc-changes-clear-buffer)
 143     ))
 144
 145 (defun realgud:terminate (&optional buf)
 146   "Resets state in all buffers associated with source or command
 147 buffer BUF) This does things like remove fringe arrows breakpoint
 148 icons and resets short-key mode."
 149   (interactive "bbuffer: ")
 150   (if (stringp buf) (setq buf (get-buffer buf)))
 151   (let ((cmdbuf (realgud-get-cmdbuf buf)))
 152     (if cmdbuf
 153         (with-current-buffer cmdbuf
 154           (realgud-cmdbuf-info-in-debugger?= nil)
 155           (realgud-cmdbuf-info-bp-list= '())
 156           (realgud-cmdbuf-mode-line-update)
 157           (realgud-fringe-erase-history-arrows)
 158           (if realgud-cmdbuf-info
 159               (dolist (srcbuf (realgud-cmdbuf-info-srcbuf-list realgud-cmdbuf-info))
 160                 (if (realgud-srcbuf? srcbuf)
 161                     (with-current-buffer srcbuf
 162                       (realgud:terminate-srcbuf srcbuf)
 163                       ))
 164                 )
 165             )
 166           )
 167       (error "Buffer %s does not seem to be attached to a debugger"
 168              (buffer-name))
 169       )
 170     )
 171   )
 172
 173 (defun realgud:kill-buffer-hook ()
 174   "When a realgud command buffer is killed, call `realgud:terminate' to
 175 clean up.
 176 Note that `realgud-term-sentinel' is not helpful here because
 177 the buffer and data associated with it are already gone."
 178   (when (realgud-cmdbuf?) (realgud:terminate (current-buffer)))
 179 )
 180 (add-hook 'kill-buffer-hook 'realgud:kill-buffer-hook)
 181
 182 (defun realgud-term-sentinel (process string)
 183   "Called when PROCESS dies. We call `realgud:terminate' to clean up."
 184   (let ((cmdbuf (realgud-get-cmdbuf)))
 185     (if cmdbuf (realgud:terminate cmdbuf)))
 186   (message "That's all folks.... %s" string))
 187
 188 (defun realgud:binary (file-name)
 189 "Return a priority for wehther file-name is likely we can run gdb on"
 190   (let ((output (shell-command-to-string (format "file %s" file-name))))
 191     (cond
 192      ((string-match "ELF" output) t)
 193      ('t nil))))
 194
 195
 196 (defun realgud-exec-shell (debugger-name script-filename program
 197                                       &optional no-reset &rest args)
 198   "Run the specified SCRIPT-FILENAME in under debugger DEBUGGER-NAME a
 199 comint process buffer. ARGS are the arguments passed to the
 200 PROGRAM.  At the moment, no piping of input is allowed.
 201
 202 SCRIPT-FILENAME will have local variable `realgud-script-info' set
 203 which contains the debugger name and debugger process-command
 204 buffer.
 205
 206 Normally command buffers are reused when the same debugger is
 207 reinvoked inside a command buffer with a similar command. If we
 208 discover that the buffer has prior command-buffer information and
 209 NO-RESET is nil, then that information which may point into other
 210 buffers and source buffers which may contain marks and fringe or
 211 marginal icons is reset."
 212
 213   (let* ((starting-directory
 214           (or (file-name-directory script-filename)
 215               default-directory "./"))
 216          (cmdproc-buffer-name
 217           (format "*%s %s shell*"
 218                   (file-name-nondirectory debugger-name)
 219                   (file-name-nondirectory script-filename)))
 220          (cmdproc-buffer (get-buffer-create cmdproc-buffer-name))
 221          (realgud-buf (current-buffer))
 222          (cmd-args (cons program args))
 223          (process (get-buffer-process cmdproc-buffer)))
 224
 225
 226     (with-current-buffer cmdproc-buffer
 227       ;; If the found command buffer isn't for the same debugger
 228       ;; invocation command, rename that and start a new one.
 229       ;;
 230       ;; For example: "bashdb /tmp/foo" does not match "bashdb
 231       ;; /etc/foo" even though they both canonicalize to the buffer
 232       ;; "*bashdb foo shell*"
 233       (unless (and (realgud-cmdbuf?)
 234                  (equal cmd-args
 235                         (realgud-cmdbuf-info-cmd-args realgud-cmdbuf-info)))
 236         (rename-uniquely)
 237         (setq cmdproc-buffer (get-buffer-create cmdproc-buffer-name))
 238         (setq process nil)
 239         ))
 240
 241     (unless (and process (eq 'run (process-status process)))
 242       (with-current-buffer cmdproc-buffer
 243         (and (realgud-cmdbuf?) (not no-reset) (realgud:reset))
 244         (setq default-directory default-directory)
 245         (insert "Current directory: " default-directory "\n")
 246         (insert "Command: " (mapconcat 'identity cmd-args " ") "\n")
 247
 248         ;; For term.el
 249         ;; (term-mode)
 250         ;; (set (make-local-variable 'term-term-name) realgud-term-name)
 251         ;; (make-local-variable 'realgud-parent-buffer)
 252         ;; (setq realgud-parent-buffer realgud-buf)
 253
 254         ;; For comint.el.
 255         (comint-mode)
 256
 257         ;; Making overlay-arrow-variable-list buffer local has to be
 258         ;; done after running commint mode. FIXME: find out why and if
 259         ;; this reason is justifyable. Also consider moving this somewhere
 260         ;; else.
 261         (make-local-variable 'overlay-arrow-variable-list)
 262         (make-local-variable 'realgud-overlay-arrow1)
 263         (make-local-variable 'realgud-overlay-arrow2)
 264         (make-local-variable 'realgud-overlay-arrow3)
 265
 266         (condition-case nil
 267             (comint-exec cmdproc-buffer debugger-name program nil args)
 268           (error cmdproc-buffer))
 269
 270         (setq process (get-buffer-process cmdproc-buffer))
 271
 272         (if (and process (eq 'run (process-status process)))
 273           (let ((src-buffer)
 274                 (cmdline-list (cons program args)))
 275             ;; is this right?
 276             (unless (realgud:binary script-filename)
 277               (setq src-buffer (find-file-noselect script-filename))
 278               (point-max)
 279               (realgud-srcbuf-init src-buffer cmdproc-buffer))
 280             )
 281           ;; else
 282           (insert
 283            (format
 284             "Failed to invoke debugger %s on program %s with args %s\n"
 285             debugger-name program (mapconcat 'identity args " ")))
 286           (error cmdproc-buffer)
 287           )
 288         (process-put process 'buffer cmdproc-buffer)))
 289     cmdproc-buffer))
 290
 291 ;; Start of a term-output-filter for term.el
 292 (defun realgud-term-output-filter (process string)
 293   (let ((process-buffer (process-get process 'buffer)))
 294     (if process-buffer
 295         (save-current-buffer
 296           (set-buffer process-buffer)
 297           ;; (insert-before-markers (format "+++1 %s" string))
 298           (insert-before-markers string)))))
 299
 300 (provide-me "realgud-")