comparison lisp/ps-print.el @ 89531:f035500271d2

(ps-generate-string-list): Function deleted. (ps-rh-cache, ps-lf-cache, ps-rf-cache): Variables deleted. (ps-header-footer-string): Function deleted. (ps-encode-header-string-function): New variable (ps-generate-header-line): Call ps-encode-header-string-function. (ps-basic-plot-string-function): New variable (ps-begin-job): Set ps-basic-plot-string-function and ps-encode-header-string-function. For setting up headers and footers, don't use caches such as ps-rh-cache. Don't call ps-mule-begin-page. (ps-basic-plot-str): Don't call ps-mule-prepare-ascii-font. (ps-basic-plot-string): Likewise. (ps-control-character): Likewise. (ps-plot-region): Don't pay attention to composition and non-ASCII characters. (ps-generate): Call ps-mule-end-job. (ps-mule-prepare-ascii-font): Delete autoload. (ps-mule-set-ascii-font): Likewise. (ps-mule-plot-string): Likewise. (ps-mule-begin-page): Likewise. (ps-mule-end-job): Declare autoload.

89530:498e5353548a

  (save-excursion
    (set-buffer ps-spool-buffer)
    (goto-char (point-max))
    (insert-file fname)))

;; These functions are used in `ps-mule' to get charset of header and footer.
;; To avoid unnecessary calls to functions in `ps-left-header',
;; `ps-right-header', `ps-left-footer' and `ps-right-footer'.

(defun ps-generate-string-list (content)
  (let (str)
    (while content
      (setq str (cons (cond
		       ((stringp (car content))
			(car content))
		       ((and (symbolp (car content)) (fboundp (car content)))
			(concat "(" (funcall (car content)) ")"))
		       ((and (symbolp (car content)) (boundp (car content)))
			(concat "(" (symbol-value (car content)) ")"))
		       (t
			""))
		      str)
	    content (cdr content)))
    (nreverse str)))

(defvar ps-lh-cache nil)
(defvar ps-rh-cache nil)
(defvar ps-lf-cache nil)
(defvar ps-rf-cache nil)

(defun ps-header-footer-string ()
  (and ps-print-header
       (setq ps-lh-cache (ps-generate-string-list ps-left-header)
	     ps-rh-cache (ps-generate-string-list ps-right-header)))
  (and ps-print-footer
       (setq ps-lf-cache (ps-generate-string-list ps-left-footer)
	     ps-rf-cache (ps-generate-string-list ps-right-footer)))
  (mapconcat 'identity
	     (append ps-lh-cache ps-rh-cache ps-lf-cache ps-rf-cache)
	     ""))

;; These functions insert the arrays that define the contents of the headers.

(defun ps-generate-header-line (fonttag &optional content)
  (ps-output " [" fonttag " ")
  (cond
   ;; Literal strings should be output as is -- the string must contain its own
   ;; PS string delimiters, '(' and ')', if necessary.
   ((stringp content)
    (ps-output (ps-mule-encode-header-string content fonttag)))

   ;; Functions are called -- they should return strings; they will be inserted
   ;; as strings and the PS string delimiters added.
   ((and (symbolp content) (fboundp content))
    (ps-output-string (ps-mule-encode-header-string (funcall content)
						    fonttag)))

   ;; Variables will have their contents inserted.  They should contain
   ;; strings, and will be inserted as strings.
   ((and (symbolp content) (boundp content))
    (ps-output-string (ps-mule-encode-header-string (symbol-value content)
						    fonttag)))

   ;; Anything else will get turned into an empty string.
   (t
    (ps-output-string "")))
  (ps-output "]\n"))

	 (list color color color))
	((stringp color) (ps-color-scale color))
	(t (list default default default))
	))


(defun ps-begin-job ()
  ;; prologue files
  (or (equal ps-mark-code-directory ps-postscript-code-directory)
      (setq ps-print-prologue-0    (ps-prologue-file 0)

	;; that ps-print can be dumped into emacs.  This expression can't be
	;; evaluated at dump-time because X isn't initialized.
	ps-color-p           (and ps-print-color-p (ps-color-device))
	ps-print-color-scale (if ps-color-p
				 (float (car (ps-color-values "white")))
			       1.0))
  ;; initialize page dimensions
  (ps-get-page-dimensions)
  ;; final check
  (and ps-color-p
       (equal ps-default-background ps-default-foreground)

  (ps-output (format "/LineNumber %d def\n" ps-showline-count)
	     (format "/PageNumber %d def\n" (ps-page-number)))

  (when ps-print-header
    (ps-generate-header "HeaderLinesLeft"  "/h0" "/h1"
			(or ps-lh-cache ps-left-header))
    (ps-generate-header "HeaderLinesRight" "/h0" "/h1"
			(or ps-rh-cache ps-right-header))
    (ps-output (format "%d SetHeaderLines\n" ps-header-lines))
    (setq ps-lh-cache nil
	  ps-rh-cache nil))

  (when ps-print-footer
    (ps-generate-header "FooterLinesLeft"  "/H0" "/H0"
			(or ps-lf-cache ps-left-footer))
    (ps-generate-header "FooterLinesRight" "/H0" "/H0"
			(or ps-rf-cache ps-right-footer))
    (ps-output (format "%d SetFooterLines\n" ps-footer-lines))
    (setq ps-lf-cache nil
	  ps-rf-cache nil))

  (ps-output (number-to-string ps-lines-printed) " BeginPage\n")
  (ps-set-font  ps-current-font)
  (ps-set-bg    ps-current-bg)
  (ps-set-color ps-current-color)
  (ps-mule-begin-page))

(defsubst ps-skip-newline (limit)
  (setq ps-showline-count (1+ ps-showline-count)
	ps-lines-printed  (1+ ps-lines-printed))
  (and (< (point) limit)

(defun ps-basic-plot-str (from to string)
  (let* ((wrappoint (ps-find-wrappoint from to
				       (ps-avg-char-width 'ps-font-for-text)))
	 (to (car wrappoint))
	 (str (substring string from to)))
    (ps-mule-prepare-ascii-font str)
    (ps-output-string str)
    (ps-output " S\n")
    wrappoint))

(defun ps-basic-plot-string (from to &optional bg-color)
  (let* ((wrappoint (ps-find-wrappoint from to
				       (ps-avg-char-width 'ps-font-for-text)))
	 (to (car wrappoint))
	 (string (buffer-substring-no-properties from to)))
    (ps-mule-prepare-ascii-font string)
    (ps-output-string string)
    (ps-output " S\n")
    wrappoint))

(defun ps-basic-plot-whitespace (from to &optional bg-color)

		  (forward-char 1))
	     (setq from (point))))
      (if (re-search-forward ps-control-or-escape-regexp to t)
	  ;; region with some control characters or some multi-byte characters
	  (let* ((match-point (match-beginning 0))
		 (match       (char-after match-point))
		 (composition (ps-e-find-composition from (1+ match-point))))
	    (if composition
		(if (and (nth 2 composition)
			 (<= (car composition) match-point))
		    (progn
		      (setq match-point (car composition)
			    match 0)
		      (goto-char (nth 1 composition)))
		  (setq composition nil)))
	    (when (< from match-point)
	      (ps-mule-set-ascii-font)
	      (ps-plot 'ps-basic-plot-string from match-point bg-color))
	    (cond
	     ((= match ?\t)		; tab
	      (let ((linestart (line-beginning-position)))
		(forward-char -1)
		(setq from (+ linestart (current-column)))
		(when (re-search-forward "[ \t]+" to t)
		  (ps-mule-set-ascii-font)
		  (ps-plot 'ps-basic-plot-whitespace
			   from (+ linestart (current-column))
			   bg-color))))

	     ((= match ?\n)		; newline

		;; \f\n ==>> skip \n, but keep line counting!!
		(and (equal (following-char) ?\n)
		     (ps-skip-newline to))
		(ps-next-page)))

	     (composition		; a composite sequence
	      (ps-plot 'ps-mule-plot-composition match-point (point) bg-color))

	     ((> match 255)		; a multi-byte character
	      (let* ((charset (char-charset match))
		     (composition (ps-e-find-composition match-point to))
		     (stop (if (nth 2 composition) (car composition) to)))
		(or (eq charset 'composition)
		    (while (and (< (point) stop) (eq (charset-after) charset))
		      (forward-char 1)))
		(ps-plot 'ps-mule-plot-string match-point (point) bg-color)))
					; characters from ^@ to ^_ and
	     (t				; characters from 127 to 255
	      (ps-control-character match)))
	    (setq from (point)))
	;; region without control characters nor multi-byte characters
	(ps-mule-set-ascii-font)
	(ps-plot 'ps-basic-plot-string from to bg-color)
	(setq from to)))))

(defvar ps-string-control-codes
  (let ((table (make-vector 256 nil))
	(char ?\000))

	 (char-width (ps-avg-char-width 'ps-font-for-text))
	 (wrappoint (ps-find-wrappoint from to char-width)))
    (if (< (car wrappoint) to)
	(ps-continue-line))
    (setq ps-width-remaining (- ps-width-remaining (* len char-width)))
    (ps-mule-prepare-ascii-font str)
    (ps-output-string str)
    (ps-output " S\n")))


(defun ps-face-attributes (face)

		    (ps-mule-begin-job from to)
		    (ps-selected-pages)))
		(ps-begin-page)
		(funcall genfunc from to)
		(ps-end-page)
		(ps-end-job needs-begin-file)

		;; Setting this variable tells the unwind form that the
		;; the PostScript was generated without error.
		(setq completed-safely t))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To make this file smaller, some commands go in a separate file.
;; But autoload them here to make the separation invisible.

(autoload 'ps-mule-prepare-ascii-font "ps-mule"
  "Setup special ASCII font for STRING.
STRING should contain only ASCII characters.")

(autoload 'ps-mule-set-ascii-font     "ps-mule"
  "Adjust current font if current charset is not ASCII.")

(autoload 'ps-mule-plot-string        "ps-mule"
  "Generate PostScript code for plotting characters in the region FROM and TO.

It is assumed that all characters in this region belong to the same charset.

Optional argument BG-COLOR specifies background color.

Returns the value:

	(ENDPOS . RUN-WIDTH)

Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
the sequence.")

(autoload 'ps-mule-initialize         "ps-mule"
  "Initialize global data for printing multi-byte characters.")

(autoload 'ps-mule-begin-job          "ps-mule"
  "Start printing job for multi-byte chars between FROM and TO.
This checks if all multi-byte characters in the region are printable or not.")

(autoload 'ps-mule-begin-page         "ps-mule"
  "Initialize multi-byte charset for printing current page.")

(autoload 'ps-mule-encode-header-string "ps-mule"
  "Generate PostScript code for plotting characters in header STRING.

It is assumed that the length of STRING is not zero.")


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(provide 'ps-print)

89531:f035500271d2

  (save-excursion
    (set-buffer ps-spool-buffer)
    (goto-char (point-max))
    (insert-file fname)))

;; These functions insert the arrays that define the contents of the headers.

(defvar ps-encode-header-string-function nil)

(defun ps-generate-header-line (fonttag &optional content)
  (ps-output " [" fonttag " ")
  (cond
   ;; Literal strings should be output as is -- the string must contain its own
   ;; PS string delimiters, '(' and ')', if necessary.
   ((stringp content)
    (ps-output content))

   ;; Functions are called -- they should return strings; they will be inserted
   ;; as strings and the PS string delimiters added.
   ((and (symbolp content) (fboundp content))
     (if (fboundp ps-encode-header-string-function)
	 (dolist (l (funcall ps-encode-header-string-function
			     (funcall content) fonttag))
	   (ps-output-string l))
    (ps-output-string (funcall content))))

   ;; Variables will have their contents inserted.  They should contain
   ;; strings, and will be inserted as strings.
   ((and (symbolp content) (boundp content))
    (if (fboundp ps-encode-header-string-function)
	(dolist (l (funcall ps-encode-header-string-function
			     (symbol-value content) fonttag))
	  (ps-output-string l))
      (ps-output-string (symbol-value content))))

   ;; Anything else will get turned into an empty string.
   (t
    (ps-output-string "")))
  (ps-output "]\n"))

	 (list color color color))
	((stringp color) (ps-color-scale color))
	(t (list default default default))
	))

(defvar ps-basic-plot-string-function 'ps-basic-plot-string)

(defun ps-begin-job ()
  ;; prologue files
  (or (equal ps-mark-code-directory ps-postscript-code-directory)
      (setq ps-print-prologue-0    (ps-prologue-file 0)

	;; that ps-print can be dumped into emacs.  This expression can't be
	;; evaluated at dump-time because X isn't initialized.
	ps-color-p           (and ps-print-color-p (ps-color-device))
	ps-print-color-scale (if ps-color-p
				 (float (car (ps-color-values "white")))
			       1.0)
	;; Set up default functions.  They may be overridden by
	;; ps-mule-begin-job.
	ps-basic-plot-string-function 'ps-basic-plot-string
	ps-encode-header-string-function nil)
  ;; initialize page dimensions
  (ps-get-page-dimensions)
  ;; final check
  (and ps-color-p
       (equal ps-default-background ps-default-foreground)

  (ps-output (format "/LineNumber %d def\n" ps-showline-count)
	     (format "/PageNumber %d def\n" (ps-page-number)))

  (when ps-print-header
    (ps-generate-header "HeaderLinesLeft"  "/h0" "/h1" ps-left-header)
    (ps-generate-header "HeaderLinesRight" "/h0" "/h1" ps-right-header)
    (ps-output (format "%d SetHeaderLines\n" ps-header-lines)))

  (when ps-print-footer
    (ps-generate-header "FooterLinesLeft"  "/H0" "/H0" ps-left-footer)
    (ps-generate-header "FooterLinesRight" "/H0" "/H0" ps-right-footer)
    (ps-output (format "%d SetFooterLines\n" ps-footer-lines)))

  (ps-output (number-to-string ps-lines-printed) " BeginPage\n")
  (ps-set-font  ps-current-font)
  (ps-set-bg    ps-current-bg)
  (ps-set-color ps-current-color))

(defsubst ps-skip-newline (limit)
  (setq ps-showline-count (1+ ps-showline-count)
	ps-lines-printed  (1+ ps-lines-printed))
  (and (< (point) limit)

(defun ps-basic-plot-str (from to string)
  (let* ((wrappoint (ps-find-wrappoint from to
				       (ps-avg-char-width 'ps-font-for-text)))
	 (to (car wrappoint))
	 (str (substring string from to)))
    (ps-output-string str)
    (ps-output " S\n")
    wrappoint))

(defun ps-basic-plot-string (from to &optional bg-color)
  (let* ((wrappoint (ps-find-wrappoint from to
				       (ps-avg-char-width 'ps-font-for-text)))
	 (to (car wrappoint))
	 (string (buffer-substring-no-properties from to)))
    (ps-output-string string)
    (ps-output " S\n")
    wrappoint))

(defun ps-basic-plot-whitespace (from to &optional bg-color)

		  (forward-char 1))
	     (setq from (point))))
      (if (re-search-forward ps-control-or-escape-regexp to t)
	  ;; region with some control characters or some multi-byte characters
	  (let* ((match-point (match-beginning 0))
		 (match       (char-after match-point)))
	    (when (< from match-point)
	      (ps-plot ps-basic-plot-string-function
		       from match-point bg-color))
	    (cond
	     ((= match ?\t)		; tab
	      (let ((linestart (line-beginning-position)))
		(forward-char -1)
		(setq from (+ linestart (current-column)))
		(when (re-search-forward "[ \t]+" to t)
		  (ps-plot 'ps-basic-plot-whitespace
			   from (+ linestart (current-column))
			   bg-color))))

	     ((= match ?\n)		; newline

		;; \f\n ==>> skip \n, but keep line counting!!
		(and (equal (following-char) ?\n)
		     (ps-skip-newline to))
		(ps-next-page)))

	     (t				; characters from 127 to 255
	      (ps-control-character match)))
	    (setq from (point)))
	;; region without control characters
	(ps-plot ps-basic-plot-string-function from to bg-color)
	(setq from to)))))

(defvar ps-string-control-codes
  (let ((table (make-vector 256 nil))
	(char ?\000))

	 (char-width (ps-avg-char-width 'ps-font-for-text))
	 (wrappoint (ps-find-wrappoint from to char-width)))
    (if (< (car wrappoint) to)
	(ps-continue-line))
    (setq ps-width-remaining (- ps-width-remaining (* len char-width)))
    (ps-output-string str)
    (ps-output " S\n")))


(defun ps-face-attributes (face)

		    (ps-mule-begin-job from to)
		    (ps-selected-pages)))
		(ps-begin-page)
		(funcall genfunc from to)
		(ps-end-page)
		(ps-mule-end-job)
		(ps-end-job needs-begin-file)

		;; Setting this variable tells the unwind form that the
		;; the PostScript was generated without error.
		(setq completed-safely t))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To make this file smaller, some commands go in a separate file.
;; But autoload them here to make the separation invisible.

(autoload 'ps-mule-initialize         "ps-mule"
  "Initialize global data for printing multi-byte characters.")

(autoload 'ps-mule-begin-job          "ps-mule"
  "Start printing job for multi-byte chars between FROM and TO.
This checks if all multi-byte characters in the region are printable or not.")

(autoload 'ps-mule-begin-page         "ps-mule"
  "Initialize multi-byte charset for printing current page.")

(autoload 'ps-mule-end-job         "ps-mule"
  "Finish printing job for multi-byte chars.")


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(provide 'ps-print)