;;; ps-mule.el --- provide multi-byte character facility to ps-print
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005 Free Software Foundation, Inc.
;; Author: Vinicius Jose Latorre <vinicius@cpqd.com.br>
;; Kenichi Handa <handa@etl.go.jp> (multi-byte characters)
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
(defun ps-mule-encode-bit (string delta)
(let* ((dim (charset-dimension (char-charset (string-to-char string))))
- (len (* (ps-mule-chars-in-string string) dim))
+ (len (* (length string) dim))
(str (make-string len 0))
(i 0)
(j 0))
(if (= dim 1)
(while (< j len)
(aset str j
- (+ (nth 1 (split-char (ps-mule-string-char string i))) delta))
- (setq i (ps-mule-next-index string i)
+ (+ (nth 1 (split-char (aref string i))) delta))
+ (setq i (1+ i)
j (1+ j)))
(while (< j len)
- (let ((split (split-char (ps-mule-string-char string i))))
+ (let ((split (split-char (aref string i))))
(aset str j (+ (nth 1 split) delta))
(aset str (1+ j) (+ (nth 2 split) delta))
- (setq i (ps-mule-next-index string i)
+ (setq i (1+ i)
j (+ j 2)))))
str))
;; Special encoding for mule-unicode-* characters.
(defun ps-mule-encode-ucs2 (string)
- (let* ((len (ps-mule-chars-in-string string))
+ (let* ((len (length string))
(str (make-string (* 2 len) 0))
(i 0)
(j 0)
ch hi lo)
(while (< i len)
- (setq ch (encode-char (ps-mule-string-char string i) 'ucs)
+ (setq ch (encode-char (aref string i) 'ucs)
hi (lsh ch -8)
lo (logand ch 255))
(aset str j hi)
(defsubst ps-mule-printable-p (charset)
"Non-nil if characters in CHARSET is printable."
- (ps-mule-get-font-spec charset 'normal))
+ ;; ASCII and Latin-1 are always printable.
+ (or (eq charset 'ascii)
+ (eq charset 'latin-iso8859-1)
+ (ps-mule-get-font-spec charset 'normal)))
(defconst ps-mule-external-libraries
'((builtin nil nil
(cons from ps-width-remaining)
(cons (if composition
(nth 1 composition)
- (ps-mule-next-point from))
+ (1+ from))
run-width)))
;; We assume that all characters in this range have the same width.
(setq char-width (* char-width (charset-width ps-mule-current-charset)))
Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
the sequence."
- (setq ps-mule-current-charset (charset-after from))
+ (let ((ch (char-after from)))
+ (setq ps-mule-current-charset
+ (char-charset (or (aref ps-print-translation-table ch) ch))))
(let* ((wrappoint (ps-mule-find-wrappoint
from to (ps-avg-char-width 'ps-font-for-text)))
(to (car wrappoint))
(ps-font-alist 'ps-font-for-text))))
(font-spec (ps-mule-get-font-spec ps-mule-current-charset font-type))
(string (buffer-substring-no-properties from to)))
+ (dotimes (i (length string))
+ (let ((ch (aref ps-print-translation-table (aref string i))))
+ (if ch
+ (aset string i ch))))
(cond
((= from to)
;; We can't print any more characters in the current line.
;; This case is obsolete for Emacs 21.
((eq ps-mule-current-charset 'composition)
- (ps-mule-plot-composition from (ps-mule-next-point from) bg-color))
+ (ps-mule-plot-composition from (1+ from) bg-color))
(t
;; No way to print this charset. Just show a vacant box of an
/BOTTOM LLY def
currentfont /RelativeCompose known {
/relative currentfont /RelativeCompose get def
+ relative false eq {
+ %% Disable relative composition by setting sufficiently low
+ %% and high positions.
+ /relative [ -100000 100000 ] def
+ } if
} {
- %% Disable relative composition by setting sufficiently low
- %% and high positions.
/relative [ -100000 100000 ] def
} ifelse
[ elt 0 0 ]
} ifelse
/FirstCode -1 store
- bmp 0 get SpaceWidthRatio ratio div mul size div 0 % wx wy
+ bmp 0 get size div 0 % wx wy
setcharwidth % We can't use setcachedevice here.
bmp 1 get 0 gt bmp 2 get 0 gt and {
(setq string (ps-mule-string-encoding font-spec string nil t))))))
string)
-;;;###autoload
-(defun ps-mule-header-string-charsets ()
- "Return a list of character sets that appears in header strings."
- (let* ((str (ps-header-footer-string))
- (len (length str))
- (i 0)
- charset-list)
- (while (< i len)
- (let ((charset (char-charset (aref str i))))
- (setq i (1+ i))
- (or (eq charset 'ascii)
- (memq charset charset-list)
- (setq charset-list (cons charset charset-list)))))
- charset-list))
+(defun ps-mule-show-warning (charsets from to header-footer-list)
+ (let ((table (make-category-table))
+ (buf (current-buffer))
+ (max-unprintable-chars 15)
+ char-pos-list)
+ (define-category ?u "Unprintable charset" table)
+ (dolist (cs charsets)
+ (modify-category-entry (make-char cs) ?u table))
+ (with-category-table table
+ (save-excursion
+ (goto-char from)
+ (while (and (<= (length char-pos-list) max-unprintable-chars)
+ (re-search-forward "\\cu" to t))
+ (or (aref ps-print-translation-table (preceding-char))
+ (push (cons (preceding-char) (1- (point))) char-pos-list)))))
+ (with-output-to-temp-buffer "*Warning*"
+ (with-current-buffer standard-output
+ (when char-pos-list
+ (let ((func #'(lambda (buf pos)
+ (when (buffer-live-p buf)
+ (pop-to-buffer buf)
+ (goto-char pos))))
+ (more nil))
+ (if (>= (length char-pos-list) max-unprintable-chars)
+ (setq char-pos-list (cdr char-pos-list)
+ more t))
+ (insert "These characters in the buffer can't be printed:\n")
+ (dolist (elt (nreverse char-pos-list))
+ (insert " ")
+ (insert-text-button (string (car elt))
+ :type 'help-xref
+ 'help-echo
+ "mouse-2, RET: jump to this character"
+ 'help-function func
+ 'help-args (list buf (cdr elt)))
+ (insert ","))
+ (if more
+ (insert " and more...")
+ ;; Delete the last comma.
+ (delete-char -1))
+ (insert "\nClick them to jump to the buffer position,\n"
+ (substitute-command-keys "\
+or \\[universal-argument] \\[what-cursor-position] will give information about them.\n"))))
+
+ (with-category-table table
+ (let (string-list idx)
+ (dolist (elt header-footer-list)
+ (when (stringp elt)
+ (when (string-match "\\cu+" elt)
+ (setq elt (copy-sequence elt))
+ (put-text-property (match-beginning 0) (match-end 0)
+ 'face 'highlight elt)
+ (while (string-match "\\cu+" elt (match-end 0))
+ (put-text-property (match-beginning 0) (match-end 0)
+ 'face 'highlight elt))
+ (push elt string-list))))
+ (when string-list
+ (insert
+ "These highlighted characters in header/footer can't be printed:\n")
+ (dolist (elt string-list)
+ (insert " " elt "\n")))))))))
;;;###autoload
(defun ps-mule-begin-job (from to)
enable-multibyte-characters
;; Initialize `ps-mule-charset-list'. If some characters aren't
;; printable, warn it.
- (let ((charsets (find-charset-region from to)))
- (setq charsets (delq 'ascii (delq 'unknown (delq nil charsets)))
- ps-mule-charset-list charsets)
- (save-excursion
- (goto-char from)
- (and (search-forward "\200" to t)
- (setq ps-mule-charset-list
- (cons 'composition ps-mule-charset-list))))
- ;; We also have to check non-ASCII charsets in the header strings.
- (let ((tail (ps-mule-header-string-charsets)))
- (while tail
- (unless (eq (car tail) 'ascii)
- (setq ps-mule-header-charsets
- (cons (car tail) ps-mule-header-charsets))
- (or (memq (car tail) charsets)
- (setq charsets (cons (car tail) charsets))))
- (setq tail (cdr tail))))
- (while charsets
- (setq charsets
- (cond
- ((or (eq (car charsets) 'composition)
- (ps-mule-printable-p (car charsets)))
- (cdr charsets))
- ((y-or-n-p
- "Font for some characters not found, continue anyway? ")
- nil)
- (t
- (error "Printing cancelled")))))))
+ (let ((header-footer-list (ps-header-footer-string))
+ unprintable-charsets)
+ (setq ps-mule-charset-list
+ (delq 'ascii (delq 'eight-bit-control
+ (delq 'eight-bit-graphic
+ (find-charset-region
+ from to ps-print-translation-table))))
+ ps-mule-header-charsets
+ (delq 'ascii (delq 'eight-bit-control
+ (delq 'eight-bit-graphic
+ (find-charset-string
+ (mapconcat
+ 'identity header-footer-list "")
+ ps-print-translation-table)))))
+ (dolist (cs ps-mule-charset-list)
+ (or (ps-mule-printable-p cs)
+ (push cs unprintable-charsets)))
+ (dolist (cs ps-mule-header-charsets)
+ (or (ps-mule-printable-p cs)
+ (memq cs unprintable-charsets)
+ (push cs unprintable-charsets)))
+ (when unprintable-charsets
+ (ps-mule-show-warning unprintable-charsets from to
+ header-footer-list)
+ (or
+ (y-or-n-p "Font for some characters not found, continue anyway? ")
+ (error "Printing cancelled")))
+
+ (or ps-mule-composition-prologue-generated
+ (let ((use-composition (nth 2 (find-composition from to))))
+ (or use-composition
+ (let (str)
+ (while header-footer-list
+ (setq str (car header-footer-list))
+ (if (and (stringp str)
+ (nth 2 (find-composition 0 (length str) str)))
+ (setq use-composition t
+ header-footer-list nil)
+ (setq header-footer-list (cdr header-footer-list))))))
+ (when use-composition
+ (progn
+ (ps-mule-prologue-generated)
+ (ps-output-prologue ps-mule-composition-prologue)
+ (setq ps-mule-composition-prologue-generated t)))))))
(setq ps-mule-current-charset 'ascii)
- (if (and (nth 2 (find-composition from to))
- (not ps-mule-composition-prologue-generated))
- (progn
- (ps-mule-prologue-generated)
- (ps-output-prologue ps-mule-composition-prologue)
- (setq ps-mule-composition-prologue-generated t)))
-
(if (or ps-mule-charset-list ps-mule-header-charsets)
- (let ((the-list (append ps-mule-header-charsets ps-mule-charset-list))
- font-spec elt)
+ (dolist (elt (append ps-mule-header-charsets ps-mule-charset-list))
(ps-mule-prologue-generated)
- ;; If external functions are necessary, generate prologues for them.
- (while the-list
- (setq elt (car the-list)
- the-list (cdr the-list))
- (cond ((and (eq elt 'composition)
- (not ps-mule-composition-prologue-generated))
- (ps-output-prologue ps-mule-composition-prologue)
- (setq ps-mule-composition-prologue-generated t))
- ((setq font-spec (ps-mule-get-font-spec elt 'normal))
- (ps-mule-init-external-library font-spec))))))
+ (ps-mule-init-external-library (ps-mule-get-font-spec elt 'normal))))
;; If ASCII font is also specified in ps-mule-font-info-database,
;; use it instead of what specified in ps-font-info-database.
;; If the header contains non-ASCII and non-Latin1 characters, prepare a font
;; and glyphs for the first occurrence of such characters.
(if (and ps-mule-header-charsets
- (not (eq (car ps-mule-header-charsets) 'latin-iso8859-1)))
+ (not (eq (car ps-mule-header-charsets) 'latin-iso8859-1))
+ (= (charset-dimension (car ps-mule-header-charsets)) 1))
(let ((font-spec (ps-mule-get-font-spec (car ps-mule-header-charsets)
'normal)))
(if font-spec