Prevent point movement when switching between org and code buffers.
[rgr-org-mode.git] / xemacs / ps-print-invisible.el
blob8f005fe86dd9538e5058db67bf37f0472ce80863
1 ;;; ps-print-invisible.el - addon to ps-print package that deals
2 ;; with invisible text printing in xemacs
4 ;; Author: Greg Chernov
5 ;;
6 ;; GNU Emacs is free software; you can redistribute it and/or modify
7 ;; it under the terms of the GNU General Public License as published by
8 ;; the Free Software Foundation; either version 2, or (at your option)
9 ;; any later version.
11 ;; GNU Emacs is distributed in the hope that it will be useful,
12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;; GNU General Public License for more details.
16 ;; You should have received a copy of the GNU General Public License
17 ;; along with GNU Emacs; see the file COPYING. If not, write to the
18 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
19 ;; Boston, MA 02110-1301, USA.
20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
22 ;;; Commentary:
23 ;;
24 ;; Put ps-print-invisible.el on your load path.
25 ;; (require 'ps-print-invisible)
26 ;; ps-print-buffer-with-faces will not print invisible parts of the buffer.
27 ;; Work with invisible extents/text properties only
28 ;; (xemacs hideshow and noutline packages).
30 (defun ps-generate-postscript-with-faces (from to)
31 ;; Some initialization...
32 (setq ps-current-effect 0)
34 ;; Build the reference lists of faces if necessary.
35 (when (or ps-always-build-face-reference
36 ps-build-face-reference)
37 (message "Collecting face information...")
38 (ps-build-reference-face-lists))
40 ;; Black/white printer.
41 (setq ps-black-white-faces-alist nil)
42 (and (eq ps-print-color-p 'black-white)
43 (ps-extend-face-list ps-black-white-faces nil
44 'ps-black-white-faces-alist))
46 ;; Generate some PostScript.
47 (save-restriction
48 (narrow-to-region from to)
49 (ps-print-ensure-fontified from to)
50 (let ((face 'default)
51 (position to))
52 (cond
53 ((memq ps-print-emacs-type '(xemacs lucid))
54 ;; Build the list of extents...
55 ;;(debug)
56 (let ((a (cons 'dummy nil))
57 record type extent extent-list
58 (list-invisible (ps-print-find-invisible-xmas from to)))
59 (ps-x-map-extents 'ps-mapper nil from to a)
60 (setq a (sort (cdr a) 'car-less-than-car)
61 extent-list nil)
63 ;; Loop through the extents...
64 (while a
65 (setq record (car a)
66 position (car record)
68 record (cdr record)
69 type (car record)
71 record (cdr record)
72 extent (car record))
74 ;; Plot up to this record.
75 ;; XEmacs 19.12: for some reason, we're getting into a
76 ;; situation in which some of the records have
77 ;; positions less than 'from'. Since we've narrowed
78 ;; the buffer, this'll generate errors. This is a hack,
79 ;; but don't call ps-plot-with-face unless from > point-min.
80 (and (>= from (point-min))
81 (ps-plot-with-face from (min position (point-max)) face))
83 (cond
84 ((eq type 'push)
85 (and (or (ps-x-extent-face extent)
86 (extent-property extent 'invisible))
87 (setq extent-list (sort (cons extent extent-list)
88 'ps-extent-sorter))))
90 ((eq type 'pull)
91 (setq extent-list (sort (delq extent extent-list)
92 'ps-extent-sorter))))
95 (setq face (if extent-list
96 (let ((prop (extent-property (car extent-list) 'invisible)))
97 (if (or (and (eq buffer-invisibility-spec t)
98 (not (null prop)))
99 (and (consp buffer-invisibility-spec)
100 (or (memq prop buffer-invisibility-spec)
101 (assq prop buffer-invisibility-spec))))
102 'emacs--invisible--face
103 (ps-x-extent-face (car extent-list))))
104 'default)
105 from position
106 a (cdr a)))))
108 ((eq ps-print-emacs-type 'emacs)
109 (let ((property-change from)
110 (overlay-change from)
111 (save-buffer-invisibility-spec buffer-invisibility-spec)
112 (buffer-invisibility-spec nil)
113 before-string after-string)
114 (while (< from to)
115 (and (< property-change to) ; Don't search for property change
116 ; unless previous search succeeded.
117 (setq property-change (next-property-change from nil to)))
118 (and (< overlay-change to) ; Don't search for overlay change
119 ; unless previous search succeeded.
120 (setq overlay-change (min (ps-e-next-overlay-change from)
121 to)))
122 (setq position (min property-change overlay-change)
123 before-string nil
124 after-string nil)
125 ;; The code below is not quite correct,
126 ;; because a non-nil overlay invisible property
127 ;; which is inactive according to the current value
128 ;; of buffer-invisibility-spec nonetheless overrides
129 ;; a face text property.
130 (setq face
131 (cond ((let ((prop (get-text-property from 'invisible)))
132 ;; Decide whether this invisible property
133 ;; really makes the text invisible.
134 (if (eq save-buffer-invisibility-spec t)
135 (not (null prop))
136 (or (memq prop save-buffer-invisibility-spec)
137 (assq prop save-buffer-invisibility-spec))))
138 'emacs--invisible--face)
139 ((get-text-property from 'face))
140 (t 'default)))
141 (let ((overlays (ps-e-overlays-at from))
142 (face-priority -1)) ; text-property
143 (while (and overlays
144 (not (eq face 'emacs--invisible--face)))
145 (let* ((overlay (car overlays))
146 (overlay-invisible
147 (ps-e-overlay-get overlay 'invisible))
148 (overlay-priority
149 (or (ps-e-overlay-get overlay 'priority) 0)))
150 (and (> overlay-priority face-priority)
151 (setq before-string
152 (or (ps-e-overlay-get overlay 'before-string)
153 before-string)
154 after-string
155 (or (and (<= (ps-e-overlay-end overlay) position)
156 (ps-e-overlay-get overlay 'after-string))
157 after-string)
158 face-priority overlay-priority
159 face
160 (cond
161 ((if (eq save-buffer-invisibility-spec t)
162 (not (null overlay-invisible))
163 (or (memq overlay-invisible
164 save-buffer-invisibility-spec)
165 (assq overlay-invisible
166 save-buffer-invisibility-spec)))
167 'emacs--invisible--face)
168 ((ps-e-overlay-get overlay 'face))
169 (t face)
170 ))))
171 (setq overlays (cdr overlays))))
172 ;; Plot up to this record.
173 (and before-string
174 (ps-plot-string before-string))
175 (ps-plot-with-face from position face)
176 (and after-string
177 (ps-plot-string after-string))
178 (setq from position)))))
179 (ps-plot-with-face from to face))))
182 (defun ps-print-find-invisible-xmas (from to)
183 (let ((list nil))
184 (map-extents '(lambda (ex ignored)
185 (let ((prop (extent-property ex 'invisible)))
186 (if (or (and (eq buffer-invisibility-spec t)
187 (not (null prop)))
188 (or (memq prop buffer-invisibility-spec)
189 (assq prop buffer-invisibility-spec)))
190 (setq list (cons (list
191 (extent-start-position ex)
192 (extent-end-position ex))
193 list))))
194 nil)
195 (current-buffer)
196 from to nil 'start-and-end-in-region 'invisible)
197 (reverse list)))
200 (defun ps-mapper (extent list)
201 ;;(debug)
202 (let ((beg (ps-x-extent-start-position extent))
203 (end (ps-x-extent-end-position extent))
204 (inv-lst list-invisible)
205 (found nil))
206 (while (and inv-lst
207 (not found))
208 (let ((inv-beg (caar inv-lst))
209 (inv-end (cadar inv-lst)))
210 (if (and (>= beg inv-beg)
211 (<= end inv-end)
212 (not (extent-property extent 'invisible)))
213 (setq found t))
214 (setq inv-lst (cdr inv-lst))))
215 (if (not found)
216 (nconc list
217 (list (list beg 'push extent)
218 (list end 'pull extent)))))
219 nil)
222 (provide 'ps-print-invisible)
225 ;;; ps-print-invisible.el ends here