;;; perl-eval.el
;;; More Perl support for emacs
;;; Rob Funk <funk+@osu.edu>
;;; last modified 26-June-1996
;;;
;;; Adds run-perl, perl-command, and perl-command-on-region functions.
;;;
;;; run-perl could probably use a little work
;;; (then again, it really isn't necessary.)

;;; run-perl is just a less-interactive wrapper around perldb
(defvar perl-command-line-interactive "perl -d -e 1 "
  "*Command line invoked by the run-perl command")

(defun run-perl (command-line)
  "Run Perl interpreter in interactive (debug) mode.
With argument, allows you to edit the command line."
  (interactive
   (list (if current-prefix-arg
	     (read-from-minibuffer "Run Perl: " perl-command-line-interactive)
	   perl-command-line-interactive)))
  (perldb command-line))

;;; All the perl-command stuff is adapted from the shell-command stuff
;;; in simple.el -- mostly just replacing "shell" with "perl".  I also
;;; removed the backgrounding support.

(defvar perl-file-name "/usr/local/bin/perl"
  "*File name to load Perl from.")

(defvar perl-command-switch "-e"
  "*Switch used to have Perl execute its command line argument.

Some possible values include:
    \"-e\"   for straight execution
    \"-ne\"  for iterative execution
    \"-ane\"     with autosplit into @F
    \"-pe\"  for iterative execution, printing $_ after each iteration
    \"-ape\"     with autosplit into @F

See the perlrun(1) manual page for more information.")

(defvar perl-field-separator "\\s+"
  "*Perl regular expression used to split fields when autosplit mode is used")

(defvar perl-command-history nil
  "History list for some commands that read Perl commands.")

(defun perl-command (command &optional output-buffer)
  "Execute string COMMAND in Perl; display output, if any.

COMMAND is executed synchronously.  The output appears in the buffer
`*Perl Command Output*'.
If the output is one line, it is displayed in the echo area *as well*,
but it is nonetheless available in buffer `*Perl Command Output*',
even though that buffer is not automatically displayed.
If there is no output, or if output is inserted in the current buffer,
then `*Perl Command Output*' is deleted.

The optional second argument OUTPUT-BUFFER, if non-nil,
says to put the output in some other buffer.
If OUTPUT-BUFFER is a buffer or buffer name, put the output there.
If OUTPUT-BUFFER is not a buffer and not nil, insert output in current
buffer.
In either case, the output is inserted after point (leaving mark after it)."
  (interactive (list (read-from-minibuffer "Perl command: "
					   nil nil nil 'perl-command-history)
		     current-prefix-arg))
  (if (and output-buffer
	   (not (or (bufferp output-buffer)  (stringp output-buffer))))
      (progn (barf-if-buffer-read-only)
	     (push-mark)
	     (call-process perl-file-name nil t nil
			   (concat "-F" perl-field-separator)
			   perl-command-switch command)
	     ;; This is like exchange-point-and-mark, but doesn't
	     ;; activate the mark.  It is cleaner to avoid activation,
	     ;; even though the command loop would deactivate the mark
	     ;; because we inserted text.
	     (goto-char (prog1 (mark t)
			  (set-marker (mark-marker) (point)
				      (current-buffer)))))
    ;; Preserve the match data in case called from a program.
      (perl-command-on-region (point) (point) command nil)
      ))

;; We have a sentinel to prevent insertion of a termination message
;; in the buffer itself.
(defun perl-command-sentinel (process signal)
  (if (memq (process-status process) '(exit signal))
      (message "%s: %s." 
	       (car (cdr (cdr (process-command process))))
	       (substring signal 0 -1))))

(defun perl-command-on-region (start end command
				      &optional output-buffer replace)
  "Execute string COMMAND in Perl with region as input.
Normally display output (if any) in temp buffer `*Perl Command Output*';
Prefix arg means replace the region with it.

The noninteractive arguments are START, END, COMMAND, OUTPUT-BUFFER, REPLACE.
If REPLACE is non-nil, that means insert the output
in place of text from START to END, putting point and mark around it.

If the output is one line, it is displayed in the echo area,
but it is nonetheless available in buffer `*Perl Command Output*'
even though that buffer is not automatically displayed.
If there is no output, or if output is inserted in the current buffer,
then `*Perl Command Output*' is deleted.

If the optional fourth argument OUTPUT-BUFFER is non-nil,
that says to put the output in some other buffer.
If OUTPUT-BUFFER is a buffer or buffer name, put the output there.
If OUTPUT-BUFFER is not a buffer and not nil,
insert output in the current buffer.
In either case, the output is inserted after point (leaving mark after it)."
  (interactive (let ((string
		      ;; Do this before calling region-beginning
		      ;; and region-end, in case subprocess output
		      ;; relocates them while we are in the minibuffer.
		      (read-from-minibuffer "Perl command on region: "
					    nil nil nil
					    'perl-command-history)))
		 ;; call-interactively recognizes region-beginning and
		 ;; region-end specially, leaving them in the history.
		 (list (region-beginning) (region-end)
		       string
		       current-prefix-arg
		       current-prefix-arg)))
  (if (or replace
	  (and output-buffer
	       (not (or (bufferp output-buffer) (stringp output-buffer)))))
      ;; Replace specified region with output from command.
      (let ((swap (and replace (< start end))))
	;; Don't muck with mark unless REPLACE says we should.
	(goto-char start)
	(and replace (push-mark))
	(call-process-region start end perl-file-name t t nil
			     (concat "-F" perl-field-separator)
			     perl-command-switch command)
	(let ((perl-buffer (get-buffer "*Perl Command Output*")))
	  (and perl-buffer (not (eq perl-buffer (current-buffer)))
	       (kill-buffer perl-buffer)))
	;; Don't muck with mark unless REPLACE says we should.
	(and replace swap (exchange-point-and-mark)))
    ;; No prefix argument: put the output in a temp buffer,
    ;; replacing its entire contents.
    (let ((buffer (get-buffer-create
		   (or output-buffer "*Perl Command Output*")))
	  (success nil))
      (unwind-protect
	  (if (eq buffer (current-buffer))
	      ;; If the input is the same buffer as the output,
	      ;; delete everything but the specified region,
	      ;; then replace that region with the output.
	      (progn (setq buffer-read-only nil)
		     (delete-region (max start end) (point-max))
		     (delete-region (point-min) (max start end))
		     (call-process-region (point-min) (point-max)
					  perl-file-name t t nil
					  (concat "-F" perl-field-separator)
					  perl-command-switch command)
		     (setq success t))
	    ;; Clear the output buffer, then run the command with output there.
	    (save-excursion
	      (set-buffer buffer)
	      (setq buffer-read-only nil)
	      (erase-buffer))
	    (call-process-region start end perl-file-name
				 nil buffer nil
				 (concat "-F" perl-field-separator)
				 perl-command-switch command)
	    (setq success t))
	;; Report the amount of output.
	(let ((lines (save-excursion
		       (set-buffer buffer)
		       (if (= (buffer-size) 0)
			   0
			 (count-lines (point-min) (point-max))))))
	  (cond ((= lines 0)
		 (if success
		     (message "(Perl command completed with no output)"))
		 (kill-buffer buffer))
		((and success (= lines 1))
		 (message "%s"
			  (save-excursion
			    (set-buffer buffer)
			    (goto-char (point-min))
			    (buffer-substring (point)
					      (progn (end-of-line) (point))))))
		(t 
		 (set-window-start (display-buffer buffer) 1))))))))