You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
326 lines
12 KiB
326 lines
12 KiB
;; Copyright (C) 2010-2016 Free Software Foundation, Inc
|
|
|
|
;; Author: Rocky Bernstein <rocky@gnu.org>
|
|
|
|
;; This program is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; (require 'term)
|
|
|
|
(require 'comint)
|
|
(require 'load-relative)
|
|
(require 'loc-changes)
|
|
(require-relative-list '("fringe" "helper" "lang" "reset")
|
|
"realgud-")
|
|
(require-relative-list '("buffer/command" "buffer/source") "realgud-buffer-")
|
|
|
|
(declare-function comint-exec 'comint)
|
|
(declare-function comint-mode 'comint)
|
|
(declare-function realgud-bp-remove-icons 'realgud-bp)
|
|
(declare-function realgud:suggest-file-from-buffer 'realgud-lang)
|
|
(declare-function realgud-cmdbuf-args= 'realgud-buffer-command)
|
|
(declare-function realgud-cmdbuf-command-string 'realgud-buffer-command)
|
|
(declare-function realgud-cmdbuf-debugger-name 'realgud-buffer-command)
|
|
(declare-function realgud-cmdbuf-info-bp-list= 'realgud-buffer-command)
|
|
(declare-function realgud-cmdbuf-info-in-debugger?= 'realgud-buffer-command)
|
|
(declare-function realgud-cmdbuf-info-starting-directory= 'realgud-buffer-command)
|
|
(declare-function realgud-cmdbuf-mode-line-update 'realgud-buffer-command)
|
|
(declare-function realgud-cmdbuf? 'realgud-helper)
|
|
(declare-function realgud-command-string 'realgud-buffer-command)
|
|
(declare-function realgud-fringe-erase-history-arrows 'realgud-buffer-command)
|
|
(declare-function realgud-get-cmdbuf 'realgud-helper)
|
|
(declare-function realgud:reset 'realgud-reset)
|
|
(declare-function realgud-short-key-mode-setup 'realgud-shortkey)
|
|
(declare-function realgud-srcbuf-command-string 'realgud-buffer-source)
|
|
(declare-function realgud-srcbuf-debugger-name 'realgud-buffer-source)
|
|
(declare-function realgud-srcbuf-init 'realgud-buffer-source)
|
|
(declare-function realgud-srcbuf? 'realgud-buffer-source)
|
|
(declare-function realgud-suggest-lang-file 'realgud-lang)
|
|
|
|
(defvar realgud-srcbuf-info)
|
|
(defvar starting-directory)
|
|
|
|
(defun realgud:expand-file-name-if-exists (filename)
|
|
"Return FILENAME expanded using `expand-file-name' if that name exists.
|
|
Otherwise, just return FILENAME."
|
|
(let* ((expanded-filename (expand-file-name filename))
|
|
(result (cond ((file-exists-p expanded-filename)
|
|
expanded-filename)
|
|
('t filename))))
|
|
result)
|
|
)
|
|
|
|
(defun realgud-suggest-invocation
|
|
(debugger-name _minibuffer-history lang-str lang-ext-regexp
|
|
&optional last-resort)
|
|
"Suggest a debugger command invocation. If the current buffer
|
|
is a source file or process buffer previously set, then use the
|
|
value of that the command invocations found by buffer-local
|
|
variables. Otherwise, we try to find a suitable program file
|
|
using LANG-STR and LANG-EXT-REGEXP."
|
|
(let* ((buf (current-buffer))
|
|
(filename)
|
|
(cmd-str-cmdbuf (realgud-cmdbuf-command-string buf))
|
|
)
|
|
(cond
|
|
((and cmd-str-cmdbuf (equal debugger-name (realgud-cmdbuf-debugger-name buf)))
|
|
cmd-str-cmdbuf)
|
|
((setq filename (realgud:suggest-file-from-buffer lang-str))
|
|
(concat debugger-name " " (shell-quote-argument filename)))
|
|
(t (concat debugger-name " "
|
|
(shell-quote-argument
|
|
(realgud-suggest-lang-file lang-str lang-ext-regexp last-resort))))
|
|
)))
|
|
|
|
(defun realgud-query-cmdline
|
|
(suggest-invocation-fn
|
|
minibuffer-local-map
|
|
minibuffer-history
|
|
&optional opt-debugger)
|
|
"Prompt for a debugger command invocation to run.
|
|
Analogous to `gud-query-cmdline'.
|
|
|
|
If you happen to be in a debugger process buffer, the last command invocation
|
|
for that first one suggested. Failing that, some amount of guessing is done
|
|
to find a suitable file via SUGGEST-INVOCATION-FN.
|
|
|
|
We also set filename completion and use a history of the prior
|
|
dbgr invocations "
|
|
(let ((debugger (or opt-debugger
|
|
(realgud-sget 'srcbuf-info 'debugger-name))))
|
|
(read-shell-command
|
|
(format "Run %s (like this): " debugger) ;; prompt string
|
|
(funcall suggest-invocation-fn debugger) ;; initial value
|
|
minibuffer-history ;; history variable
|
|
)))
|
|
|
|
(defun realgud-parse-command-arg (args two-args opt-two-args)
|
|
"Return a cons node where the car is a list containing the
|
|
entire first option and the cdr is the remaining arguments from ARGS.
|
|
|
|
We determine if an option has length one or two using the lists
|
|
TWO-ARGS and OPT-TWO-ARGS. Both of these are list of 'options',
|
|
that is strings without the leading dash. TWO-ARGS takes a
|
|
mandatory additional argument. OPT-TWO-ARGS might take two
|
|
arguments. The rule for an optional argument that we use is if
|
|
the next parameter starts with a dash ('-'), it is not part of
|
|
the preceeding parameter when that parameter is optional.
|
|
|
|
NOTE: we don't check whether the first arguments of ARGS is an
|
|
option by testing to see if it starts say with a dash. So on
|
|
return the first argument is always removed.
|
|
"
|
|
(let ((arg (car args))
|
|
(d-two-args (mapcar (lambda(x) (concat "-" x)) two-args))
|
|
(d-opt-two-args (mapcar (lambda(x) (concat "-" x)) opt-two-args))
|
|
(remaining (cdr args)))
|
|
(cond
|
|
((member arg d-two-args)
|
|
(if (not remaining)
|
|
(progn
|
|
(message "Expecting an argument after %s. Continuing anyway."
|
|
arg)
|
|
(cons (list arg) (list remaining)))
|
|
(cons (list arg (car remaining)) (list (cdr remaining)))))
|
|
((member arg d-opt-two-args)
|
|
(if (and remaining (not (string-match "^-" (car remaining))))
|
|
(cons (list arg (car remaining)) (list (cdr remaining)))
|
|
(cons (list arg) (list remaining))))
|
|
(t (cons (list arg) (list remaining))))))
|
|
|
|
(defun realgud:terminate-srcbuf (&optional srcbuf)
|
|
"Resets source buffer."
|
|
(interactive "bsource buffer: ")
|
|
(if (stringp srcbuf) (setq srcbuf (get-buffer srcbuf)))
|
|
(with-current-buffer srcbuf
|
|
(realgud-fringe-erase-history-arrows)
|
|
(realgud-bp-remove-icons (point-min) (point-max))
|
|
(when (realgud-srcbuf?)
|
|
(realgud-short-key-mode-setup nil)
|
|
(redisplay)
|
|
)
|
|
(loc-changes-clear-buffer)
|
|
))
|
|
|
|
(defun realgud:terminate (&optional buf)
|
|
"Resets state in all buffers associated with source or command
|
|
buffer BUF) This does things like remove fringe arrows breakpoint
|
|
icons and resets short-key mode."
|
|
(interactive "bbuffer: ")
|
|
(if (stringp buf) (setq buf (get-buffer buf)))
|
|
(let ((cmdbuf (realgud-get-cmdbuf buf)))
|
|
(if cmdbuf
|
|
(with-current-buffer cmdbuf
|
|
(realgud-cmdbuf-info-in-debugger?= nil)
|
|
(realgud-cmdbuf-info-bp-list= '())
|
|
(realgud-cmdbuf-mode-line-update)
|
|
(realgud-fringe-erase-history-arrows)
|
|
(if realgud-cmdbuf-info
|
|
(dolist (srcbuf (realgud-cmdbuf-info-srcbuf-list realgud-cmdbuf-info))
|
|
(if (realgud-srcbuf? srcbuf)
|
|
(with-current-buffer srcbuf
|
|
(realgud:terminate-srcbuf srcbuf)
|
|
))
|
|
)
|
|
)
|
|
)
|
|
(error "Buffer %s does not seem to be attached to a debugger"
|
|
(buffer-name))
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun realgud:kill-buffer-hook ()
|
|
"When a realgud command buffer is killed, call `realgud:terminate' to
|
|
clean up.
|
|
Note that `realgud-term-sentinel' is not helpful here because
|
|
the buffer and data associated with it are already gone."
|
|
(when (realgud-cmdbuf?) (realgud:terminate (current-buffer)))
|
|
)
|
|
(add-hook 'kill-buffer-hook 'realgud:kill-buffer-hook)
|
|
|
|
(defun realgud-term-sentinel (process string)
|
|
"Called when PROCESS dies. We call `realgud:terminate' to clean up."
|
|
(let ((cmdbuf (realgud-get-cmdbuf)))
|
|
(if cmdbuf (realgud:terminate cmdbuf)))
|
|
(message "That's all folks.... %s" string))
|
|
|
|
(defun realgud:binary (file-name)
|
|
"Return a whether FILE-NAME is executable or not or very large"
|
|
(let* ((truename (file-chase-links file-name))
|
|
(output (shell-command-to-string
|
|
(format "file %s" truename)))
|
|
(filesize (nth 7 (file-attributes truename)))
|
|
)
|
|
(cond
|
|
((string-match "ELF" output) t)
|
|
((and large-file-warning-threshold filesize
|
|
(> filesize large-file-warning-threshold)) t)
|
|
('t nil))))
|
|
|
|
|
|
(defun realgud-exec-shell (debugger-name script-filename program
|
|
&optional no-reset &rest args)
|
|
"Run the specified SCRIPT-FILENAME in under debugger DEBUGGER-NAME a
|
|
comint process buffer. ARGS are the arguments passed to the
|
|
PROGRAM. At the moment, no piping of input is allowed.
|
|
|
|
SCRIPT-FILENAME will have local variable `realgud-script-info' set
|
|
which contains the debugger name and debugger process-command
|
|
buffer.
|
|
|
|
Normally command buffers are reused when the same debugger is
|
|
reinvoked inside a command buffer with a similar command. If we
|
|
discover that the buffer has prior command-buffer information and
|
|
NO-RESET is nil, then that information which may point into other
|
|
buffers and source buffers which may contain marks and fringe or
|
|
marginal icons is reset."
|
|
|
|
(let* ((non-nil-filename (or script-filename "+No filename+"))
|
|
(current-directory
|
|
(or (file-name-directory non-nil-filename)
|
|
default-directory "./"))
|
|
(cmdproc-buffer-name
|
|
(replace-regexp-in-string
|
|
"\s+" "\s"
|
|
(format "*%s %s shell*"
|
|
(file-name-nondirectory debugger-name)
|
|
(file-name-nondirectory non-nil-filename))))
|
|
(cmdproc-buffer (get-buffer-create cmdproc-buffer-name))
|
|
(realgud-buf (current-buffer))
|
|
(cmd-args (cons program args))
|
|
(process (get-buffer-process cmdproc-buffer)))
|
|
|
|
(with-current-buffer cmdproc-buffer
|
|
;; If the found command buffer isn't for the same debugger
|
|
;; invocation command, rename that and start a new one.
|
|
;;
|
|
;; For example: "bashdb /tmp/foo" does not match "bashdb
|
|
;; /etc/foo" even though they both canonicalize to the buffer
|
|
;; "*bashdb foo shell*"
|
|
(when (and (realgud-cmdbuf?)
|
|
(not
|
|
(equal cmd-args
|
|
(realgud-cmdbuf-info-cmd-args realgud-cmdbuf-info))
|
|
))
|
|
(rename-uniquely)
|
|
(setq cmdproc-buffer (get-buffer-create cmdproc-buffer-name))
|
|
(setq process nil)
|
|
))
|
|
|
|
(if (and process (eq 'run (process-status process)))
|
|
cmdproc-buffer
|
|
(with-current-buffer cmdproc-buffer
|
|
(and (realgud-cmdbuf?) (not no-reset) (realgud:reset))
|
|
(make-local-variable 'starting-directory)
|
|
(setq starting-directory current-directory)
|
|
|
|
(insert "Current directory: " current-directory "\n")
|
|
(insert "Command: " (mapconcat 'identity cmd-args " ") "\n")
|
|
|
|
|
|
;; For term.el
|
|
;; (term-mode)
|
|
;; (set (make-local-variable 'term-term-name) realgud-term-name)
|
|
;; (make-local-variable 'realgud-parent-buffer)
|
|
;; (setq realgud-parent-buffer realgud-buf)
|
|
|
|
;; For comint.el.
|
|
(comint-mode)
|
|
|
|
;; Making overlay-arrow-variable-list buffer local has to be
|
|
;; done after running commint mode. FIXME: find out why and if
|
|
;; this reason is justifyable. Also consider moving this somewhere
|
|
;; else.
|
|
(make-local-variable 'overlay-arrow-variable-list)
|
|
(make-local-variable 'realgud-overlay-arrow1)
|
|
(make-local-variable 'realgud-overlay-arrow2)
|
|
(make-local-variable 'realgud-overlay-arrow3)
|
|
|
|
(condition-case failure
|
|
(comint-exec cmdproc-buffer debugger-name program nil args)
|
|
(error
|
|
(let ((text (format "%S\n" failure)))
|
|
(insert text)
|
|
(message text)(sit-for 1)
|
|
text)))
|
|
|
|
(setq process (get-buffer-process cmdproc-buffer))
|
|
|
|
(if (and process (eq 'run (process-status process)))
|
|
(let ((src-buffer)
|
|
(cmdline-list (cons program args)))
|
|
;; is this right?
|
|
(when (and script-filename (file-exists-p script-filename)
|
|
(not (realgud:binary script-filename)))
|
|
(setq src-buffer (find-file-noselect script-filename))
|
|
(point-max)
|
|
(realgud-srcbuf-init src-buffer cmdproc-buffer))
|
|
(process-put process 'buffer cmdproc-buffer))
|
|
;; else
|
|
(let ((text
|
|
(format
|
|
"Failed to invoke debugger %s on program %s with args %s\n"
|
|
debugger-name program (mapconcat 'identity args " "))))
|
|
(with-current-buffer cmdproc-buffer (insert text))
|
|
(message text)
|
|
))
|
|
cmdproc-buffer))))
|
|
|
|
;; Start of a term-output-filter for term.el
|
|
(defun realgud-term-output-filter (process string)
|
|
(let ((process-buffer (process-get process 'buffer)))
|
|
(if process-buffer
|
|
(save-current-buffer
|
|
(set-buffer process-buffer)
|
|
;; (insert-before-markers (format "+++1 %s" string))
|
|
(insert-before-markers string)))))
|
|
|
|
(provide-me "realgud-")
|