lisp/ps-def.el

   1 ;;; ps-def.el --- XEmacs and Emacs definitions for ps-print
   2
   3 ;; Copyright (C) 2007 Free Software Foundation, Inc.
   4
   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 ;; Version: 7.2.2
  11 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
  12
  13 ;; This file is part of GNU Emacs.
  14
  15 ;; GNU Emacs is free software; you can redistribute it and/or modify it under
  16 ;; the terms of the GNU General Public License as published by the Free
  17 ;; Software Foundation; either version 2, or (at your option) any later
  18 ;; version.
  19
  20 ;; GNU Emacs is distributed in the hope that it will be useful, but WITHOUT ANY
  21 ;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  22 ;; FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  23 ;; details.
  24
  25 ;; You should have received a copy of the GNU General Public License along with
  26 ;; GNU Emacs; see the file COPYING.  If not, write to the Free Software
  27 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  28
  29 ;;; Commentary:
  30
  31 ;; See ps-print.el for documentation.
  32
  33 ;;; Code:
  34
  35
  36 \f
  37 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  39 ;; XEmacs Definitions
  40
  41
  42 (cond
  43  ((featurep 'xemacs)                    ; XEmacs
  44
  45
  46   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47   ;; ps-bdf
  48
  49   (defvar installation-directory nil)
  50   (defvar coding-system-for-read)
  51
  52
  53   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  54   ;; ps-mule
  55
  56   (defvar leading-code-private-22 157)
  57
  58   (or (fboundp 'charset-bytes)
  59       (defun charset-bytes (charset) 1)) ; ascii
  60
  61   (or (fboundp 'charset-dimension)
  62       (defun charset-dimension (charset) 1)) ; ascii
  63
  64   (or (fboundp 'charset-id)
  65       (defun charset-id (charset) 0))   ; ascii
  66
  67   (or (fboundp 'charset-width)
  68       (defun charset-width (charset) 1)) ; ascii
  69
  70   (or (fboundp 'find-charset-region)
  71       (defun find-charset-region (beg end &optional table)
  72         (list 'ascii)))
  73
  74   (or (fboundp 'char-width)
  75       (defun char-width (char) 1))      ; ascii
  76
  77   (or (fboundp 'chars-in-region)
  78       (defun chars-in-region (beg end)
  79         (- (max beg end) (min beg end))))
  80
  81   (or (fboundp 'forward-point)
  82       (defun forward-point (arg)
  83         (save-excursion
  84           (let ((count (abs arg))
  85                 (step  (if (zerop arg)
  86                            0
  87                          (/ arg arg))))
  88             (while (and (> count 0)
  89                         (< (point-min) (point)) (< (point) (point-max)))
  90               (forward-char step)
  91               (setq count (1- count)))
  92             (+ (point) (* count step))))))
  93
  94   (or (fboundp 'decompose-composite-char)
  95       (defun decompose-composite-char (char &optional type
  96                                             with-composition-rule)
  97         nil))
  98
  99   (or (fboundp 'encode-coding-string)
 100       (defun encode-coding-string (string coding-system &optional nocopy)
 101         (if nocopy
 102             string
 103           (copy-sequence string))))
 104
 105   (or (fboundp 'coding-system-p)
 106       (defun coding-system-p (obj) nil))
 107
 108   (or (fboundp 'ccl-execute-on-string)
 109       (defun ccl-execute-on-string (ccl-prog status str
 110                                              &optional contin unibyte-p)
 111         str))
 112
 113   (or (fboundp 'define-ccl-program)
 114       (defmacro define-ccl-program (name ccl-program &optional doc)
 115         `(defconst ,name nil ,doc)))
 116
 117   (or (fboundp 'multibyte-string-p)
 118       (defun multibyte-string-p (str)
 119         (let ((len (length str))
 120               (i 0)
 121               multibyte)
 122           (while (and (< i len) (not (setq multibyte (> (aref str i) 255))))
 123             (setq i (1+ i)))
 124           multibyte)))
 125
 126   (or (fboundp 'string-make-multibyte)
 127       (defalias 'string-make-multibyte 'copy-sequence))
 128
 129   (or (fboundp 'encode-char)
 130       (defun encode-char (ch ccs)
 131         ch))
 132
 133
 134   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 135   ;; ps-print
 136
 137   ;; GNU Emacs
 138   (or (fboundp 'line-beginning-position)
 139       (defun line-beginning-position (&optional n)
 140         (save-excursion
 141           (and n (/= n 1) (forward-line (1- n)))
 142           (beginning-of-line)
 143           (point))))
 144
 145
 146   ;; GNU Emacs
 147   (or (fboundp 'find-composition)
 148       (defalias 'find-composition 'ignore))
 149
 150
 151   (defun ps-xemacs-color-name (color)
 152     (if (color-specifier-p color)
 153         (color-name color)
 154       color))
 155
 156
 157   (defalias 'ps-mark-active-p 'region-active-p)
 158
 159
 160   (defun ps-face-foreground-name (face)
 161     (ps-xemacs-color-name (face-foreground face)))
 162
 163
 164   (defun ps-face-background-name (face)
 165     (ps-xemacs-color-name (face-background face)))
 166
 167
 168   (defalias 'ps-frame-parameter 'frame-property)
 169
 170
 171   ;; Return t if the device (which can be changed during an emacs session)
 172   ;; can handle colors.
 173   ;; XEmacs change: Need to check for emacs-major-version too.
 174   (if (or (> emacs-major-version 19)
 175           (and (= emacs-major-version 19)
 176                (>= emacs-minor-version 12)))
 177       ;; xemacs >= 19.12
 178       (defun ps-color-device ()
 179         (eq (device-class) 'color))
 180     ;; xemacs < 19.12
 181     (setq ps-print-color-p nil)
 182     (defalias 'ps-color-device 'ignore))
 183
 184
 185   (defun ps-mapper (extent list)
 186     (nconc list
 187            (list (list (extent-start-position extent) 'push extent)
 188                  (list (extent-end-position extent) 'pull extent)))
 189     nil)
 190
 191
 192   (defun ps-extent-sorter (a b)
 193     (< (extent-priority a) (extent-priority b)))
 194
 195
 196   (defun ps-xemacs-face-kind-p (face kind kind-regex)
 197     (let* ((frame-font (or (face-font-instance face)
 198                            (face-font-instance 'default)))
 199            (kind-cons
 200             (and frame-font
 201                  (assq kind
 202                        (font-instance-properties frame-font))))
 203            (kind-spec (cdr-safe kind-cons))
 204            (case-fold-search t))
 205       (and kind-spec (string-match kind-regex kind-spec))))
 206
 207
 208   ;; to avoid XEmacs compilation gripes
 209   (defvar coding-system-for-write)
 210   (defvar buffer-file-coding-system)
 211
 212
 213   (and (fboundp 'find-coding-system)
 214        (or (funcall 'find-coding-system 'raw-text-unix)
 215            (funcall 'copy-coding-system 'no-conversion-unix 'raw-text-unix)))
 216
 217
 218   (defun ps-color-values (x-color)
 219     (let ((color (ps-xemacs-color-name x-color)))
 220       (cond
 221        ((fboundp 'x-color-values)
 222         (funcall 'x-color-values color))
 223        ((and (fboundp 'color-instance-rgb-components)
 224              (ps-color-device))
 225         (funcall 'color-instance-rgb-components
 226                  (if (color-instance-p x-color)
 227                      x-color
 228                    (make-color-instance color))))
 229        (t
 230         (error "No available function to determine X color values")))))
 231
 232
 233   (defun ps-face-bold-p (face)
 234     (or (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold")
 235         (memq face ps-bold-faces)))     ; Kludge-compatible
 236
 237
 238   (defun ps-face-italic-p (face)
 239     (or (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o")
 240         (ps-xemacs-face-kind-p face 'SLANT "i\\|o")
 241         (memq face ps-italic-faces)))   ; Kludge-compatible
 242
 243
 244   ;; XEmacs will have to make do with %s (princ) for floats.
 245   (defvar ps-color-format "%s %s %s")
 246   (defvar ps-float-format "%s ")
 247
 248
 249   (defun ps-generate-postscript-with-faces1 (from to)
 250     ;; Generate some PostScript.
 251     (let ((face 'default)
 252           (position to)
 253           ;; XEmacs
 254           ;; Build the list of extents...
 255           (a (cons 'dummy nil))
 256           record type extent extent-list)
 257       (map-extents 'ps-mapper nil from to a)
 258       (setq a (sort (cdr a) 'car-less-than-car)
 259             extent-list nil)
 260
 261       ;; Loop through the extents...
 262       (while a
 263         (setq record (car a)
 264               position (car record)
 265
 266               record (cdr record)
 267               type (car record)
 268
 269               record (cdr record)
 270               extent (car record))
 271
 272         ;; Plot up to this record.
 273         ;; XEmacs 19.12: for some reason, we're getting into a
 274         ;; situation in which some of the records have
 275         ;; positions less than 'from'.  Since we've narrowed
 276         ;; the buffer, this'll generate errors.  This is a hack,
 277         ;; but don't call ps-plot-with-face unless from > point-min.
 278         (and (>= from (point-min))
 279              (ps-plot-with-face from (min position (point-max)) face))
 280
 281         (cond
 282          ((eq type 'push)
 283           (and (extent-face extent)
 284                (setq extent-list (sort (cons extent extent-list)
 285                                        'ps-extent-sorter))))
 286
 287          ((eq type 'pull)
 288           (setq extent-list (sort (delq extent extent-list)
 289                                   'ps-extent-sorter))))
 290
 291         (setq face (if extent-list
 292                        (extent-face (car extent-list))
 293                      'default)
 294               from position
 295               a (cdr a)))
 296
 297       (ps-plot-with-face from to face)))
 298
 299   )
 300  (t                                     ; Emacs
 301   ;; Do nothing
 302   ))                                    ; end cond featurep
 303
 304
 305 \f
 306 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 307 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 308 ;; Emacs Definitions
 309
 310
 311 (cond
 312  ((featurep 'xemacs)                    ; XEmacs
 313   ;; Do nothing
 314   )
 315  (t                                     ; Emacs
 316
 317
 318   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 319   ;; ps-print
 320
 321
 322   (defun ps-mark-active-p ()
 323     mark-active)
 324
 325
 326   (defun ps-face-foreground-name (face)
 327     (face-foreground face nil t))
 328
 329
 330   (defun ps-face-background-name (face)
 331     (face-background face nil t))
 332
 333
 334   (defalias 'ps-frame-parameter 'frame-parameter)
 335
 336
 337   ;; Return t if the device (which can be changed during an emacs session) can
 338   ;; handle colors.  This function is not yet implemented for GNU emacs.
 339   (defun ps-color-device ()
 340     (if (fboundp 'color-values)
 341         (funcall 'color-values "Green")
 342       t))
 343
 344
 345   (defun ps-color-values (x-color)
 346     (cond
 347      ((fboundp 'color-values)
 348       (funcall 'color-values x-color))
 349      ((fboundp 'x-color-values)
 350       (funcall 'x-color-values x-color))
 351      (t
 352       (error "No available function to determine X color values"))))
 353
 354
 355   (defun ps-face-bold-p (face)
 356     (or (face-bold-p face)
 357         (memq face ps-bold-faces)))
 358
 359
 360   (defun ps-face-italic-p (face)
 361     (or (face-italic-p face)
 362         (memq face ps-italic-faces)))
 363
 364
 365   ;; Emacs understands the %f format; we'll use it to limit color RGB values
 366   ;; to three decimals to cut down some on the size of the PostScript output.
 367   (defvar ps-color-format "%0.3f %0.3f %0.3f")
 368   (defvar ps-float-format "%0.3f ")
 369
 370
 371   (defun ps-generate-postscript-with-faces1 (from to)
 372     ;; Generate some PostScript.
 373     (let ((face 'default)
 374           (position to)
 375           ;; Emacs
 376           (property-change from)
 377           (overlay-change from)
 378           (save-buffer-invisibility-spec buffer-invisibility-spec)
 379           (buffer-invisibility-spec nil)
 380           before-string after-string)
 381       (while (< from to)
 382         (and (< property-change to)     ; Don't search for property change
 383                                         ; unless previous search succeeded.
 384              (setq property-change (next-property-change from nil to)))
 385         (and (< overlay-change to)      ; Don't search for overlay change
 386                                         ; unless previous search succeeded.
 387              (setq overlay-change (min (next-overlay-change from)
 388                                        to)))
 389         (setq position (min property-change overlay-change)
 390               before-string nil
 391               after-string nil)
 392         ;; The code below is not quite correct,
 393         ;; because a non-nil overlay invisible property
 394         ;; which is inactive according to the current value
 395         ;; of buffer-invisibility-spec nonetheless overrides
 396         ;; a face text property.
 397         (setq face
 398               (cond ((let ((prop (get-text-property from 'invisible)))
 399                        ;; Decide whether this invisible property
 400                        ;; really makes the text invisible.
 401                        (if (eq save-buffer-invisibility-spec t)
 402                            (not (null prop))
 403                          (or (memq prop save-buffer-invisibility-spec)
 404                              (assq prop save-buffer-invisibility-spec))))
 405                      'emacs--invisible--face)
 406                     ((get-text-property from 'face))
 407                     (t 'default)))
 408         (let ((overlays (overlays-at from))
 409               (face-priority -1))       ; text-property
 410           (while (and overlays
 411                       (not (eq face 'emacs--invisible--face)))
 412             (let* ((overlay (car overlays))
 413                    (overlay-invisible
 414                     (overlay-get overlay 'invisible))
 415                    (overlay-priority
 416                     (or (overlay-get overlay 'priority) 0)))
 417               (and (> overlay-priority face-priority)
 418                    (setq before-string
 419                          (or (overlay-get overlay 'before-string)
 420                              before-string)
 421                          after-string
 422                          (or (and (<= (overlay-end overlay) position)
 423                                   (overlay-get overlay 'after-string))
 424                              after-string)
 425                          face-priority overlay-priority
 426                          face
 427                          (cond
 428                           ((if (eq save-buffer-invisibility-spec t)
 429                                (not (null overlay-invisible))
 430                              (or (memq overlay-invisible
 431                                        save-buffer-invisibility-spec)
 432                                  (assq overlay-invisible
 433                                        save-buffer-invisibility-spec)))
 434                            'emacs--invisible--face)
 435                           ((overlay-get overlay 'face))
 436                           (t face)
 437                           ))))
 438             (setq overlays (cdr overlays))))
 439         ;; Plot up to this record.
 440         (and before-string
 441              (ps-plot-string before-string))
 442         (ps-plot-with-face from position face)
 443         (and after-string
 444              (ps-plot-string after-string))
 445         (setq from position))
 446       (ps-plot-with-face from to face)))
 447
 448   ))                                    ; end cond featurep
 449
 450 \f
 451 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 452
 453 (provide 'ps-def)
 454
 455 ;; arch-tag: 4edde45b-af10-4685-b8ee-7cd0f951095a
 456 ;;; ps-def.el ends here