Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-print.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 859a2309aef8
children 1ce6082ce73f
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; w3-print.el --- Printing support for emacs-w3 1 ;;; w3-print.el --- Printing support for emacs-w3
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/02/07 01:05:01 3 ;; Created: 1996/07/09 02:54:01
4 ;; Version: 1.7 4 ;; Version: 1.3
5 ;; Keywords: faces, help, printing, hypermedia 5 ;; Keywords: faces, help, printing, hypermedia
6 6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu) 8 ;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
10 ;;; 9 ;;;
11 ;;; This file is part of GNU Emacs. 10 ;;; This file is part of GNU Emacs.
12 ;;; 11 ;;;
13 ;;; GNU Emacs is free software; you can redistribute it and/or modify 12 ;;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;;; it under the terms of the GNU General Public License as published by 13 ;;; it under the terms of the GNU General Public License as published by
19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;;; GNU General Public License for more details. 20 ;;; GNU General Public License for more details.
22 ;;; 21 ;;;
23 ;;; You should have received a copy of the GNU General Public License 22 ;;; You should have received a copy of the GNU General Public License
24 ;;; along with GNU Emacs; see the file COPYING. If not, write to the 23 ;;; along with GNU Emacs; see the file COPYING. If not, write to
25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 24 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
26 ;;; Boston, MA 02111-1307, USA.
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 (defvar w3-postscript-print-function 'ps-print-buffer-with-faces 26 (defvar w3-use-ps-print nil
29 "*Name of the function to use to print a buffer as PostScript. 27 "*If non-nil, then printing will be done via the ps-print package by
30 This should take no arguments, and act on the current buffer. 28 James C. Thompson <thompson@wg2.waii.com>.")
31 Possible values include: 29
32 ps-print-buffer-with-faces - print immediately 30 (defun w3-face-type (face)
33 ps-spool-buffer-with-faces - spool for later") 31 "Return a list specifying what a face looks like. ie: '(bold italic)"
32 (let ((font (or (face-font face) (face-font 'default)))
33 (retval nil))
34 (if (not (stringp font))
35 (setq font
36 (cond
37 ((and (fboundp 'fontp) (not (fontp font))) nil)
38 ((fboundp 'font-truename) (font-truename font))
39 ((fboundp 'font-name) (font-name font))
40 (t nil))))
41 (cond
42 ((not font) nil)
43 ((string-match "^-\\([^-]+\\)-\\([^-]+\\)-\\([^-]+\\)-\\([^-]+\\)-" font)
44 (let ((wght (substring font (match-beginning 3) (match-end 3)))
45 (slnt (substring font (match-beginning 4) (match-end 4))))
46 (if (string-match "bold" wght)
47 (setq retval (cons 'bold retval)))
48 (if (or (string-match "i" slnt) (string-match "o" slnt))
49 (setq retval (cons 'italic retval)))
50 (if (and (fboundp 'face-underline-p)
51 (face-underline-p face))
52 (setq retval (cons 'underline retval)))))
53 ((and (symbolp face) (string-match "bold" (symbol-name face)))
54 (setq retval '(bold)))
55 ((and (symbolp face) (string-match "italic" (symbol-name face)))
56 (setq retval '(italic)))
57 (t nil))
58 retval))
59
60 (defun w3-print-with-ps-print (&optional buffer function)
61 "Print a buffer using `ps-print-buffer-with-faces'.
62 This function wraps `ps-print-buffer-with-faces' so that the w3 faces
63 will be correctly listed in ps-bold-faces and ps-italic-faces"
64 (interactive)
65 (require 'ps-print)
66 (setq buffer (or buffer (current-buffer))
67 function (or function 'ps-print-buffer-with-faces))
68 (let ((ps-bold-faces ps-bold-faces)
69 (ps-italic-faces ps-italic-faces)
70 (inhibit-read-only t)
71 (ps-underline-faces (cond
72 ((boundp 'ps-underline-faces)
73 (symbol-value 'ps-underline-faces))
74 ((boundp 'ps-underlined-faces)
75 (symbol-value 'ps-underlined-faces))
76 (t nil)))
77 (ps-underlined-faces nil)
78 (ps-left-header '(ps-get-buffer-name url-view-url))
79 (faces (face-list))
80 (data nil)
81 (face nil))
82 (if (string< ps-print-version "1.6")
83 (while faces
84 (setq face (car faces)
85 data (w3-face-type face)
86 faces (cdr faces))
87 (if (and (memq 'bold data) (not (memq face ps-bold-faces)))
88 (setq ps-bold-faces (cons face ps-bold-faces)))
89 (if (and (memq 'italic data) (not (memq face ps-italic-faces)))
90 (setq ps-italic-faces (cons face ps-italic-faces)))
91 (if (and (memq 'underline data) (not (memq face ps-underline-faces)))
92 (setq ps-underline-faces (cons face ps-underline-faces))))
93 (setq ps-underlined-faces ps-underline-faces))
94 (save-excursion
95 (set-buffer buffer)
96 (funcall function))))
34 97
35 (defun w3-print-this-url (&optional url format) 98 (defun w3-print-this-url (&optional url format)
36 "Print out the current document (in LaTeX format)" 99 "Print out the current document (in LaTeX format)"
37 (interactive) 100 (interactive)
38 (if (not url) (setq url (url-view-url t))) 101 (if (not url) (setq url (url-view-url t)))
58 (lpr-buffer)) 121 (lpr-buffer))
59 ((or (equal "Formatted Text" format) 122 ((or (equal "Formatted Text" format)
60 (equal "" format)) 123 (equal "" format))
61 (lpr-buffer)) 124 (lpr-buffer))
62 ((equal "PostScript" format) 125 ((equal "PostScript" format)
63 (funcall w3-postscript-print-function)) 126 (w3-print-with-ps-print (current-buffer)))
64 ((equal "LaTeX'd" format) 127 ((equal "LaTeX'd" format)
65 (w3-parse-tree-to-latex w3-current-parse url) 128 (w3-parse-tree-to-latex w3-current-parse url)
66 (save-window-excursion 129 (save-window-excursion
67 (write-region (point-min) (point-max) 130 (write-region (point-min) (point-max)
68 (expand-file-name "w3-tmp.latex" 131 (expand-file-name "w3-tmp.latex"