Emacs-PDE
view release on metacpan or search on metacpan
lisp/perldb-ui.el view on Meta::CPAN
'((without-io
(vertical 0.25
(horizontal 0.50 gud-comint-buffer perldb-locals-buffer)
(vertical 0.50 source-buffer
(horizontal 0.50 perldb-stack-buffer perldb-breakpoints-buffer)))
0 0)
(with-io
(vertical 0.25
(horizontal 0.50 gud-comint-buffer perldb-locals-buffer)
(vertical 0.50
(horizontal 0.50 source-buffer perldb-inferior-io)
(horizontal 0.50 perldb-stack-buffer perldb-breakpoints-buffer)))
0 0))
"*Default window configuration for perldb-ui.
with-io style is used when `perldb-use-separate-io-buffer' is
turn on.")
(defvar perldb-source-buffer nil
"")
;;;###autoload
(defun perldb-ui (command-line)
"Run perldb on program FILE in buffer *gud-FILE*.
The directory containing FILE becomes the initial working directory
and source-file directory for your debugger."
(interactive
(progn
(push (concat gud-perldb-command-name " " buffer-file-name)
gud-perldb-history)
(list
(gud-query-cmdline 'perldb
(concat (or (buffer-file-name) "-e 0") " ")))))
(perldb-install-methods)
(gud-common-init command-line 'gud-perldb-massage-args
'perldb-marker-filter)
(set-process-sentinel (get-buffer-process (current-buffer))
'perldb-sentinel)
(set (make-local-variable 'gud-minor-mode) 'perldb)
(gud-def gud-break "b %l" "\C-b" "Set breakpoint at current line.")
(gud-def gud-remove "B %l" "\C-d" "Remove breakpoint at current line")
(gud-def gud-step "s" "\C-s" "Step one source line with display.")
(gud-def gud-next "n" "\C-n" "Step one line (skip functions).")
(gud-def gud-cont "c" "\C-r" "Continue with display.")
(gud-def gud-return "r" "\C-q" "Return from current subroutine.")
(gud-def gud-print "p %e" "\C-p" "Evaluate perl expression at point.")
(gud-def gud-until "c %l" "\C-u" "Continue to current line.")
(gud-def gud-dump "x %e" "\C-x" "Dumper data")
(setq gud-find-file 'perldb-find-file)
(setq comint-input-sender 'perldb-send)
(if perldb-use-separate-io-buffer (perldb-clear-inferior-io))
(setq comint-prompt-regexp perldb-prompt-regexp)
(setq paragraph-start comint-prompt-regexp)
;; init variable
(setq gdb-buffer-fringe-width (car (window-fringes)))
(run-hooks 'perldb-mode-hook)
(sit-for 0)
(perldb-restore-windows))
(defun perldb-sentinel (proc msg)
(dolist (bp perldb-breakpoints)
(apply 'perldb-remove-breakpoint (overlay-get bp 'break-position)))
(gud-sentinel proc msg))
(defun perldb-install-methods ()
(with-temp-buffer
(let ((conf "~/.perldb")
found)
(if (file-exists-p conf)
(progn
(insert-file-contents conf)
(goto-char (point-min))
(when (re-search-forward "^#### perldb.el version \\([0-9]+\\.[0-9]+\\)" nil t)
(if (string= (match-string 1) perldb-version)
(setq found t)
(let ((beg (line-beginning-position)) end)
(if (re-search-forward "^#### end perldb.el" nil t)
(setq end (line-end-position))
(setq end (point-max)))
(delete-region beg end)))))
(insert "# -*- perl -*-\n"))
(unless found
(message "Install methods...")
(goto-char (point-max))
(insert "#### perldb.el version " perldb-version
"
{
package DB::emacs;
use constant PRE => \"\\032\\032pre-prompt\\n\";
use constant POST => \"\\032\\032post-prompt\";
use subs qw(output);
our $o;
sub output {
my $val = shift;
$val = $o unless defined $val;
$val = '<undef>' unless defined $val;
print PRE;
print $val;
print POST;
}
sub status {
output (
sprintf \"((current-sub . \\\"%s\\\")\\n (functions . %d)\\n (includes . %d))\",
$DB::emacs::sub, scalar( keys %DB::sub ), scalar( keys %INC ));
}
# FIXME: How to inhibit this error
sub trace {
print PRE;
DB::print_trace($DB::OUT, 1);
print POST;
}
sub breakpoints {
print PRE;
DB->cmd_L('b');
print POST;
}
sub functions {
output \"(\" . join(\"\\n\", map { qq(\"$_\") } sort keys %DB::sub) . \")\";
}
sub includes {
output \"(\" . join(\"\\n\", map { s/\\.pm$//; s/\\//::/g; qq(\"$_\") } sort keys %INC) . \")\";
}
lisp/perldb-ui.el view on Meta::CPAN
(list (perldb-make-command "$DB::emacs::sub=$DB::sub;DB::emacs::status()") 'perldb-check-status)
perldb-input-queue))
(funcall (cadr perldb-current-item)))
(let ((input (perldb-dequeue-input)))
(if input
(perldb-send-item input))))
;; Handler
(defmacro perldb-define-trigger (trigger buf-key command handler
&rest body)
(declare (indent 1))
`(progn
(defun ,trigger (&rest args)
(if (perldb-get-buffer ',buf-key)
(push (list (perldb-make-command ,command) ',handler) perldb-input-queue)))
(defun ,handler (&rest args)
(with-current-buffer (perldb-get-buffer ',buf-key)
(erase-buffer)
(insert-buffer-substring (perldb-get-buffer 'gdb-partial-output-buffer))
(progn ,@body)))))
(perldb-define-trigger perldb-invalidate-stack
perldb-stack-buffer "DB::emacs::trace()" perldb-info-stack
(goto-char (point-min))
;; set FIXME in .perldb
(if (re-search-forward "^@ = DB::DB called from file" nil t)
(delete-region (point-min) (progn (forward-line 1) (point)))))
(perldb-define-trigger perldb-invalidate-functions
perldb-functions-buffer
"DB::emacs::functions()"
perldb-info-functions)
(perldb-define-trigger perldb-invalidate-includes
perldb-includes-buffer
"DB::emacs::includes()"
perldb-info-includes)
(perldb-define-trigger perldb-invalidate-breakpoints
perldb-breakpoints-buffer
"DB::emacs::breakpoints()"
perldb-info-breakpoints
(let ((breakpoints perldb-breakpoints)
bp new-breakpoints file line)
(goto-char (point-min))
;; add new breakpoints
(while (not (eobp))
(setq file (buffer-substring (point) (1- (line-end-position))))
(forward-line 1)
(while (looking-at "^\\s-+\\([0-9]+\\):")
(setq line (string-to-number (match-string 1)))
;; (message "file: %s line: %d" file line)
(unless (setq bp (perldb-find-breakpoints file line))
(setq bp (perldb-put-breakpoint file line)))
(push bp new-breakpoints)
(forward-line 2)))
;; remove not exists breakpoints
(dolist (bp breakpoints)
(unless (memq bp new-breakpoints)
(apply 'perldb-remove-breakpoint (overlay-get bp 'break-position))))
;; install to perldb-breakpoints
(setq perldb-breakpoints new-breakpoints)))
(defun perldb-invalidate-temp-buffer ()
"Dummy function for future implement."
)
(defun perldb-check-status ()
(ignore-errors
(with-current-buffer (perldb-get-buffer 'gdb-partial-output-buffer)
(goto-char (point-min))
(let ((status (read (current-buffer)))
(last perldb-last-status)
(handlers '((current-sub . perldb-invalidate-stack)
(functions . perldb-invalidate-functions)
(includes . perldb-invalidate-includes))))
(dolist (st status)
(unless (equal st (car last))
(funcall (assoc-default (car st) handlers)))
(setq last (cdr last)))
(setq perldb-last-status status)))))
(defun perldb-clear-buffer (buf-key)
(let ((buf (perldb-get-buffer buf-key)))
(if buf (with-current-buffer buf (erase-buffer)))))
(defun perldb-reset (&rest args)
(perldb-clear-buffer 'perldb-locals-buffer)
(perldb-clear-buffer 'perldb-stack-buffer)
(perldb-clear-buffer 'perldb-inferior-io)
(setq perldb-current-item nil
perldb-current-user-command nil
perldb-watchpoints nil))
;; Command sender
(defun perldb-enqueue-input (item)
(if gud-running
(push item perldb-input-queue)
(perldb-send-item item)))
(defun perldb-dequeue-input ()
(let ((queue perldb-input-queue))
(and queue
(let ((last (car (last queue))))
(unless (nbutlast queue) (setq perldb-input-queue '()))
last))))
(defun perldb-send-item (item)
(if gdb-enable-debug (push (cons 'send item) gdb-debug-log))
(setq perldb-current-item item)
(setq perldb-output-sink (if perldb-use-separate-io-buffer 'inferior 'user))
(let ((proc (get-buffer-process gud-comint-buffer)))
(if (stringp item) ; it is user command
(process-send-string proc item)
;; it is editor command
(perldb-clear-partial-output)
(process-send-string proc (car item)))))
(defun perldb-send (proc string)
lisp/perldb-ui.el view on Meta::CPAN
(message "Please enable perldb-many-windows before saving window configuration.")))
(defun perldb-create-buffers ()
(interactive)
(if perldb-use-separate-io-buffer
(perldb-clear-inferior-io))
(dolist (id '(perldb-locals-buffer perldb-stack-buffer
perldb-breakpoints-buffer))
(perldb-get-buffer id)))
(defun perldb-use-separate-io-buffer (arg)
"Toggle separate IO for debugged program.
With arg, use separate IO iff arg is positive."
(interactive "P")
(setq perldb-use-separate-io-buffer
(if (null arg)
(not perldb-use-separate-io-buffer)
(> (prefix-numeric-value arg) 0)))
(message (format "Separate IO %sabled"
(if perldb-use-separate-io-buffer "en" "dis")))
(if (and gud-comint-buffer
(buffer-name gud-comint-buffer))
(condition-case nil
(if perldb-use-separate-io-buffer
(if perldb-many-windows (perldb-restore-windows))
(kill-buffer (perldb-inferior-io-name)))
(error nil))))
(defun perldb-setup-windows ()
(let ((windata-data-restore-function 'perldb-set-window-buffer))
(windata-restore-winconf (cdr (assoc
(if perldb-use-separate-io-buffer
'with-io
'without-io)
perldb-window-configuration)))))
(defun perldb-get-buffer (id)
(cond ((assoc id gdb-buffer-rules)
(gdb-get-buffer-create id))
((eq id 'gud-comint-buffer) gud-comint-buffer)
((eq id 'source-buffer)
(if gud-last-last-frame
(perldb-find-file (car gud-last-last-frame))
(gdb-get-buffer 'perldb-temp-buffer)))))
(defun perldb-set-window-buffer (win id)
(let ((buf (perldb-get-buffer id)))
(if buf
(set-window-buffer win buf))))
;; set or clear breakpoint
(defalias 'perldb-put-string 'gdb-put-string)
(defun perldb-find-breakpoints (file line)
(let ((breakpoints perldb-breakpoints))
(when breakpoints
(let ((pos (list file line))
found)
(while (and (not found) breakpoints)
(if (equal (overlay-get (car breakpoints) 'break-position) pos)
(setq found (car breakpoints)))
(setq breakpoints (cdr breakpoints)))
found))))
(defun perldb-put-breakpoint (file line)
(unless (perldb-find-breakpoints file line)
(let ((breakpoints perldb-breakpoints))
(with-current-buffer (perldb-find-file file)
(goto-char (point-min))
(forward-line (1- line))
(let ((start (line-beginning-position))
(putstring (propertize "B" 'help-echo "mouse-1: clear bkpt, mouse-3: enable/disable bkpt"))
(source-window (get-buffer-window (current-buffer) 0))
ov)
(if (display-images-p)
(if (>= (or left-fringe-width
(if source-window (car (window-fringes source-window)))
gdb-buffer-fringe-width) 8)
(perldb-put-string
nil start
'(left-fringe breakpoint breakpoint-enabled))
(when (< left-margin-width 2)
(save-current-buffer
(setq left-margin-width 2)
(if source-window
(set-window-margins
source-window
left-margin-width right-margin-width))))
(put-image
(or breakpoint-enabled-icon
(setq breakpoint-enabled-icon
(find-image `((:type xpm :data
,breakpoint-xpm-data
:ascent 100 :pointer hand)
(:type pbm :data
,breakpoint-enabled-pbm-data
:ascent 100 :pointer hand)))))
start putstring 'left-margin))
(when (< left-margin-width 2)
(save-current-buffer
(setq left-margin-width 2)
(let ((window (get-buffer-window (current-buffer) 0)))
(if window
(set-window-margins
window left-margin-width right-margin-width)))))
(perldb-put-string
(propertize putstring 'face 'breakpoint-enabled)
start))
(setq ov (overlays-in start start))
(unless (= (length ov) 1)
(while (and ov
(not (or (overlay-get (car ov) 'put-break)
(overlay-get (car ov) 'put-image))))
(setq ov (cdr ov))))
(setq ov (car ov))
(overlay-put ov 'break-position (list file line))
(add-to-list 'perldb-breakpoints ov)
ov)))))
(defun perldb-remove-breakpoint (file line)
(let ((bp (perldb-find-breakpoints file line)))
(when bp
(setq perldb-breakpoints (delq bp perldb-breakpoints))
(delete-overlay bp))))
(defun perldb-watchpoint-handler (output)
(let (start)
(while (string-match "^Watchpoint [0-9]+:\\s-+\\(.*\\) changed" output start)
(perldb-invalidate-watchpoints (list (match-string 1 output)))
(setq start (match-end 0)))
output))
(defun perldb-invalidate-watchpoints (&rest args)
(setq args (car args))
(when (perldb-get-buffer 'perldb-locals-buffer)
(let ((expr "1") ; dummy expr
case-fold-search)
(if (listp args) ; update some watchpoint
(setq expr (car args))
(if (string-match "^w " perldb-current-user-command)
(setq expr (substring perldb-current-user-command 2 -1))))
(push
(list
(perldb-make-command (format "$DB::emacs::o=%s; DB::emacs::output()" expr))
'perldb-info-watchpoints)
perldb-input-queue))))
(defun perldb-find-watchpoint (expr)
(let ((rest (member expr perldb-watchpoints)))
(when rest
(- (length perldb-watchpoints)
(length rest)))))
(defun perldb-trim-whitespace (str)
(setq str (replace-regexp-in-string "\\`\\s-*" "" str))
(replace-regexp-in-string "\\s-*\\'" "" str))
(defun perldb-info-watchpoints ()
(let (case-fold-search expr line)
(with-current-buffer (perldb-get-buffer 'perldb-locals-buffer)
(goto-char (point-min))
(if (string-match "^W " perldb-current-user-command)
(if (string-match "^W\\s-+\\*" perldb-current-user-command)
(progn
(erase-buffer)
(setq perldb-watchpoints nil))
(setq expr (perldb-trim-whitespace (substring perldb-current-user-command 2 -1)))
(forward-line (perldb-find-watchpoint expr))
(delete-region (point) (progn (forward-line 1) (point)))
(setq perldb-watchpoints (delete expr perldb-watchpoints)))
(when (string-match "DB::emacs::o=\\(.*\\); DB::emacs::output()"
(car perldb-current-item))
(setq expr (perldb-trim-whitespace (match-string 1 (car perldb-current-item))))
(if (string-match "^w " perldb-current-user-command)
(progn
(setq perldb-watchpoints (nconc perldb-watchpoints (list expr)))
(goto-char (point-max))
(setq line t))
(setq line (perldb-find-watchpoint expr))
(if (null line)
(message "Can't found expr '%s' in watchpoints" expr)
(forward-line line)
(delete-region (point) (progn (forward-line 1) (point)))))
( run in 0.495 second using v1.01-cache-2.11-cpan-5a3173703d6 )