1 ;;; ps-def.el --- XEmacs and Emacs definitions for ps-print -*- lexical-binding: t -*-
3 ;; Copyright (C) 2007-2018 Free Software Foundation, Inc.
5 ;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
6 ;; Kenichi Handa <handa@m17n.org> (multi-byte characters)
7 ;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters)
8 ;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
9 ;; Keywords: wp, print, PostScript
10 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
13 ;; This file is part of GNU Emacs.
15 ;; GNU Emacs is free software: you can redistribute it and/or modify
16 ;; it under the terms of the GNU General Public License as published by
17 ;; the Free Software Foundation, either version 3 of the License, or
18 ;; (at your option) any later version.
20 ;; GNU Emacs is distributed in the hope that it will be useful,
21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 ;; GNU General Public License for more details.
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
30 ;; See ps-print.el for documentation.
34 (declare-function ps-plot-with-face
"ps-print" (from to face
))
35 (declare-function ps-plot-string
"ps-print" (string))
37 (defvar ps-bold-faces
) ; in ps-print.el
38 (defvar ps-italic-faces
)
42 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
43 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
48 ((featurep 'xemacs
) ; XEmacs
50 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
53 (defvar installation-directory nil
)
54 (defvar coding-system-for-read
)
56 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
59 (or (fboundp 'charset-dimension
)
60 (defun charset-dimension (_charset) 1)) ; ascii
62 (or (fboundp 'char-width
)
63 (defun char-width (_char) 1)) ; ascii
65 (or (fboundp 'encode-char
)
66 (defun encode-char (ch _ccs
)
69 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
73 (or (fboundp 'line-beginning-position
)
74 (defun line-beginning-position (&optional n
)
76 (and n
(/= n
1) (forward-line (1- n
)))
82 (or (fboundp 'find-composition
)
83 (defalias 'find-composition
'ignore
))
86 (defun ps-xemacs-color-name (color)
87 (if (color-specifier-p color
)
92 (defalias 'ps-mark-active-p
'region-active-p
)
95 (defun ps-face-foreground-name (face)
96 (ps-xemacs-color-name (face-foreground face
)))
99 (defun ps-face-background-name (face)
100 (ps-xemacs-color-name (face-background face
)))
103 (defalias 'ps-frame-parameter
'frame-property
)
106 ;; Return t if the device (which can be changed during an emacs session)
107 ;; can handle colors.
108 (defun ps-color-device ()
109 (eq (device-class) 'color
))
111 (defun ps-mapper (extent list
)
113 (list (list (extent-start-position extent
) 'push extent
)
114 (list (extent-end-position extent
) 'pull extent
)))
118 (defun ps-extent-sorter (a b
)
119 (< (extent-priority a
) (extent-priority b
)))
122 (defun ps-xemacs-face-kind-p (face kind kind-regex
)
123 (let* ((frame-font (or (face-font-instance face
)
124 (face-font-instance 'default
)))
128 (font-instance-properties frame-font
))))
129 (kind-spec (cdr-safe kind-cons
))
130 (case-fold-search t
))
131 (and kind-spec
(string-match kind-regex kind-spec
))))
134 ;; to avoid XEmacs compilation gripes
135 (defvar coding-system-for-write
)
136 (defvar buffer-file-coding-system
)
139 (and (fboundp 'find-coding-system
)
140 (or (funcall 'find-coding-system
'raw-text-unix
)
141 (funcall 'copy-coding-system
'no-conversion-unix
'raw-text-unix
)))
144 (defun ps-color-values (x-color)
145 (let ((color (ps-xemacs-color-name x-color
)))
147 ((fboundp 'x-color-values
)
148 (funcall 'x-color-values color
))
149 ((and (fboundp 'color-instance-rgb-components
)
151 (funcall 'color-instance-rgb-components
152 (if (color-instance-p x-color
)
154 (make-color-instance color
))))
156 (error "No available function to determine X color values")))))
159 (defun ps-face-bold-p (face)
160 (or (ps-xemacs-face-kind-p face
'WEIGHT_NAME
"bold\\|demibold")
161 (memq face ps-bold-faces
))) ; Kludge-compatible
164 (defun ps-face-italic-p (face)
165 (or (ps-xemacs-face-kind-p face
'ANGLE_NAME
"i\\|o")
166 (ps-xemacs-face-kind-p face
'SLANT
"i\\|o")
167 (memq face ps-italic-faces
))) ; Kludge-compatible
170 (defalias 'ps-face-strikeout-p
'ignore
)
173 (defalias 'ps-face-overline-p
'ignore
)
176 (defalias 'ps-face-box-p
'ignore
)
179 ;; XEmacs will have to make do with %s (princ) for floats.
180 (defvar ps-color-format
"%s %s %s")
181 (defvar ps-float-format
"%s ")
184 (defun ps-generate-postscript-with-faces1 (from to
)
185 ;; Generate some PostScript.
186 (let ((face 'default
)
189 ;; Build the list of extents...
190 (a (cons 'dummy nil
))
191 record type extent extent-list
)
192 (map-extents 'ps-mapper nil from to a
)
193 (setq a
(sort (cdr a
) 'car-less-than-car
)
196 ;; Loop through the extents...
199 position
(car record
)
207 ;; Plot up to this record.
208 ;; XEmacs 19.12: for some reason, we're getting into a
209 ;; situation in which some of the records have
210 ;; positions less than 'from'. Since we've narrowed
211 ;; the buffer, this'll generate errors. This is a hack,
212 ;; but don't call ps-plot-with-face unless from > point-min.
213 (and (>= from
(point-min))
214 (ps-plot-with-face from
(min position
(point-max)) face
))
218 (and (extent-face extent
)
219 (setq extent-list
(sort (cons extent extent-list
)
220 'ps-extent-sorter
))))
223 (setq extent-list
(sort (delq extent extent-list
)
224 'ps-extent-sorter
))))
226 (setq face
(if extent-list
227 (extent-face (car extent-list
))
232 (ps-plot-with-face from to face
)))
237 )) ; end cond featurep
241 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
242 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
247 ((featurep 'xemacs
) ; XEmacs
253 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
257 (defun ps-mark-active-p ()
261 (defun ps-face-foreground-name (face)
262 (face-foreground face nil t
))
265 (defun ps-face-background-name (face)
266 (face-background face nil t
))
269 (defalias 'ps-frame-parameter
'frame-parameter
)
272 ;; Return t if the device (which can be changed during an emacs session) can
273 ;; handle colors. This function is not yet implemented for GNU emacs.
274 (defun ps-color-device ()
275 (if (fboundp 'color-values
)
276 (funcall 'color-values
"Green")
280 (defun ps-color-values (x-color)
282 ((fboundp 'color-values
)
283 (funcall 'color-values x-color
))
284 ((fboundp 'x-color-values
)
285 (funcall 'x-color-values x-color
))
287 (error "No available function to determine X color values"))))
290 (defun ps-face-bold-p (face)
291 (or (face-bold-p face
)
292 (memq face ps-bold-faces
)))
295 (defun ps-face-italic-p (face)
296 (or (face-italic-p face
)
297 (memq face ps-italic-faces
)))
300 (defun ps-face-strikeout-p (face)
301 (eq (face-attribute face
:strike-through
) t
))
304 (defun ps-face-overline-p (face)
305 (eq (face-attribute face
:overline
) t
))
308 (defun ps-face-box-p (face)
309 (not (memq (face-attribute face
:box
) '(nil unspecified
))))
312 ;; Emacs understands the %f format; we'll use it to limit color RGB values
313 ;; to three decimals to cut down some on the size of the PostScript output.
314 (defvar ps-color-format
"%0.3f %0.3f %0.3f")
315 (defvar ps-float-format
"%0.3f ")
318 (defun ps-generate-postscript-with-faces1 (from to
)
319 ;; Generate some PostScript.
320 (let ((face 'default
)
323 (property-change from
)
324 (overlay-change from
)
325 before-string after-string
)
327 (and (< property-change to
) ; Don't search for property change
328 ; unless previous search succeeded.
329 (setq property-change
(next-property-change from nil to
)))
330 (and (< overlay-change to
) ; Don't search for overlay change
331 ; unless previous search succeeded.
332 (setq overlay-change
(min (next-overlay-change from
)
334 (setq position
(min property-change overlay-change
)
338 (cond ((invisible-p from
)
339 'emacs--invisible--face
)
340 ((get-char-property from
'face
))
342 ;; Plot up to this record.
344 (ps-plot-string before-string
))
345 (ps-plot-with-face from position face
)
347 (ps-plot-string after-string
))
348 (setq from position
))
349 (ps-plot-with-face from to face
)))
351 )) ; end cond featurep
354 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
358 ;;; ps-def.el ends here