Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-print.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; w3-print.el,v --- Printing support for emacs-w3
2 ;; Author: wmperry
3 ;; Created: 1996/06/06 15:03:15
4 ;; Version: 1.15
5 ;; Keywords: faces, help, printing, hypermedia
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993, 1994 by William M. Perry (wmperry@spry.com)
9 ;;;
10 ;;; This file is part of GNU Emacs.
11 ;;;
12 ;;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2, or (at your option)
15 ;;; any later version.
16 ;;;
17 ;;; GNU Emacs is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with GNU Emacs; see the file COPYING. If not, write to
24 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 (defvar w3-use-ps-print nil
27 "*If non-nil, then printing will be done via the ps-print package by
28 James C. Thompson <thompson@wg2.waii.com>.")
29
30 (defun w3-face-type (face)
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 (ps-underline-faces (cond
71 ((boundp 'ps-underline-faces)
72 (symbol-value 'ps-underline-faces))
73 ((boundp 'ps-underlined-faces)
74 (symbol-value 'ps-underlined-faces))
75 (t nil)))
76 (ps-underlined-faces nil)
77 (ps-left-header '(ps-get-buffer-name url-view-url))
78 (faces (face-list))
79 (data nil)
80 (face nil))
81 (if (string< ps-print-version "1.6")
82 (while faces
83 (setq face (car faces)
84 data (w3-face-type face)
85 faces (cdr faces))
86 (if (and (memq 'bold data) (not (memq face ps-bold-faces)))
87 (setq ps-bold-faces (cons face ps-bold-faces)))
88 (if (and (memq 'italic data) (not (memq face ps-italic-faces)))
89 (setq ps-italic-faces (cons face ps-italic-faces)))
90 (if (and (memq 'underline data) (not (memq face ps-underline-faces)))
91 (setq ps-underline-faces (cons face ps-underline-faces))))
92 (setq ps-underlined-faces ps-underline-faces))
93 (save-excursion
94 (set-buffer buffer)
95 (funcall function))))
96
97 (defun w3-print-this-url (&optional url format)
98 "Print out the current document (in LaTeX format)"
99 (interactive)
100 (if (not url) (setq url (url-view-url t)))
101 (let* ((completion-ignore-case t)
102 (format (or format
103 (completing-read
104 "Format: "
105 '(("HTML Source") ; The raw HTML code
106 ("Formatted Text") ; Plain ASCII rendition
107 ("PostScript") ; Pretty PostScript
108 ("LaTeX'd") ; LaTeX it, then print
109 )
110 nil t))))
111 (save-excursion
112 (cond
113 ((equal "HTML Source" format)
114 (if w3-current-source
115 (let ((x w3-current-source))
116 (set-buffer (get-buffer-create url-working-buffer))
117 (erase-buffer)
118 (insert x))
119 (url-retrieve url))
120 (lpr-buffer))
121 ((or (equal "Formatted Text" format)
122 (equal "" format))
123 (lpr-buffer))
124 ((equal "PostScript" format)
125 (w3-print-with-ps-print (current-buffer)))
126 ((equal "LaTeX'd" format)
127 (w3-parse-tree-to-latex w3-current-parse url)
128 (save-window-excursion
129 (write-region (point-min) (point-max)
130 (expand-file-name "w3-tmp.latex"
131 w3-temporary-directory) nil 5)
132 (shell-command
133 (format
134 "cd %s ; latex w3-tmp.latex ; %s w3-tmp.dvi ; rm -f w3-tmp*"
135 w3-temporary-directory
136 w3-print-command))
137 (kill-buffer "*Shell Command Output*")))))))
138
139 (defun w3-print-url-under-point ()
140 "Print out the url under point (in LaTeX format)"
141 (interactive)
142 (w3-print-this-url (w3-view-this-url t)))
143
144 (provide 'w3-print)