Mercurial > hg > xemacs-beta
diff lisp/w3/w3-display.el @ 44:8d2a9b52c682 r19-15prefinal
Import from CVS: tag r19-15prefinal
author | cvs |
---|---|
date | Mon, 13 Aug 2007 08:55:10 +0200 |
parents | 1a767b41a199 |
children | 6a22abad6937 |
line wrap: on
line diff
--- a/lisp/w3/w3-display.el Mon Aug 13 08:54:52 2007 +0200 +++ b/lisp/w3/w3-display.el Mon Aug 13 08:55:10 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-display.el --- display engine v99999 ;; Author: wmperry -;; Created: 1997/03/18 23:20:40 -;; Version: 1.150 +;; Created: 1997/03/26 00:03:00 +;; Version: 1.156 ;; Keywords: faces, help, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -75,9 +75,11 @@ (defmacro w3-get-attribute (attr) (` (cdr-safe (assq (, attr) args)))) - (defmacro w3-get-face-info (info) + (defmacro w3-get-face-info (info &optional other) (let ((var (intern (format "w3-face-%s" info)))) - (` (push (w3-get-style-info (quote (, info)) node (car (, var))) + (` (push (w3-get-style-info (quote (, info)) node + (or (w3-get-attribute (quote (, other))) + (car (, var)))) (, var))))) (defmacro w3-pop-face-info (info) @@ -94,8 +96,8 @@ (w3-get-face-info font-size) (w3-get-face-info text-decoration) ;;(w3-get-face-info pixmap) - (w3-get-face-info color) - (w3-get-face-info background-color) + (w3-get-face-info color color) + (w3-get-face-info background-color bgcolor) (setq w3-face-font-spec (make-font :weight (car w3-face-font-weight) :family (car w3-face-font-family) @@ -285,15 +287,6 @@ (setq string (substring string 0 (match-beginning 0)))) string) -(defvar w3-bullets - '((disc . ?*) - (circle . ?o) - (square . ?#) - (none . ? ) - ) - "*An assoc list of unordered list types mapping to characters to use -as the bullet character.") - (defsubst w3-display-line-break (n) (if (or @@ -728,6 +721,7 @@ ((stringp w3-auto-image-alt) (format w3-auto-image-alt (url-basepath src t))))) (alt (or (w3-get-attribute 'alt) our-alt)) + (c nil) (ismap (and (assq 'ismap args) 'ismap)) (usemap (w3-get-attribute 'usemap)) (base (w3-get-attribute 'base)) @@ -736,6 +730,8 @@ (widget nil) (align (or (w3-get-attribute 'align) (w3-get-style-info 'vertical-align node)))) + (while (setq c (string-match "[\C-i\C-j\C-l\C-m]" alt)) + (aset alt c ? )) (if (assq '*table-autolayout w3-display-open-element-stack) (insert alt) (setq widget (widget-create 'image @@ -757,11 +753,141 @@ ;; The table handling +(defvar w3-table-ascii-border-chars + [nil nil nil ?/ nil ?- ?\\ ?- nil ?\\ ?| ?| ?/ ?- ?| ?+] + "*Vector of ascii characters to use to draw table borders. +This vector is used when terminal characters are unavailable") + +(defvar w3-table-glyph-border-chars + [nil nil nil 11 nil 2 7 14 nil 3 8 6 1 15 4 5] + "Vector of characters to use to draw table borders. +This vector is used when terminal characters are used via glyphs") + +(defvar w3-table-graphic-border-chars + [nil nil nil ?j nil ?q ?m ?v nil ?k ?x ?u ?l ?w ?t ?n] + "Vector of characters to use to draw table borders. +This vector is used when terminal characters are used directly") + +(defvar w3-table-border-chars w3-table-ascii-border-chars + "Vector of characters to use to draw table borders. +w3-setup-terminal-chars sets this to one of +w3-table-ascii-border-chars, +w3-table-glyph-border-chars, or +w3-table-graphic-border-chars.") + +(defsubst w3-table-lookup-char (l u r b) + (aref w3-table-border-chars (logior (if l 1 0) + (if u 2 0) + (if r 4 0) + (if b 8 0)))) + +(defvar w3-terminal-properties nil) + +(defsubst w3-insert-terminal-char (character &optional count inherit) + (if w3-terminal-properties + (set-text-properties (point) + (progn + (insert-char (or character ? ) + (or count 1) inherit) + (point)) + w3-terminal-properties) + (insert-char (or character ? ) (or count 1) inherit))) + +(defsubst w3-horizontal-rule-char nil + (or w3-horizontal-rule-char (w3-table-lookup-char t nil t nil))) + +(defun w3-setup-terminal-chars nil + "Try to find the best set of characters to draw table borders with. +On a console, this can trigger some Emacs display bugs. + +Initializes a number of variables: +w3-terminal-properties to either nil or a list of properties including 'face +w3-table-border-chars to one of the the three other vectors" + (interactive) + (setq w3-table-border-chars w3-table-ascii-border-chars + w3-terminal-properties nil) + (cond + ((and w3-use-terminal-characters + (eq (device-type) 'x)) + (if (find-face 'w3-table-hack-x-face) nil + (make-face 'w3-table-hack-x-face) + (font-set-face-font 'w3-table-hack-x-face + (make-font :family "terminal"))) + (cond + ((not (face-differs-from-default-p 'w3-table-hack-x-face)) + nil) + ((and w3-use-terminal-glyphs (fboundp 'face-id)) + (let ((id (face-id 'w3-table-hack-x-face)) + (c (length w3-table-border-chars))) + (while (> (decf c) 0) + (if (aref w3-table-glyph-border-chars c) + (aset standard-display-table (aref w3-table-glyph-border-chars c) + (vector (+ (* 256 id) + (aref w3-table-graphic-border-chars c)))))) + (setq w3-table-border-chars w3-table-glyph-border-chars + w3-terminal-properties nil))) + (t + (setq w3-table-border-chars w3-table-graphic-border-chars + w3-terminal-properties (list 'start-open t + 'end-open t + 'rear-nonsticky t + 'w3-table-border t + 'face 'w3-table-hack-x-face))))) + ((and w3-use-terminal-characters-on-tty + (eq (device-type) 'tty)) + (let ((c (length w3-table-border-chars))) + (while (> (decf c) 0) + (and (aref w3-table-glyph-border-chars c) + (aref w3-table-graphic-border-chars c) + (standard-display-g1 (aref w3-table-glyph-border-chars c) + (aref w3-table-graphic-border-chars c))))) + (setq w3-table-border-chars w3-table-glyph-border-chars + w3-terminal-properties (list 'w3-table-border t))) + (t + nil)) + w3-table-border-chars) + +(defun w3-unsetup-terminal-characters nil + (interactive) + (w3-excise-terminal-characters (buffer-list)) + (standard-display-default 1 15) + (setq w3-table-border-chars w3-table-ascii-border-chars)) + +(defun w3-excise-terminal-characters (buffs) + "Replace hacked characters with ascii characters in buffers BUFFS. +Should be run before restoring w3-table-border-chars to ascii characters. +This will only work if we used glyphs rather than text properties" + (interactive (list (list (current-buffer)))) + (let ((inhibit-read-only t) + (tr (make-string 16 ? )) + (i 0)) + (while (< i (length tr)) + (aset tr i i) + (setq i (1+ i))) + (setq i 0) + (while (< i (length w3-table-border-chars)) + (and (aref w3-table-border-chars i) + (< (aref w3-table-border-chars i) 16) + (aset tr + (aref w3-table-glyph-border-chars i) + (aref w3-table-ascii-border-chars i))) + (setq i (1+ i))) + (mapcar (function (lambda (buf) + (save-excursion + (set-buffer buf) + (if (eq major-mode 'w3-mode) + (translate-region (point-min) + (point-max) + tr))))) + buffs))) + + (defvar w3-display-table-cut-words-p nil "*Whether to cut words that are oversized in table cells") (defvar w3-display-table-force-borders nil - "*Whether to always draw table borders") + "*Whether to always draw table borders +Can sometimes make the structure of a document clearer") (defun w3-display-table-cut () (save-excursion @@ -828,7 +954,7 @@ (w3-do-incremental-display nil) (hr-regexp (concat "^" (regexp-quote - (make-string 5 w3-horizontal-rule-char)) + (make-string 5 (w3-horizontal-rule-char))) "*$")) ) ;;(push 'left w3-display-alignment-stack) @@ -1042,107 +1168,6 @@ ))) (list rows cols ret-vector)))) -(defvar w3-table-ascii-border-chars - [? ? ? ?/ ? ?- ?\\ ?- ? ?\\ ?| ?| ?/ ?- ?| ?-] - "Vector of ascii characters to use to draw table borders. -w3-table-unhack-border-chars uses this to restore w3-table-border-chars.") - -(defvar w3-table-border-chars w3-table-ascii-border-chars - "Vector of characters to use to draw table borders. -If you set this you should set w3-table-ascii-border-chars to the same value -so that w3-table-unhack-borders can restore the value if necessary. - -A reasonable value is [? ? ? ?/ ? ?- ?\\\\ ?^ ? ?\\\\ ?| ?< ?/ ?- ?> ?-] -Though i recommend replacing the ^ with - and the < and > with |") - -(defsubst w3-table-lookup-char (l u r b) - (aref w3-table-border-chars (logior (if l 1 0) - (if u 2 0) - (if r 4 0) - (if b 8 0)))) - -(defun w3-table-hack-borders nil - "Try to find the best set of characters to draw table borders with. -I definitely recommend trying this on X. -On a console, this can trigger some Emacs display bugs. - -I haven't tried this on XEmacs or any window-system other than X." - (interactive) - (case (device-type) - (x - (let ((id (or (and (find-face 'w3-table-hack-x-face) - (face-id 'w3-table-hack-x-face)) - (progn - (make-face 'w3-table-hack-x-face) - (font-set-face-font 'w3-table-hack-x-face - (make-font :family "terminal")) - (face-id 'w3-table-hack-x-face))))) - (if (not (face-differs-from-default-p 'w3-table-hack-x-face)) - nil - (aset standard-display-table 1 (vector (+ (* 256 id) ?l))) - (aset standard-display-table 2 (vector (+ (* 256 id) ?q))) - (aset standard-display-table 3 (vector (+ (* 256 id) ?k))) - (aset standard-display-table 4 (vector (+ (* 256 id) ?t))) - (aset standard-display-table 5 (vector (+ (* 256 id) ?n))) - (aset standard-display-table 6 (vector (+ (* 256 id) ?u))) - (aset standard-display-table 7 (vector (+ (* 256 id) ?m))) - (aset standard-display-table 8 (vector (+ (* 256 id) ?x))) - (aset standard-display-table 11 (vector (+ (* 256 id) ?j))) - (aset standard-display-table 14 (vector (+ (* 256 id) ?v))) - (aset standard-display-table 15 (vector (+ (* 256 id) ?w))) - (setq w3-table-border-chars [? ? ? 11 ? 2 7 14 ? 3 8 6 1 15 4 5]) - (setq w3-horizontal-rule-char 2)))) - (tty - (standard-display-g1 1 108) ; ulcorner - (standard-display-g1 2 113) ; hline - (standard-display-g1 3 107) ; urcorner - (standard-display-g1 4 116) ; leftt - (standard-display-g1 5 110) ; intersection - (standard-display-g1 6 117) ; rightt - (standard-display-g1 7 109) ; llcorner - (standard-display-g1 8 120) ; vline - (standard-display-g1 11 106) ; lrcorner - (standard-display-g1 14 118) ; upt - (standard-display-g1 15 119) ; downt - (setq w3-table-border-chars [? ? ? 11 ? 2 7 14 ? 3 8 6 1 15 4 5]) - (setq w3-horizontal-rule-char 2)) - (otherwise - (error "Unknown window-system, can't do any better than ascii borders"))) - ) - -(defun w3-table-unhack-borders nil - (interactive) - (w3-table-excise-hack (buffer-list)) - (standard-display-default 1 15) - (setq w3-table-border-chars w3-table-ascii-border-chars) - (setq w3-horizontal-rule-char ?-)) - -(defun w3-table-excise-hack (buffs) - "Replace hacked characters with ascii characters in buffers BUFFS. -Should be run before restoring w3-table-border-chars to ascii characters." - (interactive (list (list (current-buffer)))) - (let ((inhibit-read-only t) - (tr (make-string 16 ? )) - (i 0)) - (while (< i (length tr)) - (aset tr i i) - (setq i (1+ i))) - (setq i 0) - (while (< i (length w3-table-border-chars)) - (if (< (aref w3-table-border-chars i) 16) - (aset tr - (aref w3-table-border-chars i) - (aref w3-table-ascii-border-chars i))) - (setq i (1+ i))) - (mapcar (function (lambda (buf) - (save-excursion - (set-buffer buf) - (if (eq major-mode 'w3-mode) - (translate-region (point-min) - (point-max) - tr))))) - buffs))) - (defun w3-display-table (node) (let* ((dimensions (w3-display-table-dimensions node)) (num-cols (max (cadr dimensions) 1)) @@ -1349,11 +1374,12 @@ (setq bflag (/= (aref table-colspans i) 0)) (setq tflag (/= (aref prev-colspans i) 0)) - (insert (w3-table-lookup-char lflag tflag rflag bflag)) + (w3-insert-terminal-char (w3-table-lookup-char lflag tflag rflag bflag)) (setq lflag t) (cond ((= (aref prev-rowspans i) 0) - (insert-char (w3-table-lookup-char t nil t nil) - (aref column-dimensions i)) + (w3-insert-terminal-char + (w3-table-lookup-char t nil t nil) + (aref column-dimensions i)) (setq i (1+ i))) ((car (aref formatted-cols i)) (insert (pop (aref formatted-cols i))) @@ -1365,8 +1391,9 @@ (setq lflag nil) (setq i (+ i (max (aref table-colspans i) (aref prev-colspans i) 1)))))) - (insert (w3-table-lookup-char lflag (/= row 1) nil t) "\n")) - + (w3-insert-terminal-char (w3-table-lookup-char lflag (/= row 1) nil t)) + (insert "\n")) + ;; recalculate height (in case we've shortened a rowspanning cell (setq height 0 i 0) @@ -1377,13 +1404,14 @@ ;; Insert a row back in original buffer (while (> height 0) - (insert fill-prefix (w3-table-lookup-char nil t nil t)) + (insert fill-prefix) + (w3-insert-terminal-char (w3-table-lookup-char nil t nil t)) (setq i 0) (while (< i num-cols) (if (car (aref formatted-cols i)) (insert (pop (aref formatted-cols i))) (insert-char ? (aref table-colwidth i))) - (insert (w3-table-lookup-char nil t nil t)) + (w3-insert-terminal-char (w3-table-lookup-char nil t nil t)) (setq i (+ i (max (aref table-colspans i) 1)))) (insert "\n") ;;(and w3-do-incremental-display (w3-pause)) @@ -1418,12 +1446,15 @@ (let (tflag lflag) (while (< i num-cols) (setq tflag (/= (aref prev-colspans i) 0)) - (insert (w3-table-lookup-char lflag tflag t nil)) + (w3-insert-terminal-char (w3-table-lookup-char lflag tflag t nil)) (setq lflag t) - (insert-char (w3-table-lookup-char t nil t nil) - (aref column-dimensions i)) + (w3-insert-terminal-char + (w3-table-lookup-char t nil t nil) + (aref column-dimensions i)) (setq i (1+ i))) - (insert (w3-table-lookup-char t t nil nil) "\n"))) + (w3-insert-terminal-char + (w3-table-lookup-char t t nil nil)) + (insert "\n"))) ) (pop w3-display-open-element-stack))))) @@ -1708,14 +1739,11 @@ (let* ((perc (or (w3-get-attribute 'width) (w3-get-style-info 'width node) "100%")) - (rule nil) (width nil)) (setq perc (/ (min (string-to-int perc) 100) 100.0) - width (* fill-column perc) - rule (make-string (max (truncate width) 0) - w3-horizontal-rule-char) - node (list 'hr nil (list rule))) - (w3-handle-content node))) + width (truncate (* fill-column perc))) + (w3-insert-terminal-char (w3-horizontal-rule-char) width) + (w3-handle-empty-tag))) (map ; Client side imagemaps (let ((name (or (w3-get-attribute 'name) (w3-get-attribute 'id) @@ -1795,6 +1823,15 @@ (w3-handle-content node) (setq w3-current-isindex (cons action prompt))) ) + ((html body) + (let ((fore (car (delq nil (copy-list w3-face-color)))) + (back (car (delq nil (copy-list w3-face-background-color)))) + ) + (if (and fore font-running-xemacs) + (font-set-face-foreground 'default fore (current-buffer))) + (if (and back font-running-xemacs) + (font-set-face-background 'default back (current-buffer))) + (w3-handle-content node))) (*document (let ((info (mapcar (lambda (x) (cons x (symbol-value x))) w3-persistent-variables))) @@ -1808,7 +1845,10 @@ w3-right-margin) (or w3-maximum-line-length (window-width)))) - (switch-to-buffer (current-buffer)) + (condition-case nil + (switch-to-buffer (current-buffer)) + (error (message "W3 buffer %s is being drawn." (buffer-name (current-buffer))))) + (buffer-disable-undo (current-buffer)) (mapcar (function (lambda (x) (set (car x) (cdr x)))) info) ;; ACK! We don't like filladapt mode! @@ -1879,21 +1919,13 @@ w3-current-form-number) args)) (w3-handle-content node))) -; (keygen -; (w3-form-add-element 'keygen -; (or (w3-get-attribute 'name) -; (w3-get-attribute 'id) -; "keygen") -; nil ; value -; nil ; size -; nil ; maxlength -; nil ; default -; w3-display-form-id ; action -; nil ; options -; w3-current-form-number -; (w3-get-attribute 'id) ; id -; nil ; checked -; (car w3-active-faces))) + (keygen + (w3-form-add-element + (w3-display-normalize-form-info + (cons '(type . "keygen") + args)) + w3-active-faces) + (w3-handle-empty-tag)) (input (w3-form-add-element (w3-display-normalize-form-info args) @@ -1957,8 +1989,7 @@ (w3-handle-empty-tag)))) (textarea (let* ((plist (w3-display-normalize-form-info args)) - (value (w3-normalize-spaces - (apply 'concat (nth 2 node))))) + (value (apply 'concat (nth 2 node)))) (setq plist (plist-put plist 'type 'multiline) plist (plist-put plist 'value value)) (w3-form-add-element plist w3-active-faces)) @@ -2040,11 +2071,13 @@ (defun w3-fixup-eol-faces () ;; Remove 'face property at end of lines - underlining screws up stuff + ;; also remove 'mouse-face property at the beginning and end of lines (let ((inhibit-read-only t)) (save-excursion (goto-char (point-min)) - (while (search-forward "\n" nil t) - (put-text-property (match-beginning 0) (match-end 0) 'face nil))))) + (while (search-forward "[ \t]*\n[ \t]*" nil t) + (remove-text-properties (match-beginning 0) (match-end 0) + '(face nil mouse-face nil) nil))))) (defsubst w3-finish-drawing () (let (url glyph widget) @@ -2065,7 +2098,7 @@ (not (eq (device-type) 'tty)) (w3-fixup-eol-faces)) (let ((inhibit-read-only t)) - (put-text-property (point-min) (point-max) 'read-only nil)) + (remove-text-properties (point-min) (point-max) '(read-only) nil)) (message "Drawing... done")) (defun w3-region (st nd)