1 ;;; ps-def.el --- XEmacs and Emacs definitions for ps-print
3 ;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
5 ;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
6 ;; Kenichi Handa <handa@m17n.org> (multi-byte characters)
7 ;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters)
8 ;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
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 <http://www.gnu.org/licenses/>.
30 ;; See ps-print.el for documentation.
35 (unless (fboundp 'declare-function
) (defmacro declare-function
(&rest r
))))
37 (declare-function ps-plot-with-face
"ps-print" (from to face
))
38 (declare-function ps-plot-string
"ps-print" (string))
40 (defvar ps-bold-faces
) ; in ps-print.el
41 (defvar ps-italic-faces
)
45 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
46 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51 ((featurep 'xemacs
) ; XEmacs
54 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
57 (defvar installation-directory nil
)
58 (defvar coding-system-for-read
)
61 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
64 (defvar leading-code-private-22
157)
66 (or (fboundp 'charset-bytes
)
67 (defun charset-bytes (charset) 1)) ; ascii
69 (or (fboundp 'charset-dimension
)
70 (defun charset-dimension (charset) 1)) ; ascii
72 (or (fboundp 'charset-id
)
73 (defun charset-id (charset) 0)) ; ascii
75 (or (fboundp 'charset-width
)
76 (defun charset-width (charset) 1)) ; ascii
78 (or (fboundp 'find-charset-region
)
79 (defun find-charset-region (beg end
&optional table
)
82 (or (fboundp 'char-width
)
83 (defun char-width (char) 1)) ; ascii
85 (or (fboundp 'chars-in-region
)
86 (defun chars-in-region (beg end
)
87 (- (max beg end
) (min beg end
))))
89 (or (fboundp 'forward-point
)
90 (defun forward-point (arg)
92 (let ((count (abs arg
))
96 (while (and (> count
0)
97 (< (point-min) (point)) (< (point) (point-max)))
99 (setq count
(1- count
)))
100 (+ (point) (* count step
))))))
102 (or (fboundp 'encode-coding-string
)
103 (defun encode-coding-string (string coding-system
&optional nocopy
)
106 (copy-sequence string
))))
108 (or (fboundp 'coding-system-p
)
109 (defun coding-system-p (obj) nil
))
111 (or (fboundp 'ccl-execute-on-string
)
112 (defun ccl-execute-on-string (ccl-prog status str
113 &optional contin unibyte-p
)
116 (or (fboundp 'define-ccl-program
)
117 (defmacro define-ccl-program
(name ccl-program
&optional doc
)
118 `(defconst ,name nil
,doc
)))
120 (or (fboundp 'multibyte-string-p
)
121 (defun multibyte-string-p (str)
122 (let ((len (length str
))
125 (while (and (< i len
) (not (setq multibyte
(> (aref str i
) 255))))
129 (or (fboundp 'string-make-multibyte
)
130 (defalias 'string-make-multibyte
'copy-sequence
))
132 (or (fboundp 'encode-char
)
133 (defun encode-char (ch ccs
)
137 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
141 (or (fboundp 'line-beginning-position
)
142 (defun line-beginning-position (&optional n
)
144 (and n
(/= n
1) (forward-line (1- n
)))
150 (or (fboundp 'find-composition
)
151 (defalias 'find-composition
'ignore
))
154 (defun ps-xemacs-color-name (color)
155 (if (color-specifier-p color
)
160 (defalias 'ps-mark-active-p
'region-active-p
)
163 (defun ps-face-foreground-name (face)
164 (ps-xemacs-color-name (face-foreground face
)))
167 (defun ps-face-background-name (face)
168 (ps-xemacs-color-name (face-background face
)))
171 (defalias 'ps-frame-parameter
'frame-property
)
174 ;; Return t if the device (which can be changed during an emacs session)
175 ;; can handle colors.
176 (defun ps-color-device ()
177 (eq (device-class) 'color
))
179 (defun ps-mapper (extent list
)
181 (list (list (extent-start-position extent
) 'push extent
)
182 (list (extent-end-position extent
) 'pull extent
)))
186 (defun ps-extent-sorter (a b
)
187 (< (extent-priority a
) (extent-priority b
)))
190 (defun ps-xemacs-face-kind-p (face kind kind-regex
)
191 (let* ((frame-font (or (face-font-instance face
)
192 (face-font-instance 'default
)))
196 (font-instance-properties frame-font
))))
197 (kind-spec (cdr-safe kind-cons
))
198 (case-fold-search t
))
199 (and kind-spec
(string-match kind-regex kind-spec
))))
202 ;; to avoid XEmacs compilation gripes
203 (defvar coding-system-for-write
)
204 (defvar buffer-file-coding-system
)
207 (and (fboundp 'find-coding-system
)
208 (or (funcall 'find-coding-system
'raw-text-unix
)
209 (funcall 'copy-coding-system
'no-conversion-unix
'raw-text-unix
)))
212 (defun ps-color-values (x-color)
213 (let ((color (ps-xemacs-color-name x-color
)))
215 ((fboundp 'x-color-values
)
216 (funcall 'x-color-values color
))
217 ((and (fboundp 'color-instance-rgb-components
)
219 (funcall 'color-instance-rgb-components
220 (if (color-instance-p x-color
)
222 (make-color-instance color
))))
224 (error "No available function to determine X color values")))))
227 (defun ps-face-bold-p (face)
228 (or (ps-xemacs-face-kind-p face
'WEIGHT_NAME
"bold\\|demibold")
229 (memq face ps-bold-faces
))) ; Kludge-compatible
232 (defun ps-face-italic-p (face)
233 (or (ps-xemacs-face-kind-p face
'ANGLE_NAME
"i\\|o")
234 (ps-xemacs-face-kind-p face
'SLANT
"i\\|o")
235 (memq face ps-italic-faces
))) ; Kludge-compatible
238 (defalias 'ps-face-strikeout-p
'ignore
)
241 (defalias 'ps-face-overline-p
'ignore
)
244 (defalias 'ps-face-box-p
'ignore
)
247 ;; XEmacs will have to make do with %s (princ) for floats.
248 (defvar ps-color-format
"%s %s %s")
249 (defvar ps-float-format
"%s ")
252 (defun ps-generate-postscript-with-faces1 (from to
)
253 ;; Generate some PostScript.
254 (let ((face 'default
)
257 ;; Build the list of extents...
258 (a (cons 'dummy nil
))
259 record type extent extent-list
)
260 (map-extents 'ps-mapper nil from to a
)
261 (setq a
(sort (cdr a
) 'car-less-than-car
)
264 ;; Loop through the extents...
267 position
(car record
)
275 ;; Plot up to this record.
276 ;; XEmacs 19.12: for some reason, we're getting into a
277 ;; situation in which some of the records have
278 ;; positions less than 'from'. Since we've narrowed
279 ;; the buffer, this'll generate errors. This is a hack,
280 ;; but don't call ps-plot-with-face unless from > point-min.
281 (and (>= from
(point-min))
282 (ps-plot-with-face from
(min position
(point-max)) face
))
286 (and (extent-face extent
)
287 (setq extent-list
(sort (cons extent extent-list
)
288 'ps-extent-sorter
))))
291 (setq extent-list
(sort (delq extent extent-list
)
292 'ps-extent-sorter
))))
294 (setq face
(if extent-list
295 (extent-face (car extent-list
))
300 (ps-plot-with-face from to face
)))
305 )) ; end cond featurep
309 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
310 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
315 ((featurep 'xemacs
) ; XEmacs
321 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
325 (defun ps-mark-active-p ()
329 (defun ps-face-foreground-name (face)
330 (face-foreground face nil t
))
333 (defun ps-face-background-name (face)
334 (face-background face nil t
))
337 (defalias 'ps-frame-parameter
'frame-parameter
)
340 ;; Return t if the device (which can be changed during an emacs session) can
341 ;; handle colors. This function is not yet implemented for GNU emacs.
342 (defun ps-color-device ()
343 (if (fboundp 'color-values
)
344 (funcall 'color-values
"Green")
348 (defun ps-color-values (x-color)
350 ((fboundp 'color-values
)
351 (funcall 'color-values x-color
))
352 ((fboundp 'x-color-values
)
353 (funcall 'x-color-values x-color
))
355 (error "No available function to determine X color values"))))
358 (defun ps-face-bold-p (face)
359 (or (face-bold-p face
)
360 (memq face ps-bold-faces
)))
363 (defun ps-face-italic-p (face)
364 (or (face-italic-p face
)
365 (memq face ps-italic-faces
)))
368 (defun ps-face-strikeout-p (face)
369 (eq (face-attribute face
:strike-through
) t
))
372 (defun ps-face-overline-p (face)
373 (eq (face-attribute face
:overline
) t
))
376 (defun ps-face-box-p (face)
377 (not (memq (face-attribute face
:box
) '(nil unspecified
))))
380 ;; Emacs understands the %f format; we'll use it to limit color RGB values
381 ;; to three decimals to cut down some on the size of the PostScript output.
382 (defvar ps-color-format
"%0.3f %0.3f %0.3f")
383 (defvar ps-float-format
"%0.3f ")
386 (defun ps-generate-postscript-with-faces1 (from to
)
387 ;; Generate some PostScript.
388 (let ((face 'default
)
391 (property-change from
)
392 (overlay-change from
)
393 (save-buffer-invisibility-spec buffer-invisibility-spec
)
394 (buffer-invisibility-spec nil
)
395 before-string after-string
)
397 (and (< property-change to
) ; Don't search for property change
398 ; unless previous search succeeded.
399 (setq property-change
(next-property-change from nil to
)))
400 (and (< overlay-change to
) ; Don't search for overlay change
401 ; unless previous search succeeded.
402 (setq overlay-change
(min (next-overlay-change from
)
404 (setq position
(min property-change overlay-change
)
407 ;; The code below is not quite correct,
408 ;; because a non-nil overlay invisible property
409 ;; which is inactive according to the current value
410 ;; of buffer-invisibility-spec nonetheless overrides
411 ;; a face text property.
413 (cond ((let ((prop (get-text-property from
'invisible
)))
414 ;; Decide whether this invisible property
415 ;; really makes the text invisible.
416 (if (eq save-buffer-invisibility-spec t
)
418 (or (memq prop save-buffer-invisibility-spec
)
419 (assq prop save-buffer-invisibility-spec
))))
420 'emacs--invisible--face
)
421 ((get-text-property from
'face
))
423 (let ((overlays (overlays-at from
))
424 (face-priority -
1)) ; text-property
426 (not (eq face
'emacs--invisible--face
)))
427 (let* ((overlay (car overlays
))
429 (overlay-get overlay
'invisible
))
431 (or (overlay-get overlay
'priority
) 0)))
432 (and (> overlay-priority face-priority
)
434 (or (overlay-get overlay
'before-string
)
437 (or (and (<= (overlay-end overlay
) position
)
438 (overlay-get overlay
'after-string
))
440 face-priority overlay-priority
443 ((if (eq save-buffer-invisibility-spec t
)
444 (not (null overlay-invisible
))
445 (or (memq overlay-invisible
446 save-buffer-invisibility-spec
)
447 (assq overlay-invisible
448 save-buffer-invisibility-spec
)))
449 'emacs--invisible--face
)
450 ((overlay-get overlay
'face
))
453 (setq overlays
(cdr overlays
))))
454 ;; Plot up to this record.
456 (ps-plot-string before-string
))
457 (ps-plot-with-face from position face
)
459 (ps-plot-string after-string
))
460 (setq from position
))
461 (ps-plot-with-face from to face
)))
463 )) ; end cond featurep
466 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
470 ;; arch-tag: 4edde45b-af10-4685-b8ee-7cd0f951095a
471 ;;; ps-def.el ends here