xemacs/ps-print-invisible.el

   1 ;;; ps-print-invisible.el - addon to ps-print package that deals
   2 ;;  with invisible text printing in xemacs
   3
   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.
  10
  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.
  15
  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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21 ;;
  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).
  29
  30 (defun ps-generate-postscript-with-faces (from to)
  31   ;; Some initialization...
  32   (setq ps-current-effect 0)
  33
  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))
  39
  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))
  45
  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)
  62
  63           ;; Loop through the extents...
  64           (while a
  65             (setq record (car a)
  66                   position (car record)
  67
  68                   record (cdr record)
  69                   type (car record)
  70
  71                   record (cdr record)
  72                   extent (car record))
  73
  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))
  82
  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))))
  89
  90              ((eq type 'pull)
  91               (setq extent-list (sort (delq extent extent-list)
  92                                       'ps-extent-sorter))))
  93
  94
  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)))))
 107
 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))))
 180
 181
 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)))
 198
 199
 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)
 220
 221
 222 (provide 'ps-print-invisible)
 223
 224
 225 ;;; ps-print-invisible.el ends here