code.delx.au - gnu-emacs/blob - lisp/mh-e/mh-funcs.el

   1 ;;; mh-funcs.el --- MH-E functions not everyone will use right away
   2
   3 ;; Copyright (C) 1993, 1995, 2001, 02, 2003 Free Software Foundation, Inc.
   4
   5 ;; Author: Bill Wohler <wohler@newt.com>
   6 ;; Maintainer: Bill Wohler <wohler@newt.com>
   7 ;; Keywords: mail
   8 ;; See: mh-e.el
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; Internal support for MH-E package.
  30 ;; Putting these functions in a separate file lets MH-E start up faster,
  31 ;; since less Lisp code needs to be loaded all at once.
  32
  33 ;;; Change Log:
  34
  35 ;;; Code:
  36
  37 (require 'mh-e)
  38
  39 ;;; Customization
  40
  41 (defvar mh-sortm-args nil
  42   "Extra arguments to have \\[mh-sort-folder] pass to the \"sortm\" command.
  43 The arguments are passed to sortm if \\[mh-sort-folder] is given a
  44 prefix argument.  Normally default arguments to sortm are specified in the
  45 MH profile.
  46 For example, '(\"-nolimit\" \"-textfield\" \"subject\") is a useful setting.")
  47
  48 (defvar mh-note-copied "C"
  49   "String whose first character is used to notate copied messages.")
  50
  51 (defvar mh-note-printed "P"
  52   "String whose first character is used to notate printed messages.")
  53
  54 ;;; Functions
  55
  56 ;;;###mh-autoload
  57 (defun mh-burst-digest ()
  58   "Burst apart the current message, which should be a digest.
  59 The message is replaced by its table of contents and the messages from the
  60 digest are inserted into the folder after that message."
  61   (interactive)
  62   (let ((digest (mh-get-msg-num t)))
  63     (mh-process-or-undo-commands mh-current-folder)
  64     (mh-set-folder-modified-p t)        ; lock folder while bursting
  65     (message "Bursting digest...")
  66     (mh-exec-cmd "burst" mh-current-folder digest "-inplace")
  67     (with-mh-folder-updating (t)
  68       (beginning-of-line)
  69       (delete-region (point) (point-max)))
  70     (mh-regenerate-headers (format "%d-last" digest) t)
  71     (mh-goto-cur-msg)
  72     (message "Bursting digest...done")))
  73
  74 ;;;###mh-autoload
  75 (defun mh-copy-msg (range folder)
  76   "Copy the specified RANGE to another FOLDER without deleting them.
  77
  78 Check the documentation of `mh-interactive-range' to see how RANGE is read in
  79 interactive use."
  80   (interactive (list (mh-interactive-range "Copy")
  81                      (mh-prompt-for-folder "Copy to" "" t)))
  82   (let ((msg-list (let ((result ()))
  83                     (mh-iterate-on-range msg range
  84                       (mh-notate nil mh-note-copied mh-cmd-note)
  85                       (push msg result))
  86                     result)))
  87     (mh-exec-cmd "refile" (mh-coalesce-msg-list msg-list)
  88                  "-link" "-src" mh-current-folder folder)))
  89
  90 ;;;###mh-autoload
  91 (defun mh-kill-folder ()
  92   "Remove the current folder and all included messages.
  93 Removes all of the messages (files) within the specified current folder,
  94 and then removes the folder (directory) itself.
  95 The value of `mh-kill-folder-suppress-prompt-hook' is a list of functions to
  96 be called, with no arguments, which should return a value of non-nil if
  97 verification is not desired."
  98   (interactive)
  99   (if (or (run-hook-with-args-until-success
 100            'mh-kill-folder-suppress-prompt-hook)
 101           (yes-or-no-p (format "Remove folder %s (and all included messages)? "
 102                                mh-current-folder)))
 103       (let ((folder mh-current-folder)
 104             (window-config mh-previous-window-config))
 105         (mh-set-folder-modified-p t)    ; lock folder to kill it
 106         (mh-exec-cmd-daemon "rmf" 'mh-rmf-daemon folder)
 107         (when (boundp 'mh-speed-folder-map)
 108           (mh-speed-invalidate-map folder))
 109         (mh-remove-from-sub-folders-cache folder)
 110         (mh-set-folder-modified-p nil)  ; so kill-buffer doesn't complain
 111         (if (and mh-show-buffer (get-buffer mh-show-buffer))
 112             (kill-buffer mh-show-buffer))
 113         (if (get-buffer folder)
 114             (kill-buffer folder))
 115         (when window-config
 116           (set-window-configuration window-config))
 117         (message "Folder %s removed" folder))
 118     (message "Folder not removed")))
 119
 120 (defun mh-rmf-daemon (process output)
 121   "The rmf PROCESS puts OUTPUT in temporary buffer.
 122 Display the results only if something went wrong."
 123   (set-buffer (get-buffer-create mh-temp-buffer))
 124   (insert-before-markers output)
 125   (when (save-excursion
 126           (beginning-of-buffer)
 127           (re-search-forward "^rmf: " (point-max) t))
 128     (display-buffer mh-temp-buffer)))
 129
 130 ;; Avoid compiler warning...
 131 (defvar view-exit-action)
 132
 133 ;;;###mh-autoload
 134 (defun mh-list-folders ()
 135   "List mail folders."
 136   (interactive)
 137   (let ((temp-buffer mh-folders-buffer))
 138     (with-output-to-temp-buffer temp-buffer
 139       (save-excursion
 140         (set-buffer temp-buffer)
 141         (erase-buffer)
 142         (message "Listing folders...")
 143         (mh-exec-cmd-output "folders" t (if mh-recursive-folders-flag
 144                                             "-recurse"
 145                                           "-norecurse"))
 146         (goto-char (point-min))
 147         (view-mode 1)
 148         (setq view-exit-action 'kill-buffer)
 149         (message "Listing folders...done")))))
 150
 151 ;;;###mh-autoload
 152 (defun mh-pack-folder (range)
 153   "Renumber the messages of a folder to be 1..n.
 154 First, offer to execute any outstanding commands for the current folder. If
 155 optional prefix argument provided, prompt for the RANGE of messages to display
 156 after packing. Otherwise, show the entire folder."
 157   (interactive (list (if current-prefix-arg
 158                          (mh-read-range "Scan" mh-current-folder t nil t
 159                                         mh-interpret-number-as-range-flag)
 160                        '("all"))))
 161   (let ((threaded-flag (memq 'unthread mh-view-ops)))
 162     (mh-pack-folder-1 range)
 163     (mh-goto-cur-msg)
 164     (when mh-index-data
 165       (mh-index-update-maps mh-current-folder))
 166     (cond (threaded-flag (mh-toggle-threads))
 167           (mh-index-data (mh-index-insert-folder-headers))))
 168   (message "Packing folder...done"))
 169
 170 (defun mh-pack-folder-1 (range)
 171   "Close and pack the current folder.
 172 Display the given RANGE of messages after packing. If RANGE is nil, show the
 173 entire folder."
 174   (mh-process-or-undo-commands mh-current-folder)
 175   (message "Packing folder...")
 176   (mh-set-folder-modified-p t)          ; lock folder while packing
 177   (save-excursion
 178     (mh-exec-cmd-quiet t "folder" mh-current-folder "-pack"
 179                        "-norecurse" "-fast"))
 180   (mh-reset-threads-and-narrowing)
 181   (mh-regenerate-headers range))
 182
 183 ;;;###mh-autoload
 184 (defun mh-pipe-msg (command include-headers)
 185   "Pipe the current message through the given shell COMMAND.
 186 If INCLUDE-HEADERS (prefix argument) is provided, send the entire message.
 187 Otherwise just send the message's body without the headers."
 188   (interactive
 189    (list (read-string "Shell command on message: ") current-prefix-arg))
 190   (let ((msg-file-to-pipe (mh-msg-filename (mh-get-msg-num t)))
 191         (message-directory default-directory))
 192     (save-excursion
 193       (set-buffer (get-buffer-create mh-temp-buffer))
 194       (erase-buffer)
 195       (insert-file-contents msg-file-to-pipe)
 196       (goto-char (point-min))
 197       (if (not include-headers) (search-forward "\n\n"))
 198       (let ((default-directory message-directory))
 199         (shell-command-on-region (point) (point-max) command nil)))))
 200
 201 ;;;###mh-autoload
 202 (defun mh-page-digest ()
 203   "Advance displayed message to next digested message."
 204   (interactive)
 205   (mh-in-show-buffer (mh-show-buffer)
 206     ;; Go to top of screen (in case user moved point).
 207     (move-to-window-line 0)
 208     (let ((case-fold-search nil))
 209       ;; Search for blank line and then for From:
 210       (or (and (search-forward "\n\n" nil t)
 211                (re-search-forward "^From:" nil t))
 212           (error "No more messages in digest")))
 213     ;; Go back to previous blank line, then forward to the first non-blank.
 214     (search-backward "\n\n" nil t)
 215     (forward-line 2)
 216     (mh-recenter 0)))
 217
 218 ;;;###mh-autoload
 219 (defun mh-page-digest-backwards ()
 220   "Back up displayed message to previous digested message."
 221   (interactive)
 222   (mh-in-show-buffer (mh-show-buffer)
 223     ;; Go to top of screen (in case user moved point).
 224     (move-to-window-line 0)
 225     (let ((case-fold-search nil))
 226       (beginning-of-line)
 227       (or (and (search-backward "\n\n" nil t)
 228                (re-search-backward "^From:" nil t))
 229           (error "No previous message in digest")))
 230     ;; Go back to previous blank line, then forward to the first non-blank.
 231     (if (search-backward "\n\n" nil t)
 232         (forward-line 2))
 233     (mh-recenter 0)))
 234
 235 ;;;###mh-autoload
 236 (defun mh-print-msg (range)
 237   "Print RANGE on printer.
 238
 239 Check the documentation of `mh-interactive-range' to see how RANGE is read in
 240 interactive use.
 241
 242 The variable `mh-lpr-command-format' is used to generate the print command.
 243 The messages are formatted by mhl. See the variable `mhl-formfile'."
 244   (interactive (list (mh-interactive-range "Print")))
 245   (message "Printing...")
 246   (let (msgs)
 247     ;; Gather message numbers and add them to "printed" sequence.
 248     (mh-iterate-on-range msg range
 249       (mh-add-msgs-to-seq msg 'printed t)
 250       (mh-notate nil mh-note-printed mh-cmd-note)
 251       (push msg msgs))
 252     (setq msgs (nreverse msgs))
 253     ;; Print scan listing if we have more than one message.
 254     (if (> (length msgs) 1)
 255         (let* ((msgs-string
 256                 (mapconcat 'identity (mh-list-to-string
 257                                       (mh-coalesce-msg-list msgs)) " "))
 258                (lpr-command
 259                 (format mh-lpr-command-format
 260                         (cond ((listp range)
 261                                (format "Folder: %s, Messages: %s"
 262                                        mh-current-folder msgs-string))
 263                               ((symbolp range)
 264                                (format "Folder: %s, Sequence: %s"
 265                                        mh-current-folder range)))))
 266                (scan-command
 267                 (format "scan %s | %s" msgs-string lpr-command)))
 268           (if mh-print-background-flag
 269               (mh-exec-cmd-daemon shell-file-name nil "-c" scan-command)
 270             (call-process shell-file-name nil nil nil "-c" scan-command))))
 271     ;; Print the messages
 272     (dolist (msg msgs)
 273       (let* ((mhl-command (format "%s %s %s"
 274                                   (expand-file-name "mhl" mh-lib-progs)
 275                                   (if mhl-formfile
 276                                       (format " -form %s" mhl-formfile)
 277                                     "")
 278                                   (mh-msg-filename msg)))
 279              (lpr-command
 280               (format mh-lpr-command-format
 281                       (format "%s/%s" mh-current-folder msg)))
 282              (print-command
 283               (format "%s | %s" mhl-command lpr-command)))
 284         (if mh-print-background-flag
 285             (mh-exec-cmd-daemon shell-file-name nil "-c" print-command)
 286           (call-process shell-file-name nil nil nil "-c" print-command)))))
 287   (message "Printing...done"))
 288
 289 ;;;###mh-autoload
 290 (defun mh-sort-folder (&optional extra-args)
 291   "Sort the messages in the current folder by date.
 292 Calls the MH program sortm to do the work.
 293 The arguments in the list `mh-sortm-args' are passed to sortm if the optional
 294 argument EXTRA-ARGS is given."
 295   (interactive "P")
 296   (mh-process-or-undo-commands mh-current-folder)
 297   (setq mh-next-direction 'forward)
 298   (mh-set-folder-modified-p t)          ; lock folder while sorting
 299   (message "Sorting folder...")
 300   (let ((threaded-flag (memq 'unthread mh-view-ops)))
 301     (mh-exec-cmd "sortm" mh-current-folder (if extra-args mh-sortm-args))
 302     (when mh-index-data
 303       (mh-index-update-maps mh-current-folder))
 304     (message "Sorting folder...done")
 305     (mh-scan-folder mh-current-folder "all")
 306     (cond (threaded-flag (mh-toggle-threads))
 307           (mh-index-data (mh-index-insert-folder-headers)))))
 308
 309 ;;;###mh-autoload
 310 (defun mh-undo-folder (&rest ignore)
 311   "Undo all pending deletes and refiles in current folder.
 312 Argument IGNORE is deprecated."
 313   (interactive)
 314   (cond ((or mh-do-not-confirm-flag
 315              (yes-or-no-p "Undo all commands in folder? "))
 316          (setq mh-delete-list nil
 317                mh-refile-list nil
 318                mh-seq-list nil
 319                mh-next-direction 'forward)
 320          (with-mh-folder-updating (nil)
 321            (mh-remove-all-notation)))
 322         (t
 323          (message "Commands not undone.")
 324          ;; Remove by 2003-06-30 if nothing seems amiss. XXX
 325          ;; (sit-for 2)
 326          )))
 327
 328 ;;;###mh-autoload
 329 (defun mh-store-msg (directory)
 330   "Store the file(s) contained in the current message into DIRECTORY.
 331 The message can contain a shar file or uuencoded file.
 332 Default directory is the last directory used, or initially the value of
 333 `mh-store-default-directory' or the current directory."
 334   (interactive (list (let ((udir (or mh-store-default-directory
 335                                      default-directory)))
 336                        (read-file-name "Store message in directory: "
 337                                        udir udir nil))))
 338   (let ((msg-file-to-store (mh-msg-filename (mh-get-msg-num t))))
 339     (save-excursion
 340       (set-buffer (get-buffer-create mh-temp-buffer))
 341       (erase-buffer)
 342       (insert-file-contents msg-file-to-store)
 343       (mh-store-buffer directory))))
 344
 345 ;;;###mh-autoload
 346 (defun mh-store-buffer (directory)
 347   "Store the file(s) contained in the current buffer into DIRECTORY.
 348 The buffer can contain a shar file or uuencoded file.
 349 Default directory is the last directory used, or initially the value of
 350 `mh-store-default-directory' or the current directory."
 351   (interactive (list (let ((udir (or mh-store-default-directory
 352                                      default-directory)))
 353                        (read-file-name "Store buffer in directory: "
 354                                        udir udir nil))))
 355   (let ((store-directory (expand-file-name directory))
 356         (sh-start (save-excursion
 357                     (goto-char (point-min))
 358                     (if (re-search-forward
 359                          "^#![ \t]*/bin/sh\\|^#\\|^: " nil t)
 360                         (progn
 361                           ;; The "cut here" pattern was removed from above
 362                           ;; because it seemed to hurt more than help.
 363                           ;; But keep this to make it easier to put it back.
 364                           (if (looking-at "^[^a-z0-9\"]*cut here\\b")
 365                               (forward-line 1))
 366                           (beginning-of-line)
 367                           (if (looking-at "^[#:]....+\n\\( ?\n\\)?end$")
 368                               nil       ;most likely end of a uuencode
 369                             (point))))))
 370         (command "sh")
 371         (uudecode-filename "(unknown filename)")
 372         log-begin)
 373     (if (not sh-start)
 374         (save-excursion
 375           (goto-char (point-min))
 376           (if (re-search-forward "^begin [0-7]+ " nil t)
 377               (setq uudecode-filename
 378                     (buffer-substring (point)
 379                                       (progn (end-of-line) (point)))))))
 380     (save-excursion
 381       (set-buffer (get-buffer-create mh-log-buffer))
 382       (setq log-begin (mh-truncate-log-buffer))
 383       (if (not (file-directory-p store-directory))
 384           (progn
 385             (insert "mkdir " directory "\n")
 386             (call-process "mkdir" nil mh-log-buffer t store-directory)))
 387       (insert "cd " directory "\n")
 388       (setq mh-store-default-directory directory)
 389       (if (not sh-start)
 390           (progn
 391             (setq command "uudecode")
 392             (insert uudecode-filename " being uudecoded...\n"))))
 393     (set-window-start (display-buffer mh-log-buffer) log-begin) ;watch progress
 394     (let ((default-directory (file-name-as-directory store-directory)))
 395       (if (equal (call-process-region sh-start (point-max) command
 396                                       nil mh-log-buffer t)
 397                  0)
 398           (save-excursion
 399             (set-buffer mh-log-buffer)
 400             (insert "\n(mh-store finished)\n"))
 401         (error "Error occurred during execution of %s" command)))))
 402
 403 \f
 404
 405 ;;; Help Functions
 406
 407 ;;;###mh-autoload
 408 (defun mh-ephem-message (string)
 409   "Display STRING in the minibuffer momentarily."
 410   (message "%s" string)
 411   (sit-for 5)
 412   (message ""))
 413
 414 ;;;###mh-autoload
 415 (defun mh-help ()
 416   "Display cheat sheet for the MH-Folder commands in minibuffer."
 417   (interactive)
 418   (mh-ephem-message
 419    (substitute-command-keys
 420     (mapconcat 'identity (cdr (assoc nil mh-help-messages)) ""))))
 421
 422 ;;;###mh-autoload
 423 (defun mh-prefix-help ()
 424   "Display cheat sheet for the commands of the current prefix in minibuffer."
 425   (interactive)
 426   ;; We got here because the user pressed a `?', but he pressed a prefix key
 427   ;; before that. Since the the key vector starts at index 0, the index of the
 428   ;; last keystroke is length-1 and thus the second to last keystroke is at
 429   ;; length-2. We use that information to obtain a suitable prefix character
 430   ;; from the recent keys.
 431   (let* ((keys (recent-keys))
 432          (prefix-char (elt keys (- (length keys) 2))))
 433     (mh-ephem-message
 434      (substitute-command-keys
 435       (mapconcat 'identity (cdr (assoc prefix-char mh-help-messages)) "")))))
 436
 437 (provide 'mh-funcs)
 438
 439 ;;; Local Variables:
 440 ;;; indent-tabs-mode: nil
 441 ;;; sentence-end-double-space: nil
 442 ;;; End:
 443
 444 ;;; arch-tag: 1936c4f1-4843-438e-bc4b-a63bb75a7762
 445 ;;; mh-funcs.el ends here