lisp/ps-print.el

   1 ;; Jim's Pretty-Good PostScript Generator for Emacs 19 (ps-print).
   2 ;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
   3
   4 ;; Author: James C. Thompson <thompson@wg2.waii.com>
   5 ;; Keywords: faces, postscript, printing
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  22
  23 ;; Acknowledgements
  24 ;; ----------------
  25 ;; Thanks to Avishai Yacobi, avishaiy@mcil.comm.mot.com, for writing
  26 ;; the Emacs 19 port.
  27 ;;
  28 ;; Thanks to Remi Houdaille and Michel Train, michel@metasoft.fdn.org,
  29 ;; for adding underline support and title code.  (Titling will appear
  30 ;; in the next release.)
  31 ;;
  32 ;; Thanks to Heiko Muenkel, muenkel@tnt.uni-hannover.de, for showing
  33 ;; me how to handle ISO-8859/1 characters.
  34 ;;
  35 ;; Code to handle ISO-8859/1 characters borrowed from the mp prologue
  36 ;; file mp.pro.ps, used with permission of Rich Burridge of Sun
  37 ;; Microsystems (Rich.Burridge@eng.sun.com).
  38
  39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  40 ;;
  41 ;; About ps-print:
  42 ;; --------------
  43 ;; This package provides printing of Emacs buffers on PostScript
  44 ;; printers; the buffer's bold and italic text attributes are
  45 ;; preserved in the printer output.  Ps-print is intended for use with
  46 ;; Emacs 19 (Lucid or FSF) and a fontifying package such as font-lock
  47 ;; or hilit.
  48 ;;
  49 ;; Installing ps-print:
  50 ;; -------------------
  51 ;; Place ps-print somewhere in your load-path and byte-compile it.
  52 ;; Load ps-print with (require 'ps-print).
  53 ;;
  54 ;; Using ps-print:
  55 ;; --------------
  56 ;; The variables ps-bold-faces and ps-italic-faces *must* contain
  57 ;; lists of the faces that you wish to print in bold or italic font.
  58 ;; These variables already contain some default values, but most users
  59 ;; will probably have to add some of their own.  To add a face to one
  60 ;; of these lists, put code something like the following into your
  61 ;; .emacs startup file:
  62 ;;
  63 ;;   (setq ps-bold-faces (cons 'my-bold-face ps-bold-faces))
  64 ;;
  65 ;; Ps-print's printer interface is governed by the variables ps-lpr-
  66 ;; command and ps-lpr-switches; these are analogous to the variables
  67 ;; lpr-command and lpr-switches in the Emacs lpr package.
  68 ;;
  69 ;; To use ps-print, invoke the command ps-print-buffer-with-faces.
  70 ;; This will generate a PostScript image of the current buffer and
  71 ;; send it to the printer.  Precede this command with a numeric prefix
  72 ;; (C-u), and the PostScript output will be saved in a file; you will
  73 ;; be prompted for a filename.  Also see the functions ps-print-
  74 ;; buffer, ps-print-region, and ps-print-region-with-faces.
  75 ;;
  76 ;; I recommend binding ps-print-buffer-with-faces to a key sequence;
  77 ;; on a Sun 4 keyboard, for example, you can bind to the PrSc key (aka
  78 ;; r22):
  79 ;;
  80 ;;   (global-set-key 'f22 'ps-print-buffer-with-faces)
  81 ;;   (global-set-key '(shift f22) 'ps-print-region-with-faces)
  82 ;;
  83 ;; Or, as I now prefer, you can also bind the ps-spool- functions to
  84 ;; keys; here's my bindings:
  85 ;;
  86 ;;   (global-set-key 'f22 'ps-spool-buffer-with-faces)
  87 ;;   (global-set-key '(shift f22) 'ps-spool-region-with-faces)
  88 ;;   (global-set-key '(control f22) 'ps-despool)
  89 ;;
  90 ;; Using ps-print with other Emacses:
  91 ;; ---------------------------------
  92 ;; Although it was intended for use with Emacs 19, ps-print will also work
  93 ;; with Emacs version 18; you won't get fancy fontified output, but it
  94 ;; should work.
  95 ;;
  96 ;; A few words about support:
  97 ;; -------------------------
  98 ;; Despite its appearance, with comment blocks, usage instructions, and
  99 ;; documentation strings, ps-print is not a supported package.  That's all
 100 ;; a masquerade.  Ps-print is something I threw together in my spare time--
 101 ;; an evening here, a Saturday there--to make my printouts look like my
 102 ;; Emacs buffers.  It works, but is not complete.
 103 ;;
 104 ;; Unfortunately, supporting elisp code is not my job and, now that I have
 105 ;; what I need out of ps-print, additional support is going to be up to
 106 ;; you, the user.  But that's the spirit of Emacs, isn't it?  I call on
 107 ;; all who use this package to help in developing it further. If you
 108 ;; notice a bug, fix it and send me the patches.  If you add a feature,
 109 ;; again, send me the patches.  I will collect all such contributions and
 110 ;; periodically post the updates to the appropriate places.
 111 ;;
 112 ;; A few more words about support:
 113 ;; ------------------------------
 114 ;; The response to my call for public support of ps-print has been
 115 ;; terrific.  With the exception of the spooling mechanism, all the new
 116 ;; features in this version of ps-print were contributed by users.  I have
 117 ;; some contributed code for printing headers that I'll add to the next
 118 ;; release of ps-print, but there are still other features that users can
 119 ;; write.  See the "Features to Add" list a little further on, and keep
 120 ;; that elisp rolling in.
 121 ;;
 122 ;; Please send all bug fixes and enhancements to me, thompson@wg2.waii.com.
 123 ;;
 124 ;; New in version 1.5
 125 ;; ------------------
 126 ;; Support for Emacs 19.  Works with both overlays and text
 127 ;; properties.
 128 ;;
 129 ;; Underlining.
 130 ;;
 131 ;; Local spooling; see function ps-spool-buffer.
 132 ;;
 133 ;; Support for ISO8859-1 character set.
 134 ;;
 135 ;; Page breaks are now handled correctly.
 136 ;;
 137 ;; Percentages reported while formatting are now correct.
 138 ;;
 139 ;; Known bugs and limitations of ps-print:
 140 ;; --------------------------------------
 141 ;; Slow.  (Byte-compiling helps.)
 142 ;;
 143 ;; The PostScript needs review/cleanup/enhancing by a PS expert.
 144 ;;
 145 ;; ASCII Control characters other than tab, linefeed and pagefeed are
 146 ;; not handled.
 147 ;;
 148 ;; The mechanism for determining whether a stretch of characters
 149 ;; should be printed bold, italic, or plain is crude and extremely
 150 ;; limited.
 151 ;;
 152 ;; Faces are always treated as opaque.
 153 ;;
 154 ;; Font names are hardcoded.
 155 ;;
 156 ;; Epoch not fully supported.
 157 ;;
 158 ;; Tested with only one PostScript printer.
 159 ;;
 160 ;; Features to add:
 161 ;; ---------------
 162 ;; Line numbers.
 163 ;;
 164 ;; Simple headers with date, filename, and page numbers.
 165 ;;
 166 ;; Gaudy headers a`la enscript and mp.
 167 ;;
 168 ;; 2-up and 4-up capability.
 169 ;;
 170 ;; Wide-print capability.
 171 ;;
 172
 173 ;;; Code:
 174
 175 (defconst ps-print-version  (substring "$Revision: 1.5 $" 11 -2)
 176   "$Id: ps-print.el,v 1.5 1994/04/22 13:25:18 jct Exp $
 177
 178 Please send all bug fixes and enhancements to Jim Thompson,
 179 thompson@wg2.waii.com.")
 180
 181 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 182 (defvar ps-lpr-command (if (memq system-type
 183                                  '(usg-unix-v hpux silicon-graphics-unix))
 184                            "lp" "lpr")
 185   "The shell command for printing a PostScript file.")
 186
 187 (defvar ps-lpr-switches nil
 188   "A list of extra switches to pass to ps-lpr-command.")
 189
 190 (defvar ps-bold-faces
 191   '(bold
 192     bold-italic
 193     font-lock-function-name-face
 194     message-headers
 195     )
 196   "A list of the faces that should be printed italic.")
 197
 198 (defvar ps-italic-faces
 199   '(italic
 200     bold-italic
 201     font-lock-function-name-face
 202     font-lock-string-face
 203     font-lock-comment-face
 204     message-header-contents
 205     message-highlighted-header-contents
 206     message-cited-text
 207     )
 208   "A list of the faces that should be printed bold.")
 209
 210 (defvar ps-underline-faces
 211   '(underline
 212     font-lock-string-face)
 213   "A list of the faces that should be printed underline.")
 214
 215 (defvar ps-razzle-dazzle t
 216   "Non-nil means report progress while formatting buffer")
 217
 218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 219
 220 (defun ps-print-buffer (&optional filename)
 221
 222 "Generate and print a PostScript image of the buffer.
 223
 224 When called with a numeric prefix argument (C-u), prompt the user for
 225 the name of a file to save the PostScript image in, instead of sending
 226 it to the printer.
 227
 228 More specifically, the FILENAME argument is treated as follows: if it
 229 is nil, send the image to the printer.  If FILENAME is a string, save
 230 the PostScript image in a file with that name.  If FILENAME is a
 231 number, prompt the user for the name of the file to save in.
 232
 233 The image is rendered using the PostScript font Courier.
 234
 235 See also: ps-print-buffer-with-faces
 236           ps-spool-buffer
 237           ps-spool-buffer-with-faces"
 238
 239   (interactive "P")
 240   (setq filename (ps-preprint filename))
 241   (ps-generate (current-buffer) (point-min) (point-max)
 242                'ps-generate-postscript)
 243   (ps-do-despool filename))
 244
 245
 246 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 247
 248 (defun ps-print-buffer-with-faces (&optional filename)
 249
 250 "Generate and print a PostScript image of the buffer.
 251
 252 This function works like ps-print-buffer, with the additional benefit
 253 that any bold/italic formatting information present in the buffer
 254 (contained in extents and faces) will be retained in the PostScript
 255 image. In other words, WYSIAWYG -- What You See Is (Almost) What You
 256 Get.
 257
 258 Ps-print uses three lists to determine which faces should be printed
 259 bold, italic, and/or underlined; the lists are named ps-bold-faces, ps-
 260 italic-faces, and ps-underline-faces.  A given face should appear on as
 261 many lists as are appropriate; for example, face bold-italic is in both
 262 the lists ps-bold-faces and ps-italic-faces.  The lists are pre-built
 263 with the standard bold, italic, and bold-italic faces, with font-lock's
 264 faces, and with the faces used by gnus and rmail.
 265
 266 The image is rendered using the PostScript fonts Courier, Courier-Bold,
 267 Courier-Oblique, and Courier-BoldOblique.
 268
 269 See also: ps-print-buffer
 270           ps-spool-buffer
 271           ps-spool-buffer-with-faces."
 272
 273   (interactive "P")
 274   (setq filename (ps-preprint filename))
 275   (ps-generate (current-buffer) (point-min) (point-max)
 276                'ps-generate-postscript-with-faces)
 277   (ps-do-despool filename))
 278
 279 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 280
 281 (defun ps-print-region (from to &optional filename)
 282
 283 "Generate and print a PostScript image of the region.
 284
 285 When called with a numeric prefix argument (C-u), prompt the user for
 286 the name of a file to save the PostScript image in, instead of sending
 287 it to the printer.
 288
 289 This function is essentially the same as ps-print-buffer except that it
 290 prints just a region, and not the entire buffer.  For more information,
 291 see the function ps-print-buffer.
 292
 293 See also: ps-print-region-with-faces
 294           ps-spool-region
 295           ps-spool-region-with-faces"
 296
 297   (interactive "r\nP")
 298   (setq filename (ps-preprint filename))
 299   (ps-generate (current-buffer) from to
 300                'ps-generate-postscript)
 301   (ps-do-despool filename))
 302
 303 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 304
 305 (defun ps-print-region-with-faces (from to &optional filename)
 306
 307 "Generate and print a PostScript image of the region.
 308
 309 This function is essentially the same as ps-print-buffer except that it
 310 prints just a region, and not the entire buffer.  See the functions
 311 ps-print-region and ps-print-buffer-with-faces for
 312 more information.
 313
 314 See also: ps-print-region
 315           ps-spool-region
 316           ps-spool-region-with-faces"
 317
 318   (interactive "r\nP")
 319   (setq filename (ps-preprint filename))
 320   (ps-generate (current-buffer) from to
 321                'ps-generate-postscript-with-faces)
 322   (ps-do-despool filename))
 323
 324 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 325
 326 (defun ps-spool-buffer ()
 327
 328 "Generate and spool a PostScript image of the buffer.
 329
 330 This function is essentially the same as function ps-print-buffer
 331 except that the PostScript image is saved in a local buffer to be sent
 332 to the printer later.
 333
 334 Each time you call one of the ps-spool- functions, the generated
 335 PostScript is appended to a buffer named *PostScript*; to send the
 336 spooled PostScript to the printer, or save it to a file, use the command
 337 ps-despool.
 338
 339 If the variable ps-spool-duplex is non-nil, then the spooled PostScript
 340 is padded with blank pages, when needed, so that each printed buffer
 341 will start on a front page when printed on a duplex printer (a printer
 342 that prints on both sides on the paper).  Users of non-duplex printers
 343 will want to leave ps-spool-duplex nil.
 344
 345 The spooling mechanism was designed for printing lots of small files
 346 (mail messages or netnews articles) to save paper that would otherwise
 347 be wasted on banner pages, and to make it easier to find your output at
 348 the printer (it's easier to pick up one 50-page printout than to find 50
 349 single-page printouts).
 350
 351 Ps-print has a hook in the kill-emacs-hook list so that you won't
 352 accidently quit from Emacs while you have unprinted PostScript waiting
 353 in the spool buffer.  If you do attempt to exit with spooled PostScript,
 354 you'll be asked if you want to print it, and if you decline, you'll be
 355 asked to confirm the exit; this is modeled on the confirmation that
 356 Emacs uses for modified buffers.
 357
 358 See also: ps-despool
 359           ps-print-buffer
 360           ps-print-buffer-with-faces
 361           ps-spool-buffer-with-faces"
 362
 363   (interactive)
 364   (ps-generate (current-buffer) (point-min) (point-max)
 365                'ps-generate-postscript))
 366
 367 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 368
 369 (defun ps-spool-buffer-with-faces ()
 370
 371 "Generate and spool PostScript image of the buffer.
 372
 373 This function is essentially the same as function ps-print-buffer-with-
 374 faces except that the PostScript image is saved in a local buffer to be
 375 sent to the printer later.
 376
 377 Use the function ps-despool to send the spooled images to the printer.
 378 See the function ps-spool-buffer for a description of the spooling
 379 mechanism.
 380
 381 See also: ps-despool
 382           ps-spool-buffer
 383           ps-print-buffer
 384           ps-print-buffer-with-faces"
 385
 386   (interactive)
 387   (ps-generate (current-buffer) (point-min) (point-max)
 388                'ps-generate-postscript-with-faces))
 389
 390 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 391
 392 (defun ps-spool-region (from to)
 393
 394 "Generate PostScript image of the region and spool locally.
 395
 396 This function is essentially the same as function ps-print-region except
 397 that the PostScript image is saved in a local buffer to be sent to the
 398 printer later.
 399
 400 Use the function ps-despool to send the spooled images to the printer.
 401 See the function ps-spool-buffer for a description of the spooling
 402 mechanism.
 403
 404 See also: ps-despool
 405           ps-spool-buffer
 406           ps-print-buffer
 407           ps-print-buffer-with-faces"
 408
 409   (interactive "r")
 410   (ps-generate (current-buffer) from to
 411                'ps-generate-postscript))
 412
 413 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 414
 415 (defun ps-spool-region-with-faces (from to)
 416
 417 "Generate PostScript image of the region and spool locally.
 418
 419 This function is essentially the same as function ps-print-region-with-
 420 faces except that the PostScript image is saved in a local buffer to be
 421 sent to the printer later.
 422
 423 Use the function ps-despool to send the spooled images to the printer.
 424 See the function ps-spool-buffer for a description of the spooling
 425 mechanism.
 426
 427 See also: ps-despool
 428           ps-spool-buffer
 429           ps-print-buffer
 430           ps-print-buffer-with-faces"
 431
 432   (interactive "r")
 433   (ps-generate (current-buffer) from to
 434                'ps-generate-postscript-with-faces))
 435
 436 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 437
 438 (defvar ps-spool-duplex nil             ; Not many people have duplex
 439                                         ; printers, so default to nil.
 440   "*Non-nil indicates spooling is for a two-sided printer.
 441 For a duplex printer, the ps-spool functions will insert blank pages
 442 as needed between print jobs so that the next buffer printed will
 443 start on the right page.")
 444
 445 (defun ps-despool (&optional filename)
 446   "Send the spooled PostScript to the printer.
 447
 448 When called with a numeric prefix argument (C-u), prompt the user for
 449 the name of a file to save the spooled PostScript in, instead of sending
 450 it to the printer.
 451
 452 More specifically, the FILENAME argument is treated as follows: if it
 453 is nil, send the image to the printer.  If FILENAME is a string, save
 454 the PostScript image in a file with that name.  If FILENAME is a
 455 number, prompt the user for the name of the file to save in."
 456
 457   (interactive "P")
 458
 459 ;; If argument FILENAME is nil, send the image to the printer; if
 460 ;; FILENAME is a string, save the PostScript image in that filename;
 461 ;; if FILENAME is a number, prompt the user for the name of the file
 462 ;; to save in.
 463
 464   (setq filename (ps-preprint filename))
 465   (ps-do-despool filename))
 466
 467 ;; Here end the definitions that users need to know about; proceed
 468 ;; further at your own risk!
 469 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 470
 471 (defun ps-kill-emacs-check ()
 472   (if (and (setq ps-buffer (get-buffer ps-spool-buffer-name))
 473            (buffer-modified-p ps-buffer))
 474       (if (y-or-n-p "Unprinted PostScript waiting... print now? ")
 475           (ps-despool)))
 476
 477   (if (and (setq ps-buffer (get-buffer ps-spool-buffer-name))
 478            (buffer-modified-p ps-buffer))
 479       (if (yes-or-no-p "Unprinted PostScript waiting; exit anyway? ")
 480           nil
 481         (error "Unprinted PostScript"))))
 482
 483 (if (fboundp 'add-hook)
 484     (add-hook 'kill-emacs-hook 'ps-kill-emacs-check)
 485   (if kill-emacs-hook
 486       (message "Won't override existing kill-emacs-hook.")
 487     (setq kill-emacs-hook 'ps-kill-emacs-check)))
 488
 489 (defun ps-preprint (&optional filename)
 490   (if (and filename
 491            (or (numberp filename)
 492                (listp filename)))
 493       (setq filename
 494             (let* ((name (concat (buffer-name) ".ps"))
 495                    (prompt (format "Save PostScript to file: (default %s) "
 496                                    name)))
 497               (read-file-name prompt default-directory
 498                               name nil)))))
 499
 500 (defvar ps-spool-buffer-name "*PostScript*")
 501
 502 (defvar ps-col 0)
 503 (defvar ps-row 0)
 504 (defvar ps-xpos 0)
 505 (defvar ps-ypos 0)
 506
 507 (defvar ps-chars-per-line 80)
 508 (defvar ps-lines-per-page 66)
 509
 510 (defvar ps-page-start-ypos 745)
 511 (defvar ps-line-start-xpos 40)
 512
 513 (defvar ps-char-xpos-inc 6)
 514 (defvar ps-line-ypos-inc 11)
 515
 516 (defvar ps-current-font 0)
 517
 518 (defvar ps-multiple nil)
 519 (defvar ps-virtual-page-number 0)
 520
 521 (defun ps-begin-file ()
 522   (save-excursion
 523     (set-buffer ps-output-buffer)
 524     (goto-char (point-min))
 525     (setq ps-real-page-number 1)
 526     (insert
 527 "%!PS-Adobe-1.0
 528
 529 /S /show load def
 530 /M /moveto load def
 531 /L { gsave newpath 3 1 roll 1 sub M 0 rlineto closepath stroke grestore } def
 532
 533 /F{$fd exch get setfont}def
 534
 535 /StartPage{/svpg save def}def
 536 /EndPage{svpg restore showpage}def
 537
 538 /SetUpFonts
 539  {dup/$fd exch array def{findfont exch scalefont $fd 3 1 roll put}repeat}def
 540
 541 % Define /ISOLatin1Encoding only if it's not already there.
 542 /ISOLatin1Encoding where { pop save true }{ false } ifelse
 543 /ISOLatin1Encoding [ StandardEncoding 0 45 getinterval aload pop /minus
 544   StandardEncoding 46 98 getinterval aload pop /dotlessi /grave /acute
 545   /circumflex /tilde /macron /breve /dotaccent /dieresis /.notdef /ring
 546   /cedilla /.notdef /hungarumlaut /ogonek /caron /space /exclamdown /cent
 547   /sterling /currency /yen /brokenbar /section /dieresis /copyright
 548   /ordfeminine /guillemotleft /logicalnot /hyphen /registered /macron
 549   /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph
 550   /periodcentered /cedilla /onesuperior /ordmasculine /guillemotright
 551   /onequarter /onehalf /threequarters /questiondown /Agrave /Aacute
 552   /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla /Egrave /Eacute
 553   /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex /Idieresis /Eth
 554   /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply
 555   /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn
 556   /germandbls /agrave /aacute /acircumflex /atilde /adieresis /aring /ae
 557   /ccedilla /egrave /eacute /ecircumflex /edieresis /igrave /iacute
 558   /icircumflex /idieresis /eth /ntilde /ograve /oacute /ocircumflex
 559   /otilde /odieresis /divide /oslash /ugrave /uacute /ucircumflex
 560   /udieresis /yacute /thorn /ydieresis ] def
 561 { restore } if
 562
 563 /reencodeISO { %def
 564   findfont dup length dict begin
 565     { 1 index /FID ne { def }{ pop pop } ifelse } forall
 566     /Encoding ISOLatin1Encoding def
 567     currentdict end definefont pop
 568 } bind def
 569
 570 /CourierISO /Courier                         reencodeISO
 571 /Courier-ObliqueISO /Courier-Oblique         reencodeISO
 572 /Courier-BoldISO /Courier-Bold               reencodeISO
 573 /Courier-BoldObliqueISO /Courier-BoldOblique reencodeISO
 574
 575 3 10 /Courier-BoldObliqueISO
 576 2 10 /Courier-ObliqueISO
 577 1 10 /Courier-BoldISO
 578 0 10 /CourierISO
 579 4 SetUpFonts
 580
 581 .4 setlinewidth
 582 ")))
 583
 584 (defun ps-end-file ()
 585   )
 586
 587 (defun ps-next-page ()
 588   (ps-end-page)
 589   (ps-begin-page)
 590   (ps-set-font ps-current-font)
 591   (ps-init-page))
 592
 593 (defun ps-top-of-page () (ps-next-page))
 594
 595 (defun ps-init-page ()
 596   (setq ps-row 0)
 597   (setq ps-col 0)
 598   (setq ps-ypos ps-page-start-ypos)
 599   (setq ps-xpos ps-line-start-xpos)
 600   (ps-set-font))
 601
 602 (defun ps-begin-page ()
 603   (save-excursion
 604     (set-buffer ps-output-buffer)
 605     (goto-char (point-max))
 606     (insert (format "%%%%Page: ? %d\n" ps-real-page-number))
 607     (setq ps-real-page-number (+ 1 ps-real-page-number))
 608     (insert "StartPage\n0.4 setlinewidth\n")))
 609
 610 (defun ps-end-page ()
 611   (save-excursion
 612     (set-buffer ps-output-buffer)
 613     (goto-char (point-max))
 614     (insert "EndPage\n")))
 615
 616 (defun ps-next-line ()
 617   (setq ps-row (+ ps-row 1))
 618   (if (>= ps-row ps-lines-per-page)
 619       (ps-next-page)
 620     (setq ps-col 0)
 621     (setq ps-xpos ps-line-start-xpos)
 622     (setq ps-ypos (- ps-ypos ps-line-ypos-inc))))
 623
 624 (defun ps-continue-line ()
 625   (ps-next-line))
 626
 627 (defvar ps-source-buffer nil)
 628 (defvar ps-output-buffer nil)
 629
 630 (defun ps-basic-plot-string (from to &optional underline-p)
 631   (setq text (buffer-substring from to))
 632   (save-excursion
 633     (set-buffer ps-output-buffer)
 634     (goto-char (point-max))
 635     (setq count (- to from))
 636
 637     (if underline-p
 638         (insert (format "%d %d %d L\n" ps-xpos ps-ypos
 639                         (* count ps-char-xpos-inc))))
 640
 641     (insert (format "%d %d M (" ps-xpos ps-ypos))
 642     (save-excursion
 643       (insert text))
 644
 645     (while (re-search-forward "[()\\]" nil t)
 646       (save-excursion
 647         (forward-char -1)
 648         (insert "\\")))
 649
 650     (end-of-line)
 651     (insert ") S\n")
 652
 653     (setq ps-xpos (+ ps-xpos (* count ps-char-xpos-inc)))))
 654
 655 (defun ps-basic-plot-whitespace (from to underline-p)
 656   (setq count (- to from))
 657   (setq ps-xpos (+ ps-xpos (* count ps-char-xpos-inc))))
 658
 659 (defun ps-plot (plotfunc from to &optional underline-p)
 660
 661   (while (< from to)
 662     (setq count (- to from))
 663     ;; Test to see whether this region will fit on the current line
 664     (if (<= (+ ps-col count) ps-chars-per-line)
 665         (progn
 666           ;; It fits; plot it.
 667           (funcall plotfunc from to underline-p)
 668           (setq from to))
 669
 670       ;; It needs to be wrapped;  plot part of it, then loop
 671       (setq chars-that-will-fit (- ps-chars-per-line ps-col))
 672       (funcall plotfunc from (+ from chars-that-will-fit))
 673
 674       (ps-continue-line)
 675
 676       (setq from (+ from chars-that-will-fit))))
 677
 678   (if ps-razzle-dazzle
 679       (let* ((q-todo (- (point-max) (point-min)))
 680              (q-done (- to (point-min)))
 681              (chunkfrac (/ q-todo 8))
 682              (chunksize (if (> chunkfrac 10000) 10000 chunkfrac)))
 683         (if (> (- q-done ps-razchunk) chunksize)
 684             (progn
 685               (setq ps-razchunk q-done)
 686               (setq foo
 687                     (if (< q-todo 100)
 688                         (* (/ q-done q-todo) 100)
 689                       (setq basis (/ q-todo 100))
 690                       (/ q-done basis)))
 691
 692               (message "Formatting... %d%%" foo))))))
 693
 694 (defun ps-set-font (&optional font)
 695   (save-excursion
 696     (set-buffer ps-output-buffer)
 697     (goto-char (point-max))
 698     (insert (format "%d F\n" (if font font ps-current-font))))
 699   (if font
 700       (setq ps-current-font font)))
 701
 702 (defun ps-plot-region (from to font &optional underline-p)
 703
 704   (ps-set-font font)
 705
 706   (save-excursion
 707     (goto-char from)
 708     (while (< from to)
 709       (if (re-search-forward "[\t\n\014]" to t)
 710           (let ((match (char-after (match-beginning 0))))
 711             (cond
 712              ((= match ?\n)
 713               (ps-plot 'ps-basic-plot-string from (- (point) 1) underline-p)
 714               (ps-next-line))
 715
 716              ((= match ?\t)
 717               (ps-plot 'ps-basic-plot-string from (- (point) 1) underline-p)
 718               (setq linestart (save-excursion (beginning-of-line) (point)))
 719               (forward-char -1)
 720               (setq from (+ linestart (current-column)))
 721               (if (re-search-forward "[ \t]+" to t)
 722                   (ps-plot 'ps-basic-plot-whitespace from
 723                            (+ linestart (current-column)))))
 724
 725              ((= match ?\014)
 726               (ps-plot 'ps-basic-plot-string from (- (point) 1) underline-p)
 727               (ps-top-of-page)))
 728             (setq from (point)))
 729
 730         (ps-plot 'ps-basic-plot-string from to underline-p)
 731         (setq from to)))))
 732
 733 (defun ps-format-buffer ()
 734   (interactive)
 735
 736   (setq ps-source-buffer (current-buffer))
 737   (setq ps-output-buffer (get-buffer-create "%PostScript%"))
 738
 739   (save-excursion
 740     (set-buffer ps-output-buffer)
 741     (delete-region (point-max) (point-min)))
 742
 743   (ps-begin-file)
 744   (ps-begin-page)
 745   (ps-init-page)
 746
 747   (ps-plot-region (point-min) (point-max) 0)
 748
 749   (ps-end-page)
 750   (ps-end-file)
 751   )
 752
 753 (defun ps-mapper (extent list)
 754   (nconc list (list (list (extent-start-position extent) 'push extent)
 755                     (list (extent-end-position extent) 'pull extent)))
 756   nil)
 757
 758 (defun ps-sorter (a b)
 759   (< (car a) (car b)))
 760
 761 (defun ps-extent-sorter (a b)
 762   (< (extent-priority a) (extent-priority b)))
 763
 764 (defun overlay-priority (p)
 765   (if (setq priority (overlay-get p 'priority)) priority 0))
 766
 767 (defun ps-overlay-sorter (a b)
 768   (> (overlay-priority a) (overlay-priority b)))
 769
 770 (defun ps-plot-with-face (from to face)
 771
 772   (setq bold-p (memq face ps-bold-faces))
 773   (setq italic-p (memq face ps-italic-faces))
 774   (setq underline-p (memq face ps-underline-faces))
 775
 776   (cond
 777    ((and bold-p italic-p)
 778     (ps-plot-region from to 3 underline-p))
 779    (italic-p
 780     (ps-plot-region from to 2 underline-p))
 781    (bold-p
 782     (ps-plot-region from to 1 underline-p))
 783    (t
 784     (ps-plot-region from to 0 underline-p))))
 785
 786
 787 (defun ps-generate-postscript-with-faces (from to)
 788
 789   (save-restriction
 790     (narrow-to-region from to)
 791     (setq face 'default)
 792
 793     (cond ((string-match "Lucid" emacs-version)
 794            ;; Build the list of extents...
 795            (let ((a (cons 'dummy nil)))
 796              (map-extents 'ps-mapper nil from to a)
 797              (setq a (cdr a))
 798              (setq a (sort a 'ps-sorter))
 799
 800              (setq extent-list nil)
 801
 802              ;; Loop through the extents...
 803              (while a
 804                (setq record (car a))
 805
 806                (setq position (car record))
 807                (setq record (cdr record))
 808
 809                (setq type (car record))
 810                (setq record (cdr record))
 811
 812                (setq extent (car record))
 813
 814                ;; Plot up to this record.
 815                (ps-plot-with-face from position face)
 816
 817                (cond
 818                 ((eq type 'push)
 819                  (setq extent-list (sort (cons extent extent-list)
 820                                          'ps-extent-sorter)))
 821
 822                 ((eq type 'pull)
 823                  (setq extent-list (sort (delq extent extent-list)
 824                                          'ps-extent-sorter))))
 825
 826                (setq face
 827                      (if extent-list
 828                          (extent-face (car extent-list))
 829                        'default))
 830
 831                (setq from position)
 832                (setq a (cdr a)))))
 833
 834           ((string-match "^19" emacs-version)
 835
 836            (while (< from to)
 837
 838              (setq prop-position
 839                    (if (setq p (next-property-change from))
 840                        (if (> p to) to p)
 841                      to))
 842
 843              (setq over-position
 844                    (if (setq p (next-overlay-change from))
 845                        (if (> p to) to p)
 846                      to))
 847
 848              (setq position
 849                    (if (< prop-position over-position)
 850                        prop-position
 851                      over-position))
 852
 853              (setq face
 854                    (if (setq f (get-text-property from 'face)) f 'default))
 855
 856              (if (setq overlays (overlays-at from))
 857                  (progn
 858                    (setq overlays (sort overlays 'ps-overlay-sorter))
 859                    (while overlays
 860                      (if (setq face (overlay-get (car overlays) 'face))
 861                          (setq overlays nil)
 862                        (setq overlays (cdr overlays))))))
 863
 864              ;; Plot up to this record.
 865              (ps-plot-with-face from position face)
 866
 867              (setq from position))))
 868
 869     (ps-plot-with-face from to face)))
 870
 871 (defun ps-generate-postscript (from to)
 872   (ps-plot-region from to 0))
 873
 874 (defun ps-generate (buffer from to genfunc)
 875
 876   (save-restriction
 877     (narrow-to-region from to)
 878     (if ps-razzle-dazzle
 879         (message "Formatting... %d%%" (setq ps-razchunk 0)))
 880
 881     (set-buffer buffer)
 882     (setq ps-source-buffer buffer)
 883     (setq ps-output-buffer (get-buffer-create ps-spool-buffer-name))
 884
 885     (unwind-protect
 886         (progn
 887
 888           (set-buffer ps-output-buffer)
 889           (goto-char (point-min))
 890           (if (looking-at (regexp-quote "%!PS-Adobe-1.0"))
 891               (ps-set-font ps-current-font)
 892             (ps-begin-file))
 893           (ps-begin-page)
 894           (ps-init-page)
 895
 896           (goto-char (point-max))
 897           (if (and ps-spool-duplex
 898                    (re-search-backward "^%%Page")
 899                    (looking-at "^%%Page.*[24680]$"))
 900               (ps-next-page))
 901
 902           (set-buffer ps-source-buffer)
 903           (funcall genfunc from to)
 904
 905           (ps-end-page)))
 906
 907     (if ps-razzle-dazzle
 908         (message "Formatting... Done."))))
 909
 910 (defun ps-do-despool (filename)
 911
 912   (if (or (not (boundp 'ps-output-buffer))
 913           (not ps-output-buffer))
 914       (message "No spooled PostScript to print.")
 915
 916     (ps-end-file)
 917
 918     (if filename
 919         (save-excursion
 920           (if ps-razzle-dazzle
 921               (message "Saving..."))
 922
 923           (set-buffer ps-output-buffer)
 924           (setq filename (expand-file-name filename))
 925           (write-region (point-min) (point-max) filename)
 926
 927           (if ps-razzle-dazzle
 928               (message "Wrote %s" filename)))
 929
 930       ;; Else, spool to the printer
 931       (if ps-razzle-dazzle
 932           (message "Printing..."))
 933
 934       (save-excursion
 935         (set-buffer ps-output-buffer)
 936         (apply 'call-process-region
 937                (point-min) (point-max) ps-lpr-command nil 0 nil
 938                ps-lpr-switches))
 939
 940       (if ps-razzle-dazzle
 941           (message "Printing... Done.")))
 942
 943     (kill-buffer ps-output-buffer)))
 944
 945 (defun ps-testpattern ()
 946   (setq foo 1)
 947   (while (< foo 60)
 948     (insert "|" (make-string foo ?\ ) (format "%d\n" foo))
 949     (setq foo (+ 1 foo))))
 950
 951 (defun pts (stuff)
 952   (save-excursion
 953     (set-buffer "*scratch*")
 954     (goto-char (point-max))
 955     (insert "---------------------------------\n"
 956             (symbol-name stuff) ":\n"
 957             (prin1-to-string (symbol-value stuff))
 958             "\n")))
 959
 960 (provide 'ps-print)
 961
 962 ;; ps-print.el ends here