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

;; Author: Noah Friedman <friedman@splode.com>
;; Created: 1992
;; Public domain.

;; $Id: proc-filters.el,v 1.48 2024/07/07 07:02:55 friedman Exp $

;;; 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:

;;;###autoload
(defvar proc-filter-simple-send-eol "\n"
  "*Line ending to use by `proc-filter-simple-send' when sending user input to a process.
This variable normally would be bound to \"\\n\" or \"\\r\\n\".

This variable is automatically buffer-local if set.")

(make-variable-buffer-local 'proc-filter-simple-send-eol)

(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
  '(proc-filter-color
    proc-filter-column-motion
    proc-filter-carriage-motion
    proc-filter-osc
    proc-filter-misc-ctlseqs
    proc-filter-trailing-whitespace)
  "*Filters to run by `proc-filter-shell-output-filter'.
The order in which these run is marginally sensitive in some cases.  For
example, color filters should be applied before column motion, since column
motion might specify cursor positioning using relative motion that assumes
all prior escape sequences are processed already.")

(defvar proc-filter-inhibit-quit nil
  "Whether to inhibit quit while `proc-filter-shell-output-filter' runs.

This is value is temporarily bound to `inhibit-quit', which normally is set
to `t' while process filters run.  Enabling it prevents runaway code from
being stopped, and since these filters do not manage any critical state,
it's ok to leave them in an indeterminate one if the user needs to abort
it.  So it defaults to nil here.")


;;; These are not user variables.

(defconst proc-filter-misc-regexp
  (format "\\(?:%s\\)"
          (mapconcat 'identity ;;(lambda (re) (concat "\\(?:" re "\\)"))
                     '(;; CSI Pm h		Set Mode
                       ;; CSI ? Pm h		DEC Private Mode Set
                       ;; CSI Pm i		Reset Mode
                       ;; CSI ? Pm l		DEC Private Mode Reset
                       ;; CSI Ps ; Ps ; Ps t	Window Manipulation extensions
                       "\e\\[\\??[0-9;]+[lht]"
                       ;; bluetoothctl outputs this.  What for?
                       "\C-a\C-b"
                       )
                     "\\|")))

;; This needs to be buffer-local because its value is saved between calls
;; to proc-filter-carriage-motion, which may be called in multiple buffers.
(defvar proc-filter-carriage-motion-last-end-char ?0)
(make-variable-buffer-local 'proc-filter-carriage-motion-last-end-char)

;; We can save some consing by reusing the same markers whenever
;; proc-filter-carriage-motion is called.  These don't need to be
;; buffer-local because their values are not reused between calls.
(defvar proc-filter-carriage-motion-beg (make-marker))
(defvar proc-filter-carriage-motion-end (make-marker))

(defvar proc-filter-carriage-overlay nil)
(make-variable-buffer-local 'proc-filter-carriage-overlay)


(defsubst proc-filter-symbol-on-hook (symbol hook)
  (or (memq symbol (symbol-value hook))
      (and (memq t (symbol-value hook))
           (memq symbol (default-value hook)))))


(defun proc-filter-simple-send (proc string)
  "Function to send to PROCESS the STRING submitted by user.
This function is like `comint-simple-send', but the end-of-line sequence is
configurable; see `proc-filter-simple-send-eol'.  This function can be used
as the value for `comint-input-sender' or can be used by process modes
directly."
  ;; Try to mimic comint-simple-send if we are in a comint buffer.
  (cond ((and (fboundp 'derived-mode-p)
              (derived-mode-p 'comint-mode))
         (comint-send-string proc string)
         (if comint-input-sender-no-newline
             (if (not (string-equal string ""))
                 (process-send-eof proc))
           (comint-send-string proc proc-filter-simple-send-eol)))
        (t
         (process-send-string proc string)
         (process-send-string proc proc-filter-simple-send-eol))))

;;;###autoload
(defun proc-filter-input-sender (&rest args)
  (interactive)
  (when proc-filter-process-echoes-mode
    (delete-region comint-last-input-start comint-last-input-end))
  (apply 'proc-filter-simple-send args))

;;;###autoload
(define-minor-mode proc-filter-crlf-input-mode
  "Send CRLF instead of LF with end of input."
  :init-value nil
  :lighter    " CRLF"
  :keymap     nil
  (setq-local comint-input-sender 'proc-filter-input-sender)
  (setq-local proc-filter-simple-send-eol
              (if proc-filter-crlf-input-mode
                  "\r\n"
                "\n")))

(defvar proc-filter-saved:comint-process-echoes)

;;;###autoload
(define-minor-mode proc-filter-process-echoes-mode
  "Erase our input from buffer if process echoes that input"
  :init-value nil
  :lighter    nil
  :keymap     nil
  (cond (proc-filter-process-echoes-mode
         (setq-local comint-input-sender 'proc-filter-input-sender)
         (setq-local proc-filter-saved:comint-process-echoes
                     comint-process-echoes))

        ((boundp 'proc-filter-saved:comint-process-echoes)
         (setq comint-process-echoes
               proc-filter-saved:comint-process-echoes)
         (makunbound 'proc-filter-saved:comint-process-echoes))))


(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))))

(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))))))


(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, only the most recent comint output
region is modified.
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)))

;; Prefer comint-last-input-end to comint-last-output-start, since the
;; latter may be earlier in the buffer and we do not want to modify user
;; input regions.
(defun process-filter-last-output-start (&optional string end)
  (cond ((and (boundp 'comint-last-input-end)
              (boundp 'comint-last-output-start)
              comint-last-input-end
              comint-last-output-start)
         (max comint-last-input-end comint-last-output-start))
        ((stringp string)
         (- (or end (process-mark (get-buffer-process (current-buffer))))
            (length string)))
       (t (point-min))))


;;;###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))))
  (and (interactive-p)
       (message "proc-filter-shell-output-filter-mode is %s"
                (if proc-filter-shell-output-filter-mode
                    "enabled"
                  "disabled"))))

(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'."
  (when proc-filter-shell-output-filter-mode
    (let ((proc (get-buffer-process (current-buffer))))
      (when proc
        (let* ((inhibit-quit proc-filter-inhibit-quit)
               (inhibit-field-text-motion t)
               (inhibit-point-motion-hooks t)
               (inhibit-read-only t)
               (buffer-undo-list t) ; don't record changes here

               (filters proc-filter-shell-output-filters)
               (end (process-mark proc))
               (beg (process-filter-last-output-start string end)))
          (save-excursion
            (save-restriction
              (save-match-data
                (narrow-to-region beg end)
                (while filters
                  (goto-char (point-min))
                  (funcall (car filters) string)
                  (setq filters (cdr filters)))))))))))

(defun proc-filter-carriage-motion (&optional string)
  "Interpret carriage control characters in buffer.
Translate carriage return/linefeed sequences to linefeeds.
Make single carriage returns delete to the beginning of the line.
Make backspaces delete the previous character.

If a final naked carriage return appears in the region, it is not processed
right away; this is so that it can be interpreted correctly when the next
piece of output arrives.  Likewise, destructive backspaces are not
processed until replacement text is output."
  (cond ((string= "" string))
        ;; Avoid the work below if there are no special chars to process
        ((not (or (memq proc-filter-carriage-motion-last-end-char '(?\r ?\b))
                  (< (skip-chars-forward "^\b\r" (point-max))
                     (- (point-max) (point-min))))))
        (t
         (or proc-filter-carriage-overlay
             (let ((ovl (make-overlay 0 0)))
               (overlay-put ovl 'invisible 'proc-filter-carriage-motion)
               (setq proc-filter-carriage-overlay ovl)))

         (save-restriction
           (let ((beg proc-filter-carriage-motion-beg)
                 (end proc-filter-carriage-motion-end))
             (set-marker beg (point-min))
             (set-marker end (point-max))

             (widen)

             ;; Leading carriage returns at the start of a line can be removed.
             (goto-char beg)
             (while (re-search-forward "^\r+" end t)
               (delete-region (match-beginning 0) (match-end 0)))

             ;; If last output chunk had an unprocessed trailing CR or
             ;; backspaces, include them in the current chunk.  Just use
             ;; point-min if buffer was erased.
             (cond ((char-equal ?\r proc-filter-carriage-motion-last-end-char)
                    (set-marker beg (max (point-min) (1- beg))))
                   ((char-equal ?\b proc-filter-carriage-motion-last-end-char)
                    ;; Cannot use (re-search-backward "\b+" nil t)
                    ;; because nearest \b at end will match; greediness only
                    ;; works in forward direction.
                    (while (and (> beg (point-min))
                                (char-equal ?\b (char-after (1- beg))))
                      (set-marker beg (1- beg)))))

             (setq proc-filter-carriage-motion-last-end-char
                   (or (char-after (1- end)) ?0))
             (cond ((char-equal ?\r proc-filter-carriage-motion-last-end-char)
                    ;; If last char in output chunk is a CR or backspaces,
                    ;; do not process them now.  This enables correct
                    ;; processing of CR LF below even if the CR and LF
                    ;; arrive in different output chunks.
                    (set-marker end (1- end))
                    (move-overlay proc-filter-carriage-overlay end (1+ end)))
                   ((char-equal ?\b proc-filter-carriage-motion-last-end-char)
                    ;; Or alternatively, if there is output followed by
                    ;; backspaces to erase the just-output text at the end
                    ;; of an output chunk, delay processing them until the
                    ;; next output sequence; otherwise the text is never
                    ;; visible in the buffer since backspace processing is
                    ;; destructive.
                    ;;
                    ;; Rant: if you are going to backspace over text for
                    ;; e.g. progress indicators, the backspaces should be
                    ;; emitted in the output chunk just prior to the
                    ;; replacement output, not at the end of the prior
                    ;; output (which is usually supposed to be visible for
                    ;; some period of time).  Many programs violate this
                    ;; principle on the assumption that backspace is not
                    ;; destructive.
                    (let ((last (marker-position end)))
                      (while (char-equal ?\b (char-after (1- end)))
                        (set-marker end (1- end)))
                      (move-overlay proc-filter-carriage-overlay end last))))

             ;; CR LF -> LF
             (goto-char beg)
             ;;(while (re-search-forward "\r$" end t)
             ;;  (delete-char -1))
             ;; Don't let "output^M^M^J" erase "output" line.
             (while (re-search-forward "\r+$" end t)
               (delete-region (match-beginning 0) (match-end 0)))
             ;; bare CR -> delete preceding line
             (goto-char beg)
             (while (search-forward "\r" end t)
               (beginning-of-line)
               (delete-region (point) (match-end 0)))
             ;; BS -> delete preceding character
             ;; don't attempt to delete beyond point-min
             (goto-char beg)
             (while (search-forward "\b" end t)
               (and (> (- (point) (point-min)) 1)
                    (delete-char -2))))))))


(defun proc-filter-column-motion (&optional string)
  "Process column positioning escape sequences.
This filter does not honor row movement sequences since this is not a full
terminal emulator."
  (let ((inhibit-quit nil)
        (case-fold-search nil)
        (inhibit-point-motion-hooks nil)
        (inhibit-field-text-motion t)
        (proc (get-buffer-process (current-buffer))))

    ;; Widen enough so that true beginning of current line is in region.
    (let ((end (point-max)))
      (widen)
      (narrow-to-region (line-beginning-position) end))

    ;; A succession of CSI [0] K sequences at the beginning of a contiguous
    ;; set of lines are usually an operation to blank all the lines on a
    ;; screen.  Ignore these.
    (while (re-search-forward "\\(?:\e\\[K0?\r?\n?\\)\\{2,\\}" nil t)
      (delete-region (match-beginning 0) (match-end 0)))

    (goto-char (point-min))
    (while (re-search-forward "\e\\[\\([0-9;]+\\)?[ -/]*\\([@ACDGHJKPXa]\\)" nil t)
      (let* ((op (match-string 2))
             (Pm (let ((match (match-string 1)))
                   (if (and match
                            (> (length match) 0))
                       (save-match-data
                         (split-string match ";")))))
             (Ps1 (string-to-number (or (car Pm) "1")))
             ;; For relative motion
             (direction (- (point) Ps1))
             (distance (abs direction))

             (cur-col nil))

        (delete-region (match-beginning 0) (match-end 0))
        (setq cur-col (current-column))

        ;; n.b. the operators are not mnemonic.
        ;; e.g. "D" is Back, not Down.  Down is "B"!
        (cond ((string= op "@")  ;; insert blank chars
               (dotimes (i distance)
                 (insert-before-markers " ")))

              ((string= op "C")  ;; cursor forward
               (let* ((motion (+ cur-col Ps1))
                      (goal (+ (point) Ps1))
                      (pmark (process-mark proc)))
                 (if (>= goal pmark)
                     (progn
                       (goto-char pmark)
                       (insert-before-markers
                        (make-string (- goal pmark) #x20)))
                   (move-to-column motion t))))

              ((string= op "D")  ;; cursor backward
               (move-to-column (max 1 (- cur-col Ps1))))

              ((string= op "G")  ;; cursor column absolute
               (delete-region (point)
                              (save-excursion
                                (move-to-column (max 0 (1- Ps1)))
                                (point))))

              ((string= op "H")  ;; abs cursor position
               ;; n.b. this only honors column
               (let ((col (1- (string-to-number (or (cadr Pm) "1")))))
                 (if (>= col cur-col)
                     (insert-before-markers (make-string (- col cur-col) #x20))
                   (delete-region (point)
                                  (save-excursion
                                    (move-to-column (max 0 col) t)
                                    (point))))))

              ((string= op "J")) ;; erase in display; ignored

              ((string= op "K")  ;; erase in line
               (cond ((null Pm))

                     ((= Ps1 0)
                      ;; Actually we only delete to the next escape
                      ;; sequence if there is one.
                      (let ((end (proc-filter-eol-or-esc)))
                        (delete-region (point) end)))

                     ;; Don't delete line if a prior CR or backspace is
                     ;; already in the buffer just before this sequence;
                     ;; that forces an erase now, which creates a redundant
                     ;; erase and prevents the buffering done by
                     ;; proc-filter-carriage-motion from working when
                     ;; replacement text has not yet arrived.
                     ((memq (char-after (1- (point))) '(?\b ?\r)))

                     ((= Ps1 1)
                      (delete-region
                       (point)
                       (line-beginning-position)))

                     ((= Ps1 2)
                      (delete-region
                       (line-beginning-position)
                       (line-end-position)))))

              ((or (string= op "P")   ;; delete characters
                   (string= op "X"))  ;; erase characters
               ;; "Erase" is supposed to blank the area
               ;; but in our case we just delete it.
               ;; Also, don't blank past eol.
               (delete-region (point)
                              (min (line-end-position)
                                   (+ (point) distance)
                                   (point-max))))

              ((string= op "a")
               (goto-char (min (+ (point) distance)
                               (point-max)))))))))

;; Helper function for proc-filter-column-motion.
;; Match from point to the next escape character, eol, or the process mark.
(defun proc-filter-eol-or-esc ()
  (save-excursion
    (let* ((proc (get-buffer-process (current-buffer)))
           (end (min (process-mark proc)
                     (line-end-position))))
      (if (re-search-forward "[\e\r]" end t)
          (match-beginning 0)
        end))))


;; Some linux distributions configure user sessions by default to enable
;; color highlighting of all output from `ls'.
;; These don't work in emacs buffers by default; this function strips them
;; out unless ansi-color.el is enabled.
(defun proc-filter-color (&optional string)
  "Possibly strip ANSI terminal color escape sequences."
  (cond ((and (boundp 'ansi-color-for-comint-mode)
              ansi-color-for-comint-mode
              (proc-filter-symbol-on-hook 'ansi-color-process-output
                                          'comint-output-filter-functions)))
        (t
         (let ((case-fold-search nil))
           (while (re-search-forward "\e\\[[0-9;]*m" nil t)
             (delete-region (match-beginning 0) (match-end 0)))))))

;; Common examples of OSCs include setting window titles
(defun proc-filter-osc (&optional string)
  "Strip \"Operating System Command\" escape sequences"
  (while (re-search-forward "\\(?:\e\\]\\|\x9d\\)[0-9]+;.*?[\a\x9c]" nil t)
    (delete-region (match-beginning 0) (match-end 0))))

;; This should be last in proc-filter-shell-output-filters to clean up any
;; recognizable sequences that no previous filter has handled.
(defun proc-filter-misc-ctlseqs (&optional string)
  "Strip various terminal escape sequences"
  (let ((case-fold-search nil))
    (while (re-search-forward proc-filter-misc-regexp nil t)
      (delete-region (match-beginning 0) (match-end 0)))))

;; To avoid output chunking problems, this function ignores the current
;; output line but does check the line just immediately previous to the
;; current output chunk, in case it was skipped over from processing the
;; previous output chunk.
;; Thus, trailing whitespace after prompts are never deleted.
(defun proc-filter-trailing-whitespace (&optional string)
  "Strip trailing whitespace from output lines."
  (save-restriction
    (let ((beg (point-min))
          (end (point-max)))
      (widen)
      (goto-char end)
      (skip-chars-backward "^\n")
      (setq end (point))

      (goto-char beg)
      (skip-chars-backward "^\n")
      (beginning-of-line)
      (narrow-to-region (point) end))

    (while (re-search-forward "[ \t]+$" nil t)
      (delete-region (match-beginning 0) (match-end 0)))))


;;;###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)))
          ;; Ignore read-only text properties, but not read-only buffers.
          (inhibit-read-only (not buffer-read-only))
          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))))))


(defun proc-filter-sentinel (proc event)
  (unless (process-live-p proc)
    (save-excursion
      (set-buffer (process-buffer proc))
      (setq comint-output-filter-functions nil))))

(provide 'proc-filters)

;;; proc-filters.el ends here.