lib/distel/elisp/edb.el

   1 ;;; edb.el --- Erlang debugger front-end
   2
   3 (eval-when-compile (require 'cl))
   4 (require 'erl)
   5 (require 'erl-service)
   6 (require 'erlang)
   7 (require 'ewoc)
   8
   9 (eval-and-compile
  10   (autoload 'erlang-extended-mode "distel"))
  11
  12 (when (featurep 'xemacs)
  13   (require 'overlay))
  14
  15 ;; Hack for XEmacs compatibility..
  16 (unless (fboundp 'line-beginning-position)
  17   (defalias 'line-beginning-position 'point-at-bol))
  18
  19 ;; ----------------------------------------------------------------------
  20 ;; Configurables
  21
  22 (defcustom edb-popup-monitor-on-event t
  23   "*Automatically popup the monitor on interesting events.
  24 An interesting event is an unattached process reaching a breakpoint,
  25 or an attached process exiting."
  26   :type 'boolean
  27   :group 'distel)
  28
  29 (defface edb-breakpoint-face
  30   `((((type tty) (class color))
  31      (:background "red" :foreground "black"))
  32     (((type tty) (class mono))
  33      (:inverse-video t))
  34     (((class color) (background dark))
  35      (:background "darkred" :foreground "white"))
  36     (((class color) (background light))
  37      (:background "tomato" :foreground "black"))
  38     (t (:background "gray")))
  39   "Face for marking a breakpoint definition."
  40   :group 'distel)
  41
  42 (defface edb-breakpoint-stale-face
  43   `((((type tty) (class color))
  44      (:background "yellow" :foreground "black"))
  45     (((type tty) (class mono))
  46      (:inverse-video t))
  47     (((class color) (background dark))
  48      (:background "purple4"))
  49     (((class color) (background light))
  50      (:background "medium purple" :foreground "black"))
  51     (t (:background "dark gray")))
  52   "Face for marking a stale breakpoint definition."
  53   :group 'distel)
  54
  55 ;; ----------------------------------------------------------------------
  56 ;; Integration with erlang-extended-mode buffers.
  57
  58 (make-variable-buffer-local
  59  (defvar edb-module-interpreted nil
  60    "Non-nil means that the buffer's Erlang module is interpreted.
  61 This variable is meaningful in erlang-extended-mode buffers.
  62 The interpreted status refers to the node currently being monitored by
  63 edb."))
  64
  65 (defun edb-setup-source-buffer ()
  66   (make-local-variable 'kill-buffer-hook)
  67   (add-hook 'kill-buffer-hook 'edb-delete-buffer-breakpoints)
  68   (make-local-variable 'after-change-functions)
  69   (add-to-list 'after-change-functions 'edb-make-breakpoints-stale)
  70   (edb-update-interpreted-status)
  71   (when edb-module-interpreted
  72     (edb-create-buffer-breakpoints (edb-module))))
  73
  74 (add-hook 'erlang-extended-mode-hook
  75           'edb-setup-source-buffer)
  76
  77 ;; ----------------------------------------------------------------------
  78 ;; EDB minor mode for erlang-mode source files
  79
  80 (defun edb-toggle-interpret (node module file)
  81   "Toggle debug-interpreting of the current buffer's module."
  82   (interactive (list (erl-target-node)
  83                      (edb-module)
  84                      buffer-file-name))
  85   (when (edb-ensure-monitoring node)
  86     (erl-spawn
  87       (erl-set-name "EDB RPC to toggle interpretation of %S on %S"
  88                     module node)
  89       (erl-send-rpc node 'distel 'debug_toggle (list module file))
  90       (erl-receive (module)
  91           ((['rex 'interpreted]
  92             (message "Interpreting: %S" module))
  93            (['rex 'uninterpreted]
  94             (message "Stopped interpreting: %S" module))
  95            (['rex ['badrpc reason]]
  96             (message "Failed to interpret-toggle: %S" reason)))))))
  97
  98 (defun edb-module ()
  99   (if (erlang-get-module)
 100       (intern (erlang-get-module))
 101     (error "Can't determine module for current buffer")))
 102
 103 (defun edb-toggle-breakpoint (node module line)
 104   "Toggle a breakpoint on the current line."
 105   (interactive (list (erl-target-node)
 106                      (edb-module)
 107                      (edb-line-number)))
 108   (unless (edb-module-interpreted-p module)
 109     (error "Module is not interpreted, can't set breakpoints."))
 110   (if edb-buffer-breakpoints-stale
 111       (edb-toggle-stale-breakpoint module line)
 112     (edb-toggle-real-breakpoint node module line)))
 113
 114 (defun edb-toggle-stale-breakpoint (module line)
 115   (let ((overlay (edb-first (lambda (ov) (overlay-get ov 'edb-breakpoint))
 116                             (overlays-in (line-beginning-position)
 117                                          (1+ (line-end-position))))))
 118     (if overlay
 119         (delete-overlay overlay)
 120       (edb-create-breakpoint module line))))
 121
 122 (defun edb-toggle-real-breakpoint (node module line)
 123   (when (edb-ensure-monitoring node)
 124     (erl-spawn
 125       (erl-set-name "EDB RPC to toggle of breakpoint %S:%S on %S"
 126                     module line node)
 127       (erl-send-rpc node 'distel 'break_toggle (list module line))
 128       (erl-receive (module line)
 129           ((['rex 'enabled]
 130             (message "Enabled breakpoint at %S:%S" module line))
 131            (['rex 'disabled]
 132             (message "Disabled breakpoint at %S:%S" module line)))))))
 133
 134 (defun edb-module-interpreted-p (module)
 135   (assoc module edb-interpreted-modules))
 136
 137 (defun edb-line-number ()
 138   "Current line number."
 139   ;; Taken from `count-lines' in gud.el
 140   (save-restriction
 141     (widen)
 142     (+ (count-lines 1 (point))
 143        (if (bolp) 1 0))))
 144
 145 (defun edb-save-dbg-state (node)
 146   "Save debugger state (modules to interpret and breakpoints).
 147 Use edb-restore-dbg-state to restore the state to the erlang node."
 148   (interactive (list (erl-target-node)))
 149   (let ((do-save nil))
 150     (when (or (null edb-saved-interpreted-modules)
 151               (y-or-n-p "You already have a saved debugger state, continue? "))
 152       (setq edb-saved-interpreted-modules edb-interpreted-modules)
 153       (edb-save-breakpoints node)
 154       (message "Debugger state saved."))))
 155
 156 (defun edb-restore-dbg-state (node)
 157   "Restore debugger state (modules to interpret and breakpoints)."
 158   (interactive (list (erl-target-node)))
 159   (if edb-saved-interpreted-modules
 160       (when (edb-ensure-monitoring node)
 161         (erl-spawn
 162           (erl-set-name "EDB RPC to restore debugger state on %S" node)
 163           (erl-send-rpc node 'distel 'debug_add
 164                         (list edb-saved-interpreted-modules))
 165           (erl-receive (node)
 166               ((['rex 'ok]
 167                 (when (edb-restore-breakpoints
 168                        node
 169                        (lambda ()
 170                          (message "Debugger state restored.")))))))))
 171     (message "No saved debugger state, aborting.")))
 172
 173
 174 ;; ----------------------------------------------------------------------
 175 ;; Monitor process
 176
 177 (defvar edb-monitor-buffer nil
 178   "Monitor process/viewer buffer.")
 179
 180 (defvar edb-monitor-node nil
 181   "Node we are debug-monitoring.")
 182
 183 (defvar edb-monitor-mode-map nil
 184   "Keymap for Erlang debug monitor mode.")
 185
 186 (defvar edb-interpreted-modules '()
 187   "Set of (module filename) being interpreted on the currently monitored node.")
 188
 189 (defvar edb-saved-interpreted-modules '()
 190   "Set of (module filename) to interpret if edb-restore-dbg-state is called.")
 191
 192 (unless edb-monitor-mode-map
 193   (setq edb-monitor-mode-map (make-sparse-keymap))
 194   (define-key edb-monitor-mode-map [return] 'edb-attach-command)
 195   (define-key edb-monitor-mode-map [(control m)] 'edb-attach-command)
 196   (define-key edb-monitor-mode-map [?a] 'edb-attach-command)
 197   (define-key edb-monitor-mode-map [?q] 'erl-bury-viewer)
 198   (define-key edb-monitor-mode-map [?k] 'erl-quit-viewer))
 199
 200 (defvar edb-processes nil
 201   "EWOC of processes running interpreted code.")
 202
 203 (defstruct (edb-process
 204             (:constructor nil)
 205             (:constructor make-edb-process (pid mfa status info)))
 206   pid mfa status info)
 207
 208 (defun edb-monitor-mode ()
 209   "Major mode for viewing debug'able processes.
 210
 211 Available commands:
 212 \\[edb-attach-command]  - Attach to the process at point.
 213 \\[erl-bury-viewer]     - Hide the monitor window.
 214 \\[erl-quit-viewer]     - Quit monitor."
 215   (interactive)
 216   (kill-all-local-variables)
 217   (setq buffer-read-only t)
 218   (setq erl-old-window-configuration (current-window-configuration))
 219   (use-local-map edb-monitor-mode-map)
 220   (setq mode-name "EDB Monitor")
 221   (setq major-mode 'edb-monitor-mode))
 222
 223 (defun edb-monitor-insert-process (p)
 224   (let ((buffer-read-only nil)
 225         (text (edb-monitor-format (erl-pid-to-string (edb-process-pid p))
 226                                   (edb-process-mfa p)
 227                                   (edb-process-status p)
 228                                   (edb-process-info p))))
 229     (put-text-property 0 (length text) 'erl-pid (edb-process-pid p) text)
 230     (insert text)))
 231
 232 (defun edb-monitor-format (pid mfa status info)
 233   (format "%s %s %s %s"
 234           (padcut pid 12)
 235           (padcut mfa 21)
 236           (padcut status 9)
 237           (cut info 21)))
 238
 239 (defun padcut (s w)
 240   (let ((len (length s)))
 241     (cond ((= len w) s)
 242           ((< len w) (concat s (make-string (- w len) ? )))
 243           ((> len w) (substring s 0 w)))))
 244
 245 (defun cut (s w)
 246   (if (> (length s) w)
 247       (substring s 0 w)
 248     s))
 249
 250 (defun edb-monitor-header ()
 251   (edb-monitor-format "PID" "Initial Call" "Status" "Info"))
 252
 253 (defun edb-monitor (node)
 254   (interactive (list (erl-target-node)))
 255   (when (edb-ensure-monitoring node)
 256     (unless (get-buffer-window edb-monitor-buffer)
 257       ;; Update the restorable window configuration
 258       (with-current-buffer edb-monitor-buffer
 259         (setq erl-old-window-configuration
 260               (current-window-configuration))))
 261     (pop-to-buffer edb-monitor-buffer)
 262     (goto-char (point-max))
 263     (forward-line -2)))
 264
 265 (defun edb-ensure-monitoring (node)
 266   "Make sure the debug monitor is watching the node.
 267 Returns NIL if this cannot be ensured."
 268   (if (edb-monitor-node-change-p node)
 269       (when (y-or-n-p (format "Attach debugger to %S instead of %S? "
 270                               node edb-monitor-node))
 271         ;; Kill existing edb then start again
 272         (kill-buffer edb-monitor-buffer)
 273         (edb-start-monitor node))
 274     (if (edb-monitor-live-p)
 275         t
 276       (edb-start-monitor node))))
 277
 278 (defun edb-monitor-node-change-p (node)
 279   "Do we have to detach/reattach to debug on NODE?"
 280   (and (edb-monitor-live-p)
 281        (not (equal node edb-monitor-node))))
 282
 283 (defun edb-monitor-live-p ()
 284   "Are we actively debug-monitoring a node?"
 285   (and edb-monitor-buffer
 286        (buffer-live-p edb-monitor-buffer)))
 287
 288 (defun edb-monitor-buffer-name (node)
 289   (format "*edb %S*" node))
 290
 291 (defun edb-start-monitor (node)
 292   "Start debug-monitoring NODE."
 293   (erl-spawn
 294     (erl-set-name "EDB Monitor on %S" node)
 295     (setq edb-monitor-node node)
 296     (setq edb-monitor-buffer (current-buffer))
 297     (rename-buffer (edb-monitor-buffer-name node))
 298     (edb-monitor-mode)
 299     (make-local-variable 'kill-buffer-hook)
 300     (add-hook 'kill-buffer-hook 'edb-monitor-cleanup)
 301     (erl-send-rpc node 'distel 'debug_subscribe (list erl-self))
 302     (erl-receive (node)
 303         ((['rex [interpreted breaks snapshot]]
 304           (setq edb-interpreted-modules interpreted)
 305           (edb-init-breakpoints breaks)
 306           (edb-update-source-buffers)
 307           (setq edb-processes
 308                 (ewoc-create 'edb-monitor-insert-process
 309                              (edb-monitor-header)))
 310           (mapc (lambda (item)
 311                   (mlet [pid mfa status info] item
 312                     (ewoc-enter-last edb-processes
 313                                      (make-edb-process pid
 314                                                        mfa
 315                                                        status
 316                                                        info))))
 317                 snapshot)
 318           (&edb-monitor-loop))))))
 319
 320 (defun &edb-monitor-loop ()
 321   "Monitor process main loop.
 322 Tracks events and state changes from the Erlang node."
 323   (erl-receive ()
 324       ((['int ['new_status pid status info]]
 325          (let ((proc (edb-monitor-lookup pid)))
 326            (if (null proc)
 327                (message "Unknown process: %s" (erl-pid-to-string pid))
 328              (setf (edb-process-status proc) (symbol-name status))
 329              (setf (edb-process-info proc) info)
 330              (when (and edb-popup-monitor-on-event
 331                         (edb-interesting-event-p pid status info))
 332                (display-buffer (current-buffer))))))
 333        ;;
 334        (['int ['new_process (pid mfa status info)]]
 335          (ewoc-enter-last edb-processes
 336                           (make-edb-process pid
 337                                             mfa
 338                                             (symbol-name status)
 339                                             info)))
 340        ;;
 341        (['int ['interpret mod file]]
 342         (push (list mod file) edb-interpreted-modules)
 343         (edb-update-source-buffers mod))
 344        ;;
 345        (['int ['no_interpret mod]]
 346         (setq edb-interpreted-modules
 347               (assq-delete-all mod edb-interpreted-modules))
 348         (edb-update-source-buffers mod))
 349        ;;
 350        (['int ['no_break mod]]
 351         (edb-delete-breakpoints mod))
 352        ;;
 353        (['int ['new_break [[mod line] _info]]]
 354         (edb-create-breakpoint mod line))
 355        ;;
 356        (['int ['delete_break [mod line]]]
 357         (edb-delete-breakpoint mod line)))
 358     (ewoc-refresh edb-processes)
 359     (&edb-monitor-loop)))
 360
 361 (defun edb-get-buffer (mod)
 362   (edb-get-buffer2 mod (buffer-list)))
 363
 364 (defun edb-get-buffer2 (mod bufl)
 365   (if (null bufl) nil
 366     (with-current-buffer (car bufl)
 367       (if (and erlang-extended-mode
 368                (eq (edb-source-file-module-name) mod))
 369           (car bufl)
 370         (edb-get-buffer2 mod (cdr bufl))))))
 371
 372
 373 (defun edb-interesting-event-p (pid status info)
 374   (or (and (eq status 'exit)
 375            (edb-attached-p pid))
 376       (and (eq status 'break)
 377            (not (edb-attached-p pid)))))
 378
 379 (defun edb-update-interpreted-status ()
 380   "Update `edb-module-interpreted' for current buffer."
 381   (when erlang-extended-mode
 382     (let ((mod (edb-source-file-module-name)))
 383       (if (and mod (assq mod edb-interpreted-modules))
 384           (setq edb-module-interpreted t)
 385         (setq edb-module-interpreted nil)
 386         ;; the erlang debugger automatically removes breakpoints when a
 387         ;; module becomes uninterpreted, so we match it here
 388         (edb-delete-breakpoints (edb-source-file-module-name))))
 389     (force-mode-line-update)))
 390
 391 (defun edb-update-source-buffers (&optional mod)
 392   "Update the debugging state of all Erlang buffers.
 393 When MOD is given, only update those visiting that module."
 394   (mapc (lambda (buf)
 395           (with-current-buffer buf
 396             (when (and erlang-extended-mode
 397                        (or (null mod)
 398                            (eq (edb-source-file-module-name) mod)))
 399               (edb-update-interpreted-status))))
 400         (buffer-list)))
 401
 402 (defun edb-source-file-module-name ()
 403   "Return the Erlang module of the current buffer as a symbol, or NIL."
 404   (let ((name (erlang-get-module)))
 405     (if name (intern name) nil)))
 406
 407 (defun edb-monitor-lookup (pid)
 408   (car (ewoc-collect edb-processes
 409                      (lambda (p) (equal (edb-process-pid p) pid)))))
 410
 411 (defun edb-monitor-cleanup ()
 412   "Cleanup state after the edb process exits."
 413   (setq edb-interpreted-modules '())
 414   (edb-delete-all-breakpoints)
 415   (edb-update-source-buffers))
 416
 417 ;; ----------------------------------------------------------------------
 418 ;; Attach process
 419
 420 (make-variable-buffer-local
 421  (defvar edb-pid nil
 422    "Pid of attached process."))
 423
 424 (make-variable-buffer-local
 425  (defvar edb-node nil
 426    "Node of attached process."))
 427
 428 (make-variable-buffer-local
 429  (defvar edb-module nil
 430    "Current module source code in attach buffer."))
 431
 432 (make-variable-buffer-local
 433  (defvar edb-variables-buffer nil
 434    "Buffer showing variable bindings of attached process."))
 435
 436 (make-variable-buffer-local
 437  (defvar edb-attach-buffer nil
 438    "True if buffer is attach buffer."))
 439
 440 (defvar edb-attach-with-new-frame nil
 441   "When true, attaching to a process opens a new frame.")
 442
 443 ;; Attach setup
 444
 445 (defun edb-attach-command ()
 446   (interactive)
 447   (let ((pid (get-text-property (point) 'erl-pid)))
 448     (if pid
 449         (progn (when edb-attach-with-new-frame
 450                  (select-frame (make-frame)))
 451                (edb-attach pid))
 452       (error "No process at point."))))
 453
 454 (defun edb-attach (pid)
 455   (let ((old-window-config (current-window-configuration)))
 456     (delete-other-windows)
 457     (switch-to-buffer (edb-attach-buffer pid))
 458     (setq erl-old-window-configuration old-window-config)))
 459
 460 (defun edb-attach-buffer (pid)
 461   (let ((bufname (edb-attach-buffer-name pid)))
 462     (or (get-buffer bufname)
 463         (edb-new-attach-buffer pid))))
 464
 465 (defun edb-new-attach-buffer (pid)
 466   "Start a new attach process and returns its buffer."
 467   (erl-pid->buffer
 468    (erl-spawn
 469      (erl-set-name "EDB Attach to process %S on %S"
 470                    (erl-pid-id pid)
 471                    (erl-pid-node pid))
 472      (rename-buffer (edb-attach-buffer-name pid))
 473      ;; We must inhibit the erlang-new-file-hook, otherwise we trigger
 474      ;; it by entering erlang-mode in an empty buffer
 475      (let ((erlang-new-file-hook nil))
 476        (erlang-mode))
 477      (erlang-extended-mode t)
 478      (edb-attach-mode t)
 479      (setq edb-attach-buffer t)
 480      (message "Entered debugger. Press 'h' for help.")
 481      (setq buffer-read-only t)
 482      (erl-send-rpc (erl-pid-node pid)
 483                    'distel 'debug_attach (list erl-self pid))
 484      (erl-receive ()
 485          ((['rex pid]
 486            (assert (erl-pid-p pid))
 487            (setq edb-pid pid)
 488            (setq edb-node (erl-pid-node pid))
 489            (save-excursion (edb-make-variables-window))))
 490        (&edb-attach-loop)))))
 491
 492 ;; Variables listing window
 493
 494 (defun edb-make-variables-window ()
 495   "Make a window and buffer for viewing variable bindings.
 496 The *Variables* buffer is killed with the current buffer."
 497   (split-window-vertically (edb-variables-window-height))
 498   (let ((vars-buf (edb-make-variables-buffer)))
 499     (setq edb-variables-buffer vars-buf)
 500     (make-local-variable 'kill-buffer-hook)
 501     (add-hook 'kill-buffer-hook
 502               (lambda () (kill-buffer edb-variables-buffer)))
 503     (other-window 1)
 504     (switch-to-buffer vars-buf)
 505     (other-window -1)))
 506
 507 (defun edb-variables-window-height ()
 508   (- (min (/ (window-height) 2) 12)))
 509
 510 (defun edb-make-variables-buffer ()
 511   "Create the edb variable list buffer."
 512   (let ((meta-pid edb-pid))
 513     (with-current-buffer (generate-new-buffer "*Variables*")
 514       (edb-variables-mode)
 515       (setq edb-pid meta-pid)
 516       (current-buffer))))
 517
 518 (defun edb-variables-mode ()
 519   (kill-all-local-variables)
 520   (setq major-mode 'edb-variables)
 521   (setq mode-name "EDB Variables")
 522   (setq buffer-read-only t)
 523   (use-local-map edb-variables-mode-map))
 524
 525 (defvar edb-variables-mode-map nil
 526   "Keymap for EDB variables viewing.")
 527
 528 (when (null edb-variables-mode-map)
 529   (setq edb-variables-mode-map (make-sparse-keymap))
 530   (define-key edb-variables-mode-map [?m]          'edb-show-variable)
 531   (define-key edb-variables-mode-map [(control m)] 'edb-show-variable))
 532
 533 (defun edb-show-variable ()
 534   "Pop a window showing the full value of the variable at point."
 535   (interactive)
 536   (let ((var (get-text-property (point) 'edb-variable-name)))
 537     (if (null var)
 538         (message "No variable at point")
 539       (edb-attach-meta-cmd `[get_binding ,var]))))
 540
 541 ;; Attach process states
 542
 543 (defun &edb-attach-loop ()
 544   "Attached process loop."
 545   (erl-receive ()
 546       ((['location mod line pos max]
 547         (let ((msg (format "Location: %S:%S (Stack pos: %S/%S)"
 548                            mod line pos max)))
 549           (setq header-line-format msg))
 550         (&edb-attach-goto-source mod line))
 551        (['status status]
 552         (unless (memq status '(running idle))
 553           (message "Unrecognised status: %S" status))
 554         (setq header-line-format (format "Status: %S" status))
 555         (setq overlay-arrow-position nil)
 556         (&edb-attach-loop))
 557        (['variables vars]
 558         ;; {variables, [{Name, String}]}
 559         (when (buffer-live-p edb-variables-buffer)
 560           (with-current-buffer edb-variables-buffer
 561             (let ((buffer-read-only nil))
 562               (erase-buffer)
 563               (mapc (lambda (b)
 564                       (let ((name   (tuple-elt b 1))
 565                             (string (tuple-elt b 2)))
 566                         (put-text-property 0 (length string)
 567                                            'edb-variable-name name
 568                                            string)
 569                         (insert string)))
 570                     vars))))
 571         (&edb-attach-loop))
 572        (['message msg]
 573         (message msg)
 574         (&edb-attach-loop))
 575        (['show_variable value]
 576         (save-excursion (display-message-or-view value "*Variable Value*"))
 577         (&edb-attach-loop))
 578        (other
 579         (message "Other: %S" other)
 580         (&edb-attach-loop)))))
 581
 582 (defun &edb-attach-goto-source (module line)
 583   "Display MODULE:LINE in the attach buffer and reenter attach loop."
 584   (if (eq edb-module module)
 585       (progn (edb-attach-goto-line line)
 586              (&edb-attach-loop))
 587     (&edb-attach-find-source module line)))
 588
 589 (defun &edb-attach-find-source (module line)
 590   "Load the source code for MODULE into current buffer at LINE.
 591 Once loaded, reenters the attach loop."
 592   (erl-send-rpc edb-node 'distel 'find_source (list module))
 593   (erl-receive (module line)
 594       ((['rex ['ok path]]
 595         (if (file-regular-p path)
 596             (progn (setq edb-module module)
 597                    (let ((buffer-read-only nil))
 598                      (erase-buffer)
 599                      (insert-file-contents path))
 600                    (edb-delete-buffer-breakpoints)
 601                    (edb-create-buffer-breakpoints module)
 602                    (edb-attach-goto-line line))
 603           (message "No such file: %s" path))))
 604     (&edb-attach-loop)))
 605
 606 (defun edb-attach-goto-line (line)
 607   (goto-line line)
 608   (setq overlay-arrow-string "=>")
 609   (setq overlay-arrow-position (copy-marker (point))))
 610
 611 (defun edb-attach-buffer-name (pid)
 612   (format "*edbproc %s on %S*"
 613           (erl-pid-to-string pid)
 614           (erl-pid-node pid)))
 615
 616 (defun edb-attached-p (pid)
 617   "Non-nil when we have an attach buffer viewing PID."
 618   (buffer-live-p (get-buffer (edb-attach-buffer-name pid))))
 619
 620 ;; ----------------------------------------------------------------------
 621 ;; Attach minor mode and commands
 622
 623 (define-minor-mode edb-attach-mode
 624   "Minor mode for debugging an Erlang process.
 625
 626 Available commands:
 627 \\<edb-attach-mode-map>
 628 \\[edb-attach-help]     - Popup this help text.
 629 \\[erl-quit-viewer]     - Quit the viewer (doesn't kill the process)
 630 \\[edb-attach-step]     - Step (into expression)
 631 \\[edb-attach-next]     - Next (over expression)
 632 \\[edb-attach-up]       - Up to the next stack frame
 633 \\[edb-attach-down]     - Down to the next stack frame
 634 \\[edb-attach-continue] - Continue (until breakpoint)
 635 \\[edb-toggle-breakpoint]       - Toggle a breakpoint on the current line."
 636   nil
 637   " (attached)"
 638   '(([? ] . edb-attach-step)
 639     ([?n] . edb-attach-next)
 640     ([?c] . edb-attach-continue)
 641     ([?u] . edb-attach-up)
 642     ([?d] . edb-attach-down)
 643     ([?q] . erl-quit-viewer)
 644     ([?h] . edb-attach-help)
 645     ([?b] . edb-toggle-breakpoint)))
 646
 647 (defun edb-attach-help ()
 648   (interactive)
 649   (describe-function 'edb-attach-mode))
 650
 651 (defun edb-attach-step ()
 652   (interactive)
 653   (edb-attach-meta-cmd 'step))
 654 (defun edb-attach-next ()
 655   (interactive)
 656   (edb-attach-meta-cmd 'next))
 657 (defun edb-attach-continue ()
 658   (interactive)
 659   (edb-attach-meta-cmd 'continue))
 660 (defun edb-attach-up ()
 661   (interactive)
 662   (edb-attach-meta-cmd 'up))
 663 (defun edb-attach-down ()
 664   (interactive)
 665   (edb-attach-meta-cmd 'down))
 666
 667 (defun edb-attach-meta-cmd (cmd)
 668   (erl-send edb-pid `[emacs meta ,cmd]))
 669
 670 ;; ----------------------------------------------------------------------
 671 ;; Breakpoints
 672
 673 (defvar edb-breakpoints '()
 674   "List of all breakpoints on the currently monitored node.")
 675
 676 (defvar edb-saved-breakpoints '()
 677   "List of breakpoints to set if edb-restore-dbg-state is called.")
 678
 679 (make-variable-buffer-local
 680  (defvar edb-buffer-breakpoints nil
 681    "List of active buffer breakpoints."))
 682
 683 (make-variable-buffer-local
 684  (defvar edb-buffer-breakpoints-stale nil
 685    "Nil if the breakpoints in the buffer are stale (out of synch)."))
 686
 687 ;; breakpoints
 688 (defun make-bp (mod line) (list mod line))
 689 (defun bp-mod (bp) (car bp))
 690 (defun bp-line (bp) (cadr bp))
 691
 692 ;; buffer breakpoints
 693 (defun make-bbp (mod line ov) (list mod line ov))
 694 (defun bbp-mod (bbp) (car bbp))
 695 (defun bbp-line (bbp) (cadr bbp))
 696 (defun bbp-ov (bbp) (caddr bbp))
 697
 698 (defun edb-init-breakpoints (breaks)
 699   (setq edb-breakpoints
 700         (mapcar (lambda (pos)
 701                   (let ((mod (aref pos 0))
 702                         (line (aref pos 1)))
 703                     (make-bp mod line)))
 704                 breaks))
 705   (mapc
 706    (lambda (buf)
 707      (with-current-buffer buf
 708        (when erlang-extended-mode
 709          (edb-create-buffer-breakpoints (edb-source-file-module-name)))))
 710    (buffer-list)))
 711
 712
 713 (defun edb-create-breakpoint (mod line)
 714   "Updates all internal structures in all buffers with new breakpoint."
 715   (push (make-bp mod line) edb-breakpoints)
 716   (mapc
 717    (lambda (buf)
 718      (with-current-buffer buf
 719        (if (and erlang-extended-mode
 720                 (eq (edb-source-file-module-name) mod))
 721            (let ((bbp (make-bbp mod line (edb-make-breakpoint-overlay line))))
 722              (push bbp edb-buffer-breakpoints)))))
 723    (buffer-list)))
 724
 725 (defun edb-delete-all-breakpoints ()
 726   "Updates all internal structures in all buffers."
 727   (edb-del-breakpoints
 728    (lambda (bp) t)
 729    (lambda (bbp) t)))
 730
 731 (defun edb-delete-breakpoints (mod)
 732   "Updates all internal structures in all buffers."
 733   (edb-del-breakpoints
 734    (lambda (bp) (eq (bp-mod bp) mod))
 735    (lambda (bbp) (eq (bbp-mod bbp) mod))
 736    mod))
 737
 738 (defun edb-delete-breakpoint (mod line)
 739   "Updates all internal structures in all buffers."
 740   (edb-del-breakpoints
 741    (lambda (bp) (and (eq (bp-mod bp) mod)
 742                      (eq (bp-line bp) line)))
 743    (lambda (bbp) (and (eq (bbp-mod bbp) mod)
 744                       (eq (bbp-line bbp) line)))
 745    mod))
 746
 747 (defun edb-create-buffer-breakpoints (mod)
 748   "Creates buffer breakpoints in the current buffer."
 749   (when edb-buffer-breakpoints
 750     ;; remove old/stale breakpoints
 751     (edb-delete-buffer-breakpoints))
 752   (setq edb-buffer-breakpoints (edb-mk-bbps mod)))
 753
 754 (defun edb-delete-buffer-breakpoints ()
 755   "Deletes all buffer breakpoints in the current buffer."
 756   (setq edb-buffer-breakpoints
 757         (edb-del-bbps edb-buffer-breakpoints (lambda (bbp) t))))
 758
 759 (defun edb-del-breakpoints (bp-f bbp-f &optional mod)
 760   "Updates all internal structures in all buffers."
 761   (setq edb-breakpoints (erl-remove-if bp-f edb-breakpoints))
 762   (mapc
 763    (lambda (buf)
 764      (with-current-buffer buf
 765        (if (and erlang-extended-mode
 766                 (or (not mod)
 767                     (eq (edb-source-file-module-name) mod)))
 768            (setq edb-buffer-breakpoints
 769                  (edb-del-bbps edb-buffer-breakpoints bbp-f)))))
 770    (buffer-list)))
 771
 772 (defun edb-synch-breakpoints (node module)
 773   "Synchronizes the breakpoints in the current buffer to erlang.
 774 I.e. deletes all old breakpoints, and re-applies them at the current line."
 775   (interactive (list (erl-target-node)
 776                      (edb-module)))
 777   (when (edb-ensure-monitoring node)
 778     (let ((id (lambda (r) r)))
 779       (mapc (lambda (new-bbp)
 780               (let ((bbp (car new-bbp))
 781                     (new-line (cdr new-bbp)))
 782                 (erl-rpc id nil node 'distel 'break_delete
 783                          (list (bbp-mod bbp) (bbp-line bbp)))
 784                 (erl-rpc id nil node 'distel 'break_add
 785                          (list module new-line))))
 786             (edb-new-bbps))
 787       (setq edb-buffer-breakpoints-stale nil))))
 788
 789 (defun edb-make-breakpoints-stale (begin end length)
 790   "Make breakpoints in the current buffer stale.
 791 Has no effect if the buffer's module is not interpreted, or the
 792 breakpoints are already marked as stale."
 793   (when (and (not edb-attach-buffer)
 794              (not edb-buffer-breakpoints-stale)
 795              edb-module-interpreted)
 796     (mapc (lambda (bbp)
 797             (let ((ov (bbp-ov bbp)))
 798               (overlay-put ov 'face 'edb-breakpoint-stale-face)))
 799           edb-buffer-breakpoints)
 800     (setq edb-buffer-breakpoints-stale t)))
 801
 802 (defun edb-save-breakpoints (node)
 803   (let ((modules '()))
 804     (setq edb-saved-breakpoints '())
 805     (mapc
 806      (lambda (buf)
 807        (with-current-buffer buf
 808          (if erlang-extended-mode
 809              (let ((cur-mod (edb-source-file-module-name)))
 810                (unless (member cur-mod modules)
 811                  (let ((new-lines (mapcar (lambda (new-bbp) (cdr new-bbp))
 812                                           (edb-new-bbps))))
 813                    (push cur-mod modules)
 814                    (push (list cur-mod new-lines) edb-saved-breakpoints)))))))
 815      (buffer-list))
 816     (mapc (lambda (bp)
 817             (unless (member (bp-mod bp) modules)
 818               (push (list (bp-mod bp) (list (bp-line bp)))
 819                     edb-saved-breakpoints)))
 820           edb-breakpoints)))
 821
 822 (defun edb-restore-breakpoints (node cont)
 823   (erl-send-rpc node 'distel 'break_restore (list edb-saved-breakpoints))
 824   (erl-receive (cont)
 825       ((['rex 'ok]
 826         (funcall cont))
 827        (['rex ['badrpc reason]]
 828         (message "Failed to restore breakpoints: %S" reason)))))
 829
 830 (defun edb-new-bbps ()
 831   (mapcar (lambda (bbp)
 832             (let* ((new-pos (overlay-start (bbp-ov bbp)))
 833                    (new-line (+ (count-lines (point-min) new-pos) 1)))
 834               (cons bbp new-line)))
 835           edb-buffer-breakpoints))
 836
 837 (defun edb-mk-bbps (mod)
 838   (zf
 839    (lambda (bp)
 840      (let ((bmod (bp-mod bp))
 841            (line (bp-line bp)))
 842        (if (eq bmod mod)
 843            (let ((ov (edb-make-breakpoint-overlay line)))
 844              (make-bbp bmod line ov))
 845          nil)))
 846    edb-breakpoints))
 847
 848 (defun edb-del-bbps (list pred)
 849   (zf
 850    (lambda (bbp)
 851      (cond ((funcall pred bbp)
 852             (delete-overlay (bbp-ov bbp))
 853             nil)
 854            (t bbp)))
 855    list))
 856
 857 (defun edb-make-breakpoint-overlay (line)
 858   "Creats an overlay at line"
 859   (save-excursion
 860     (goto-line line)
 861     (let ((ov (make-overlay (line-beginning-position)
 862                             (line-beginning-position 2)
 863                             (current-buffer)
 864                             t
 865                             nil)))
 866       (overlay-put ov 'edb-breakpoint t)
 867       (if edb-buffer-breakpoints-stale
 868           (overlay-put ov 'face 'edb-breakpoint-stale-face)
 869         (overlay-put ov 'face 'edb-breakpoint-face))
 870       ov)))
 871
 872 (defun zf (f l)
 873   (let ((res nil))
 874     (dolist (x l)
 875       (let ((r (funcall f x)))
 876         (if r (push r res))))
 877     res))
 878
 879 (defun edb-first (pred list)
 880   "Return the first element of LIST that satisfies PRED."
 881   (loop for x in list
 882         when (funcall pred x) return x))
 883
 884 (provide 'edb)