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