lisp/ps-samp.el

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