(perldb): New function, plus subroutines.

lisp/gud.el

@@ -65,7 +65,7 @@ This association list has elements of the form
 
 (defun gud-find-file (f)
   (error "GUD not properly entered."))
-
+
 ;; ======================================================================
 ;; command definition
 
@@ -146,7 +146,7 @@ we're in the GUD buffer)."
 ;; The job of the find-file method is to visit and return the buffer indicated
 ;; by the car of gud-tag-frame.  This may be a file name, a tag name, or
 ;; something else.
-
+
 ;; ======================================================================
 ;; gdb functions
 
@@ -247,7 +247,7 @@ and source-file directory for your debugger."
   (run-hooks 'gdb-mode-hook)
   )
 
-
+
 ;; ======================================================================
 ;; sdb functions
 
@@ -326,7 +326,7 @@ and source-file directory for your debugger."
   (setq comint-prompt-regexp  "\\(^\\|\n\\)\\*")
   (run-hooks 'sdb-mode-hook)
   )
-
+
 ;; ======================================================================
 ;; dbx functions
 
@@ -388,7 +388,7 @@ and source-file directory for your debugger."
   (setq comint-prompt-regexp  "^[^)]*dbx) *")
   (run-hooks 'dbx-mode-hook)
   )
-
+
 ;; ======================================================================
 ;; xdb (HP PARISC debugger) functions
 
@@ -489,11 +489,112 @@ directories if your program contains sources from more than one directory."
   (make-local-variable 'gud-xdb-accumulation)
   (setq gud-xdb-accumulation "")
   (run-hooks 'xdb-mode-hook))
+
+;; ======================================================================
+;; perldb functions
+
+;;; History of argument lists passed to perldb.
+(defvar gud-perldb-history nil)
+
+(defun gud-perldb-massage-args (file args)
+  (cons "-fullname" (cons file args)))
+
+;; There's no guarantee that Emacs will hand the filter the entire
+;; marker at once; it could be broken up across several strings.  We
+;; might even receive a big chunk with several markers in it.  If we
+;; receive a chunk of text which looks like it might contain the
+;; beginning of a marker, we save it here between calls to the
+;; filter.
+(defvar gud-perldb-marker-acc "")
+
+(defun gud-perldb-marker-filter (string)
+  (save-match-data
+    (setq gud-perldb-marker-acc (concat gud-perldb-marker-acc string))
+    (let ((output ""))
+
+      ;; Process all the complete markers in this chunk.
+      (while (string-match "^\032\032\\([^:\n]*\\):\\([0-9]*\\):.*\n"
+			   gud-perldb-marker-acc)
+	(setq
+
+	 ;; Extract the frame position from the marker.
+	 gud-last-frame
+	 (cons (substring gud-perldb-marker-acc (match-beginning 1) (match-end 1))
+	       (string-to-int (substring gud-perldb-marker-acc
+					 (match-beginning 2)
+					 (match-end 2))))
+
+	 ;; Append any text before the marker to the output we're going
+	 ;; to return - we don't include the marker in this text.
+	 output (concat output
+			(substring gud-perldb-marker-acc 0 (match-beginning 0)))
+
+	 ;; Set the accumulator to the remaining text.
+	 gud-perldb-marker-acc (substring gud-perldb-marker-acc (match-end 0))))
+
+      ;; Does the remaining text look like it might end with the
+      ;; beginning of another marker?  If it does, then keep it in
+      ;; gud-perldb-marker-acc until we receive the rest of it.  Since we
+      ;; know the full marker regexp above failed, it's pretty simple to
+      ;; test for marker starts.
+      (if (string-match "^\032.*\\'" gud-perldb-marker-acc)
+	  (progn
+	    ;; Everything before the potential marker start can be output.
+	    (setq output (concat output (substring gud-perldb-marker-acc
+						   0 (match-beginning 0))))
+
+	    ;; Everything after, we save, to combine with later input.
+	    (setq gud-perldb-marker-acc
+		  (substring gud-perldb-marker-acc (match-beginning 0))))
+
+	(setq output (concat output gud-perldb-marker-acc)
+	      gud-perldb-marker-acc ""))
+
+      output)))
+
+(defun gud-perldb-find-file (f)
+  (find-file-noselect f))
+
+;;;###autoload
+(defun perldb (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
+   (list (read-from-minibuffer "Run perldb (like this): "
+			       (if (consp gud-perldb-history)
+				   (car gud-perldb-history)
+				 "perldb ")
+			       nil nil
+			       '(gud-perldb-history . 1))))
+  (gud-overload-functions '((gud-massage-args . gud-perldb-massage-args)
+			    (gud-marker-filter . gud-perldb-marker-filter)
+			    (gud-find-file . gud-perldb-find-file)
+			    ))
+
+  (gud-common-init command-line)
+
+  (gud-def gud-break  "break %f:%l"  "\C-b" "Set breakpoint at current line.")
+  (gud-def gud-tbreak "tbreak %f:%l" "\C-t" "Set breakpoint at current line.")
+  (gud-def gud-remove "clear %l"     "\C-d" "Remove breakpoint at current line")
+  (gud-def gud-step   "step %p"      "\C-s" "Step one source line with display.")
+  (gud-def gud-stepi  "stepi %p"     "\C-i" "Step one instruction with display.")
+  (gud-def gud-next   "next %p"      "\C-n" "Step one line (skip functions).")
+  (gud-def gud-cont   "cont"         "\C-r" "Continue with display.")
+  (gud-def gud-finish "finish"       "\C-f" "Finish executing current function.")
+  (gud-def gud-up     "up %p"        "<" "Up N stack frames (numeric arg).")
+  (gud-def gud-down   "down %p"      ">" "Down N stack frames (numeric arg).")
+  (gud-def gud-print  "print %e"     "\C-p" "Evaluate C expression at point.")
+
+  (setq comint-prompt-regexp "^(.*perldb[+]?) *")
+  (run-hooks 'gdb-mode-hook)
+  )
 
 ;;
 ;; End of debugger-specific information
 ;;
 
+
 ;;; When we send a command to the debugger via gud-call, it's annoying
 ;;; to see the command and the new prompt inserted into the debugger's
 ;;; buffer; we have other ways of knowing the command has completed.