perldb.el

早期freebsd实现

	(perldb-filter-accumulate-marker proc
				      (concat perldb-filter-accumulator string))
	(perldb-filter-scan-input proc string))))

(defun perldb-filter-accumulate-marker (proc string)
  (setq perldb-filter-accumulator nil)
  (if (> (length string) 1)
      (if (= (aref string 1) ?\032)
	  (let ((end (string-match "\n" string)))
	    (if end
		(progn
		  (let* ((first-colon (string-match ":" string 2))
			 (second-colon
			  (string-match ":" string (1+ first-colon))))
		    (setq perldb-last-frame
			  (cons (substring string 2 first-colon)
				(string-to-int
				 (substring string (1+ first-colon)
					    second-colon)))))
		  (setq perldb-last-frame-displayed-p nil)
		  (perldb-filter-scan-input proc
					 (substring string (1+ end))))
	      (setq perldb-filter-accumulator string)))
	(perldb-filter-insert proc "\032")
	(perldb-filter-scan-input proc (substring string 1)))
    (setq perldb-filter-accumulator string)))

(defun perldb-filter-scan-input (proc string)
  (if (equal string "")
      (setq perldb-filter-accumulator nil)
      (let ((start (string-match "\032" string)))
	(if start
	    (progn (perldb-filter-insert proc (substring string 0 start))
		   (perldb-filter-accumulate-marker proc
						 (substring string start)))
	    (perldb-filter-insert proc string)))))

(defun perldb-filter-insert (proc string)
  (let ((moving (= (point) (process-mark proc)))
	(output-after-point (< (point) (process-mark proc)))
	(old-buffer (current-buffer))
	start)
    (set-buffer (process-buffer proc))
    (unwind-protect
	(save-excursion
	  ;; Insert the text, moving the process-marker.
	  (goto-char (process-mark proc))
	  (setq start (point))
	  (insert string)
	  (set-marker (process-mark proc) (point))
	  (perldb-maybe-delete-prompt)
	  ;; Check for a filename-and-line number.
	  (perldb-display-frame
	   ;; Don't display the specified file
	   ;; unless (1) point is at or after the position where output appears
	   ;; and (2) this buffer is on the screen.
	   (or output-after-point
	       (not (get-buffer-window (current-buffer))))
	   ;; Display a file only when a new filename-and-line-number appears.
	   t))
      (set-buffer old-buffer))
    (if moving (goto-char (process-mark proc)))))

(defun perldb-sentinel (proc msg)
  (cond ((null (buffer-name (process-buffer proc)))
	 ;; buffer killed
	 ;; Stop displaying an arrow in a source file.
	 (setq overlay-arrow-position nil)
	 (set-process-buffer proc nil))
	((memq (process-status proc) '(signal exit))
	 ;; Stop displaying an arrow in a source file.
	 (setq overlay-arrow-position nil)
	 ;; Fix the mode line.
	 (setq mode-line-process
	       (concat ": "
		       (symbol-name (process-status proc))))
	 (let* ((obuf (current-buffer)))
	   ;; save-excursion isn't the right thing if
	   ;;  process-buffer is current-buffer
	   (unwind-protect
	       (progn
		 ;; Write something in *compilation* and hack its mode line,
		 (set-buffer (process-buffer proc))
		 ;; Force mode line redisplay soon
		 (set-buffer-modified-p (buffer-modified-p))
		 (if (eobp)
		     (insert ?\n mode-name " " msg)
		   (save-excursion
		     (goto-char (point-max))
		     (insert ?\n mode-name " " msg)))
		 ;; If buffer and mode line will show that the process
		 ;; is dead, we can delete it now.  Otherwise it
		 ;; will stay around until M-x list-processes.
		 (delete-process proc))
	     ;; Restore old buffer, but don't restore old point
	     ;; if obuf is the perldb buffer.
	     (set-buffer obuf))))))


(defun perldb-refresh ()
  "Fix up a possibly garbled display, and redraw the arrow."
  (interactive)
  (redraw-display)
  (perldb-display-frame))

(defun perldb-display-frame (&optional nodisplay noauto)
  "Find, obey and delete the last filename-and-line marker from PERLDB.
The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n.
Obeying it means displaying in another window the specified file and line."
  (interactive)
  (perldb-set-buffer)
  (and perldb-last-frame (not nodisplay)
       (or (not perldb-last-frame-displayed-p) (not noauto))
       (progn (perldb-display-line (car perldb-last-frame) (cdr perldb-last-frame))
	      (setq perldb-last-frame-displayed-p t))))

;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
;; and that its line LINE is visible.
;; Put the overlay-arrow on the line LINE in that buffer.

(defun perldb-display-line (true-file line)
  (let* ((buffer (find-file-noselect true-file))
	 (window (display-buffer buffer t))
	 (pos))
    (save-excursion
      (set-buffer buffer)
      (save-restriction
	(widen)
	(goto-line line)
	(setq pos (point))
	(setq overlay-arrow-string "=>")
	(or overlay-arrow-position
	    (setq overlay-arrow-position (make-marker)))
	(set-marker overlay-arrow-position (point) (current-buffer)))
      (cond ((or (< pos (point-min)) (> pos (point-max)))
	     (widen)
	     (goto-char pos))))
    (set-window-point window overlay-arrow-position)))

(defun perldb-call (command)
  "Invoke perldb COMMAND displaying source in other window."
  (interactive)
  (goto-char (point-max))
  (setq perldb-delete-prompt-marker (point-marker))
  (perldb-set-buffer)
  (send-string (get-buffer-process current-perldb-buffer)
	       (concat command "\n")))

(defun perldb-maybe-delete-prompt ()
  (if (and perldb-delete-prompt-marker
	   (> (point-max) (marker-position perldb-delete-prompt-marker)))
      (let (start)
	(goto-char perldb-delete-prompt-marker)
	(setq start (point))
	(beginning-of-line)
	(delete-region (point) start)
	(setq perldb-delete-prompt-marker nil))))

(defun perldb-break ()
  "Set PERLDB breakpoint at this source line."
  (interactive)
  (let ((line (save-restriction
		(widen)
		(1+ (count-lines 1 (point))))))
    (send-string (get-buffer-process current-perldb-buffer)
		 (concat "b " line "\n"))))

(defun perldb-read-token()
  "Return a string containing the token found in the buffer at point.
A token can be a number or an identifier.  If the token is a name prefaced
by `$', `@', or `%', the leading character is included in the token."
  (save-excursion
    (let (begin)
      (or (looking-at "[$@%]")
	  (re-search-backward "[^a-zA-Z_0-9]" (point-min) 'move))
      (setq begin (point))
      (or (looking-at "[$@%]") (setq begin (+ begin 1)))
      (forward-char 1)
      (buffer-substring begin
			(if (re-search-forward "[^a-zA-Z_0-9]"
					       (point-max) 'move)
			       (- (point) 1)
			  (point)))
)))

(defvar perldb-commands nil
  "List of strings or functions used by send-perldb-command.
It is for customization by the user.")

(defun send-perldb-command (arg)
  "Issue a Perl debugger command selected by the prefix arg.  A numeric
arg selects the ARG'th member COMMAND of the list perldb-commands.
The token under the cursor is passed to the command.  If COMMAND is a
string, (format COMMAND TOKEN) is inserted at the end of the perldb
buffer, otherwise (funcall COMMAND TOKEN) is inserted.  If there is
no such COMMAND, then the token itself is inserted.  For example,
\"p %s\" is a possible string to be a member of perldb-commands,
or \"p $ENV{%s}\"."
  (interactive "P")
  (let (comm token)
    (if arg (setq comm (nth arg perldb-commands)))
    (setq token (perldb-read-token))
    (if (eq (current-buffer) current-perldb-buffer)
	(set-mark (point)))
    (cond (comm
	   (setq comm
		 (if (stringp comm) (format comm token) (funcall comm token))))
	  (t (setq comm token)))
    (switch-to-buffer-other-window current-perldb-buffer)
    (goto-char (dot-max))
    (insert-string comm)))