lisp/ps-samp.el

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