Mercurial > hg > xemacs-beta
diff lisp/w3/w3-display.el @ 82:6a378aca36af r20-0b91
Import from CVS: tag r20-0b91
author | cvs |
---|---|
date | Mon, 13 Aug 2007 09:07:36 +0200 |
parents | 9ee227acff29 |
children | 364816949b59 |
line wrap: on
line diff
--- a/lisp/w3/w3-display.el Mon Aug 13 09:06:45 2007 +0200 +++ b/lisp/w3/w3-display.el Mon Aug 13 09:07:36 2007 +0200 @@ -1,12 +1,12 @@ ;;; w3-display.el --- display engine v99999 ;; Author: wmperry -;; Created: 1997/01/02 20:20:45 -;; Version: 1.90 +;; Created: 1997/01/21 19:45:13 +;; Version: 1.110 ;; Keywords: faces, help, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Copyright (c) 1996 by William M. Perry (wmperry@cs.indiana.edu) -;;; Copyright (c) 1996 Free Software Foundation, Inc. +;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; This file is part of GNU Emacs. @@ -38,14 +38,14 @@ (w3-d-s-var-def w3-display-open-element-stack) (w3-d-s-var-def w3-display-alignment-stack) (w3-d-s-var-def w3-display-list-stack) -(w3-d-s-var-def w3-display-form-stack) +(w3-d-s-var-def w3-display-form-id) (w3-d-s-var-def w3-display-whitespace-stack) (w3-d-s-var-def w3-display-font-family-stack) (w3-d-s-var-def w3-display-font-weight-stack) (w3-d-s-var-def w3-display-font-variant-stack) (w3-d-s-var-def w3-display-font-size-stack) (w3-d-s-var-def w3-face-color) -(w3-d-s-var-def w3-face-background) +(w3-d-s-var-def w3-face-background-color) (w3-d-s-var-def w3-active-faces) (w3-d-s-var-def w3-active-voices) (w3-d-s-var-def w3-current-form-number) @@ -85,7 +85,7 @@ (w3-get-face-info text-decoration) ;;(w3-get-face-info pixmap) (w3-get-face-info color) - (w3-get-face-info background) + (w3-get-face-info background-color) (setq w3-face-font-spec (make-font :weight (car w3-face-font-weight) :family (car w3-face-font-family) @@ -101,10 +101,11 @@ (w3-pop-face-info text-decoration) ;;(w3-pop-face-info pixmap) (w3-pop-face-info color) - (w3-pop-face-info background)))) + (w3-pop-face-info background-color)))) ) +(defvar w3-display-same-buffer nil) (defvar w3-face-cache nil "Cache for w3-face-for-element") (defvar w3-face-index 0) (defvar w3-image-widgets-waiting nil) @@ -233,10 +234,10 @@ (car w3-face-font-variant))) (setq w3-face-descr (list w3-face-font-spec (car w3-face-color) - (car w3-face-background)) + (car w3-face-background-color)) w3-face-face (cdr-safe (assoc w3-face-descr w3-face-cache))) (if (or w3-face-face (not (or (car w3-face-color) - (car w3-face-background) + (car w3-face-background-color) w3-face-font-spec))) nil ; Do nothing, we got it already (setq w3-face-face @@ -247,8 +248,8 @@ (set-face-font w3-face-face w3-face-font-spec)) (if (car w3-face-color) (set-face-foreground w3-face-face (car w3-face-color))) - (if (car w3-face-background) - (set-face-background w3-face-face (car w3-face-background))) + (if (car w3-face-background-color) + (set-face-background w3-face-face (car w3-face-background-color))) ;;(set-face-background-pixmap w3-face-face w3-face-pixmap) (setq w3-face-cache (cons (cons w3-face-descr w3-face-face) @@ -274,6 +275,7 @@ '((disc . ?*) (circle . ?o) (square . ?#) + (none . ? ) ) "*An assoc list of unordered list types mapping to characters to use as the bullet character.") @@ -358,21 +360,25 @@ ) (defun w3-widget-echo (widget &rest ignore) - (let ((href (widget-get widget 'href)) + (let ((url (widget-get widget 'href)) (name (widget-get widget 'name)) (text (buffer-substring (widget-get widget :from) (widget-get widget :to))) (title (widget-get widget 'title)) + (check w3-echo-link) (msg nil)) - (if href - (setq href (url-truncate-url-for-viewing href))) + (if url + (setq url (url-truncate-url-for-viewing url))) (if name (setq name (concat "anchor:" name))) - (case w3-echo-link - (url (or href title text name)) - (text (or text title href name)) - (title (or title text href name)) - (otherwise nil)))) + (if (not (listp check)) + (setq check (cons check '(title url text name)))) + (catch 'exit + (while check + (and (boundp (car check)) + (stringp (symbol-value (car check))) + (throw 'exit (symbol-value (car check)))) + (pop check))))) (defun w3-follow-hyperlink (widget &rest ignore) (let* ((target (widget-get widget 'target)) @@ -423,7 +429,7 @@ (` (case (car break-style) (list-item - (let ((list-style (w3-get-style-info 'list-style node)) + (let ((list-style (w3-get-style-info 'list-style-type node)) (list-num (if (car w3-display-list-stack) (incf (car w3-display-list-stack)) 1)) @@ -572,7 +578,7 @@ (setq desc (and desc (intern dc-desc))) (case desc ((style stylesheet) - (w3-handle-style args)) + (w3-handle-style plist)) (otherwise ) ) @@ -1389,6 +1395,25 @@ ) "HoplesSLYCoNfUSED"))) +(defun w3-display-chop-into-table (node cols) + ;; Chop the content of 'node' up into 'cols' columns suitable for inclusion + ;; as the content of a table + (let ((content (nth 2 node)) + (items nil) + (rows nil)) + (setq cols (max cols 1)) + (while content + (push (list 'td nil (list (pop content))) items) + (if (= (length items) cols) + (setq rows (cons (nreverse items) rows) + items nil))) + (if items ; Store any leftovers + (setq rows (cons (nreverse items) rows) + items nil)) + (while rows + (push (list 'tr nil (pop rows)) items)) + items)) + (defun w3-display-node (node &optional nofaces) (let ( (content-stack (list (list node))) @@ -1421,6 +1446,9 @@ (list 'mouse-face 'highlight 'duplicable t + 'start-open t + 'end-open t + 'rear-nonsticky t 'help-echo 'w3-balloon-help-callback 'balloon-help 'w3-balloon-help-callback)) (fillin-text-property (car hyperlink-info) (point) @@ -1428,8 +1456,6 @@ (widget-put (cadr hyperlink-info) :to (set-marker (make-marker) (point)))) (setq hyperlink-info nil)) - (form - (pop w3-display-form-stack)) ((ol ul dl dir menu) (pop w3-display-list-stack)) (otherwise @@ -1454,14 +1480,20 @@ (if (w3-get-attribute 'style) (let ((unique-id (or (w3-get-attribute 'id) (w3-display-create-unique-id))) - (sheet "")) + (sheet "") + (class (assq 'class args))) (setq sheet (format "%s.%s { %s }\n" tag unique-id (w3-get-attribute 'style))) - (setf (nth 1 node) (cons (cons 'id unique-id) args)) - (w3-handle-style (list (cons 'data sheet) - (cons 'notation "css"))))) + (if class + (setcdr class (cons unique-id (cdr class))) + (setf (nth 1 node) (cons (cons 'class (list unique-id)) + (nth 1 node)))) + (setf (nth 1 node) (cons (cons 'id unique-id) (nth 1 node))) + (w3-handle-style (list 'data sheet + 'notation "css")))) (setq w3-display-css-properties (css-get - (nth 0 node) (nth 1 node) + (nth 0 node) + (nth 1 node) w3-current-stylesheet w3-display-open-element-stack)) (if nofaces @@ -1514,8 +1546,22 @@ (w3-handle-content node) ) ) - ((ol ul dl dir menu) + ((ol ul dl menu) + (push 0 w3-display-list-stack) + (w3-handle-content node)) + (dir (push 0 w3-display-list-stack) + (setq node + (list tag args + (list + (list 'table nil + (w3-display-chop-into-table node 3))))) + (w3-handle-content node)) + (multicol + (setq node (list tag args + (list + (list 'table nil + (w3-display-chop-into-table node 2))))) (w3-handle-content node)) (img ; inlined image (w3-handle-image) @@ -1565,7 +1611,27 @@ (setq w3-imagemaps (cons (cons name areas) w3-imagemaps))) (w3-handle-empty-tag) ) - (table ; Yeeee-hah! + (note + ;; Ewwwwhhh. Looks gross, but it works. This converts a + ;; <note> into a two-cell table, so that things look all + ;; pretty. + (setq node + (list 'note nil + (list + (list 'table nil + (list + (list 'tr nil + (list + (list 'td (list 'align 'right) + (list + (concat + (or (w3-get-attribute 'role) + "CAUTION") ":"))) + (list 'td nil + (nth 2 node))))))))) + (w3-handle-content node) + ) + (table (w3-display-table node) (setq w3-last-fill-pos (point)) (w3-handle-empty-tag) @@ -1599,7 +1665,8 @@ (*document (let ((info (mapcar (lambda (x) (cons x (symbol-value x))) w3-persistent-variables))) - (set-buffer (generate-new-buffer "Untitled")) + (if (not w3-display-same-buffer) + (set-buffer (generate-new-buffer "Untitled"))) (setq w3-current-form-number 0 w3-display-open-element-stack nil w3-last-fill-pos (point-min) @@ -1613,6 +1680,7 @@ ;; ACK! We don't like filladapt mode! (set (make-local-variable 'filladapt-mode) nil) (set (make-local-variable 'adaptive-fill-mode) nil) + (set (make-local-variable 'voice-lock-mode) t) (setq w3-current-stylesheet (css-copy-stylesheet w3-user-stylesheet) w3-last-fill-pos (point) @@ -1660,7 +1728,8 @@ (setq potential-title (concat potential-title (car content)) content (cdr content))) (setq potential-title (w3-normalize-spaces potential-title)) - (if (string-match "^[ \t]*$" potential-title) + (if (or w3-display-same-buffer + (string-match "^[ \t]*$" potential-title)) nil (rename-buffer (generate-new-buffer-name (w3-fix-spaces potential-title))))) @@ -1672,134 +1741,157 @@ (url nil)) (if (not action) (setq args (cons (cons 'action (url-view-url t)) args))) - (push (cons - (cons 'form-number - w3-current-form-number) - args) w3-display-form-stack) + (setq w3-display-form-id (cons + (cons 'form-number + 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))) (input - (if (not (assq 'form w3-display-open-element-stack)) - (message "Input field outside of a <form>") - (let* ( - (type (intern (downcase (or (w3-get-attribute 'type) - "text")))) - (name (w3-get-attribute 'name)) - (value (or (w3-get-attribute 'value) "")) - (size (if (w3-get-attribute 'size) - (string-to-int (w3-get-attribute 'size)))) - (maxlength (cdr (assoc 'maxlength args))) - (default value) - (action (car w3-display-form-stack)) - (options) - (id (w3-get-attribute 'id)) - (checked (assq 'checked args))) - (if (and (string-match "^[ \t\n\r]+$" value) - (not (eq type 'hidden))) - (setq value "")) - (if maxlength (setq maxlength (string-to-int maxlength))) - (if (and name (string-match "[\r\n]" name)) - (setq name (mapconcat (function - (lambda (x) - (if (memq x '(?\r ?\n)) - "" - (char-to-string x)))) - name ""))) - (if (memq type '(checkbox radio)) (setq default checked)) - (if (and (eq type 'checkbox) (string= value "")) - (setq value "on")) - (w3-form-add-element type name - value size maxlength default action - options w3-current-form-number id checked - (car w3-active-faces)) - ) + (let* ( + (type (intern (downcase (or (w3-get-attribute 'type) + "text")))) + (name (w3-get-attribute 'name)) + (value (or (w3-get-attribute 'value) "")) + (size (if (w3-get-attribute 'size) + (string-to-int (w3-get-attribute 'size)))) + (maxlength (cdr (assoc 'maxlength args))) + (default value) + (action w3-display-form-id) + (options) + (id (w3-get-attribute 'id)) + (checked (assq 'checked args))) + (if (and (string-match "^[ \t\n\r]+$" value) + (not (eq type 'hidden))) + (setq value "")) + (if maxlength (setq maxlength (string-to-int maxlength))) + (if (and name (string-match "[\r\n]" name)) + (setq name (mapconcat (function + (lambda (x) + (if (memq x '(?\r ?\n)) + "" + (char-to-string x)))) + name ""))) + (if (memq type '(checkbox radio)) (setq default checked)) + (if (and (eq type 'checkbox) (string= value "")) + (setq value "on")) + (w3-form-add-element type name + value size maxlength default action + options w3-current-form-number id checked + (car w3-active-faces)) ) (w3-handle-empty-tag) ) (select - (if (not (assq 'form w3-display-open-element-stack)) - (message "Input field outside of a <form>") - (let* ( - (name (w3-get-attribute 'name)) - (size (string-to-int (or (w3-get-attribute 'size) - "20"))) - (maxlength (cdr (assq 'maxlength args))) - (value nil) - (tmp nil) - (action (car w3-display-form-stack)) - (options) - (id (w3-get-attribute 'id)) - (checked (assq 'checked args))) - (if maxlength (setq maxlength (string-to-int maxlength))) - (if (and name (string-match "[\r\n]" name)) - (setq name (mapconcat (function - (lambda (x) - (if (memq x '(?\r ?\n)) - "" - (char-to-string x)))) - name ""))) - (setq options - (mapcar - (function - (lambda (n) - (setq tmp (w3-normalize-spaces - (apply 'concat (nth 2 n))) - tmp (cons tmp - (or - (cdr-safe (assq 'value (nth 1 n))) - tmp))) - (if (assq 'selected (nth 1 n)) - (setq value (car tmp))) - tmp)) - (nth 2 node))) - (if (not value) - (setq value (caar options))) - (w3-form-add-element 'option name - value size maxlength value action - options w3-current-form-number id nil + (let* ( + (name (w3-get-attribute 'name)) + (size (string-to-int (or (w3-get-attribute 'size) + "20"))) + (maxlength (cdr (assq 'maxlength args))) + (value nil) + (tmp nil) + (action w3-display-form-id) + (options) + (id (w3-get-attribute 'id)) + (multiple (assq 'multiple args)) + (checked (assq 'checked args))) + (if maxlength (setq maxlength (string-to-int maxlength))) + (if (and name (string-match "[\r\n]" name)) + (setq name (mapconcat (function + (lambda (x) + (if (memq x '(?\r ?\n)) + "" + (char-to-string x)))) + name ""))) + (setq options + (mapcar + (function + (lambda (n) + (setq tmp (w3-normalize-spaces + (apply 'concat (nth 2 n))) + tmp (cons tmp + (or + (cdr-safe (assq 'value (nth 1 n))) + tmp))) + (if (assq 'selected (nth 1 n)) + (setq value (car tmp))) + tmp)) + (nth 2 node))) + (if (not value) + (setq value (caar options))) + (if multiple + (progn + (setq options + (mapcar + (function + (lambda (opt) + (list 'div nil + (list + (list 'input + (list (cons 'name name) + (cons 'type "checkbox") + (cons 'value (car opt)))) + " " (car opt) (list 'br nil nil))))) + options)) + (setq node (list 'p nil options)) + (w3-handle-content node)) + (w3-form-add-element 'option + name value size maxlength value + action options + w3-current-form-number id nil (car w3-active-faces)) ;; This should really not be necessary, but some versions ;; of the widget library leave point _BEFORE_ the menu ;; widget instead of after. (goto-char (point-max)) - ) - ) - (w3-handle-empty-tag) - ) + (w3-handle-empty-tag)))) (textarea - (if (not (assq 'form w3-display-open-element-stack)) - (message "Input field outside of a <form>") - (let* ( - (name (w3-get-attribute 'name)) - (size (string-to-int (or (w3-get-attribute 'size) - "20"))) - (maxlength (cdr (assq 'maxlength args))) - (value (w3-normalize-spaces - (apply 'concat (nth 2 node)))) - (default value) - (tmp nil) - (action (car w3-display-form-stack)) - (options) - (id (w3-get-attribute 'id)) - (checked (assq 'checked args))) - (if maxlength (setq maxlength (string-to-int maxlength))) - (if (and name (string-match "[\r\n]" name)) - (setq name (mapconcat (function - (lambda (x) - (if (memq x '(?\r ?\n)) - "" - (char-to-string x)))) - name ""))) - (w3-form-add-element 'multiline name - value size maxlength value action - options w3-current-form-number id nil - (car w3-active-faces)) - ) + (let* ( + (name (w3-get-attribute 'name)) + (size (string-to-int (or (w3-get-attribute 'size) + "22"))) + (maxlength (cdr (assq 'maxlength args))) + (value (w3-normalize-spaces + (apply 'concat (nth 2 node)))) + (default value) + (tmp nil) + (action w3-display-form-id) + (options) + (id (w3-get-attribute 'id)) + (checked (assq 'checked args))) + (if maxlength (setq maxlength (string-to-int maxlength))) + (if (and name (string-match "[\r\n]" name)) + (setq name (mapconcat (function + (lambda (x) + (if (memq x '(?\r ?\n)) + "" + (char-to-string x)))) + name ""))) + (w3-form-add-element 'multiline name + value size maxlength value action + options w3-current-form-number id nil + (car w3-active-faces)) ) (w3-handle-empty-tag) ) (style - (w3-handle-style (cons (cons 'data (apply 'concat (nth 2 node))) - (nth 1 node))) + (w3-handle-style (alist-to-plist + (cons (cons 'data (apply 'concat (nth 2 node))) + (nth 1 node)))) (w3-handle-empty-tag)) (otherwise ;; Generic formatting @@ -1829,6 +1921,48 @@ (- nd st))) +(defsubst w3-finish-drawing () + (if (and (boundp 'w3-image-widgets-waiting) w3-image-widgets-waiting) + (let (url glyph widget) + (while w3-image-widgets-waiting + (setq widget (car w3-image-widgets-waiting) + w3-image-widgets-waiting (cdr w3-image-widgets-waiting) + url (widget-get widget 'src) + glyph (cdr-safe (assoc url w3-graphics-list))) + (widget-value-set widget glyph))) + ;;(w3-handle-annotations) + ;;(w3-handle-headers) + ) + ) + +(defun w3-region (st nd) + (if (not w3-setup-done) (w3-do-setup)) + (let* ((source (buffer-substring st nd)) + (w3-display-same-buffer t) + (parse nil)) + (save-excursion + (set-buffer (get-buffer-create " *w3-region*")) + (erase-buffer) + (insert source) + (setq parse (w3-parse-buffer (current-buffer)))) + (narrow-to-region st nd) + (delete-region (point-min) (point-max)) + (w3-draw-tree parse) + (w3-finish-drawing))) + +(defun w3-refresh-buffer () + (interactive) + (let ((parse w3-current-parse) + (inhibit-read-only t) + (w3-display-same-buffer t)) + (if (not parse) + (error "Could not find the parse tree for this buffer. EEEEK!")) + (erase-buffer) + (w3-draw-tree parse) + (w3-finish-drawing) + (w3-mode) + (set-buffer-modified-p nil))) + (defun w3-prepare-buffer (&rest args) ;; The text/html viewer - does all the drawing and displaying of the buffer ;; that is necessary to go from raw HTML to a good presentation. @@ -1841,17 +1975,8 @@ (set-buffer-modified-p nil) (setq w3-current-source source w3-current-parse parse) - (if (and (boundp 'w3-image-widgets-waiting) w3-image-widgets-waiting) - (let (url glyph widget) - (while w3-image-widgets-waiting - (setq widget (car w3-image-widgets-waiting) - w3-image-widgets-waiting (cdr w3-image-widgets-waiting) - url (widget-get widget 'src) - glyph (cdr-safe (assoc url w3-graphics-list))) - (widget-value-set widget glyph)))) + (w3-finish-drawing) (w3-mode) - ;;(w3-handle-annotations) - ;;(w3-handle-headers) (set-buffer-modified-p nil) (goto-char (point-min)) (if url-keep-history