;;; buffer-fns.el --- functions for modifying buffer contents or display

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

;; $Id: buffer-fns.el,v 1.43 2022/03/18 07:30:08 friedman Exp $

;;; Commentary:

;; This package defines a number of other unrelated functions, except that
;; they all more or less have to do with buffer manipulation, buffer or
;; modeline display, or lisp evaluation in buffers.  The main reason for
;; creating this package was to get these functions out of my .emacs file.

;;; Code:

(require 'rect)
(require 'list-fns)
(require 'emacs-variants)


;; process-related buffer functions

(defmacro with-command-output-to-temp-buffer (command &rest body)
  "Execute inferior COMMAND, putting its contents into a temporary buffer, and evalulate BODY.
COMMAND should be a string or a list of strings."
  (declare (indent 1))
  `(with-temp-buffer
     (apply 'call-process (car ,command) nil t nil (cdr ,command))
     ,@body))

(defun buffer-process-list (&optional buffer)
  "Return a list of all processes associated with BUFFER.
If BUFFER is nil, the current buffer is used.
The processes returned include any which are no longer live.

There is usually only one process associated with any buffer, but that
isn't a requirement.  The function `get-buffer-process' returns at most one
process, and only one which is still live."
  (setq buffer (if buffer
                   (get-buffer buffer) ;; buffername->buffer
                 (current-buffer)))
  (let ((result))
    (mapc (lambda (proc)
            (if (eq (process-buffer proc) buffer)
                (push proc result)))
      (process-list))
    result))

;; Optional arg is for call-compatibility wth get-buffer-process.
(defun current-buffer-process (&optional ignore)
  "Get the (or a) live process associated with current buffer.
This is equivalent to \(get-buffer-process \(current-buffer\)\)
which is idiomatic but tiresome to type out all the time."
  (get-buffer-process (current-buffer)))


;;; functions for operating on rectangles

(defun apply-on-rectangle-region-points (fun beg end &rest args)
  "Like `apply-on-rectangle', but pass points in the buffer to FUN instead of columns."
  (apply-on-rectangle
   (lambda (bcol ecol)
     (apply fun
            (progn
              (move-to-column bcol 'coerce)
              (point))
            (progn
              (move-to-column ecol 'coerce)
              (prog1
                  (point)
                (beginning-of-line)))
            args))
   beg end))

;;;###autoload
(defun downcase-rectangle (beg end)
  "Convert the marked rectangle to lower case."
  (interactive "r")
  (apply-on-rectangle-region-points 'downcase-region beg end))

;;;###autoload
(defun upcase-rectangle (beg end)
  "Convert the marked rectangle to upper case."
  (interactive "r")
  (apply-on-rectangle-region-points 'upcase-region beg end))

;;;###autoload
(defun capitalize-rectangle (beg end)
  "Capitalize all the words in the marked rectangle."
  (interactive "r")
  (apply-on-rectangle-region-points 'capitalize-region beg end))


;;; Smallcaps commands
;;; Inspired by discussions with Vadim Nasardinov on Google+, c. 2014-12
;;; https://plus.google.com/+VadimNasardinov/posts/6rjqB8zvzYk

(defconst smallcaps-table
  (when (fboundp 'ucs-names)
    (let ((ucs (ucs-names))
          (tbl (make-vector (- ?Z ?A -1) nil))
          (c ?A) s)
      (while (<= c ?Z)
        (setq s (format "LATIN LETTER SMALL CAPITAL %c" c))
        (aset tbl (- c ?A)
              (or (if (hash-table-p ucs)  ;; Emacs 26
                      (gethash s ucs)
                    (cdr (assoc s ucs)))
                  c))
        (setq c (1+ c)))
      tbl)))

;;;###autoload
(defun smallcaps-region (beg end)
  "Like DOWNCASE-REGION but convert capital letters to small caps instead."
  (interactive "r")
  (goto-char beg)
  (while (< (point) end)
    (let ((c (upcase (char-after (point)))))
      (cond ((and (>= c ?A)
                  (<= c ?Z))
             (insert-char (aref smallcaps-table (- c ?A)) 1 t)
             (delete-char 1))
            (t
             (forward-char 1))))))

;;;###autoload
(defun smallcaps-word ()
  "Like DOWNCASE-WORD but convert capital letters to small caps instead."
  (interactive)
  (smallcaps-region (point) (progn (forward-word 1) (point))))

;;;###autoload
(defun smallcaps-rectangle (beg end)
  "Convert all capital letters in rectangle to small caps"
  (interactive "r")
  (apply-on-rectangle-region-points 'smallcaps-region beg end))


;;; buffer-percentage-mode functions

;;;###autoload
(defvar buffer-percentage-mode t
  "*If non-nil, display buffer percentage in mode line.
This variable is used by `set-default-mode-line-format.'")

;;;###autoload
(defvar buffer-percentage-mode-line-format
  '(buffer-percentage-mode ("" (-3 . "%p") " "))
  "*Buffer percentage mode line format.")

;;;###autoload
(defun buffer-percentage-mode (&optional prefix)
  "Toggle buffer-percentage-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 buffer-percentage-mode
        (cond ((null prefix)
               (not buffer-percentage-mode))
              (t
               (>= (prefix-numeric-value prefix) 0)))))

;;;###autoload
(defun buffer-percentage-mode-install ()
  (let ((existing)
        (mlf (default-value 'mode-line-format))
        (member-car-fn (lambda (elt obj)
                         (and (consp obj)
                              (eq elt (car obj))))))
    (cond ((member 'buffer-percentage-mode-line-format mlf))
          ((member-by 'buffer-percentage-mode mlf member-car-fn))
          ((setq existing (member '(-3 . "%p") mlf))
           (setcar existing 'buffer-percentage-mode-line-format))
          ((setq existing (member-by 'column-number-mode mlf member-car-fn))
           (setcdr existing (cons 'buffer-percentage-mode-line-format
                                  (cdr existing)))))))


;;; other mode line hacks

;;;###autoload
(defvar buffer-directory-file-name nil
  "Pretty-printed form of directory in which current file resides.")
(make-variable-buffer-local 'buffer-directory-file-name)
(put 'buffer-directory-file-name 'permanent-local t)

;; This function must return nil or it will prevent buffers from ever
;; being saved if it's called by write-file-hooks (read documentation
;; for this hook to find out why).
;;;###autoload
(defun set-buffer-directory-file-name ()
  (interactive)
  (let ((name (buffer-file-name)))
    (and name
         (setq buffer-directory-file-name
               (pretty-directory-file-name (file-name-directory name)))))
  nil)

;; For sh-mode (sh-script.el)
;;;###autoload
(defun abbreviate-sh-mode-name ()
  ;; If prior to emacs 19.31, mode-line-process always has the shell name.
  (cond (mode-line-process
         (setq mode-name mode-line-process)
         (setq mode-line-process nil))
        ;; Otherwise, find it ourselves.
        ((save-match-data
           (save-excursion
             (let ((interp nil))
               (goto-char (point-min))
               (end-of-line)
               (setq interp (buffer-substring (point-min) (point)))
               (cond
                ((string-match "^#![ \t]*\\([^ \t\n]+\\)" interp)
                 (setq interp (matching-substring 1 interp))
                 (setq mode-name
                       (format "[%s]" (file-name-nondirectory interp)))))))))))

;;;###autoload
(defun toggle-mode-line-inverse-video (&optional current-only)
  (interactive)
  (cond ((fboundp 'set-face-attribute)
         ;; Emacs 21 changed modeline to mode-line
         (let* ((mface (if (facep 'mode-line) 'mode-line 'modeline))
                (onp (face-attribute mface :inverse-video))
                (dt (cdr (assq 'display-type (frame-parameters)))))
           (set-face-attribute mface
                               (and current-only (selected-frame))
                               :inverse-video (not onp))
           ;; This variable was removed in Emacs 25.
           (when (boundp 'mode-line-inverse-video)
             ;; This should be toggled on mono frames; in color frames, this
             ;; must always be t to use the face attribute.
             (setq mode-line-inverse-video (or (eq dt 'color) (not onp))))
           (force-mode-line-update (not current-only))))
        (t
         (setq mode-line-inverse-video (not mode-line-inverse-video))
         (force-mode-line-update (not current-only)))))

(defun toggle-variable-command (variable &optional direction enabled-value disabled-value)
  "Toggle arbitrary VARIABLE whose value might enable or disable a mode.
Returns new value.

Can be used by wrapper functions which more or less all do the same thing
other than which variable they modify.

DIRECTION is examined like a command prefix argument: when given a
universal prefix value, a positive numeric argument, or `t', always set
VARIABLE to ENABLED-VALUE.

If DIRECTION is the symbol `-' or a negative numeric value, always set
VARIABLE to DISABLED-VALUE.

If DIRECTION is nil or 0, then set VARIABLE to whichever of ENABLED-VALUE
or DISABLED-VALUE the variable is current *not* set.  If it is not
currently set to either one of them, ENABLED-VALUE is chosen.
Comparison against the current value is done with `equal'.

ENABLED-VALUE defaults to `t'.
DISABLED-VALUE defaults to nil."
  (unless (boundp variable) (set variable nil))
  (unless enabled-value    (setq enabled-value t))

  (cond ((or (eq direction t)
             (consp direction)
             (and (numberp direction) (> direction 0)))
         (set variable enabled-value))

        ((or (eq direction '-)
             (and (numberp direction) (< direction 0)))
         (set variable disabled-value))

        ((or (null direction)
             (and (numberp direction) (= direction 0)))

         (if (equal (symbol-value variable) enabled-value)
             (set variable disabled-value)
           (set variable enabled-value)))

        (t
         (error (format "%s: Unrecognized direction specified for toggling %s"
                        direction variable))))

  (symbol-value variable))

(defun bell-flash-mode-line ()
  "Effect ringing bell by flashing mode line momentarily.
In emacs 20.1 or later, you can use the variable `ring-bell-function'
to declare a function to run in order to ring the emacs bell."
  (let ((localp (local-variable-p 'mode-line-inverse-video)))
    (or localp
        (make-local-variable 'mode-line-inverse-video))
    (toggle-mode-line-inverse-video t)
    (sit-for 0 50)
    ;; Set it back because it may be a permanently local variable.
    (toggle-mode-line-inverse-video t)
    (or localp
        (kill-local-variable 'mode-line-inverse-video))))


;;; Lisp evaluation and variable modification functions

(defun make-local-copied-variables (&rest symlist)
  "Make all variables SYM1, SYM2, ... SYMn buffer-local in the current buffer.
If the variable is already buffer-local and is a sequence, copy it \(in case
any subsequences are shared\).  Otherwise, initialize variable with a copy
of the global default.

Return SYM1, for compatibility with `make-local-hook'.

Caveat: obarrays will not be copied properly by this function; use
make-local-obarray from obarray-fns.el for those instead."
  (let ((first (car symlist))
        sym already-buffer-local)
    (while symlist
      (setq sym (car symlist))
      (setq already-buffer-local (assq sym (buffer-local-variables)))
      (cond
       ((and already-buffer-local
             (sequencep (symbol-value sym)))
        (set sym (copy-alist (symbol-value sym))))
       (already-buffer-local)
       ((boundp sym)
        (make-local-variable sym)
        (if (sequencep (default-value sym))
            (set sym (copy-alist (default-value sym)))
          (set sym (default-value sym))))
       (t
        (make-local-variable sym)))
      (setq symlist (cdr symlist)))
    first))

;;;###autoload
(defun eval-page ()
  "Eval region in current buffer delimited by page markers.
If there is no explicit page beginning or end, point-min or point-max are
  used, respectively.
Page markers are specified with the regexp `page-delimiter'."
  (interactive)
  (let ((beg (point-min))
        (end (point-max))
        (opoint (point)))
    (save-match-data
      (and (re-search-forward page-delimiter nil t)
           (setq end (match-beginning 0)))
      (goto-char opoint)
      (and (re-search-backward page-delimiter nil t)
           (setq beg (match-end 0)))
      (goto-char opoint))
    (eval-region beg end)))

;;;###autoload
(defun eval-pretty-print-last-sexp ()
  (interactive)
  (require 'pp)
  (insert "\n")
  (pp-eval-last-sexp t))

;;;###autoload
(defun fold-sexp-indent ()
  "Insert a newline between each member of sexp at point and indent it."
  (interactive)
  (save-excursion
    (save-restriction
      (narrow-to-sexp)
      (goto-char (point-min))
      (when (ignore-errors (down-list 1) t)
        (while (not (looking-at "\\s)"))
          (cond ((looking-at "\\s-*#<")
                 (goto-char (match-end 0))
                 (backward-char 2)
                 (insert "\\")
                 (forward-char 3)
                 (let ((depth 1))
                   (while (and (> depth 0)
                               (re-search-forward "\\s-\\|[<>()]" nil t))
                     (cond ((= (char-before) ?<)
                            (setq depth (1+ depth)))
                           ((= (char-before) ?>)
                            (setq depth (1- depth)))
                           (t (backward-char)
                              (insert "\\")
                              (forward-char))))))
                (t (forward-sexp)))
          (insert "\n"))
        (delete-char -1))))
  (indent-sexp))

(defun set-tab-stop-width (width)
"Sets tab-stop-list to list of tab stops separated by WIDTH
characters, up to, but not exceeding, 120."
  (setq tab-stop-list nil)
  (let ((tab-stop-counter width))
    (while (<= tab-stop-counter 120)
      (progn
        (setq tab-stop-list (cons tab-stop-counter tab-stop-list))
        (setq tab-stop-counter (+ tab-stop-counter width))))
    (setq tab-stop-list (nreverse tab-stop-list))))

;;;###autoload
(defun buffer-gc-undo (&optional buffer)
  "Wipe undo list for BUFFER, but leave it enabled.
Defaults to the current buffer."
  (interactive)
  (or buffer (setq buffer (current-buffer)))
  (buffer-disable-undo buffer)
  (buffer-enable-undo buffer))

;;;###autoload
(defun flush-all-undo-lists ()
  (interactive)
  (save-excursion
    (let ((l (buffer-list)))
      (while l
        (set-buffer (car l))
        (and (consp buffer-undo-list)
             (setq buffer-undo-list nil))
        (setq l (cdr l))))))

;;;###autoload
(defun current-buffer-disable-undo ()
  (interactive)
  (buffer-disable-undo (current-buffer)))


;;; Miscellaneous utility functions

;; Copied from 19.29 simple.el `current-word', then modified very slightly.
(defun current-word-region (&optional strict)
  "Return the beginning and ending points of word point is on.
This returns a cons containing the offsets in the buffer delimiting the
beginning and ending point of the current word.

If optional arg STRICT is non-nil, return nil unless point is within
or adjacent to a word."
  (save-excursion
    (let ((oldpoint (point)) (start (point)) (end (point)))
      (skip-syntax-backward "w_") (setq start (point))
      (goto-char oldpoint)
      (skip-syntax-forward "w_") (setq end (point))
      (if (and (eq start oldpoint) (eq end oldpoint))
	  ;; Point is neither within nor adjacent to a word.
	  (and (not strict)
	       (progn
		 ;; Look for preceding word in same line.
		 (skip-syntax-backward "^w_"
				       (save-excursion (beginning-of-line)
						       (point)))
		 (if (bolp)
		     ;; No preceding word in same line.
		     ;; Look for following word in same line.
		     (progn
		       (skip-syntax-forward "^w_"
					    (save-excursion (end-of-line)
							    (point)))
		       (setq start (point))
		       (skip-syntax-forward "w_")
		       (setq end (point)))
		   (setq end (point))
		   (skip-syntax-backward "w_")
		   (setq start (point)))
		 (cons start end)))
	(cons start end)))))


;;;###autoload
(defvar messages-syslog "/var/log/messages"
  "*File to display when `messages' is invoked with a prefix arg.")

;;;###autoload
(defun messages (&optional prefix)
  "Display message log buffer, if it exists.
With prefix arg, show file specified by `messages-syslog'."
  (interactive "P")
  (if prefix
      (live-find-file messages-syslog)
    (let* ((variant (emacs-variant))
           (buffer-name (cond
                         ((eq variant 'emacs)  "*Messages*")
                         ((eq variant 'xemacs) " *Message-Log*")
                         (t (error "This emacs variant has no message log."))))
           (buf (get-buffer buffer-name))
           (curbuf (current-buffer))
           (curwin (selected-window))
           winbuf)
      (cond (buf
             (unwind-protect
                 (progn
                   (setq winbuf (display-buffer buf))
                   (select-window winbuf)
                   (set-buffer buf)
                   (goto-char (point-max))
                   (recenter -1))
               (select-window curwin)
               (set-buffer curbuf)))
            (t
             (message "Message log is empty."))))))


;;;###autoload
(defun insert-numbers (start end &optional padp)
  "Insert the numbers from START to END (inclusive) in the current buffer.
Each is inserted on a separate line.  START may be less than END, in which
case counting is backward.

If given a prefix argument or optional arg PADP is non-nil, pad all numbers
with sufficient leading zeros so they are the same width."
  (interactive "nStart: \nnEnd: \nP")
  (let ((add-func (if (<= start end) '1+ '1-))
        (comp-func (if (<= start end) '<= '>=))
        (i start)
        (fmt (and padp (format "%%.%dd"
                               (length (int-to-string (max (abs start)
                                                           (abs end))))))))
    (while (funcall comp-func i end)
      (insert (if fmt (format fmt i) (int-to-string i)) "\n")
      (setq i (funcall add-func i)))))

(defun new-marker (pos &optional buffer insertion-type)
  "Copy existing marker, or make a new one from point.
POS may be a marker, in which case the marker is copied verbatim.
Otherwise, args POS and BUFFER are like those used by `set-marker'.
Arg INSERTION-TYPE is like that used by `set-marker-insertion-type',
which is present in Emacs 19.30 and later."
  (let ((new-marker nil))
    (cond ((markerp pos)
           (setq new-marker (copy-marker pos))
           (and buffer
                (set-marker new-marker (marker-position pos) buffer)))
          (t
           (setq new-marker (make-marker))
           (set-marker new-marker pos buffer)))
    (and (fboundp 'set-marker-insertion-type)
         (set-marker-insertion-type new-marker insertion-type))
    new-marker))

;;;###autoload
(defun occur-long-lines (&optional width)
  "Display all lines longer than WIDTH characters.
With no argument, the width used is the same as `fill-column'.
With a positive prefix argument, display all lines with width equal to or
greater than that many characters."
  (interactive "P")
  (cond ((null width)
         (setq width fill-column))
        ((consp width)
         (setq width (car width))))
  (let ((re (concat "^" (make-string width ?.))))
    (save-match-data
      (cond ((save-excursion
               (re-search-forward re nil t))
             (occur re))
            (t
             (message "No lines >= %d characters" width))))))

;;;###autoload
(defun reverse-characters-region (beg end)
  "Reverse the order of characters in region."
  (interactive "r")
  (let ((len (- end beg)))
    (setq end (1- end))
    (goto-char beg)
    (while (<= beg end)
      (insert-char (char-after end))
      (setq beg (1+ beg)))
    (delete-region beg (+ beg len))))

;;;###autoload
(defun reverse-characters-rectangle (beg end)
  "Reverse the order of characters on each line in the rectable."
  (interactive "r")
  (apply-on-rectangle-region-points 'reverse-characters-region beg end))

;;;###autoload
(defun zippify-region (beg end &optional rand-limit)
  "Randomly capitalize certain words in the region.
From Lisp, wants BEG and END.
Optional third arg RAND-LIMIT means capitalize roughly one out of
every RAND-LIMIT words."
  (interactive "rp")
  (or rand-limit (setq rand-limit 8))
  (save-excursion
    (goto-char beg)
    (if (bobp) nil (forward-word -1) (forward-word 1))
    (while (< (point) end)
      (if (zerop (random rand-limit))
          (upcase-word 1)
        (forward-word 1)))))

;;;###autoload
(defun unfill-region (beg end)
  "Unfill each of the paragraphs in the region.
This should result in every paragraph consisting of a single line."
  (interactive "r")
  (let* ((moby-fixnum (if (boundp 'most-positive-fixnum)
                          most-positive-fixnum
                        (lsh (lsh -1 1) -1)))
         (fill-column moby-fixnum))
    (fill-region beg end)))


;;;###autoload
(defun hide-region (beg end)
  "Make a region of the current buffer invisible."
  (interactive "r")
  (let ((ovl (make-overlay beg end (current-buffer) t nil)))
    (overlay-put ovl 'hide-region-overlay t)
    (overlay-put ovl 'invisible t)))

;;;###autoload
(defun unhide-region (beg end)
  "Expose any regions previously made invisible by `hide-region'."
  (interactive "r")
  (mapc (lambda (ovl)
          (when (overlay-get ovl 'hide-region-overlay)
            (delete-overlay ovl)))
      (overlays-in beg end)))


(defun text-property-regions (beg end &optional buffer equality-pred)
  "Return a list of all text properties between BEG and END in BUFFER.
BUFFER defaults to the current buffer.

Each element of the return value is another list of the form

        \(FROM TO PROPERTY VALUE\)

indicating the range where that property-value pair begins and stops
appearing sequentially in the buffer.

A property-value pair is considered changed if the value for a property at
some point is not equal to that at the previous point.  This comparison is
made with EQUALITY-PRED, a 2-arity function, defaulting to `eq' if not
provided."
  (save-excursion
    (if buffer (set-buffer buffer))
    (save-restriction
      (narrow-to-region beg end)
      (let ((eql (or equality-pred 'eq))
            (startmap (make-hash-table))
            ;; This symbol is used as a default return value to distinguish
            ;; from a hash key whose value is nil.
            (null (make-symbol "null"))
            (pos (point-min))
            props)
        (while (< pos (point-max))
          (let* ((plist-pos  (text-properties-at pos))
                 (next       (or (next-property-change pos) (point-max)))
                 (plist-next (text-properties-at next)))
            (map-plist (lambda (k v)
                         (let ((prior-v (gethash k startmap null)))
                           (cond ((eq prior-v null) ;; always use eq here
                                  (setq prior-v (cons v pos))
                                  (puthash k prior-v startmap))

                                 ((not (funcall eql (car prior-v) v))
                                  (push (list (cdr prior-v) pos k (car prior-v)) props)
                                  (setq prior-v (cons v pos))
                                  (puthash k prior-v startmap)))

                           (cond ((not (plist-member plist-next k))
                                  (push (list (cdr prior-v) next k v) props)
                                  (remhash k startmap)))))

                       plist-pos)
            (setq pos next)))
        ;; returned as-is; caller may sort to taste
        props))))

(defun text-property-regions-sorted (&rest text-property-regions-args)
  "Like `text-property-regions', but sort results by buffer start position and range."
  (sort (apply 'text-property-regions text-property-regions-args)
        (lambda (a b)
          (or (< (car a) (car b))
              (and (= (car  a) (car  b))
                   (< (cadr a) (cadr b)))
              (and (= (cadr a) (cadr b))
                   (string-lessp (prin1-to-string (caddr a))
                                 (prin1-to-string (caddr b))))))))


;;;###autoload
(defun nuke-all-overlays (beg end)
  "Eliminate all overlays in region.
This only removes overlays, not text properties."
  (interactive "r")
  (mapc 'delete-overlay (overlays-in beg end)))

;;;###autoload
(defun nuke-all-text-properties (beg end)
  "Eliminate all text properties in region.
This only removes text properties, not overlays."
  (interactive "r")
  (set-text-properties beg end nil))

;; Poor man's html formatter.
;;;###autoload
(defun nuke-html-tags (beg end)
  (interactive "r")
  (let ((table '(("\n"                               . nil)
                 ("<p>"                              . "\n\n")
                 ("<br>"                             . "\n")
                 ("</?h[0-9]>"                       . "\n\n")
                 ("</?blockquote>"                   . "\n\n")
                 ("&nbsp;"                           . " ")
                 ("\\(&[^ <]*;\\)\\|\\(<[^>]*>\\)" . nil)))
        re sub)
    (save-excursion
      (save-restriction
        (narrow-to-region beg end)
        (while table
          (setq re (car (car table)))
          (setq sub (cdr (car table)))
          (setq table (cdr table))

          (goto-char (point-min))
          (cond (sub
                 (while (re-search-forward re nil t)
                   (replace-match sub)))
                (t
                 (while (re-search-forward re nil t)
                   (delete-region (match-beginning 0) (match-end 0))))))))))


;;; Misc buffer functions

(defun find-buffers-named (name &optional re)
"Return a list of all buffers named NAME or matching NAME.
Optional arg RE non-nil means NAME is a regular expression.

When NAME is not a regular expression, the name must match exactly
so no more than one buffer could ever be returned."
  (let ((matches))
    (save-match-data
      (mapc (lambda (buffer)
              (if (cond (re (string-match name (buffer-name buffer)))
                        (t         (equal name (buffer-name buffer))))
                  (setq matches (cons buffer matches))))
        (buffer-list)))
    ;; Return matches in the same order they would appear in buffer list.
    (nreverse matches)))

;;;###autoload
(defun kill-all-buffers (&optional confirm)
  "Attempt to kill all buffers.
When called interactively, prompt for confirmation.
When called from lisp, always kill all buffers.

Some buffers might not actually be killed, depending on the value of their
`kill-buffer-query-functions' (which see)."
  (interactive (list (yes-or-no-p "Are you sure you want to kill all buffers? ")))
  (cond ((and (interactive-p)
              (not confirm))
         (message "Not killing buffers"))
        (t
         (mapc 'kill-buffer (buffer-list)))))

(defun temporary-display-command-output (&rest args)
  "Run command specified by ARGS, displaying output in a temporary buffer.
The buffer is killed and the window configuration restored after a key press."
  (let ((wc (current-window-configuration))
        (buf (format "*%s*" (car args))))
    (unwind-protect
        (progn
          (with-output-to-temp-buffer buf
            (apply 'call-process (car args) nil buf t (cdr args)))
          (read-char-exclusive " "))
      (kill-buffer buf)
      (set-window-configuration wc))))


;;; Modifications to buffer commands.
;;; These have no autoload cookie because they do not define new commands,
;;; just modify existing ones.

;; This is defined but not activated by default.
(defadvice capitalize-word (before upcase-before-middle)
  "If point is in the middle of a downcased word, no argument is
just like \\[negative-argument] \\[capitalize-word]."
  (interactive "p")
  (if (and (= 1 (ad-get-arg 0))
           (looking-at "\\B\\w")
           (save-excursion
             (string= (current-word) (downcase (current-word)))))
      (ad-set-arg 0 -1)))

(defadvice rename-buffer (before interactive-edit-buffer-name activate)
  "Prompt for buffer name supplying current buffer name for editing."
  (interactive
   (list (let ((minibuffer-local-completion-map
                (copy-keymap minibuffer-local-completion-map)))
           (define-key
             minibuffer-local-completion-map " " 'self-insert-command)
           (completing-read "Rename current buffer to: "
                            (mapcar (lambda (buffer)
                                      (list (buffer-name buffer)))
                                    (buffer-list))
                            nil
                            nil
                            (if (string-lessp "19" emacs-version)
                                (cons (buffer-name) 0)
                              (buffer-name))))
         current-prefix-arg)))

;;;###autoload
(defun copy-and-comment-lines (beg end)
  "Insert a copy of the lines in region and comment them.
When transient-mark-mode is enabled, if no region is active then only the
current line is acted upon.

If the region begins or ends in the middle of a line, that entire line is
copied, even if the region is narrowed to the middle of a line.
The copied lines are commented according to mode.

Current position is preserved."
  (interactive "r")
  (save-excursion
    (save-restriction
      (widen)
      (when (and transient-mark-mode (not (use-region-p)))
        (setq beg (line-beginning-position)
              end (line-beginning-position 2)))

      (goto-char beg)
      (setq beg (line-beginning-position))
      (goto-char end)
      (unless (= (point) (line-beginning-position))
        (setq end (line-beginning-position 2)))

      (goto-char beg)
      (insert-before-markers (buffer-substring-no-properties beg end))
      (comment-region beg end))

    ;; Don't modify region or display if called as a function.
    (when (called-interactively-p 'all)
      ;; If narrowed, make sure newly commented lines are visible in the
      ;; narrowed region.
      (when (> (point-min) beg)
        (narrow-to-region beg (point-max)))

      ;; Make sure newly commented lines are visible in the window if at the
      ;; very top.
      (unless (pos-visible-in-window-p beg)
        (set-window-start (selected-window) beg)))))


(provide 'buffer-fns)

;;; buffer-fns.el ends here.