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