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   (message "mh-ps-spool-buffer %s" buffer)
  68   (save-excursion
  69     (set-buffer buffer)
  70     (let ((ps-print-color-p mh-ps-print-color-option)
  71       (ps-left-header
  72        (list
  73         (concat "("
  74                 (mh-get-header-field "Subject:") ")")
  75         (concat "("
  76                 (mh-get-header-field "From:") ")")))
  77       (ps-right-header
  78        (list
  79         "/pagenumberstring load"
  80         (concat "("
  81                 (mh-get-header-field "Date:") ")"))))
  82     (funcall mh-ps-print-func))))
  83
  84 (defun mh-ps-spool-a-msg (msg buffer)
  85   "Print MSG.
  86 First the message is decoded in BUFFER before the results are sent to the
  87 printer."
  88   (message "mh-ps-spool-a-msg msg %s buffer %s"
  89                    msg buffer)
  90   (let ((mh-show-buffer mh-show-buffer)
  91         (folder mh-current-folder)
  92         ;; The following is commented out because
  93         ;; `clean-message-header-flag' isn't used anywhere. I
  94         ;; commented rather than deleted in case somebody had some
  95         ;; future plans for it. --SY.
  96         ;(clean-message-header-flag mh-clean-message-header-flag)
  97         )
  98     (unwind-protect
  99         (progn
 100           (setq mh-show-buffer buffer)
 101           (save-excursion
 102             ;;
 103             ;; XXX - Use setting of mh-ps-print-mime
 104             ;;
 105             (mh-display-msg msg folder)
 106             (mh-ps-spool-buffer mh-show-buffer)
 107       (kill-buffer mh-show-buffer))))))
 108
 109 ;;;###mh-autoload
 110 (defun mh-ps-print-msg (range)
 111   "Print the messages in RANGE.
 112
 113 Check the documentation of `mh-interactive-range' to see how RANGE is read in
 114 interactive use."
 115   (interactive (list (mh-interactive-range "Print")))
 116   (message "mh-ps-print-msg range %s keys %s"
 117                     range (this-command-keys))
 118   (mh-iterate-on-range msg range
 119     (let ((buffer (get-buffer-create mh-temp-buffer)))
 120       (unwind-protect
 121           (mh-ps-spool-a-msg msg buffer)
 122         (kill-buffer buffer)))
 123     (mh-notate nil mh-note-printed mh-cmd-note))
 124   (ps-despool nil))
 125
 126 (defun mh-ps-print-preprint (prefix-arg)
 127   "Replacement for `ps-print-preprint'.
 128 The original function does not handle the fact that MH folders are directories
 129 nicely, when generating the default file name. This function works around
 130 that. The function is passed the interactive PREFIX-ARG."
 131   (let ((buffer-file-name (format "/tmp/%s" (substring (buffer-name) 1))))
 132     (ps-print-preprint prefix-arg)))
 133
 134 ;;;###mh-autoload
 135 (defun mh-ps-print-msg-file (file range)
 136   "Print to FILE the messages in RANGE.
 137
 138 Check the documentation of `mh-interactive-range' to see how RANGE is read in
 139 interactive use."
 140   (interactive (list
 141                 (mh-ps-print-preprint 1)
 142                 (mh-interactive-range "Print")))
 143   (mh-iterate-on-range msg range
 144     (let ((buffer (get-buffer-create mh-temp-buffer)))
 145       (unwind-protect
 146           (mh-ps-spool-a-msg msg buffer)
 147         (kill-buffer buffer)))
 148     (mh-notate nil mh-note-printed mh-cmd-note))
 149   (ps-despool file))
 150
 151 ;;;###mh-autoload
 152 (defun mh-ps-print-msg-show (file)
 153   "Print current show buffer to FILE."
 154   (interactive (list (mh-ps-print-preprint current-prefix-arg)))
 155   (message "mh-ps-print-msg-show file %s keys %s mh-show-buffer %s"
 156                    file (this-command-keys) mh-show-buffer)
 157   (let ((msg (mh-get-msg-num t))
 158         (folder mh-current-folder)
 159         (show-buffer mh-show-buffer)
 160         (show-window (get-buffer-window mh-show-buffer)))
 161     (if (and show-buffer show-window)
 162         (mh-in-show-buffer (show-buffer)
 163           (if (equal (mh-msg-filename msg folder) buffer-file-name)
 164               (progn
 165                 (mh-ps-spool-buffer show-buffer)
 166                 (ps-despool file))
 167             (message "Current message is not being shown(1).")))
 168       (message "Current message is not being shown(2)."))))
 169
 170 ;;;###mh-autoload
 171 (defun mh-ps-print-toggle-faces ()
 172  "Toggle whether printing is done with faces or not."
 173  (interactive)
 174  (if (eq mh-ps-print-func 'ps-spool-buffer-with-faces)
 175      (progn
 176        (setq mh-ps-print-func 'ps-spool-buffer)
 177        (message "Printing without faces"))
 178    (setq mh-ps-print-func 'ps-spool-buffer-with-faces)
 179    (message "Printing with faces")))
 180
 181 ;;;###mh-autoload
 182 (defun mh-ps-print-toggle-color ()
 183   "Toggle whether color is used in printing messages."
 184  (interactive)
 185  (if (eq mh-ps-print-color-option nil)
 186      (progn
 187        (setq mh-ps-print-color-option 'black-white)
 188        (message "Colors will be printed as black & white."))
 189    (if (eq mh-ps-print-color-option 'black-white)
 190        (progn
 191          (setq mh-ps-print-color-option t)
 192          (message "Colors will be printed."))
 193      (setq mh-ps-print-color-option nil)
 194      (message "Colors will not be printed."))))
 195
 196 ;;; XXX: Check option 3. Documentation doesn't sound right.
 197 ;;;###mh-autoload
 198 (defun mh-ps-print-toggle-mime ()
 199   "Cycle through available choices on how MIME parts should be printed.
 200 The available settings are:
 201   1. Print only inline MIME parts.
 202   2. Print all MIME parts.
 203   3. Print no MIME parts."
 204   (interactive)
 205   (if (eq mh-ps-print-mime nil)
 206       (progn
 207         (setq mh-ps-print-mime t)
 208         (message "Inline parts will be printed, attachments will not be printed."))
 209     (if (eq mh-ps-print-mime t)
 210         (progn
 211           (setq mh-ps-print-mime 1)
 212           (message "Both Inline parts and attachments will be printed."))
 213       (setq mh-ps-print-mime nil)
 214       (message "Neither inline parts nor attachments will be printed."))))
 215
 216 ;;; Old non-PS based printing
 217 ;;;###mh-autoload
 218 (defun mh-print-msg (range)
 219   "Print RANGE on printer.
 220
 221 Check the documentation of `mh-interactive-range' to see how RANGE is read in
 222 interactive use.
 223
 224 The variable `mh-lpr-command-format' is used to generate the print command.
 225 The messages are formatted by mhl. See the variable `mhl-formfile'."
 226   (interactive (list (mh-interactive-range "Print")))
 227   (message "Printing...")
 228   (let (msgs)
 229     ;; Gather message numbers and add them to "printed" sequence.
 230     (mh-iterate-on-range msg range
 231       (mh-add-msgs-to-seq msg 'printed t)
 232       (mh-notate nil mh-note-printed mh-cmd-note)
 233       (push msg msgs))
 234     (setq msgs (nreverse msgs))
 235     ;; Print scan listing if we have more than one message.
 236     (if (> (length msgs) 1)
 237         (let* ((msgs-string
 238                 (mapconcat 'identity (mh-list-to-string
 239                                       (mh-coalesce-msg-list msgs)) " "))
 240                (lpr-command
 241                 (format mh-lpr-command-format
 242                         (cond ((listp range)
 243                                (format "Folder: %s, Messages: %s"
 244                                        mh-current-folder msgs-string))
 245                               ((symbolp range)
 246                                (format "Folder: %s, Sequence: %s"
 247                                        mh-current-folder range)))))
 248                (scan-command
 249                 (format "scan %s | %s" msgs-string lpr-command)))
 250           (if mh-print-background-flag
 251               (mh-exec-cmd-daemon shell-file-name nil "-c" scan-command)
 252             (call-process shell-file-name nil nil nil "-c" scan-command))))
 253     ;; Print the messages
 254     (dolist (msg msgs)
 255       (let* ((mhl-command (format "%s %s %s"
 256                                   (expand-file-name "mhl" mh-lib-progs)
 257                                   (if mhl-formfile
 258                                       (format " -form %s" mhl-formfile)
 259                                     "")
 260                                   (mh-msg-filename msg)))
 261              (lpr-command
 262               (format mh-lpr-command-format
 263                       (format "%s/%s" mh-current-folder msg)))
 264              (print-command
 265               (format "%s | %s" mhl-command lpr-command)))
 266         (if mh-print-background-flag
 267             (mh-exec-cmd-daemon shell-file-name nil "-c" print-command)
 268           (call-process shell-file-name nil nil nil "-c" print-command)))))
 269   (message "Printing...done"))
 270
 271 (provide 'mh-print)
 272
 273 ;;; Local Variables:
 274 ;;; indent-tabs-mode: nil
 275 ;;; sentence-end-double-space: nil
 276 ;;; End:
 277
 278 ;; arch-tag: 8d84d50b-2a49-4d0d-b51e-ba9c9b6fc679
 279 ;;; mh-print.el ends here