lisp/mail/pmailout.el

   1 ;;; pmailout.el --- "PMAIL" mail reader for Emacs: output message to a file.
   2
   3 ;; Copyright (C) 1985, 1987, 1993, 1994, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
   5
   6 ;; Maintainer: FSF
   7 ;; Keywords: mail
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (provide 'pmailout)
  29
  30 (eval-when-compile
  31   (require 'pmail)
  32   (require 'pmaildesc))
  33
  34 ;;;###autoload
  35 (defcustom pmail-output-file-alist nil
  36   "*Alist matching regexps to suggested output Pmail files.
  37 This is a list of elements of the form (REGEXP . NAME-EXP).
  38 The suggestion is taken if REGEXP matches anywhere in the message buffer.
  39 NAME-EXP may be a string constant giving the file name to use,
  40 or more generally it may be any kind of expression that returns
  41 a file name as a string."
  42   :type '(repeat (cons regexp
  43                        (choice :value ""
  44                                (string :tag "File Name")
  45                                sexp)))
  46   :group 'pmail-output)
  47
  48 ;;;###autoload
  49 (defcustom pmail-fields-not-to-output nil
  50   "*Regexp describing fields to exclude when outputting a message to a file."
  51   :type '(choice (const :tag "None" nil)
  52                  regexp)
  53   :group 'pmail-output)
  54
  55 (defun pmail-output-read-file-name ()
  56   "Read the file name to use for `pmail-output'.
  57 Set `pmail-default-file' to this name as well as returning it."
  58   (let* ((default-file
  59            (with-current-buffer pmail-buffer
  60              (expand-file-name
  61               (or (catch 'answer
  62                     (dolist (i pmail-output-file-alist)
  63                       (goto-char (point-min))
  64                       (when (re-search-forward (car i) nil t)
  65                         (throw 'answer (eval (cdr i))))))
  66                   pmail-default-file))))
  67          (read-file
  68           (expand-file-name
  69            (read-file-name
  70             (concat "Output message to Pmail (mbox) file: (default "
  71                     (file-name-nondirectory default-file) "): ")
  72             (file-name-directory default-file)
  73             (abbreviate-file-name default-file))
  74            (file-name-directory default-file))))
  75     (setq pmail-default-file
  76           (if (file-directory-p read-file)
  77               (expand-file-name
  78                (file-name-nondirectory default-file) read-file)
  79             (expand-file-name
  80              (or read-file (file-name-nondirectory default-file))
  81              (file-name-directory default-file))))))
  82
  83 (declare-function pmail-update-summary "pmailsum" (&rest ignore))
  84
  85 ;;; There are functions elsewhere in Emacs that use this function;
  86 ;;; look at them before you change the calling method.
  87 ;;;###autoload
  88 (defun pmail-output-to-pmail-file (file-name &optional count stay)
  89   "Append the current message to an Pmail (mbox) file named FILE-NAME.
  90 If the file does not exist, ask if it should be created.
  91 If file is being visited, the message is appended to the Emacs
  92 buffer visiting that file.
  93 If the file exists and is not an Pmail file, the message is
  94 appended in inbox format, the same way `pmail-output' does it.
  95
  96 The default file name comes from `pmail-default-pmail-file',
  97 which is updated to the name you use in this command.
  98
  99 A prefix argument COUNT says to output that many consecutive messages,
 100 starting with the current one.  Deleted messages are skipped and don't count.
 101
 102 If the optional argument STAY is non-nil, then leave the last filed
 103 message up instead of moving forward to the next non-deleted message."
 104   (interactive (list (pmail-output-read-file-name)
 105                      (prefix-numeric-value current-prefix-arg)))
 106   ;; Use the 'pmail-output function to perform the output.
 107   (pmail-output file-name count nil nil)
 108   ;; Deal with the next message
 109   (if pmail-delete-after-output
 110       (unless (if (and (= count 0) stay)
 111                   (pmail-delete-message)
 112                 (pmail-delete-forward))
 113         (setq count 0))
 114     (when (> count 0)
 115       (unless (when (not stay)
 116                 (pmail-next-undeleted-message 1))
 117         (setq count 0)))))
 118
 119 (defun pmail-delete-unwanted-fields ()
 120   "Delete from the buffer header fields we don't want output."
 121   (when pmail-fields-not-to-output
 122     (save-excursion
 123       (let ((limit (pmail-header-get-limit))
 124             (inhibit-point-motion-hooks t)
 125             start)
 126         (goto-char (point-min))
 127         (while (re-search-forward pmail-fields-not-to-output limit t)
 128           (forward-line 0)
 129           (setq start (point))
 130           (while (progn (forward-line 1) (looking-at "[ \t]+"))
 131             (goto-char (line-end-position)))
 132           (delete-region start (point)))))))
 133
 134 ;;; There are functions elsewhere in Emacs that use this function;
 135 ;;; look at them before you change the calling method.
 136 ;;;###autoload
 137 (defun pmail-output (file-name &optional count noattribute from-gnus)
 138   "Append this message to system-inbox-format mail file named FILE-NAME.
 139 A prefix argument COUNT says to output that many consecutive messages,
 140 starting with the current one.  Deleted messages are skipped and don't count.
 141 When called from lisp code, COUNT may be omitted and defaults to 1.
 142
 143 If the pruned message header is shown on the current message, then
 144 messages will be appended with pruned headers; otherwise, messages
 145 will be appended with their original headers.
 146
 147 The default file name comes from `pmail-default-file',
 148 which is updated to the name you use in this command.
 149
 150 The optional third argument NOATTRIBUTE, if non-nil, says not
 151 to set the `filed' attribute, and not to display a message.
 152
 153 The optional fourth argument FROM-GNUS is set when called from GNUS."
 154   (interactive
 155    (list (pmail-output-read-file-name)
 156          (prefix-numeric-value current-prefix-arg)))
 157   (or count (setq count 1))
 158   (setq file-name
 159         (expand-file-name file-name
 160                           (and pmail-default-file
 161                                (file-name-directory pmail-default-file))))
 162   (if (and (file-readable-p file-name) (mail-file-babyl-p file-name))
 163       (error "BABYL output not supported.")
 164     (with-current-buffer pmail-buffer
 165       (let ((orig-count count)
 166             (pmailbuf (current-buffer))
 167             (destbuf (find-buffer-visiting file-name))
 168             (case-fold-search t))
 169         (while (> count 0)
 170           (with-temp-buffer
 171             (insert-buffer-substring pmailbuf)
 172             ;; ensure we can write without barfing on exotic characters
 173             (setq buffer-file-coding-system
 174                   (or pmail-file-coding-system 'raw-text))
 175             ;; prune junk headers
 176             (pmail-delete-unwanted-fields)
 177             (if (not destbuf)
 178                 ;; The destination file is not being visited, just write
 179                 ;; out the processed message.
 180                 (write-region (point-min) (point-max) file-name
 181                               t (when noattribute 'nomsg))
 182               ;; The destination file is being visited.  Update it.
 183               (let ((msg-string (buffer-string)))
 184                 (with-current-buffer destbuf
 185                   ;; Determine if the destination file is an Pmail file.
 186                   (let ((buffer-read-only nil)
 187                         (dest-current-message
 188                          (and (boundp 'pmail-current-message)
 189                               pmail-current-message)))
 190                     (if dest-current-message
 191                         ;; The buffer is an Pmail buffer.  Append the
 192                         ;; message.
 193                         (progn
 194                           (widen)
 195                           (narrow-to-region (point-max) (point-max))
 196                           (insert msg-string)
 197                           (insert "\n")
 198                           (pmail-process-new-messages)
 199                           (pmail-show-message dest-current-message))
 200                       ;; The destination file is not an Pmail file, just
 201                       ;; insert at the end.
 202                       (goto-char (point-max))
 203                       (insert msg-string)))))))
 204           (unless noattribute
 205             (when (equal major-mode 'pmail-mode)
 206               (pmail-set-attribute "filed" t)
 207               (pmail-header-hide-headers)))
 208           (setq count (1- count))
 209           (unless from-gnus
 210             (let ((next-message-p
 211                    (if pmail-delete-after-output
 212                        (pmail-delete-forward)
 213                      (when (> count 0)
 214                        (pmail-next-undeleted-message 1))))
 215                   (num-appended (- orig-count count)))
 216               (when (and (> count 0) (not next-message-p))
 217                 (error (format "Only %d message%s appended" num-appended
 218                                (if (= num-appended 1) "" "s")))
 219                 (setq count 0)))))))))
 220
 221 ;;;###autoload
 222 (defun pmail-output-body-to-file (file-name)
 223   "Write this message body to the file FILE-NAME.
 224 FILE-NAME defaults, interactively, from the Subject field of the message."
 225   (interactive
 226    (let ((default-file (or (mail-fetch-field "Subject")
 227                            pmail-default-body-file)))
 228      (list (setq pmail-default-body-file
 229                  (read-file-name
 230                   "Output message body to file: "
 231                   (and default-file (file-name-directory default-file))
 232                   default-file
 233                   nil default-file)))))
 234   (setq file-name
 235         (expand-file-name
 236          file-name
 237          (and pmail-default-body-file
 238               (file-name-directory pmail-default-body-file))))
 239   (save-excursion
 240     (goto-char (point-min))
 241     (search-forward "\n\n")
 242     (and (file-exists-p file-name)
 243          (not (y-or-n-p (message "File %s exists; overwrite? " file-name)))
 244          (error "Operation aborted"))
 245     (write-region (point) (point-max) file-name)
 246     (when (equal major-mode 'pmail-mode)
 247       (pmail-desc-set-attribute pmail-desc-stored-index
 248                                 t pmail-current-message)))
 249   (when pmail-delete-after-output
 250     (pmail-delete-forward)))
 251
 252 ;; arch-tag: 4059abf0-f249-4be4-8e0d-602d370d01d1
 253 ;;; pmailout.el ends here