lisp/ps-samp.el

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