lisp/mh-e/mh-print.el

   1 ;;; mh-print.el --- MH-E printing support
   2
   3 ;; Copyright (C) 2003, 2004, 2005 Free Software Foundation, Inc.
   4
   5 ;; Author: Jeffrey C Honig <jch@honig.net>
   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., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28 ;;      Pp      Print to lpr              |   Default inline settings
  29 ;;      Pf      Print to file             |   Generate a postscript file
  30 ;;      Ps      Print show buffer         |   Fails if no show buffer
  31 ;;
  32 ;;      PA      Toggle inline/attachments
  33 ;;      PC      Toggle color
  34 ;;      PF      Toggle faces
  35
  36 ;;; Change Log:
  37
  38 ;;; Code:
  39
  40 (eval-when-compile (require 'mh-acros))
  41 (mh-require-cl)
  42 (require 'ps-print)
  43 (require 'mh-utils)
  44 (require 'mh-funcs)
  45 (eval-when-compile (require 'mh-seq))
  46
  47 (defvar mh-ps-print-mime nil
  48   "Control printing of MIME parts.
  49 The three possible states are:
  50   1. nil to not print inline parts
  51   2. t to print inline parts
  52   3. non-zero to print inline parts and attachments")
  53
  54 (defvar mh-ps-print-color-option ps-print-color-p
  55   "MH-E's version of `\\[ps-print-color-p]'.")
  56
  57 (defvar mh-ps-print-func 'ps-spool-buffer-with-faces
  58   "Function to use to spool a buffer.
  59 Sensible choices are the functions `ps-spool-buffer' and
  60 `ps-spool-buffer-with-faces'.")
  61
  62 ;; XXX - If buffer is already being displayed, use that buffer
  63 ;; XXX - What about showing MIME content?
  64 ;; XXX - Default print buffer is bogus
  65 (defun mh-ps-spool-buffer (buffer)
  66   "Send BUFFER to printer queue."
  67   (save-excursion
  68     (set-buffer buffer)
  69     (let ((ps-print-color-p mh-ps-print-color-option)
  70       (ps-left-header
  71        (list
  72         (concat "("
  73                 (mh-get-header-field "Subject:") ")")
  74         (concat "("
  75                 (mh-get-header-field "From:") ")")))
  76       (ps-right-header
  77        (list
  78         "/pagenumberstring load"
  79         (concat "("
  80                 (mh-get-header-field "Date:") ")"))))
  81     (funcall mh-ps-print-func))))
  82
  83 (defun mh-ps-spool-a-msg (msg buffer)
  84   "Print MSG.
  85 First the message is decoded in BUFFER before the results are sent to the
  86 printer."
  87   (let ((mh-show-buffer mh-show-buffer)
  88         (folder mh-current-folder)
  89         ;; The following is commented out because
  90         ;; `clean-message-header-flag' isn't used anywhere. I
  91         ;; commented rather than deleted in case somebody had some
  92         ;; future plans for it. --SY.
  93         ;(clean-message-header-flag mh-clean-message-header-flag)
  94         )
  95     (unwind-protect
  96         (progn
  97           (setq mh-show-buffer buffer)
  98           (save-excursion
  99             ;;
 100             ;; XXX - Use setting of mh-ps-print-mime
 101             ;;
 102             (mh-display-msg msg folder)
 103             (mh-ps-spool-buffer mh-show-buffer)
 104       (kill-buffer mh-show-buffer))))))
 105
 106 ;;;###mh-autoload
 107 (defun mh-ps-print-msg (range)
 108   "Print the messages in RANGE.
 109
 110 Check the documentation of `mh-interactive-range' to see how RANGE is read in
 111 interactive use."
 112   (interactive (list (mh-interactive-range "Print")))
 113   (mh-iterate-on-range msg range
 114     (let ((buffer (get-buffer-create mh-temp-buffer)))
 115       (unwind-protect
 116           (mh-ps-spool-a-msg msg buffer)
 117         (kill-buffer buffer)))
 118     (mh-notate nil mh-note-printed mh-cmd-note))
 119   (ps-despool nil))
 120
 121 (defun mh-ps-print-preprint (prefix-arg)
 122   "Replacement for `ps-print-preprint'.
 123 The original function does not handle the fact that MH folders are directories
 124 nicely, when generating the default file name. This function works around
 125 that. The function is passed the interactive PREFIX-ARG."
 126   (let ((buffer-file-name (format "/tmp/%s" (substring (buffer-name) 1))))
 127     (ps-print-preprint prefix-arg)))
 128
 129 ;;;###mh-autoload
 130 (defun mh-ps-print-msg-file (file range)
 131   "Print to FILE the messages in RANGE.
 132
 133 Check the documentation of `mh-interactive-range' to see how RANGE is read in
 134 interactive use."
 135   (interactive (list
 136                 (mh-ps-print-preprint 1)
 137                 (mh-interactive-range "Print")))
 138   (mh-iterate-on-range msg range
 139     (let ((buffer (get-buffer-create mh-temp-buffer)))
 140       (unwind-protect
 141           (mh-ps-spool-a-msg msg buffer)
 142         (kill-buffer buffer)))
 143     (mh-notate nil mh-note-printed mh-cmd-note))
 144   (ps-despool file))
 145
 146 ;;;###mh-autoload
 147 (defun mh-ps-print-msg-show (file)
 148   "Print current show buffer to FILE."
 149   (interactive (list (mh-ps-print-preprint current-prefix-arg)))
 150   (let ((msg (mh-get-msg-num t))
 151         (folder mh-current-folder)
 152         (show-buffer mh-show-buffer)
 153         (show-window (get-buffer-window mh-show-buffer)))
 154     (if (and show-buffer show-window)
 155         (mh-in-show-buffer (show-buffer)
 156           (if (equal (mh-msg-filename msg folder) buffer-file-name)
 157               (progn
 158                 (mh-ps-spool-buffer show-buffer)
 159                 (ps-despool file))
 160             (message "Current message is not being shown(1)")))
 161       (message "Current message is not being shown(2)"))))
 162
 163 ;;;###mh-autoload
 164 (defun mh-ps-print-toggle-faces ()
 165  "Toggle whether printing is done with faces or not."
 166  (interactive)
 167  (if (eq mh-ps-print-func 'ps-spool-buffer-with-faces)
 168      (progn
 169        (setq mh-ps-print-func 'ps-spool-buffer)
 170        (message "Printing without faces"))
 171    (setq mh-ps-print-func 'ps-spool-buffer-with-faces)
 172    (message "Printing with faces")))
 173
 174 ;;;###mh-autoload
 175 (defun mh-ps-print-toggle-color ()
 176   "Toggle whether color is used in printing messages."
 177  (interactive)
 178  (if (eq mh-ps-print-color-option nil)
 179      (progn
 180        (setq mh-ps-print-color-option 'black-white)
 181        (message "Colors will be printed as black & white"))
 182    (if (eq mh-ps-print-color-option 'black-white)
 183        (progn
 184          (setq mh-ps-print-color-option t)
 185          (message "Colors will be printed"))
 186      (setq mh-ps-print-color-option nil)
 187      (message "Colors will not be printed"))))
 188
 189 ;;; XXX: Check option 3. Documentation doesn't sound right.
 190 ;;;###mh-autoload
 191 (defun mh-ps-print-toggle-mime ()
 192   "Cycle through available choices on how MIME parts should be printed.
 193 The available settings are:
 194   1. Print only inline MIME parts.
 195   2. Print all MIME parts.
 196   3. Print no MIME parts."
 197   (interactive)
 198   (if (eq mh-ps-print-mime nil)
 199       (progn
 200         (setq mh-ps-print-mime t)
 201         (message "Inline parts will be printed, attachments will not be printed"))
 202     (if (eq mh-ps-print-mime t)
 203         (progn
 204           (setq mh-ps-print-mime 1)
 205           (message "Both Inline parts and attachments will be printed"))
 206       (setq mh-ps-print-mime nil)
 207       (message "Neither inline parts nor attachments will be printed"))))
 208
 209 ;;; Old non-PS based printing
 210 ;;;###mh-autoload
 211 (defun mh-print-msg (range)
 212   "Print RANGE on printer.
 213
 214 Check the documentation of `mh-interactive-range' to see how RANGE is read in
 215 interactive use.
 216
 217 The variable `mh-lpr-command-format' is used to generate the print command.
 218 The messages are formatted by mhl. See the variable `mhl-formfile'."
 219   (interactive (list (mh-interactive-range "Print")))
 220   (message "Printing...")
 221   (let (msgs)
 222     ;; Gather message numbers and add them to "printed" sequence.
 223     (mh-iterate-on-range msg range
 224       (mh-add-msgs-to-seq msg 'printed t)
 225       (mh-notate nil mh-note-printed mh-cmd-note)
 226       (push msg msgs))
 227     (setq msgs (nreverse msgs))
 228     ;; Print scan listing if we have more than one message.
 229     (if (> (length msgs) 1)
 230         (let* ((msgs-string
 231                 (mapconcat 'identity (mh-list-to-string
 232                                       (mh-coalesce-msg-list msgs)) " "))
 233                (lpr-command
 234                 (format mh-lpr-command-format
 235                         (cond ((listp range)
 236                                (format "Folder: %s, Messages: %s"
 237                                        mh-current-folder msgs-string))
 238                               ((symbolp range)
 239                                (format "Folder: %s, Sequence: %s"
 240                                        mh-current-folder range)))))
 241                (scan-command
 242                 (format "scan %s | %s" msgs-string lpr-command)))
 243           (if mh-print-background-flag
 244               (mh-exec-cmd-daemon shell-file-name nil "-c" scan-command)
 245             (call-process shell-file-name nil nil nil "-c" scan-command))))
 246     ;; Print the messages
 247     (dolist (msg msgs)
 248       (let* ((mhl-command (format "%s %s %s"
 249                                   (expand-file-name "mhl" mh-lib-progs)
 250                                   (if mhl-formfile
 251                                       (format " -form %s" mhl-formfile)
 252                                     "")
 253                                   (mh-msg-filename msg)))
 254              (lpr-command
 255               (format mh-lpr-command-format
 256                       (format "%s/%s" mh-current-folder msg)))
 257              (print-command
 258               (format "%s | %s" mhl-command lpr-command)))
 259         (if mh-print-background-flag
 260             (mh-exec-cmd-daemon shell-file-name nil "-c" print-command)
 261           (call-process shell-file-name nil nil nil "-c" print-command)))))
 262   (message "Printing...done"))
 263
 264 (provide 'mh-print)
 265
 266 ;;; Local Variables:
 267 ;;; indent-tabs-mode: nil
 268 ;;; sentence-end-double-space: nil
 269 ;;; End:
 270
 271 ;; arch-tag: 8d84d50b-2a49-4d0d-b51e-ba9c9b6fc679
 272 ;;; mh-print.el ends here