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

   1 ;;; process-command buffer things
   2 ;;; Copyright (C) 2010-2012, 2014-2015 Rocky Bernstein <rocky@gnu.org>
   3
   4 (require 'load-relative)
   5 (require 'json)
   6 (require-relative-list
   7  '("../fringe"  "../loc" "../lochist" "../regexp")  "realgud-")
   8 (require-relative-list '("info")  "realgud-buffer-")
   9
  10 (declare-function realgud-get-cmdbuf 'realgud-buffer-helper)
  11
  12 (eval-when-compile
  13   (byte-compile-disable-warning 'cl-functions)
  14   ;; Somehow disabling cl-functions causes the erroneous message:
  15   ;;   Warning: the function `reduce' might not be defined at runtime.
  16   ;; FIXME: isolate, fix and/or report back to Emacs developers a bug
  17   (byte-compile-disable-warning 'unresolved)
  18   (defvar realgud-cmdbuf-info)
  19   )
  20 (require 'cl-lib)
  21
  22 (defface debugger-running
  23   '((((class color) (min-colors 16) (background light))
  24      (:foreground "Green4" :weight bold))
  25     (((class color) (min-colors 88) (background dark))
  26      (:foreground "Green1" :weight bold))
  27     (((class color) (min-colors 16) (background dark))
  28      (:foreground "Green" :weight bold))
  29     (((class color)) (:foreground "green" :weight bold))
  30     (t (:weight bold)))
  31   "Face used to highlight debugger run information."
  32   :group 'realgud
  33   :version "24.1")
  34
  35 (defface debugger-not-running
  36   '((t :inherit font-lock-warning-face))
  37   "Face used when debugger or process is not running."
  38   :group 'realgud
  39   :version "24.1")
  40
  41
  42 (defstruct realgud-cmdbuf-info
  43   "The debugger object/structure specific to a process buffer."
  44   debugger-name        ;; Name of debugger
  45   cmd-args             ;; Command-line invocation arguments
  46   frame-switch?        ;; Should the selected window be the source buffer or
  47                        ;; command buffer?
  48   in-srcbuf?           ;; If true, selected window should be the source buffer.
  49                        ;; Otherwise, the command buffer?
  50   last-input-end       ;; point where input last ended. Set from
  51                        ;; comint-last-input-end
  52   prior-prompt-regexp  ;; regular expression prompt (e.g.
  53                        ;; comint-prompt-regexp) *before* setting
  54                        ;; loc-regexp
  55   no-record?           ;; Should we update the location history?
  56   in-debugger?         ;; True if we think we are in a debugger
  57   src-shortkey?        ;; Are source buffers in realgud-short-key mode?
  58   regexp-hash          ;; hash table of regular expressions appropriate for
  59                        ;; this debugger. Eventually loc-regexp, file-group
  60                        ;; and line-group below will removed and stored here.
  61   srcbuf-list          ;; list of source buffers we have stopped at
  62   bt-buf               ;; backtrace buffer if it exists
  63   bp-list              ;; list of breakpoints
  64   divert-output?       ;; Output is part of a conversation between front-end
  65                        ;; debugger.
  66   cmd-hash             ;; Allows us to remap command names like
  67                        ;; quit => quit!
  68   callback-loc-fn      ;; If we need, as in the case of Java, to do
  69                        ;; special handling to map output to a file
  70                        ;; location, this is set to that special
  71                        ;; function
  72
  73   ;; FIXME: REMOVE THIS and use regexp-hash
  74   loc-regexp   ;; Location regular expression string
  75   file-group
  76   line-group
  77   text-group
  78   ignore-file-re
  79
  80   loc-hist     ;; ring of locations seen in the course of execution
  81                ;; see realgud-lochist
  82 )
  83 (make-variable-buffer-local 'realgud-cmdbuf-info)
  84 (make-variable-buffer-local 'realgud-last-output-start)
  85
  86 (defalias 'realgud-cmdbuf-info? 'realgud-cmdbuf-info-p)
  87
  88 ;; FIXME: figure out how to put in a loop.
  89 (realgud-struct-field-setter "realgud-cmdbuf-info" "bp-list")
  90 (realgud-struct-field-setter "realgud-cmdbuf-info" "bt-buf")
  91 (realgud-struct-field-setter "realgud-cmdbuf-info" "cmd-args")
  92 (realgud-struct-field-setter "realgud-cmdbuf-info" "last-input-end")
  93 (realgud-struct-field-setter "realgud-cmdbuf-info" "divert-output?")
  94 (realgud-struct-field-setter "realgud-cmdbuf-info" "frame-switch?")
  95 (realgud-struct-field-setter "realgud-cmdbuf-info" "in-srcbuf?")
  96 (realgud-struct-field-setter "realgud-cmdbuf-info" "no-record?")
  97 (realgud-struct-field-setter "realgud-cmdbuf-info" "prior-prompt-regexp")
  98 (realgud-struct-field-setter "realgud-cmdbuf-info" "src-shortkey?")
  99 (realgud-struct-field-setter "realgud-cmdbuf-info" "in-debugger?")
 100 (realgud-struct-field-setter "realgud-cmdbuf-info" "callback-loc-fn")
 101
 102 (defun realgud:cmdbuf-follow-buffer(event)
 103   (interactive "e")
 104   (let* ((pos (posn-point (event-end event)))
 105          (buffer (get-text-property pos 'buffer)))
 106     (find-file-other-window (buffer-file-name buffer))))
 107
 108 (defun realgud:cmdbuf-buffers-describe (buffer-list)
 109   (insert "** Source Buffers Seen\n")
 110   (dolist (buffer buffer-list)
 111     (insert "  - ")
 112     (put-text-property
 113      (insert-text-button
 114       (buffer-name buffer)
 115       'action 'realgud:cmdbuf-follow-buffer
 116       'help-echo "mouse-2: visit this file")
 117      (point)
 118      'buffer buffer)
 119     (insert "\n")
 120     ))
 121
 122 (defun realgud:cmdbuf-info-describe (&optional buffer)
 123   "Display realgud-cmdcbuf-info fields of BUFFER.
 124 BUFFER is either a debugger command or source buffer. If BUFFER is not given
 125 the current buffer is used as a starting point.
 126 Information is put in an internal buffer called *Describe*."
 127   (interactive "")
 128   (setq buffer (realgud-get-cmdbuf buffer))
 129   (if buffer
 130       (with-current-buffer buffer
 131         (let ((info realgud-cmdbuf-info)
 132               (cmdbuf-name (buffer-name)))
 133           (switch-to-buffer (get-buffer-create "*Describe*"))
 134           (setq buffer-read-only 'nil)
 135           (delete-region (point-min) (point-max))
 136           (insert "#+STARTUP: showall\n")
 137           ;;(insert "#+OPTIONS:    H:2 num:nil toc:t \\n:nil ::t |:t ^:nil -:t f:t *:t tex:t d:(HIDE) tags:not-in-toc\n")
 138           (insert (format "#+TITLE: Debugger info for %s\n" cmdbuf-name))
 139           (insert "** General Information\n")
 140           (mapc 'insert
 141                 (list
 142                  (format "  - Debugger name     ::\t%s\n"
 143                          (json-encode (realgud-cmdbuf-info-debugger-name info)))
 144                  (format "  - Command-line args ::\t%s\n"
 145                          (json-encode (realgud-cmdbuf-info-cmd-args info)))
 146                  (format "  - Selected window should contain source? :: %s\n"
 147                          (realgud-cmdbuf-info-in-srcbuf? info))
 148                  (format "  - Last input end    ::\t%s\n"
 149                          (realgud-cmdbuf-info-last-input-end info))
 150                  (format "  - Source should go into short-key mode? :: %s\n"
 151                          (realgud-cmdbuf-info-src-shortkey? info))
 152                  (format "  - Breakpoint list   ::\t %s\n"
 153                          (realgud-cmdbuf-info-bp-list info))
 154                  (format "  - Remap table for debugger commands ::\n\t%s\n"
 155                          (json-encode (realgud-cmdbuf-info-cmd-hash info)))
 156                  (format "  - Backtrace buffer  ::\t%s\n"
 157                          (realgud-cmdbuf-info-bt-buf info))
 158                  (format "  - In debugger?      ::\t%s\n"
 159                          (realgud-cmdbuf-info-in-debugger? info))
 160                  ))
 161           (insert "\n")
 162           (realgud:cmdbuf-buffers-describe (realgud-cmdbuf-info-srcbuf-list info))
 163           (insert "\n")
 164           (realgud:loc-hist-describe (realgud-cmdbuf-info-loc-hist info))
 165           (goto-char (point-min))
 166           (realgud:info-mode)
 167           )
 168         )
 169     (message "Buffer %s is not a debugger source or command buffer; nothing done."
 170              (or buffer (current-buffer)))
 171     )
 172   )
 173
 174 (defun realgud-cmdbuf? (&optional buffer)
 175   "Return true if BUFFER is a debugger command buffer."
 176   (with-current-buffer-safe
 177    (or buffer (current-buffer))
 178    (realgud-cmdbuf-info-set?)))
 179
 180 (defun realgud-cmdbuf-info-set? ()
 181   "Return true if realgud-cmdbuf-info is set."
 182   (and (boundp 'realgud-cmdbuf-info)
 183        realgud-cmdbuf-info
 184        (realgud-cmdbuf-info? realgud-cmdbuf-info)))
 185
 186 (defun realgud-cmdbuf-toggle-in-debugger? (&optional buffer)
 187   "Toggle state of whether we think we are in the debugger or not"
 188   (interactive "")
 189   (setq buffer (realgud-get-cmdbuf buffer))
 190   (if buffer
 191       (with-current-buffer buffer
 192         (realgud-cmdbuf-info-in-debugger?=
 193          (not (realgud-sget 'cmdbuf-info 'in-debugger?)))
 194         (message "Command buffer is in debugger?: %s\n"
 195                  (realgud-cmdbuf-info-in-debugger? realgud-cmdbuf-info))
 196         (realgud-cmdbuf-mode-line-update)
 197         )
 198     (message "Buffer %s is not a debugger buffer; nothing done."
 199              (or buffer (current-buffer)))
 200     )
 201   )
 202
 203 (defun realgud-cmdbuf-stay-in-source-toggle (&optional buffer)
 204   "Toggle state of whether we should stay in source code or not"
 205   (interactive "")
 206   (setq buffer (realgud-get-cmdbuf buffer))
 207   (if buffer
 208       (with-current-buffer buffer
 209         (realgud-cmdbuf-info-in-srcbuf?=
 210          (not (realgud-sget 'cmdbuf-info 'in-srcbuf?)))
 211         (message "Selected window should contain source?: %s\n"
 212                  (realgud-cmdbuf-info-in-srcbuf? realgud-cmdbuf-info))
 213         )
 214     (message "Buffer %s is not a debugger buffer; nothing done."
 215              (or buffer (current-buffer)))
 216     )
 217   )
 218
 219 (defun realgud-cmdbuf-add-srcbuf(srcbuf &optional cmdbuf)
 220   "Add SRCBUF to srcbuf-list field of INFO unless it is already included."
 221   (setq cmdbuf (or cmdbuf (current-buffer)))
 222   (if (realgud-cmdbuf? cmdbuf)
 223       (with-current-buffer-safe cmdbuf
 224         (unless (memq srcbuf (realgud-cmdbuf-info-srcbuf-list realgud-cmdbuf-info))
 225           (setf (realgud-cmdbuf-info-srcbuf-list realgud-cmdbuf-info)
 226                 (cons srcbuf (realgud-cmdbuf-info-srcbuf-list realgud-cmdbuf-info))))
 227         )
 228     )
 229   )
 230
 231 (defun realgud-cmdbuf-set-shortkey(&optional cmdbuf unset)
 232   (interactive "")
 233   (setq cmdbuf (or cmdbuf (current-buffer)))
 234   (if (realgud-cmdbuf? cmdbuf)
 235       (with-current-buffer-safe cmdbuf
 236         (setf (realgud-cmdbuf-info-src-shortkey? realgud-cmdbuf-info) (not unset))
 237         (message "Set source to shortkey is now %s" (not unset))
 238         ))
 239   )
 240
 241 (defun realgud-cmdbuf-command-string(cmd-buffer)
 242   "Get the command string invocation for this command buffer"
 243     (cond
 244      ((realgud-cmdbuf? cmd-buffer)
 245       (with-current-buffer cmd-buffer
 246         (let*
 247             ((cmd-args (realgud-sget 'cmdbuf-info 'cmd-args))
 248              (result (car cmd-args)))
 249           (and cmd-args
 250                (reduce (lambda(result x)
 251                          (setq result (concat result " " x)))
 252                        cmd-args)))))
 253      (t nil)))
 254
 255 ;; FIXME cmd-hash should not be optional. And while I am at it, remove
 256 ;; parameters loc-regexp, file-group, and line-group which can be found
 257 ;; inside pat-hash
 258 ;;
 259 ;; To do this however we need to fix up the caller
 260 ;; realgud:track-set-debugger by changing realgud-pat-hash to store a hash
 261 ;; rather than the loc, file, and line fields; those fields then get
 262 ;; removed.
 263
 264 (defun realgud-cmdbuf-init
 265   (cmd-buf debugger-name regexp-hash &optional cmd-hash)
 266   "Initialize CMD-BUF for a working with a debugger.
 267 DEBUGGER-NAME is the name of the debugger; REGEXP-HASH are debugger-specific
 268 values set in the debugger's init.el."
 269   (with-current-buffer-safe cmd-buf
 270     (let ((realgud-loc-pat (gethash "loc" regexp-hash))
 271           (font-lock-keywords)
 272           )
 273       (setq realgud-cmdbuf-info
 274             (make-realgud-cmdbuf-info
 275              :in-srcbuf? nil
 276              :debugger-name debugger-name
 277              :loc-regexp (realgud-sget 'loc-pat 'regexp)
 278              :file-group (realgud-sget 'loc-pat 'file-group)
 279              :line-group (realgud-sget 'loc-pat 'line-group)
 280              :text-group (realgud-sget 'loc-pat 'text-group)
 281              :ignore-file-re (realgud-sget 'loc-pat 'ignore-file-re)
 282              :loc-hist (make-realgud-loc-hist)
 283              :regexp-hash regexp-hash
 284              :bt-buf nil
 285              :last-input-end (point-max)
 286              :cmd-hash cmd-hash
 287              :src-shortkey? 't
 288              :in-debugger? nil
 289              :callback-loc-fn (gethash "loc-callback-fn" regexp-hash)
 290              ))
 291       (setq font-lock-keywords (realgud-cmdbuf-pat "font-lock-keywords"))
 292       (if font-lock-keywords
 293           (set (make-local-variable 'font-lock-defaults)
 294                (list font-lock-keywords)))
 295       )
 296
 297     (put 'realgud-cmdbuf-info 'variable-documentation
 298          "Debugger object for a process buffer."))
 299   )
 300
 301 (defun realgud-cmdbuf-debugger-name (&optional cmd-buf)
 302   "Return the debugger name recorded in the debugger command-process buffer."
 303   (with-current-buffer-safe (or cmd-buf (current-buffer))
 304     (if (realgud-cmdbuf?)
 305         (realgud-sget 'cmdbuf-info 'debugger-name)
 306       nil))
 307   )
 308
 309 (defun realgud-cmdbuf-pat(key)
 310   "Extract regexp stored under KEY in a realgud-cmdbuf via realgud-cmdbuf-info"
 311   (if (realgud-cmdbuf?)
 312       (let*
 313           ((debugger-name (realgud-cmdbuf-debugger-name))
 314            (regexp-hash (gethash debugger-name realgud-pat-hash))
 315            (loc-pat (gethash key regexp-hash)))
 316         loc-pat)
 317     nil))
 318
 319 (defun realgud-cmdbuf-loc-hist(cmd-buf)
 320   "Return the history ring of locations that a debugger
 321 command-process buffer has stored."
 322   (with-current-buffer-safe cmd-buf
 323     (realgud-sget 'cmdbuf-info 'loc-hist))
 324 )
 325
 326 (defun realgud-cmdbuf-src-marker(cmd-buf)
 327   "Return a marker to current source location stored in the history ring."
 328   (with-current-buffer cmd-buf
 329     (lexical-let* ((loc (realgud-loc-hist-item (realgud-cmdbuf-loc-hist cmd-buf))))
 330       (and loc (realgud-loc-marker loc)))))
 331
 332 (defun realgud-cmdbuf-mode-line-update (&optional opt-cmdbuf)
 333   "Force update of command buffer to include process status"
 334   (let ((cmdbuf (realgud-get-cmdbuf opt-cmdbuf))
 335         (debug-status)
 336         (status)
 337         (cmd-process)
 338         )
 339     (if (and cmdbuf (buffer-name cmdbuf))
 340         (with-current-buffer cmdbuf
 341           (setq cmd-process (get-buffer-process cmdbuf))
 342           (setq debug-status
 343                 (if (realgud-sget 'cmdbuf-info 'in-debugger?)
 344                     " debugger"
 345                   ""))
 346           (setq status
 347                 (if cmd-process
 348                     (list (propertize
 349                            (format ":%s%s"
 350                                    (process-status cmd-process) debug-status)
 351                            'face 'debugger-running))
 352                   (list (propertize ":not running" 'face
 353                         'debugger-not-running))
 354                   ))
 355           (setq mode-line-process status)
 356           ;; Force mode line redisplay soon.
 357           (force-mode-line-update))
 358       ))
 359   )
 360
 361
 362 (provide-me "realgud-buffer-")