lisp/ps-samp.el

   1 ;;; ps-samp.el --- ps-print sample setup code
   2
   3 ;; Copyright (C) 2007-2019 Free Software Foundation, Inc.
   4
   5 ;; Author: Jim Thompson (was <thompson@wg2.waii.com>)
   6 ;;      Jacques Duthen (was <duthen@cegelec-red.fr>)
   7 ;;      Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
   8 ;;      Kenichi Handa <handa@gnu.org> (multi-byte characters)
   9 ;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
  10 ;; Keywords: wp, print, PostScript
  11 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
  12 ;; Package: ps-print
  13
  14 ;; This file is part of GNU Emacs.
  15
  16 ;; GNU Emacs is free software: you can redistribute it and/or modify
  17 ;; it under the terms of the GNU General Public License as published by
  18 ;; the Free Software Foundation, either version 3 of the License, or
  19 ;; (at your option) any later version.
  20
  21 ;; GNU Emacs is distributed in the hope that it will be useful,
  22 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 ;; GNU General Public License for more details.
  25
  26 ;; You should have received a copy of the GNU General Public License
  27 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  28
  29 ;;; Commentary:
  30
  31 ;; Some example hacks for ps-print.el.
  32 ;; This stuff is for anybody that's brave enough to look this far,
  33 ;; and able to figure out how to use it.  It isn't really part of
  34 ;; ps-print, but I'll leave it here in hopes it might be useful:
  35
  36 ;; WARNING!!! The following code is *sample* code only.
  37 ;; Don't use it unless you understand what it does!
  38
  39 ;;; Code:
  40
  41 (require 'ps-print)
  42
  43 \f
  44
  45 ;; A hook to bind to `rmail-mode-hook' to locally bind prsc and set
  46 ;; `ps-left-header' specially for mail messages.
  47 (defun ps-rmail-mode-hook ()
  48   (local-set-key [print] 'ps-rmail-print-message-from-summary)
  49   (setq-local ps-header-lines 3)
  50   ;; The left header will display the message's subject, its
  51   ;; author, and the name of the folder it was in.
  52   (setq-local ps-left-header
  53               '(ps-article-subject ps-article-author buffer-name)))
  54
  55 ;; Like `ps-gnus-print-article-from-summary', but for rmail.
  56 (defun ps-rmail-print-message-from-summary ()
  57   (interactive)
  58   (ps-print-message-from-summary 'rmail-summary-buffer "RMAIL"))
  59
  60 ;; Used in `ps-rmail-print-article-from-summary',
  61 ;; `ps-gnus-print-article-from-summary' and `ps-vm-print-message-from-summary'.
  62 (defun ps-print-message-from-summary (summary-buffer summary-default)
  63   (let ((ps-buf (or (and (boundp summary-buffer)
  64                          (symbol-value summary-buffer))
  65                     summary-default)))
  66     (and (get-buffer ps-buf)
  67          (with-current-buffer ps-buf
  68            (ps-spool-buffer-with-faces)))))
  69
  70 ;; Look in an article or mail message for the Subject: line.
  71 (defun ps-article-subject ()
  72   (save-excursion
  73     (save-restriction
  74       (narrow-to-region (point-min) (progn (rfc822-goto-eoh) (point)))
  75       (concat "Subject: " (or (mail-fetch-field "Subject") "???")))))
  76
  77 ;; Look in an article or mail message for the From: line.  Sorta-kinda
  78 ;; understands RFC 822 (or later) addresses and can pull the real name
  79 ;; out where it's provided.
  80 (defun ps-article-author ()
  81   (save-excursion
  82     (save-restriction
  83       (narrow-to-region (point-min) (progn (rfc822-goto-eoh) (point)))
  84       (let ((fromstring (mail-fetch-field "From")))
  85         (cond
  86          ;; Try first to match addresses that look like
  87          ;; thompson@wg2.waii.com (Jim Thompson)
  88          ((and fromstring (string-match ".*[ \t]+(\\(.*\\))" fromstring))
  89           (match-string 1 fromstring))
  90          ;; Next try to match addresses that look like
  91          ;; Jim Thompson <thompson@wg2.waii.com> or
  92          ;; "Jim Thompson" <thompson@wg2.waii.com>
  93          ((and fromstring
  94                (string-match "\\(\"?\\)\\(.*\\)\\1[ \t]+<.*>" fromstring))
  95           (match-string 2 fromstring))
  96          ;; Couldn't find a real name -- show the address instead.
  97          (fromstring)
  98          (t "From ???"))))))
  99
 100 ;; A hook to bind to `gnus-article-prepare-hook'.  This will set
 101 ;; `ps-left-header' specially for gnus articles.  Unfortunately,
 102 ;; `gnus-article-mode-hook' is called only once, the first time the *Article*
 103 ;; buffer enters that mode, so it would only work for the first time
 104 ;; we ran gnus.  The second time, this hook wouldn't get set up.  The
 105 ;; only alternative is `gnus-article-prepare-hook'.
 106 (defun ps-gnus-article-prepare-hook ()
 107   (setq-local ps-header-lines 3)
 108   ;; The left headers will display the article's subject, its
 109   ;; author, and the newsgroup it was in.
 110   (setq-local ps-left-header
 111               '(ps-article-subject ps-article-author gnus-newsgroup-name)))
 112
 113 ;; A hook to bind to `vm-mode-hook' to locally bind prsc and set
 114 ;; `ps-left-header' specially for mail messages.
 115 (defun ps-vm-mode-hook ()
 116   (local-set-key [print] 'ps-vm-print-message-from-summary)
 117   (setq-local ps-header-lines 3)
 118   ;; The left headers will display the message's subject, its
 119   ;; author, and the name of the folder it was in.
 120   (setq-local ps-left-header
 121         '(ps-article-subject ps-article-author buffer-name)))
 122
 123 ;; Every now and then I forget to switch from the *Summary* buffer to
 124 ;; the *Article* before hitting prsc, and a nicely formatted list of
 125 ;; article subjects shows up at the printer.  This function, bound to
 126 ;; prsc for the gnus *Summary* buffer means I don't have to switch
 127 ;; buffers first.
 128 (defun ps-gnus-print-article-from-summary ()
 129   (interactive)
 130   (ps-print-message-from-summary 'gnus-article-buffer "*Article*"))
 131
 132 ;; Like `ps-gnus-print-article-from-summary', but for vm.
 133 (defun ps-vm-print-message-from-summary ()
 134   (interactive)
 135   (ps-print-message-from-summary 'vm-mail-buffer ""))
 136
 137 ;; A hook to bind to `gnus-summary-setup-buffer' to locally bind prsc.
 138 (defun ps-gnus-summary-setup ()
 139   (local-set-key [print] 'ps-gnus-print-article-from-summary))
 140
 141 (defun ps-info-file ()
 142   (save-excursion
 143     (goto-char (point-min))
 144     (if (re-search-forward "File:[ \t]+\\([^, \t\n]*\\)" nil t)
 145         (match-string 1)
 146       "File ???")))
 147
 148 (defun ps-info-node ()
 149   (save-excursion
 150     (goto-char (point-min))
 151     (if (re-search-forward "Node:[ \t]+\\([^,\t\n]*\\)" nil t)
 152         (match-string 1)
 153       "Node ???")))
 154
 155 (defun ps-info-mode-hook ()
 156   ;; The left headers will display the node name and file name.
 157   (setq-local ps-left-header '(ps-info-node ps-info-file)))
 158
 159 ;; WARNING! The following function is a *sample* only, and is *not* meant
 160 ;; to be used as a whole unless you understand what the effects will be!
 161 (defun ps-samp-ps-setup ()
 162   (global-set-key [print] 'ps-spool-buffer-with-faces)
 163   (global-set-key [S-print] 'ps-spool-region-with-faces)
 164   (global-set-key [C-print] 'ps-despool)
 165   (add-hook 'gnus-article-prepare-hook 'ps-gnus-article-prepare-hook)
 166   (add-hook 'gnus-summary-mode-hook 'ps-gnus-summary-setup)
 167   (add-hook 'vm-mode-hook 'ps-vm-mode-hook)
 168   (add-hook 'vm-mode-hooks 'ps-vm-mode-hook)
 169   (add-hook 'Info-mode-hook 'ps-info-mode-hook)
 170   (setq ps-spool-duplex t
 171         ps-print-color-p nil
 172         ps-lpr-command "lpr"
 173         ps-lpr-switches '("-Jjct,duplex_long")
 174         ps-paper-type        'a4
 175         ps-landscape-mode    t
 176         ps-number-of-columns 2
 177         ps-left-margin   (/ (* 72  1.0) 2.54) ;  1.0 cm
 178         ps-right-margin  (/ (* 72  1.0) 2.54) ;  1.0 cm
 179         ps-inter-column  (/ (* 72  1.0) 2.54) ;  1.0 cm
 180         ps-bottom-margin (/ (* 72  1.5) 2.54) ;  1.5 cm
 181         ps-top-margin    (/ (* 72  1.5) 2.54) ;  1.5 cm
 182         ps-header-offset (/ (* 72  1.0) 2.54) ;  1.0 cm
 183         ps-header-line-pad    .15
 184         ps-print-header       t
 185         ps-print-header-frame t
 186         ps-header-lines       2
 187         ps-show-n-of-n        t
 188         ps-spool-duplex       nil
 189         ps-font-family             'Courier
 190         ps-font-size               5.5
 191         ps-header-font-family      'Helvetica
 192         ps-header-font-size        6
 193         ps-header-title-font-size  8))
 194
 195 \f
 196 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 197
 198 ;; If zeroconf is enabled, all CUPS printers can be detected.  The
 199 ;; "PostScript printer" menu will be modified dynamically, as printers
 200 ;; are added or removed.
 201
 202 ;; Preconditions:
 203 ;;
 204 ;; * Emacs has D-Bus support enabled.  That is, D-Bus is installed on
 205 ;;   the system, and Emacs has been configured and built with the
 206 ;;   --with-dbus option.
 207 ;;
 208 ;; * The zeroconf daemon avahi-daemon is running.
 209 ;;
 210 ;; * CUPS has enabled the option "Share published printers connected
 211 ;;   to this system" (see <http://localhost:631/admin>).
 212
 213
 214 (require 'printing)
 215 (require 'zeroconf)
 216
 217 ;; Add a PostScript printer to the "PostScript printer" menu.
 218 (defun ps-add-printer (service)
 219   (let ((name (zeroconf-service-name service))
 220         (text (zeroconf-service-txt service))
 221         (addr (zeroconf-service-address service))
 222         (port (zeroconf-service-port service))
 223         is-ps cups-queue)
 224     ;; `text' is an array of key=value strings like ("Duplex=T" "Copies=T").
 225     (dolist (string text)
 226       (let ((split (split-string string "=" t)))
 227         ;; If it is a PostScript printer, there must be a string like
 228         ;; "pdl=application/postscript,application/vnd.hp-PCL,...".
 229         (when (and (string-equal "pdl" (car split))
 230                    (string-match "application/postscript" (cadr split)))
 231           (setq is-ps t))
 232         ;; A CUPS printer queue is coded as "rp=printers/<name>".
 233         (when (and (string-equal "rp" (car split))
 234                    (string-match "printers/\\(.+\\)" (cadr split)))
 235           (setq cups-queue (match-string 1 (cadr split))))))
 236     ;; Add the printer.
 237     (when is-ps
 238       (if cups-queue
 239           (add-to-list
 240            'pr-ps-printer-alist (list (intern name) "lpr" nil "-P" cups-queue))
 241         ;; No CUPS printer, but a network printer.
 242         (add-to-list
 243          'pr-ps-printer-alist (list (intern name) "cupsdoprint"
 244                                     '("-P" "default")
 245                                     "-H" (format "%s:%s" addr port))))
 246       (pr-update-menus t))))
 247
 248 ;; Remove a printer from the "PostScript printer" menu.
 249 (defun ps-remove-printer (service)
 250   (setq pr-ps-printer-alist
 251         (delete (assoc (intern (zeroconf-service-name service))
 252                        pr-ps-printer-alist)
 253                 pr-ps-printer-alist))
 254   (pr-update-menus t))
 255
 256 ;; Activate the functions in zeroconf.
 257 (defun ps-make-dynamic-printer-menu ()
 258   (when (featurep 'dbusbind)
 259     (zeroconf-init)
 260     (zeroconf-service-add-hook "_ipp._tcp" :new 'ps-add-printer)
 261     (zeroconf-service-add-hook "_ipp._tcp" :removed 'ps-remove-printer)))
 262
 263 \f
 264 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 265
 266 (provide 'ps-samp)
 267
 268 ;;; ps-samp.el ends here