Re: comint-ctrl-m: handle ^M intelligently in subprocess output

[Noah Friedman]

>Tired of seeing your shell buffers full of garbage like this?
>
>0% done, 1:40 remaining...^M2% done, 1:38 remaining...
>...
>Just switch on comint-ctrl-m-mode and stop giving your xterm-using
>friends a reason to feel superior.

Along these lines is proc-filter-shell-output-filter-mode.
Require this file and then add 

(add-hook 'comint-output-filter-functions 'proc-filter-shell-output-filter)

to your .emacs.

;;; proc-filters.el -- some generally useful process filters

;; Copyright (C) 1992, 93, 99, 2000 Noah S. Friedman

;; Author: Noah Friedman <address@hidden>
;; Maintainer: address@hidden
;; Keywords: extensions

;; $Id: proc-filters.el,v 1.13 2000/10/27 09:24:26 friedman Exp $

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, you can either send email to this
;; program's maintainer or write to: The Free Software Foundation,
;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.

;;; Commentary:

;; These are basically my templates for useful process filters.
;; They have been designed to work with inferior processes that may emit
;; output while the user is typing; they won't become mixed.

;;; Code:

(defvar proc-filter-shell-prompt-pattern-modes
  '(shell-mode rlogin-mode ssh-mode telnet-mode ftelnet-mode)
  "*List of major modes which are shell-mode or comint-mode based.
Used by `proc-filter-shell-erase-buffer' to determine which variables
contain valid interpreter prompt regexps.")

(defvar process-filter-output-functions
  '(proc-filter-shell-output-filter)
  "*Functions to run on the most recent output region.
This hook is called by `process-filter-using-insert-before-markers'
and `process-filter-using-insert'.")

(defvar proc-filter-shell-output-filter-mode t
  "*If nil, `proc-filter-shell-output-filter' does nothing.")

(defvar proc-filter-shell-output-filters
  '(process-ticker-filter
    process-backspace-filter
    process-color-ls-filter
    process-carriage-output-filter
    process-trailing-whitespace-filter)
  "*Filters to run by `proc-filter-shell-output-filter'.")

;; To improve emacs regexp performance, it is important to put newlines
;; in "complemented character sets" (e.g. [^abcde...]) unless you really
;; intend for a match to span newlines.  I've noticed that regexp matching
;; is significantly slower across multi-line text.
(defvar process-ticker-filter-regexps
  '(;; ftp tick
    "\r?bytes transferred:[ \t]*[0-9]+"
    ;; rsync --progress meter
    "\r?[0-9]+[ \t]+([0-9]+%)"
    ;; scp
    "\r?[^|\n]+|[ \t]+[0-9]+ KB |[ \t]+[0-9.]+ kB/s | ETA: [0-9:]+ |[ 
\t]+[0-9]+%"
    ;; lukemftp progress bar
    "\r? *[0-9]+% |\\** *| *[0-9]+\\(\\| KB\\)? +[0-9.]+ KB/s +[0-9:-]+ ETA"
    ;; mpg123
    "\r?Frame#[ \t]+[0-9]+ \\[[ 0-9]+\\],[^\n\r]+"
    ;; cdparanoia
    "\r? (== PROGRESS == \\[[^\n\r]+"
    ;; gogo mp3 encoder
    "\r?{[ \t\0]*[0-9]+/[ \t\0]*[0-9]+}"
    ;; pi-getrom (palm rom downloader)
    "\r?[0-9]+ of [0-9]+ bytes"
    ;; uudeview
    "\r?scanned[ \t]+[0-9]+% of "
    "\r?Loaded from .*: '"
    "\r?decoding part[ \t0-9]+of[ \t0-9]+ [#.]+"
    "\r?copying target file[ \t]+[.#]+")
  "*Filters to run by `process-ticker-filter'.")


;;;###autoload
(defun process-filter-using-insert-before-markers (proc string
                                                        &optional filters)
  (let (proc-mark region-begin window)
    (save-excursion
      (set-buffer (process-buffer proc))
      (setq proc-mark (process-mark proc))
      (setq region-begin (marker-position proc-mark))
      ;; If process mark is at window start, insert-before-markers will
      ;; insert text off-window since it's also inserting before the start
      ;; Window mark.  Make sure we can see the most recent text.
      (setq window (and (= proc-mark (window-start))
                        (get-buffer-window (current-buffer))))
      (goto-char proc-mark)
      (insert-before-markers string)
      (run-process-filter-output-functions region-begin proc-mark filters))
    ;; Frob window-start outside of save-excursion so it works whether the
    ;; current buffer is the process buffer or not.
    (and window
         (>= (window-start window) region-begin)
         (set-window-start window region-begin 'noforce))))

;;;###autoload
(defun process-filter-using-insert (proc string &optional filters)
  (let* ((original-buffer (current-buffer))
         (process-buffer (process-buffer proc))
         (window (get-buffer-window process-buffer))
         (proc-mark (process-mark proc))
         old-proc-mark-pos
         user-point
         user-point-offset)
    (unwind-protect
        (progn
          (set-buffer process-buffer)
          (setq user-point (point))
          (setq old-proc-mark-pos (marker-position proc-mark))
          (setq user-point-offset (- user-point old-proc-mark-pos))
          (goto-char proc-mark)
          (insert string)
          (set-marker proc-mark (point))
          (run-process-filter-output-functions old-proc-mark-pos
                                               proc-mark filters)
          (if (>= user-point-offset 0)
              (goto-char (+ (marker-position proc-mark) user-point-offset))
            (goto-char user-point))
          (and window
               (set-window-point window (point))))
      (set-buffer original-buffer))))

(defun run-process-filter-output-functions (&optional beg end functions)
  (save-restriction
    (narrow-to-region (or beg (region-beginning)) (or end (region-end)))
    (let ((fns (or functions process-filter-output-functions)))
      (while fns
        (goto-char (point-min))
        (funcall (car fns))
        (setq fns (cdr fns))))))


;;;###autoload
(defun process-re-output-filter (string &rest re)
  "Generic comint process output filter.
The argument STRING is only used if the current buffer is not a comint
process buffer; it is used compute the size of the region containging the
most recent process output.  Otherwise, `comint-last-output-start' is used.
The remaining arguments RE are a regexps which matches text to be removed
from the region."
  (let* ((point-marker (point-marker))
         (end (process-mark (get-buffer-process (current-buffer))))
         (beg (process-filter-last-output-start string end)))
    (save-match-data
      (while re
        (goto-char beg)
        (while (re-search-forward (car re) end t)
          (delete-region (match-beginning 0) (match-end 0)))
        (setq re (cdr re))))
    (goto-char point-marker)))

(defun process-filter-last-output-start (&optional string end)
  (cond ((and (boundp 'comint-last-output-start)
              comint-last-output-start)
         comint-last-output-start)
        ((stringp string)
         (- (or end (process-mark (get-buffer-process (current-buffer))))
            (length string)))
       (t (point-min))))

(defun process-carriage-output-filter (&optional string)
  "Strip naked carriage returns from process output.
When added to comint-output-filter-functions, this strips naked carriage
returns from output that telnet and rlogin are so keen to add."
  (let ((re (or (and (boundp 'process-carriage-output-filter-chars)
                     process-carriage-output-filter-chars)
                "[\C-m]+")))
    (process-re-output-filter string re)))

(defun process-color-ls-filter (&optional string)
  "Strip terminal escape sequences from linux `ls' color enhancements.
Some versions of linux include a terminally cretinous version of
`ls' which always outputs escape sequences to colorize file names.
These don't work in emacs buffers (at least not without some font-lock
like enhancements.  This function strips them out."
  (process-re-output-filter string "\C-[\\[[0-9;]*m"))

(defun process-trailing-whitespace-filter (&optional string)
  "Strip trailing whitespace from non-prompt lines."
  (save-excursion
    (goto-char (process-mark (get-buffer-process (current-buffer))))
    (cond ((> (current-column) 0))
          ((progn
             (beginning-of-line)
             (save-match-data
               (looking-at
                (cond
                 ((boundp 'shell-prompt-pattern) shell-prompt-pattern)
                 ((boundp 'comint-prompt-regexp) comint-prompt-regexp)
                 (t "^[^#$%>\n]*[#$%>] *"))))))
          (t
           (process-re-output-filter string "[ \t]+$")))))


;;;###autoload
(defun process-ticker-re-output-filter (string &rest re)
  "Generic comint process output filter for displaying counters.
Counters are successive lines of text which display updated download
transfer statistics, etc. and usually consist of lines of output separated
by a carriage return so that they will overrwrite the previous in place on
most terminals.

The argument STRING is only used if the current buffer is not a comint
process buffer; it is used compute the size of the region containging the
most recent process output \(see `process-filter-last-output-start'\).

The remaining arguments RE are regexps which match the counter text to be
updated in place."
  (let* ((point-marker (point-marker))
         (beg nil)
         (end (process-mark (get-buffer-process (current-buffer))))
         (output-start (process-filter-last-output-start string end))
         (case-fold-search t))
    (save-restriction
      (narrow-to-region output-start end)
      (save-match-data
        ;; Counters are assumed to occupy only one line (updates made in
        ;; place by sending a carriage return).  Since the output we're
        ;; interested in processing may arrive in a chunk containing
        ;; unrelated stuff at the beginning or the end, we have to check
        ;; whether counter output is at the beginning of the chunk or there
        ;; is stuff before it.
        (while re
          (setq beg output-start)
          (goto-char beg)
          (cond ((looking-at (car re)))
                ((re-search-forward (car re) end t)
                 (setq beg (match-beginning 0)))
                (t
                 (goto-char end)
                 (beginning-of-line)
                 (setq beg (point))))
          ;; This chunk may contain multiple counter updates.  Delete all but
          ;; the last one.
          (goto-char beg)
          (while (looking-at (car re))
            (goto-char (match-end 0))
            (and (looking-at (car re))
                 (delete-region beg (point))))
          ;; Now delete the immediately preceding counter output (if any) from
          ;; the last filter run.
          (goto-char beg)
          (and (looking-at (car re))
               (save-restriction
                 (widen)
                 (beginning-of-line)
                 (delete-region (point) beg)))
          (setq re (cdr re)))))
    (goto-char point-marker)))

;; indent like `while'.
(put 'process-ticker-re-output-filter 'lisp-indent-function 1)

(defun process-ticker-filter (&optional string)
  "Apply filters in `process-ticker-filter-regexps'
Filters are processed by `process-ticker-re-output-filter'."
  (apply 'process-ticker-re-output-filter string
         process-ticker-filter-regexps))


;;;###autoload
(defun proc-filter-shell-output-filter-mode (&optional prefix)
  "Toggle proc-filter-shell-output-filter-mode (see variable docstring).
If called with a positive prefix argument, always enable.
If called with a negative prefix argument, always disable.
If called with no prefix argument, toggle current state."
  (interactive "P")
  (setq proc-filter-shell-output-filter-mode
        (cond ((null prefix)
               (not proc-filter-shell-output-filter-mode))
              (t
               (>= (prefix-numeric-value prefix) 0)))))

(defun proc-filter-shell-output-filter (&optional string)
  "Run all filters in `proc-filter-shell-output-filters'.
This is a reasonable thing to put on `comint-output-filter-functions'."
  (and proc-filter-shell-output-filter-mode
       (let ((point-marker (point-marker))
             (filters proc-filter-shell-output-filters))
         (while filters
           (goto-char point-marker)
           (funcall (car filters) string)
           (setq filters (cdr filters)))
         (goto-char point-marker))))

(defun process-backspace-filter (&optional string)
  "Treat output of C-h characters as destructive backspace.
When a C-h character is seen in a buffer, delete that character as well as
the previous character."
  (let* ((point-marker (point-marker))
         (end (process-mark (get-buffer-process (current-buffer))))
         (beg (process-filter-last-output-start string end)))
    (save-match-data
      (goto-char beg)
      (while (re-search-forward "\C-h+" end t)
        (delete-region (match-beginning 0) (match-end 0))
        (delete-region (- (match-beginning 0)
                          (- (match-end 0)
                             (match-beginning 0)))
                       (match-beginning 0))))
    (goto-char point-marker)))

;;;###autoload
(defun reset-process-mark (&optional proc)
  "Set process-mark for process PROC to point-max.
This is useful if the process mark has been clobbered in some mysterious way."
  (interactive)
  (or proc (setq proc (get-buffer-process (current-buffer))))
  (set-marker (process-mark proc) (point-max)))

;;;###autoload
(defun proc-filter-shell-erase-buffer ()
  "Delete all buffer contents leading up to the process mark.
Leave a prompt visible."
  (interactive)
  (save-match-data
    (let ((orig-point (point-marker))
          (proc (get-buffer-process (current-buffer)))
          pattern)
      (cond
       ((and (boundp 'shell-prompt-pattern)
             (memq major-mode proc-filter-shell-prompt-pattern-modes))
        (setq pattern shell-prompt-pattern))
       ((boundp 'comint-prompt-regexp)
        (setq pattern comint-prompt-regexp))
       (t
        (signal 'void-variable (list 'comint-prompt-regexp
                                     'shell-prompt-pattern
                                     shell-prompt-pattern-modes))))
      (cond
       ((and proc (> (process-mark proc) orig-point))
        (goto-char (process-mark proc))
        (and (re-search-backward pattern nil t)
             (progn
               (delete-region (point-min) (point))
               (goto-char (process-mark proc)))))
       (t
        (and (re-search-backward pattern nil t)
             (delete-region (point-min) (point)))
        (goto-char orig-point))))))

(provide 'proc-filters)

;;; proc-filters.el ends here.