home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / w3-display.el.z / w3-display.el
Encoding:
Text File  |  1998-05-21  |  86.4 KB  |  2,717 lines
  1. ;;; w3-display.el --- display engine v99999
  2. ;; Author: wmperry
  3. ;; Created: 1997/12/23 22:13:08
  4. ;; Version: 1.216
  5. ;; Keywords: faces, help, hypermedia
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1996 by William M. Perry <wmperry@cs.indiana.edu>
  9. ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
  10. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11. ;;;
  12. ;;; This file is part of GNU Emacs.
  13. ;;;
  14. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  15. ;;; it under the terms of the GNU General Public License as published by
  16. ;;; the Free Software Foundation; either version 2, or (at your option)
  17. ;;; any later version.
  18. ;;;
  19. ;;; GNU Emacs is distributed in the hope that it will be useful,
  20. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22. ;;; GNU General Public License for more details.
  23. ;;;
  24. ;;; You should have received a copy of the GNU General Public License
  25. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  27. ;;; Boston, MA 02111-1307, USA.
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29. (require 'cl)
  30. (eval-when-compile
  31.   (require 'w3-props))
  32. (require 'w3-keyword)
  33. (require 'css)
  34. (require 'font)
  35. (require 'w3-widget)
  36. (require 'w3-imap)
  37.  
  38. (autoload 'sentence-ify "flame")
  39. (autoload 'string-ify "flame")
  40. (autoload '*flame "flame")
  41. (if (not (fboundp 'flatten)) (autoload 'flatten "flame"))
  42. (defvar w3-cookie-cache nil)
  43.  
  44. (defmacro w3-d-s-var-def (var)
  45.   (` (make-variable-buffer-local (defvar (, var) nil))))
  46.  
  47. (w3-d-s-var-def w3-display-label-marker)
  48. (w3-d-s-var-def w3-display-open-element-stack)
  49. (w3-d-s-var-def w3-display-alignment-stack)
  50. (w3-d-s-var-def w3-display-list-stack)
  51. (w3-d-s-var-def w3-display-form-id)
  52. (w3-d-s-var-def w3-display-whitespace-stack)
  53. (w3-d-s-var-def w3-display-liststyle-stack)
  54. (w3-d-s-var-def w3-display-font-family-stack)
  55. (w3-d-s-var-def w3-display-font-weight-stack)
  56. (w3-d-s-var-def w3-display-font-variant-stack)
  57. (w3-d-s-var-def w3-display-font-size-stack)
  58. (w3-d-s-var-def w3-face-color)
  59. (w3-d-s-var-def w3-face-background-color)
  60. (w3-d-s-var-def w3-active-faces)
  61. (w3-d-s-var-def w3-active-voices)
  62. (w3-d-s-var-def w3-current-form-number)
  63. (w3-d-s-var-def w3-face-font-family)
  64. (w3-d-s-var-def w3-face-font-weight)
  65. (w3-d-s-var-def w3-face-font-variant)
  66. (w3-d-s-var-def w3-face-font-size)
  67. (w3-d-s-var-def w3-face-font-family)
  68. (w3-d-s-var-def w3-face-font-size)
  69. (w3-d-s-var-def w3-face-font-style)
  70. (w3-d-s-var-def w3-face-font-spec)
  71. (w3-d-s-var-def w3-face-text-decoration)
  72. (w3-d-s-var-def w3-face-face)
  73. (w3-d-s-var-def w3-face-descr)
  74. (w3-d-s-var-def w3-face-background-image)
  75. (w3-d-s-var-def w3-display-css-properties)
  76. (w3-d-s-var-def w3-display-background-properties)
  77.  
  78. (eval-when-compile
  79.   (defmacro w3-get-attribute (attr)
  80.     (` (cdr-safe (assq (, attr) args))))
  81.   
  82.   (defmacro w3-get-face-info (info &optional other)
  83.     (let ((var (intern (format "w3-face-%s" info))))
  84.       (` (push (w3-get-style-info (quote (, info)) node
  85.                   (or (and (not w3-user-colors-take-precedence)
  86.                        (cdr-safe (assq (quote (, other))
  87.                                (nth 1 node))))
  88.                       (car (, var))))
  89.            (, var)))))
  90.  
  91.   (defmacro w3-pop-face-info (info)
  92.     (let ((var (intern (format "w3-face-%s" info))))
  93.       (` (pop (, var)))))
  94.  
  95.   (defmacro w3-get-all-face-info ()
  96.     (`
  97.      (progn
  98.        (w3-get-face-info font-family)
  99.        ;; This is to handle the 'face' attribute on arbitrary elements
  100.        (if (cdr-safe (assq 'face (nth 1 node)))
  101.        (setf (car w3-face-font-family)
  102.          (append (car w3-face-font-family)
  103.              (split-string (cdr-safe
  104.                     (assq 'face (nth 1 node)))
  105.                        " *, *"))))
  106.        (w3-get-face-info font-style)
  107.        (w3-get-face-info font-weight)
  108.        (w3-get-face-info font-variant)
  109.        (w3-get-face-info font-size)
  110.        (w3-get-face-info text-decoration)
  111.        (w3-get-face-info background-image)
  112.        (w3-get-face-info color color)
  113.        (w3-get-face-info background-color bgcolor)
  114.        (setq w3-face-font-spec (make-font
  115.                 :weight (car w3-face-font-weight)
  116.                 :family (car w3-face-font-family)
  117.                 :size (car w3-face-font-size))))))
  118.  
  119.   (defmacro w3-pop-all-face-info ()
  120.     (`
  121.      (progn
  122.        (w3-pop-face-info font-family)
  123.        (w3-pop-face-info font-weight)
  124.        (w3-pop-face-info font-variant)
  125.        (w3-pop-face-info font-size)
  126.        (w3-pop-face-info font-style)
  127.        (w3-pop-face-info text-decoration)
  128.        (w3-pop-face-info background-image)
  129.        (w3-pop-face-info color)
  130.        (w3-pop-face-info background-color))))
  131.  
  132.   )
  133.  
  134. (defvar w3-display-same-buffer nil)
  135. (defvar w3-face-cache nil  "Cache for w3-face-for-element")
  136. (defvar w3-face-index 0)
  137. (defvar w3-image-widgets-waiting nil)
  138.  
  139. (make-variable-buffer-local 'w3-last-fill-pos)
  140.  
  141. (defconst w3-fill-prefixes-vector
  142.   (let ((len 0)
  143.         (prefix-vector (make-vector 80 nil)))
  144.     (while (< len 80)
  145.       (aset prefix-vector len (make-string len ? ))
  146.       (setq len (1+ len)))
  147.     prefix-vector))
  148.  
  149. (defconst w3-line-breaks-vector
  150.   (let ((len 0)
  151.     (breaks-vector (make-vector 10 nil)))
  152.     (while (< len 10)
  153.       (aset breaks-vector len (make-string len ?\n))
  154.       (setq len (1+ len)))
  155.     breaks-vector))
  156.  
  157. (defvar w3-pause-keystroke nil)
  158.  
  159. (defsubst w3-pause ()
  160.   (declare (special cur-viewing-pos))
  161.   (save-excursion
  162.     (goto-char (or cur-viewing-pos (point-min)))
  163.     (cond
  164.      (w3-running-xemacs
  165.       (if (and (not (sit-for 0)) (input-pending-p))
  166.       (condition-case ()
  167.           (dispatch-event (next-command-event))
  168.         (error nil))))
  169.      (t
  170.       (if (and (not (sit-for 0)) (input-pending-p))
  171.       (condition-case ()
  172.           (progn
  173.         (setq w3-pause-keystroke
  174.               (lookup-key w3-mode-map (vector (read-event))))
  175.         (case w3-pause-keystroke
  176.           ((w3-quit w3-leave-buffer) nil)
  177.           (otherwise
  178.            (call-interactively w3-pause-keystroke))))
  179.         (error nil)))))
  180.     (setq cur-viewing-pos (point))))
  181.  
  182. (defmacro w3-get-pad-string (len)
  183.   (` (cond
  184.       ((< (, len) 0)
  185.        "")
  186.       ((< (, len) 80)
  187.        (aref w3-fill-prefixes-vector (, len)))
  188.       (t (make-string (, len) ? )))))
  189.  
  190. (defsubst w3-set-fill-prefix-length (len)
  191.   (setq fill-prefix (if (< len (- (or w3-strict-width (window-width)) 4))
  192.             (w3-get-pad-string len)
  193.               (url-warn
  194.                'html
  195.                "Runaway indentation!  Too deep for window width!")
  196.               fill-prefix)))
  197.  
  198. (defsubst w3-get-style-info (info node &optional default)
  199.   (or (cdr-safe (assq info w3-display-css-properties)) default))
  200.  
  201. (defun w3-decode-area-coords (str)
  202.   (let (retval)
  203.     (while (string-match "\\([ \t0-9]+\\),\\([ \t0-9]+\\)" str)
  204.       (setq retval (cons (vector (string-to-int (match-string 1 str))
  205.                  (string-to-int (match-string 2 str))) retval)
  206.         str (substring str (match-end 0) nil)))
  207.     (if (string-match "\\([0-9]+\\)" str)
  208.     (setq retval (cons (vector (+ (aref (car retval) 0)
  209.                       (string-to-int (match-string 1 str)))
  210.                    (aref (car retval) 1)) retval)))
  211.     (nreverse retval)))
  212.  
  213. (defun w3-normalize-color (color)
  214.   (cond
  215.    ((valid-color-name-p color)
  216.     color)
  217.    ((valid-color-name-p (concat "#" color))
  218.     (concat "#" color))
  219.    ((string-match "[ \t\r\n]" color)
  220.     (w3-normalize-color
  221.      (mapconcat (function (lambda (x) (if (memq x '(?\t ?\r ?\n ? )) ""
  222.                     (char-to-string x)))) color "")))
  223.    ((valid-color-name-p (font-normalize-color color))
  224.     (font-normalize-color color))
  225.    (t
  226.     (w3-warn 'html (format "Bad color specification: %s" color))
  227.     nil)))
  228.  
  229. (defsubst w3-voice-for-element (node)
  230.   (if (featurep 'emacspeak)
  231.       (let (family gain left right pitch pitch-range stress richness voice)
  232.     (setq family (w3-get-style-info 'voice-family node)
  233.           gain (w3-get-style-info 'gain node)
  234.           left (w3-get-style-info 'left-volume node)
  235.           right (w3-get-style-info 'right-volume node)
  236.           pitch (w3-get-style-info 'pitch node)
  237.           pitch-range (w3-get-style-info 'pitch-range node)
  238.           stress (w3-get-style-info 'stress node)
  239.           richness (w3-get-style-info 'richness node))
  240.     (if (or family gain left right pitch pitch-range stress richness)
  241.         (setq voice (dtk-personality-from-speech-style
  242.              (make-dtk-speech-style :family (or family 'paul)
  243.                         :gain (or gain 5)
  244.                         :left-volume (or left 5)
  245.                         :right-volume (or right 5)
  246.                         :average-pitch (or pitch 5)
  247.                         :pitch-range (or pitch-range 5)
  248.                         :stress (or stress 5)
  249.                         :richness (or richness 5))))
  250.       (setq voice nil))
  251.     (or voice (car w3-active-voices)))))
  252.  
  253. (defun w3-make-face-emacs19 (name &optional doc-string temporary)
  254.   "Defines and returns a new FACE described by DOC-STRING.
  255. If the face already exists, it is unmodified."
  256.   (make-face name))
  257.  
  258. (cond
  259.  ((not (fboundp 'make-face))
  260.   (fset 'w3-make-face 'ignore))
  261.  (w3-running-xemacs
  262.   (fset 'w3-make-face 'make-face))
  263.  (t
  264.   (fset 'w3-make-face 'w3-make-face-emacs19)))
  265.  
  266. (defsubst w3-face-for-element (node)
  267.   (w3-get-all-face-info)
  268.   (if (car w3-face-text-decoration)
  269.       (set-font-style-by-keywords w3-face-font-spec
  270.                   (car w3-face-text-decoration)))
  271.   (if w3-face-font-variant
  272.       (set-font-style-by-keywords w3-face-font-spec
  273.                   (car w3-face-font-variant)))
  274.   (if w3-face-font-style
  275.       (set-font-style-by-keywords w3-face-font-spec
  276.                   (car w3-face-font-style)))
  277.   (setq w3-face-descr (list w3-face-font-spec
  278.                 (car w3-face-background-image)
  279.                 (car w3-face-color)
  280.                 (car w3-face-background-color))
  281.     w3-face-face (cdr-safe (assoc w3-face-descr w3-face-cache)))
  282.   (if (or w3-face-face (not (or (car w3-face-color)
  283.                 (car w3-face-background-image)
  284.                 (car w3-face-background-color)
  285.                 w3-face-font-spec)))
  286.       nil                ; Do nothing, we got it already
  287.     (setq w3-face-face
  288.       (w3-make-face (intern (format "w3-style-face-%05d" w3-face-index))
  289.             "An Emacs-W3 face... don't edit by hand." t)
  290.       w3-face-index (1+ w3-face-index))
  291.     (if (car w3-face-background-image)
  292.     (w3-maybe-start-background-image-download
  293.      (car w3-face-background-image) w3-face-face))
  294.     (if w3-face-font-spec
  295.     (font-set-face-font w3-face-face w3-face-font-spec))
  296.     (if (car w3-face-color)
  297.     (font-set-face-foreground w3-face-face (car w3-face-color)))
  298.     (if (car w3-face-background-color)
  299.     (font-set-face-background w3-face-face (car w3-face-background-color)))
  300.     (setq w3-face-cache (cons
  301.              (cons w3-face-descr w3-face-face)
  302.              w3-face-cache)))
  303.   w3-face-face)
  304.  
  305. (defun w3-normalize-spaces (string)
  306.   ;; nuke spaces in the middle
  307.   (while (string-match "[ \t\r\n][ \r\t\n]+" string)
  308.     (setq string (concat (substring string 0 (1+ (match-beginning 0)))
  309.              (substring string (match-end 0)))))
  310.  
  311.   ;; nuke spaces at the beginning
  312.   (if (string-match "^[ \t\r\n]+" string)
  313.       (setq string (substring string (match-end 0))))
  314.  
  315.   ;; nuke spaces at the end
  316.   (if (string-match "[ \t\n\r]+$" string)
  317.       (setq string (substring string 0 (match-beginning 0))))
  318.   string)
  319.  
  320.  
  321. (if (not (fboundp 'char-before))
  322.     (defun char-before (&optional pos)
  323.       (char-after (1- (or pos (point))))))
  324.  
  325. (defsubst w3-display-line-break (n)
  326.   (if (or
  327.        (memq (car w3-display-whitespace-stack) '(pre nowrap)) ; Been told
  328.        (= w3-last-fill-pos (point))
  329.        (> w3-last-fill-pos (point-max)))
  330.       (if (not (eq (char-before (point)) ?\n))
  331.       (setq n (1+ n))) ; at least put one line in
  332.     (let ((fill-column (max (1+ (length fill-prefix)) fill-column))
  333.       width)
  334.       (case (car w3-display-alignment-stack)
  335.     (center
  336.      (fill-region-as-paragraph w3-last-fill-pos (point))
  337.      (center-region w3-last-fill-pos (point-max)))
  338.     ((justify full)
  339.      (fill-region-as-paragraph w3-last-fill-pos (point) t))
  340.     (right
  341.      (fill-region-as-paragraph w3-last-fill-pos (point))
  342.      (goto-char w3-last-fill-pos)
  343.      (catch 'fill-exit
  344.        (while (re-search-forward ".$" nil t)
  345.          (if (>= (setq width (current-column)) fill-column)
  346.          nil            ; already justified, or error
  347.            (beginning-of-line)
  348.            (insert-char ?  (- fill-column width) t)
  349.            (end-of-line)
  350.            (if (eobp)
  351.            (throw 'fill-exit t))
  352.            (condition-case ()
  353.            (forward-char 1)
  354.          (error (throw 'fill-exit t))))))
  355.      )
  356.     (otherwise            ; Default is left justification
  357.      (fill-region-as-paragraph w3-last-fill-pos (point)))
  358.     ))
  359.     (setq n (1- n)))
  360.   (setq w3-last-fill-pos (point-max))
  361.   (insert (cond
  362.        ((<= n 0) "")
  363.        ((< n 10)
  364.         (aref w3-line-breaks-vector n))
  365.        (t
  366.         (make-string n ?\n)))))
  367.  
  368. (defsubst w3-munge-line-breaks-p ()
  369.   (eq (car w3-display-whitespace-stack) 'pre))
  370.  
  371. (defvar w3-display-nil-face (w3-make-face nil "Stub face... don't ask." t))
  372.  
  373. (defvar w3-scratch-start-point nil)
  374.  
  375. (defsubst w3-handle-string-content (string)
  376.   (setq w3-scratch-start-point (point))
  377.   (insert string)
  378.   (if (w3-munge-line-breaks-p)
  379.       (progn
  380.     (goto-char w3-scratch-start-point)
  381.     (if (not (search-forward "\n" nil t))
  382.         (subst-char-in-region w3-scratch-start-point (point-max) ?\r ?\n)
  383.       (subst-char-in-region w3-scratch-start-point (point-max) ?\r ? )))
  384.     (goto-char w3-scratch-start-point)
  385.     (while (re-search-forward
  386.         " [ \t\n\r]+\\|[\t\n\r][ \t\n\r]*"
  387.         nil 'move)
  388.       (replace-match " "))
  389.     (goto-char w3-scratch-start-point)
  390.     (if (and (memq (char-before (point)) '(?  ?\t ?\r ?\n))
  391.          (looking-at "[ \t\r\n]"))
  392.     (delete-region (point)
  393.                (progn
  394.              (skip-chars-forward " \t\r\n")
  395.              (point)))))
  396.   (goto-char (point-max))
  397.   (add-text-properties w3-scratch-start-point
  398.                (point) (list 'face w3-active-faces
  399.                      'html-stack w3-display-open-element-stack
  400.                      'start-open nil
  401.                      'end-open nil
  402.                      'front-sticky t
  403.                      'rear-nonsticky nil
  404.                      'duplicable t))
  405.   (if (car w3-active-voices)
  406.       (add-text-properties w3-scratch-start-point (point)
  407.                (list 'personality (car w3-active-voices))))
  408.   )
  409.  
  410. (defun w3-display-get-cookie (args)
  411.   (if (not (fboundp 'cookie))
  412.       "Sorry, no cookies today."
  413.     (let* ((href (or (w3-get-attribute 'href) (w3-get-attribute 'src)))
  414.        (fname (or (cdr-safe (assoc href w3-cookie-cache))
  415.               (url-generate-unique-filename "%s.cki")))
  416.        (st (or (cdr-safe (assq 'start args)) "Loading cookies..."))
  417.        (nd (or (cdr-safe (assq 'end args)) "Loading cookies... done.")))
  418.       (if (not (file-exists-p fname))
  419.       (save-excursion
  420.         (set-buffer (generate-new-buffer " *cookie*"))
  421.         (url-insert-file-contents href)
  422.         (write-region (point-min) (point-max) fname 5)
  423.         (setq w3-cookie-cache (cons (cons href fname) w3-cookie-cache))))
  424.       (cookie fname st nd))))
  425.  
  426. (defun w3-widget-echo (widget &rest ignore)
  427.   (let* ((url (widget-get widget :href))
  428.      (name (widget-get widget :name))
  429.      (text (buffer-substring-no-properties (widget-get widget :from)
  430.                            (widget-get widget :to)))
  431.      (title (widget-get widget :title))
  432.      (check w3-echo-link)
  433.      (msg nil))
  434.     (if url
  435.     (setq url (url-truncate-url-for-viewing url)))
  436.     (if name
  437.     (setq name (concat "anchor:" name)))
  438.     (if (not (listp check))
  439.     (setq check (cons check '(title url text name))))
  440.     (catch 'exit
  441.       (while check
  442.     (and (boundp (car check))
  443.          (stringp (symbol-value (car check)))
  444.          (> (length (symbol-value (car check))) 0)
  445.          (throw 'exit (symbol-value (car check))))
  446.     (pop check)))))
  447.  
  448. (defun w3-follow-hyperlink (widget &rest ignore)
  449.   (let* ((target (or (widget-get widget :target) w3-base-target))
  450.      (visited (widget-get widget :visited-face))
  451.      (href (widget-get widget :href)))
  452.     (if target (setq target (intern (downcase target))))
  453.     (if visited
  454.     (condition-case ()
  455.         (add-text-properties (widget-get widget :start)
  456.                  (widget-get widget :end)
  457.                  (list 'face visited))
  458.     (error nil)))
  459.     (case target
  460.       ((_blank external)
  461.        (w3-fetch-other-frame href))
  462.       (_top
  463.        (delete-other-windows)
  464.        (w3-fetch href))
  465.       (otherwise
  466.        (w3-fetch href target)))))
  467.  
  468. (defun w3-balloon-help-callback (object &optional event)
  469.   (let* ((widget (widget-at (extent-start-position object)))
  470.      (href (widget-get widget :href)))
  471.     (if href
  472.     (url-truncate-url-for-viewing href)
  473.       nil)))
  474.  
  475.  
  476. ;; Various macros
  477. (eval-when-compile
  478.   (defmacro w3-node-visible-p ()
  479.     (` (not (eq (car break-style) 'none))))
  480.  
  481.   (defmacro w3-handle-empty-tag ()
  482.     (`
  483.      (progn
  484.        (push (cons tag args) w3-display-open-element-stack)
  485.        (push content content-stack)
  486.        (setq content nil))))
  487.  
  488.   (defmacro w3-handle-content (node)
  489.     (`
  490.      (progn
  491.        (push (cons tag args) w3-display-open-element-stack)
  492.        (push content content-stack)
  493.        (setq content (nth 2 (, node))))))
  494.  
  495.   (defmacro w3-display-handle-list-type ()
  496.     (`
  497.      (add-text-properties
  498.       (point)
  499.       (progn
  500.     (case (car break-style)
  501.       (list-item
  502.        (let ((list-style (or (car w3-display-liststyle-stack) 'disc))
  503.          (list-num (if (car w3-display-list-stack)
  504.                    (incf (car w3-display-list-stack))
  505.                  1))
  506.          (margin (1- (car left-margin-stack)))
  507.          (indent (w3-get-style-info 'text-indent node 0)))
  508.          (if (> indent 0)
  509.          (setq margin (+ margin indent))
  510.            (setq margin (max 0 (- margin indent))))
  511.          (beginning-of-line)
  512.          (case list-style
  513.            ((disc circle square)
  514.         (insert (format (format "%%%dc" margin)
  515.                 (or (cdr-safe (assq list-style w3-bullets))
  516.                     ?o))))
  517.            ((decimal lower-roman upper-roman lower-alpha upper-alpha)
  518.         (let ((x (case list-style
  519.                (lower-roman
  520.                 (w3-decimal-to-roman list-num))
  521.                (upper-roman
  522.                 (upcase
  523.                  (w3-decimal-to-roman list-num)))
  524.                (lower-alpha
  525.                 (w3-decimal-to-alpha list-num))
  526.                (upper-alpha
  527.                 (upcase
  528.                  (w3-decimal-to-alpha list-num)))
  529.                (otherwise
  530.                 (int-to-string list-num)))))
  531.           (insert (format (format "%%%ds." margin) x))
  532.           )
  533.         )
  534.            (otherwise
  535.         (insert (w3-get-pad-string margin)))
  536.            )
  537.          )
  538.        )
  539.       (otherwise
  540.        (insert (w3-get-pad-string (+ (car left-margin-stack)
  541.                      (w3-get-style-info 'text-indent node 0)))))
  542.       )
  543.     (point))
  544.       (list 'start-open t
  545.         'end-open t
  546.         'rear-nonsticky nil
  547.         'face 'nil))))
  548.  
  549.   (defmacro w3-display-set-margins ()
  550.     (`
  551.      (progn
  552.        (push (+ (w3-get-style-info 'margin-left node 0)
  553.         (car left-margin-stack)) left-margin-stack)
  554.        (push (-
  555.           (car right-margin-stack)
  556.           (w3-get-style-info 'margin-right node 0)) right-margin-stack)
  557.        (setq fill-column (car right-margin-stack))
  558.        (w3-set-fill-prefix-length (car left-margin-stack))
  559.        (w3-display-handle-list-type))))
  560.  
  561.   (defmacro w3-display-restore-margins ()
  562.     (`
  563.      (progn
  564.        (pop right-margin-stack)
  565.        (pop left-margin-stack))))
  566.  
  567.   (defmacro w3-display-handle-break ()
  568.     (`
  569.      (case (car break-style)
  570.        (block                ; Full paragraph break
  571.     (if (eq (cadr break-style) 'list-item)
  572.         (setf (cadr break-style) 'line)
  573.       (w3-display-line-break 1))
  574.     (w3-display-set-margins)
  575.     (push
  576.      (w3-get-style-info 'white-space node
  577.                 (car w3-display-whitespace-stack))
  578.      w3-display-whitespace-stack)
  579.     (push
  580.      (or (w3-get-attribute 'foobarblatz)
  581.          (w3-get-style-info 'list-style-type node
  582.                 (car w3-display-liststyle-stack)))
  583.      w3-display-liststyle-stack)
  584.     (push
  585.      (or (w3-get-attribute 'align)
  586.          (w3-get-style-info 'text-align node
  587.                 (car w3-display-alignment-stack)))
  588.      w3-display-alignment-stack)
  589.     (and w3-do-incremental-display (w3-pause)))
  590.        ((line list-item)        ; Single line break
  591.     (w3-display-line-break 0)
  592.     (w3-display-set-margins)
  593.     (push
  594.      (or (w3-get-attribute 'foobarblatz)
  595.          (w3-get-style-info 'list-style-type node
  596.                 (car w3-display-liststyle-stack)))
  597.      w3-display-liststyle-stack)
  598.     (push
  599.      (w3-get-style-info 'white-space node
  600.                 (car w3-display-whitespace-stack))
  601.      w3-display-whitespace-stack)
  602.     (push
  603.      (w3-get-style-info 'text-align node
  604.                 (or (w3-get-attribute 'align)
  605.                 (car w3-display-alignment-stack)))
  606.      w3-display-alignment-stack))
  607.        (otherwise            ; Assume 'inline' rendering as default
  608.     nil))
  609.      )
  610.     )
  611.  
  612.   (defmacro w3-display-progress-meter ()
  613.     (`
  614.      (url-lazy-message "Drawing... %c" (aref "/|\\-" (random 4)))))
  615.     
  616.   (defmacro w3-display-handle-end-break ()
  617.     (`
  618.      (case (pop break-style)
  619.        (block                ; Full paragraph break
  620.     (w3-display-line-break 1)
  621.     (w3-display-restore-margins)
  622.     (pop w3-display-whitespace-stack)
  623.     (pop w3-display-liststyle-stack)
  624.     (pop w3-display-alignment-stack)
  625.     (and w3-do-incremental-display (w3-pause)))
  626.        ((line list-item)        ; Single line break
  627.     (w3-display-restore-margins)
  628.     (w3-display-line-break 0)
  629.     (pop w3-display-whitespace-stack)
  630.     (pop w3-display-liststyle-stack)
  631.     (pop w3-display-alignment-stack))      
  632.        (otherwise            ; Assume 'inline' rendering as default
  633.     nil))
  634.      )
  635.     )
  636.   )
  637.  
  638. ;; <link> handling
  639. (defun w3-parse-link (args)
  640.   (let* ((type (if (w3-get-attribute 'rel) 'rel 'rev))
  641.      (desc (w3-get-attribute type))
  642.      (dc-desc (and desc (downcase desc))) ; canonical case
  643.      (dest (w3-get-attribute 'href))
  644.      (plist (alist-to-plist args))
  645.      (node-1 (assq type w3-current-links))
  646.      (node-2 (and node-1 desc (or (assoc desc
  647.                          (cdr node-1))
  648.                       (assoc dc-desc
  649.                          (cdr node-1)))))
  650.      )
  651.     ;; Canonicalize the case of link types we may look for
  652.     ;; specifically (toolbar etc.) since that's done with
  653.     ;; assoc.  See `w3-mail-document-author' and
  654.     ;; `w3-link-toolbar', at least.
  655.     (if (member dc-desc w3-defined-link-types)
  656.     (setq desc dc-desc))
  657.     (if dest                ; ignore if HREF missing
  658.     (cond
  659.      (node-2            ; Add to old value
  660.       (setcdr node-2 (cons plist (cdr node-2))))
  661.      (node-1            ; first rel/rev
  662.       (setcdr node-1 (cons (cons desc (list plist))
  663.                    (cdr node-1))))
  664.      (t (setq w3-current-links
  665.           (cons (cons type (list (cons desc (list plist))))
  666.             w3-current-links)))))
  667.     (setq desc (and desc (intern dc-desc)))
  668.     (case desc
  669.       ((style stylesheet)
  670.        (if w3-honor-stylesheets
  671.        (w3-handle-style plist)))
  672.       (otherwise
  673.        )
  674.       )
  675.     )
  676.   )
  677.  
  678.  
  679. ;; Image handling
  680. (defun w3-maybe-start-image-download (widget)
  681.   (let* ((src (widget-get widget :src))
  682.      (cached-glyph (w3-image-cached-p src)))
  683.     (cond
  684.      ((and cached-glyph
  685.        (widget-glyphp cached-glyph)
  686.        (not (eq 'nothing
  687.             (condition-case ()
  688.             (image-instance-type
  689.              (glyph-image-instance cached-glyph))
  690.               (error 'nothing)))))
  691.       (setq w3-image-widgets-waiting (cons widget w3-image-widgets-waiting)))
  692.      ((or w3-delay-image-loads        ; Delaying images
  693.       (not (fboundp 'valid-specifier-domain-p)) ; Can't do images
  694.       (eq (device-type) 'tty))    ; Why bother?
  695.       (w3-add-delayed-graphic widget))
  696.      ((not (w3-image-loadable-p src nil)) ; Hey, we can't load it!
  697.       (mesage "Skipping image %s" (url-basepath src t))
  698.       (w3-add-delayed-graphic widget))
  699.      (t                    ; Grab the images
  700.       (let (
  701.         (url-request-method "GET")
  702.         (old-asynch (default-value 'url-be-asynchronous))
  703.         (url-request-data nil)
  704.         (url-request-extra-headers nil)
  705.         (url-source t)
  706.         (url-mime-accept-string (substring
  707.                      (mapconcat
  708.                       (function
  709.                        (lambda (x)
  710.                      (if x
  711.                          (concat (car x) ",")
  712.                        "")))
  713.                       w3-allowed-image-types "")
  714.                      0 -1))
  715.         (url-working-buffer (generate-new-buffer-name " *W3GRAPH*")))
  716.     (unwind-protect
  717.         (progn
  718.           (setq-default url-be-asynchronous t)
  719.           (setq w3-graphics-list (cons (cons src (make-glyph))
  720.                        w3-graphics-list))
  721.           (save-excursion
  722.         (set-buffer (get-buffer-create url-working-buffer))
  723.         (setq url-current-callback-data (list src (widget-get widget 'buffer)
  724.                               widget)
  725.               url-be-asynchronous t
  726.               url-current-callback-func 'w3-finalize-image-download)
  727.         (url-retrieve src)))
  728.       (setq-default url-be-asynchronous old-asynch)))))))
  729.  
  730. (defun w3-maybe-start-background-image-download (src face)
  731.   (let* ((cached-glyph (w3-image-cached-p src))
  732.      (buf (current-buffer)))
  733.     (cond
  734.      ((and cached-glyph
  735.        (widget-glyphp cached-glyph)
  736.        (not (eq 'nothing
  737.             (image-instance-type
  738.              (glyph-image-instance cached-glyph)))))
  739.       (set-face-background-pixmap face
  740.                   (glyph-image-instance cached-glyph) buf))
  741.      ((or (not (fboundp 'valid-specifier-domain-p)) ; Can't do images
  742.       (eq (device-type) 'tty))    ; Why bother?
  743.       nil)
  744.      ((not (w3-image-loadable-p src nil)) ; Hey, we can't load it!
  745.       (mesage "Skipping image %s" (url-basepath src t))
  746.       nil)
  747.      (t                    ; Grab the images
  748.       (let (
  749.         (url-request-method "GET")
  750.         (old-asynch (default-value 'url-be-asynchronous))
  751.         (url-request-data nil)
  752.         (url-request-extra-headers nil)
  753.         (url-source t)
  754.         (url-mime-accept-string (substring
  755.                      (mapconcat
  756.                       (function
  757.                        (lambda (x)
  758.                      (if x
  759.                          (concat (car x) ",")
  760.                        "")))
  761.                       w3-allowed-image-types "")
  762.                      0 -1))
  763.         (url-working-buffer (generate-new-buffer-name " *W3GRAPH*")))
  764.     (unwind-protect
  765.         (progn
  766.           (setq-default url-be-asynchronous t)
  767.           (setq w3-graphics-list (cons (cons src (make-glyph))
  768.                        w3-graphics-list))
  769.           (save-excursion
  770.         (set-buffer (get-buffer-create url-working-buffer))
  771.         (setq url-current-callback-data (list src buf 'background face)
  772.               url-be-asynchronous t
  773.               url-current-callback-func 'w3-finalize-image-download)
  774.         (url-retrieve src)))
  775.       (setq-default url-be-asynchronous old-asynch)))))))
  776.  
  777. (defun w3-finalize-image-download (url buffer &optional widget face)
  778.   (let ((glyph nil)
  779.     (node nil))
  780.     (message "Enhancing image...")
  781.     (setq glyph (image-normalize (cdr-safe (assoc url-current-mime-type
  782.                           w3-image-mappings))
  783.                  (buffer-string)))
  784.     (message "Enhancing image... done")
  785.     (kill-buffer (current-buffer))
  786.     (cond
  787.      ((w3-image-invalid-glyph-p glyph)
  788.       (setq glyph nil)
  789.       (message "Reading of %s failed." url))
  790.      ((eq (aref glyph 0) 'xbm)
  791.       (let ((temp-fname (url-generate-unique-filename "%s.xbm")))
  792.     (save-excursion
  793.       (set-buffer (generate-new-buffer " *xbm-garbage*"))
  794.       (erase-buffer)
  795.       (insert (aref glyph 2))
  796.       (setq glyph temp-fname)
  797.       (write-region (point-min) (point-max) temp-fname)
  798.       (kill-buffer (current-buffer)))
  799.     (setq glyph (make-glyph (list (cons 'x glyph))))
  800.     (condition-case ()
  801.         (delete-file temp-fname)
  802.       (error nil))))
  803.      (t
  804.       (setq glyph (make-glyph glyph))))
  805.     (setq node (assoc url w3-graphics-list))
  806.     (cond
  807.      ((and node glyph)
  808.       (set-glyph-image (cdr node) (glyph-image glyph)))
  809.      (glyph
  810.       (setq w3-graphics-list (cons (cons url glyph) w3-graphics-list)))
  811.      (t nil))
  812.  
  813.     (cond
  814.      ((or (not buffer)
  815.       (not (widget-glyphp glyph))
  816.       (not (buffer-name buffer)))
  817.       nil)
  818.      ((and (eq widget 'background)
  819.        w3-running-xemacs)
  820.       (set-face-background-pixmap face
  821.                   (glyph-image-instance glyph)
  822.                   buffer))
  823.      ((not (eq widget 'background))
  824.       (save-excursion
  825.     (set-buffer buffer)
  826.     (if (eq major-mode 'w3-mode)
  827.         (widget-value-set widget glyph)
  828.       (setq w3-image-widgets-waiting
  829.         (cons widget w3-image-widgets-waiting))))))))
  830.  
  831. (defcustom w3-min-img-size 15
  832.   "*Image size under which the alt string is replaced by `w3-dummy-img-alt-repl'.
  833. 15 is a bit aggressive, 5 pixels would be safer"
  834.   :group 'w3-images
  835.   :type 'integer
  836.   )
  837.  
  838. (defcustom w3-dummy-img-re
  839.   "\\b\\(boule\\|bullet\\|dot\\|pebble[0-9]*[a-z]?[0-9]*\\|pixel\\)\\b"
  840.   "Image name regexp for which the alt string is replaced by `w3-dummy-img-alt-repl'."
  841.   :group 'w3-images
  842.   :type 'regexp)
  843.  
  844. (defcustom w3-dummy-img-alt-repl "* "
  845.   "*Dummy image alt string replacement."
  846.   :group 'w3-images
  847.   :type 'string)  
  848.  
  849. (defun w3-default-image-alt-func (fname)
  850.   ;; Assumes height/width bound by calling function
  851.   (declare (special height width))
  852.   (if (or (and (stringp height)
  853.            (< (string-to-int height) w3-min-img-size))
  854.       (and (stringp width)
  855.            (< (string-to-int width) w3-min-img-size))
  856.       (string-match w3-dummy-img-re fname))
  857.       w3-dummy-img-alt-repl
  858.     (concat "[" (file-name-sans-extension fname) "]")))
  859.  
  860. (defmacro w3-image-alt (src)
  861.   (`
  862.    (let* ((doc-alt (w3-get-attribute 'alt))
  863.       (alt (or (and doc-alt
  864.             (not (string-equal doc-alt ""))
  865.             doc-alt)
  866.            (cond
  867.             ((null w3-auto-image-alt) "")
  868.             ((eq t w3-auto-image-alt)
  869.              (concat "[IMAGE(" (url-basepath src t) ")] "))
  870.             ((stringp w3-auto-image-alt)
  871.              (format w3-auto-image-alt (url-basepath src t)))
  872.             ((functionp w3-auto-image-alt)
  873.              (funcall w3-auto-image-alt (url-basepath src t))))))
  874.       c)
  875.      (while (setq c (string-match "[\C-i\C-j\C-l\C-m]" alt))
  876.        (aset alt c ? ))
  877.      alt)))
  878.  
  879. (defmacro w3-handle-image ()
  880.   (`
  881.    (let* ((height (w3-get-attribute 'height))
  882.       (width (w3-get-attribute 'width))
  883.       (src (or (w3-get-attribute 'src) "Error Image"))
  884.       (alt (w3-image-alt src))
  885.       (ismap (and (assq 'ismap args) 'ismap))
  886.       (usemap (w3-get-attribute 'usemap))
  887.       (base (w3-get-attribute 'base))
  888.       (href (and hyperlink-info (cadr (widget-plist-member (cadr hyperlink-info) :href))))
  889.       (target (and hyperlink-info (cadr (widget-plist-member (cadr hyperlink-info) :target))))
  890.       (widget nil)
  891.       (align (or (w3-get-attribute 'align)
  892.              (w3-get-style-info 'vertical-align node)))
  893.       (face w3-active-faces))
  894.      (if (assq '*table-autolayout w3-display-open-element-stack)
  895.      (insert alt)
  896.        (setq hyperimage-info
  897.          (list (point)
  898.            (list 'image
  899.              :src src       ; Where to load the image from
  900.              'alt alt       ; Textual replacement
  901.              'ismap ismap       ; Is it a server-side map?
  902.              'usemap usemap       ; Is it a client-side map?
  903.              :href href       ; Hyperlink destination
  904.              :target target       ; target frame
  905.              :button-face face ; img:link or img:visited entry in stylesheet
  906.              )))
  907.        (setq widget (apply (function widget-create) (cadr hyperimage-info)))
  908.        (widget-put widget 'buffer (current-buffer))
  909.        ;;(w3-maybe-start-image-download widget) ; in w3-resurrect-images
  910.        (if (widget-get widget :from)
  911.        (add-text-properties (widget-get widget :from)
  912.                 (widget-get widget :to)
  913.                 (list 'html-stack w3-display-open-element-stack)))
  914.        (goto-char (point-max))))))
  915.  
  916. ;; The table handling
  917. (eval-and-compile
  918.   (case mule-sysdep-version
  919.     (xemacs
  920.      (if (not (find-charset 'w3-dingbats))
  921.      (make-charset 'w3-dingbats "Dingbats character set for Emacs/W3"
  922.                '(registry "" dimension 1 chars 96 final ?:))))
  923.     ((3.0 3.1)
  924.      (if (not (charsetp 'w3-dingbats))
  925.      (define-charset nil 'w3-dingbats
  926.        (vector
  927.         1                ; dimension
  928.         96                ; chars
  929.         1                ; width
  930.         1                ; direction
  931.         ?:                ; iso-final-char
  932.         0                ; iso-graphic-plane (whats this?)
  933.         "dingbats" "emacs/w3-dingbats"
  934.         "Dingbats character set for Emacs/W3"))))
  935.     (t
  936.      nil)))
  937.  
  938. (defun w3-make-char (oct)
  939.   (case mule-sysdep-version
  940.     (xemacs 
  941.      (make-char 'w3-dingbats (if (characterp oct) (char-int oct) oct)))
  942.     ((3.0 3.1)
  943.      (make-char 'w3-dingbats oct))
  944.     (t
  945.      oct)))
  946.  
  947. (defvar w3-table-ascii-border-chars
  948.   [nil  nil  nil  ?+ nil  ?- ?+ ?- nil ?+ ?| ?| ?+ ?- ?| ?+]
  949.   "*Vector of ascii characters to use to draw table borders.
  950. This vector is used when terminal characters are unavailable")
  951.  
  952. (defvar w3-table-glyph-border-chars
  953.   [nil  nil  nil  11 nil  2 7 14 nil 3 8 6 1 15 4 5]
  954.   "Vector of characters to use to draw table borders.
  955. This vector is used when terminal characters are used via glyphs")
  956.  
  957. (defvar w3-table-graphic-border-chars
  958.   (vector
  959.    nil
  960.    nil
  961.    nil
  962.    (w3-make-char ?j)
  963.    nil
  964.    (w3-make-char ?q)
  965.    (w3-make-char ?m)
  966.    (w3-make-char ?v)
  967.    nil
  968.    (w3-make-char ?k)
  969.    (w3-make-char ?x)
  970.    (w3-make-char ?u)
  971.    (w3-make-char ?l)
  972.    (w3-make-char ?w)
  973.    (w3-make-char ?t)
  974.    (w3-make-char ?n))
  975.   "Vector of characters to use to draw table borders.
  976. This vector is used when terminal characters are used directly")
  977.  
  978. (defvar w3-table-border-chars w3-table-ascii-border-chars
  979.   "Vector of characters to use to draw table borders.
  980. w3-setup-terminal-chars sets this to one of 
  981. w3-table-ascii-border-chars, 
  982. w3-table-glyph-border-chars, or
  983. w3-table-graphic-border-chars.")
  984.  
  985. (defsubst w3-table-lookup-char (l u r b &optional char)
  986.   (or char (aref w3-table-border-chars (logior (if l 1 0)
  987.                            (if u 2 0)
  988.                            (if r 4 0)
  989.                            (if b 8 0)))))
  990.  
  991. (defvar w3-terminal-properties nil)
  992.  
  993. (defsubst w3-insert-terminal-char (character &optional count inherit)
  994.   (if w3-terminal-properties
  995.       (set-text-properties (point)
  996.                (progn
  997.                  (insert-char (or character ? )
  998.                       (or count 1) inherit)
  999.                  (point))
  1000.                w3-terminal-properties)
  1001.     (insert-char (or character ? ) (or count 1) inherit)))
  1002.  
  1003. (defsubst w3-horizontal-rule-char ()
  1004.   (w3-table-lookup-char t nil t nil w3-horizontal-rule-char))
  1005.  
  1006. (defun w3-setup-terminal-chars ()
  1007.   "Try to find the best set of characters to draw table borders with.
  1008. On a console, this can trigger some Emacs display bugs.
  1009.  
  1010. Initializes a number of variables:
  1011. w3-terminal-properties to either nil or a list of properties including 'face
  1012. w3-table-border-chars to one of the the three other vectors"
  1013.   (interactive)
  1014.   (setq w3-table-border-chars w3-table-ascii-border-chars
  1015.     w3-terminal-properties nil)
  1016.   (cond
  1017.    ((and w3-use-terminal-characters
  1018.      (eq (device-type) 'x))
  1019.     (if (and (find-face 'w3-table-hack-x-face)
  1020.          (face-differs-from-default-p 'w3-table-hack-x-face))
  1021.     nil
  1022.       (make-face 'w3-table-hack-x-face)
  1023.       (if (not (face-differs-from-default-p 'w3-table-hack-x-face))
  1024.       (font-set-face-font 'w3-table-hack-x-face
  1025.                   (make-font :family "terminal"
  1026.                      :registry "*"
  1027.                      :encoding "*"
  1028.                      ))))
  1029.     (cond
  1030.      ((not (face-differs-from-default-p 'w3-table-hack-x-face))
  1031.       nil)
  1032.      ((and w3-use-terminal-glyphs (fboundp 'face-id))
  1033.       (let ((id (face-id 'w3-table-hack-x-face))
  1034.         (c (length w3-table-border-chars)))
  1035.     (while (> (decf c) 0)
  1036.       (if (aref w3-table-glyph-border-chars c)
  1037.           (aset standard-display-table (aref w3-table-glyph-border-chars c)
  1038.             (vector (+ (* 256 id)
  1039.                    (aref w3-table-graphic-border-chars c))))))
  1040.     (setq w3-table-border-chars w3-table-glyph-border-chars
  1041.           w3-terminal-properties nil)))
  1042.      (t 
  1043.       (setq w3-table-border-chars w3-table-graphic-border-chars
  1044.         w3-terminal-properties (list 'start-open t
  1045.                      'end-open t
  1046.                      'rear-nonsticky t
  1047.                      'w3-table-border t
  1048.                      'face 'w3-table-hack-x-face)))))
  1049.    ((and w3-use-terminal-characters-on-tty
  1050.      (eq (device-type) 'tty))
  1051.     (let ((c (length w3-table-border-chars)))
  1052.       (while (> (decf c) 0)
  1053.     (and (aref w3-table-glyph-border-chars c)
  1054.          (aref w3-table-graphic-border-chars c)
  1055.          (standard-display-g1 (aref w3-table-glyph-border-chars c)
  1056.                   (aref w3-table-graphic-border-chars c)))))
  1057.     (setq w3-table-border-chars w3-table-glyph-border-chars
  1058.       w3-terminal-properties (list 'w3-table-border t)))
  1059.    (t
  1060.     nil))
  1061.   w3-table-border-chars)
  1062.  
  1063. (defun w3-unsetup-terminal-characters nil
  1064.   (interactive)
  1065.   (w3-excise-terminal-characters (buffer-list))
  1066.   (standard-display-default 1 15)
  1067.   (setq w3-table-border-chars w3-table-ascii-border-chars))
  1068.  
  1069. (defun w3-excise-terminal-characters (buffs)
  1070.   "Replace hacked characters with ascii characters in buffers BUFFS.
  1071. Should be run before restoring w3-table-border-chars to ascii characters.
  1072. This will only work if we used glyphs rather than text properties"
  1073.   (interactive (list (list (current-buffer))))
  1074.   (let ((inhibit-read-only t)
  1075.     (tr (make-string 16 ? ))
  1076.     (i 0))
  1077.     (while (< i (length tr))
  1078.       (aset tr i i)
  1079.       (setq i (1+ i)))
  1080.     (setq i 0)
  1081.     (while (< i (length w3-table-border-chars))
  1082.       (and (aref w3-table-border-chars i)
  1083.        (< (aref w3-table-border-chars i) 16)
  1084.        (aset tr 
  1085.          (aref w3-table-glyph-border-chars i)
  1086.          (aref w3-table-ascii-border-chars i)))
  1087.       (setq i (1+ i)))
  1088.     (mapcar (function (lambda (buf)
  1089.             (save-excursion
  1090.               (set-buffer buf)
  1091.               (if (eq major-mode 'w3-mode)
  1092.                   (translate-region (point-min)
  1093.                         (point-max)
  1094.                         tr)))))
  1095.         buffs)))
  1096.  
  1097.  
  1098. (defvar w3-display-table-cut-words-p nil
  1099.   "*Whether to cut words that are oversized in table cells")
  1100.   
  1101. (defvar w3-display-table-force-borders nil
  1102.   "*Whether to always draw table borders
  1103. Can sometimes make the structure of a document clearer")
  1104.  
  1105. (defun w3-display-table-cut ()
  1106.   (save-excursion
  1107.     (goto-char (point-min))
  1108.     (let ((offset -1))
  1109.       (while (< offset 0)
  1110.       (end-of-line)
  1111.       (setq offset (- fill-column (current-column)))
  1112.       (cond ((< offset 0)
  1113.              (condition-case nil
  1114.              (progn (forward-char offset)
  1115.                 (insert ?\n))
  1116.           (error (setq offset 0))))
  1117.             ((not (eobp))
  1118.              (forward-line 1)
  1119.              (setq offset -1)))))))
  1120.  
  1121.  
  1122. (defun w3-display-fix-widgets ()
  1123.   ;; Make markers belong to the right buffer
  1124.   (save-excursion
  1125.     (let ((st (point-min))
  1126.        (nd nil)
  1127.       (widget nil) parent
  1128.        (to-marker nil)
  1129.        (from-marker nil))
  1130.       (while (setq st (next-single-property-change st 'button))
  1131.      (setq nd (or (next-single-property-change st 'button) (point-max))
  1132.            widget (widget-at st)
  1133.            to-marker (and widget (widget-get widget :to))
  1134.            from-marker (and widget (widget-get widget :from))
  1135.            parent (and widget (widget-get widget :parent))
  1136.            )
  1137.     (if (not widget)
  1138.         nil
  1139.       (widget-put widget :from (set-marker (make-marker) st))
  1140.       (widget-put widget :to   (set-marker (make-marker) nd))
  1141.       (if (not parent)
  1142.           nil
  1143.         (widget-put parent :from (set-marker (make-marker) st))
  1144.         (widget-put parent :to   (set-marker (make-marker) nd))))
  1145.      (if (condition-case ()
  1146.          (get-text-property (1+ nd) 'button)
  1147.            (error nil))
  1148.          (setq st nd)
  1149.        (setq st (min (point-max) (1+ nd))))))))
  1150.  
  1151. (defun w3-size-of-tree (tree minmax)
  1152.   (declare (special args))
  1153.   (save-excursion
  1154.     (save-restriction
  1155.       (narrow-to-region (point) (point))
  1156.       ;; XXX fill-column set to 1 fails when fill-prefix is set
  1157.       ;; XXX setting fill-column at all isn't really right
  1158.       ;; for example <hr>s shouldn't be especially wide
  1159.       ;; we should set a flag that makes w3 never wrap a line
  1160.       (let ((fill-column (cond ((eq minmax 'min)
  1161.                 3)
  1162.                    ((eq minmax 'max)
  1163.                 400))) 
  1164.         (fill-prefix "")
  1165.         (w3-last-fill-pos (point-min))
  1166.         a retval
  1167.         (w3-do-incremental-display nil)
  1168.         (hr-regexp  (concat "^"
  1169.                 (regexp-quote 
  1170.                  (make-string 5 (w3-horizontal-rule-char)))
  1171.                 "*$"))
  1172.         )
  1173.     ;;(push 'left  w3-display-alignment-stack)
  1174.     (push (if (eq minmax 'max) 'nowrap) w3-display-whitespace-stack)
  1175.     (while tree
  1176.       (push (cons '*td args) w3-display-open-element-stack)
  1177.       (w3-display-node (pop tree)))
  1178.     (pop w3-display-whitespace-stack)
  1179.     (goto-char (point-min))
  1180.     (while (re-search-forward hr-regexp nil t)
  1181.       (replace-match "" t t))
  1182.     (goto-char (point-min))
  1183.     (while (not (eobp))
  1184.       ;; loop invariant: at beginning of uncounted line
  1185.       (end-of-line)
  1186.       (skip-chars-backward " ")
  1187.       (setq retval (cons (current-column)
  1188.                  retval))
  1189.       (beginning-of-line 2))
  1190.     (if (= (point-min) (point-max))
  1191.         (setq retval 0)
  1192.       (setq retval (apply 'max (cons 0 retval))))
  1193.     (delete-region (point-min) (point-max))
  1194.     retval))))
  1195.  
  1196. (defun w3-display-table-dimensions (node)
  1197.   ;; fill-column sets maximum width
  1198.   (declare (special args))
  1199.   (let (min-vector
  1200.     max-vector
  1201.     rows cols
  1202.     ;;(w3-form-elements (and (boundp 'w3-form-elements) w3-form-elements))
  1203.     (table-info (assq 'w3-table-info (cadr node)))) 
  1204.     
  1205.     (if table-info 
  1206.     (setq min-vector (nth 1 table-info)
  1207.           max-vector (nth 2 table-info)
  1208.           rows       (nth 3 table-info)
  1209.           cols       (nth 4 table-info))
  1210.  
  1211.       (push (cons '*table-autolayout args) w3-display-open-element-stack)
  1212.       (let (content
  1213.         cur
  1214.         (table-spans (list nil))    ; don't make this '(nil) 
  1215.         ptr
  1216.         col
  1217.         constraints
  1218.         
  1219.         colspan rowspan min max)
  1220.     (setq content (nth 2 node))
  1221.     (setq rows 0 cols 0)
  1222.     (while content
  1223.       (setq cur (pop content))
  1224.       (if (stringp cur)
  1225.           nil
  1226.         (case (car cur)
  1227.           ((thead tfoot col colgroup)
  1228.            (if (nth 2 cur)
  1229.            (setq content (append (nth 2 cur) content))))
  1230.           (tr
  1231.            (setq col 0)
  1232.            (setq rows (1+ rows))
  1233.            (setq ptr table-spans)
  1234.            (mapcar
  1235.         (function
  1236.          (lambda (td)
  1237.            (setq colspan (string-to-int (or (cdr-safe (assq 'colspan (nth 1 td))) "1"))
  1238.              rowspan (string-to-int (or (cdr-safe (assq 'rowspan (nth 1 td))) "1"))
  1239.              min  (w3-size-of-tree  (nth 2 td) 'min)
  1240.              max  (w3-size-of-tree  (nth 2 td) 'max)
  1241.              )
  1242.            (while (eq (car-safe (car-safe (cdr ptr))) col)
  1243.              (setq col (+ col (cdr (cdr (car (cdr ptr))))))
  1244.              (if (= 0 (decf (car (cdr (car (cdr ptr))))))
  1245.              (pop (cdr ptr))
  1246.                (setq ptr (cdr ptr))))
  1247.            (push (list col colspan min max)
  1248.              constraints)
  1249.            (if (= rowspan 1) nil
  1250.              (push (cons col (cons (1- rowspan) colspan)) (cdr ptr))
  1251.              (setq ptr (cdr ptr)))
  1252.            (setq col (+ col colspan))
  1253.            ))
  1254.         (nth 2 cur))
  1255.            (while (cdr ptr)
  1256.          (if (= 0 (decf (car (cdr (car (cdr ptr))))))
  1257.              (pop (cdr ptr))
  1258.            (setq ptr (cdr ptr))))
  1259.            (setq cols (max cols col))
  1260.            )
  1261.           (caption
  1262.            nil)
  1263.           (otherwise
  1264.            (setq content (nth 2 cur)))
  1265.           )
  1266.         )
  1267.       )
  1268.     (setq constraints (sort constraints
  1269.                 (function
  1270.                  (lambda (a b)
  1271.                    (< (cadr a) (cadr b)))))
  1272.           min-vector (make-vector cols 0)
  1273.           max-vector (make-vector cols 0))
  1274.     (let (start end i mincellwidth maxcellwidth)
  1275.       (mapcar (function (lambda (c)
  1276.                   (cond ((= (cadr c) 1) 
  1277.                      (aset min-vector (car c) 
  1278.                        (max (aref min-vector (car c))
  1279.                         (nth 2 c)))
  1280.                      (aset max-vector (car c) 
  1281.                        (max (aref max-vector (car c))
  1282.                         (nth 3 c))))
  1283.                     (t 
  1284.                      (setq start (car c)
  1285.                        end (+ (car c) (cadr c))
  1286.                        mincellwidth 0
  1287.                        maxcellwidth 0
  1288.                        i start)
  1289.                      (while (< i end)
  1290.                        (setq mincellwidth (+ mincellwidth
  1291.                                  (aref min-vector i))
  1292.                          maxcellwidth (+
  1293.                                maxcellwidth
  1294.                                (aref max-vector i))
  1295.                          i (1+ i)))
  1296.                      (setq i start)
  1297.                      (if (= mincellwidth 0)
  1298.                      ;; if existing width is 0 divide evenly
  1299.                      (while (< i end)
  1300.                        (aset min-vector i
  1301.                          (/ (nth 2 c) (cadr c)))
  1302.                        (aset max-vector i
  1303.                          (/ (nth 3 c) (cadr c)))
  1304.                        (setq i (1+ i)))
  1305.                        ;; otherwise weight it by existing widths
  1306.                        (while (< i end)
  1307.                      (aset min-vector i
  1308.                            (max (aref min-vector i)
  1309.                             (/ (* (nth 2 c)
  1310.                               (aref min-vector i))
  1311.                                mincellwidth)))
  1312.                      (aset max-vector i
  1313.                            (max (aref max-vector i)
  1314.                             (/ (* (nth 3 c)
  1315.                               (aref max-vector i))
  1316.                                maxcellwidth)))
  1317.                      (setq i (1+ i))))
  1318.                      ))))
  1319.           constraints)))
  1320.       (push (cons 'w3-table-info
  1321.           (list min-vector max-vector rows cols))
  1322.         (cadr node))
  1323.       (pop w3-display-open-element-stack))
  1324.     
  1325.     (let (max-width
  1326.       min-width 
  1327.       ret-vector
  1328.       col
  1329.       )
  1330.     
  1331.  
  1332.       (setq max-width (apply '+ (append max-vector (list cols 1))))
  1333.       (setq min-width (apply '+ (append min-vector (list cols 1))))
  1334.  
  1335.       ;; the comments in the cond are excerpts from rfc1942 itself
  1336.       (cond 
  1337.        ;;   1.  The minimum table width is equal to or wider than the available
  1338.        ;;       space. In this case, assign the minimum widths and allow the
  1339.        ;;       user to scroll horizontally. For conversion to braille, it will
  1340.        ;;       be necessary to replace the cells by references to notes
  1341.        ;;       containing their full content. By convention these appear
  1342.        ;;       before the table.
  1343.        ((>= min-width fill-column)
  1344.     (setq ret-vector min-vector))
  1345.      
  1346.        ;;   2.  The maximum table width fits within the available space. In
  1347.        ;;       this case, set the columns to their maximum widths.
  1348.        ((<= max-width fill-column)
  1349.     (setq ret-vector max-vector))
  1350.      
  1351.        ;;   3.  The maximum width of the table is greater than the available
  1352.        ;;       space, but the minimum table width is smaller. In this case,
  1353.        ;;       find the difference between the available space and the minimum
  1354.        ;;       table width, lets call it W. Lets also call D the difference
  1355.        ;;       between maximum and minimum width of the table.
  1356.      
  1357.        ;;       For each column, let d be the difference between maximum and
  1358.        ;;       minimum width of that column. Now set the column's width to the
  1359.        ;;       minimum width plus d times W over D. This makes columns with
  1360.        ;;       large differences between minimum and maximum widths wider than
  1361.        ;;       columns with smaller differences.
  1362.        (t
  1363.     (setq ret-vector (make-vector cols 0))
  1364.     (let ((W (- fill-column min-width))
  1365.           (D (- max-width min-width))
  1366.           d extra)
  1367.       (setq col 0)
  1368.       (while (< col (length ret-vector))
  1369.         (setq d (- (aref max-vector col)
  1370.                (aref min-vector col)))
  1371.         (aset ret-vector col 
  1372.           (+ (aref min-vector col)
  1373.              (/ (* d W) D)))
  1374.         (setq col (1+ col)))
  1375.       (setq extra (- fill-column
  1376.              (apply '+ (append ret-vector
  1377.                        (list (length ret-vector) 1))))
  1378.         col 0)
  1379.       (while (and (< col (length ret-vector)) (> extra 0))
  1380.         (if (= 1 (- (aref max-vector col) (aref ret-vector col) ))
  1381.         (aset ret-vector col (1+ (aref ret-vector col))))
  1382.         (setq extra (1- extra)
  1383.           col (1+ col)))
  1384.       )))
  1385.       (list rows cols ret-vector))))
  1386.  
  1387. (defun w3-display-table (node)
  1388.   (let* ((dimensions (w3-display-table-dimensions node))
  1389.      (num-cols (max (cadr dimensions) 1))
  1390.      (num-rows (max (car dimensions) 1))
  1391.      (column-dimensions (caddr dimensions))
  1392.      (table-width (apply '+ (append column-dimensions (list num-cols 1)))))
  1393.     (cond
  1394.      ((or (<= (cadr dimensions) 0) (<= (car dimensions) 0))
  1395.       ;; We have an invalid table
  1396.       nil)
  1397.      ((assq '*table-autolayout w3-display-open-element-stack)
  1398.       ;; don't bother displaying the table if all we really need is the size
  1399.       (progn (insert-char ?T table-width) (insert "\n")))
  1400.      (t
  1401.       (let* ((tag  (nth 0 node))
  1402.          (args (nth 1 node))
  1403.          (border-node (cdr-safe (assq 'border args)))
  1404.          (border-char
  1405.           (unless (or w3-display-table-force-borders
  1406.               (and border-node
  1407.                    (or (/= 0 (string-to-int border-node))
  1408.                    (string= "border" border-node))))
  1409.         ? ))
  1410.  
  1411.          valign align 
  1412.          (content (nth 2 node))
  1413.          (avgwidth (/ (- fill-column num-cols num-cols) num-cols))
  1414.          (formatted-cols (make-vector num-cols nil))
  1415.          (table-rowspans (make-vector num-cols 0))
  1416.          (table-colspans (make-vector num-cols 1))
  1417.          (prev-colspans  (make-vector num-cols 0))
  1418.          (prev-rowspans  (make-vector num-cols 0))
  1419.          (table-colwidth (make-vector num-cols 0))
  1420.          (fill-prefix "")
  1421.          (height nil)
  1422.          (cur-height nil)
  1423.          (cols nil)
  1424.          (rows nil)
  1425.          (row 0)
  1426.          (this-rectangle nil)
  1427.          (inhibit-read-only t)
  1428.          (i 0)
  1429.          )
  1430.  
  1431.     (push (cons tag args) w3-display-open-element-stack)
  1432.  
  1433.     (if (memq 'nowrap w3-display-whitespace-stack)
  1434.         (setq fill-prefix "")
  1435.       (case (car w3-display-alignment-stack)
  1436.         (center
  1437.          (w3-set-fill-prefix-length
  1438.           (max 0 (/ (- fill-column table-width) 2))))
  1439.         (right
  1440.          (w3-set-fill-prefix-length
  1441.           (max 0 (- fill-column table-width))))
  1442.         (t
  1443.          (setq fill-prefix ""))))
  1444.     (while content
  1445.       (case (caar content)
  1446.         ((thead tfoot col colgroup)
  1447.          (if (nth 2 (car content))
  1448.          (setq content (append (nth 2 (car content)) (cdr content)))
  1449.            (setq content (cdr content))))
  1450.         (tr
  1451.          (setq w3-display-css-properties (css-get
  1452.                           (nth 0 (car content))
  1453.                           (nth 1 (car content))
  1454.                           w3-current-stylesheet
  1455.                           w3-display-open-element-stack))
  1456.          (setq cols (nth 2 (car content))
  1457.            valign (or (cdr-safe (assq 'valign (nth 1 (car content))))
  1458.                   (w3-get-style-info 'vertical-align node))
  1459.            align  (or (cdr-safe (assq 'align  (nth 1 (car content))))
  1460.                   (w3-get-style-info 'text-align node))
  1461.            content (cdr content)
  1462.            row (1+ row))
  1463.          (if (and valign (stringp valign))
  1464.          (setq valign (intern (downcase valign))))
  1465.          ;; this is iffy
  1466.          ;;(if align (push (intern (downcase align)) w3-display-alignment-stack))
  1467.          (save-excursion
  1468.            (save-restriction
  1469.          (narrow-to-region (point) (point))
  1470.          (setq fill-column avgwidth
  1471.                w3-last-fill-pos (point-min)
  1472.                i 0)
  1473.          ;; skip over columns that have leftover content
  1474.          (while (and (< i num-cols)
  1475.                  (/= 0 (aref table-rowspans i)))
  1476.            (setq i (+ i (max 1 (aref table-colspans i)))))
  1477.          ;; Need to push the properties for the table onto the stack
  1478.          (setq w3-display-css-properties (css-get
  1479.                           tag
  1480.                           args
  1481.                           w3-current-stylesheet
  1482.                           w3-display-open-element-stack))
  1483.          (push (w3-face-for-element (list tag args nil)) w3-active-faces)
  1484.          (push (w3-voice-for-element (list tag args nil)) w3-active-voices)
  1485.          (push (cons tag args) w3-display-open-element-stack)
  1486.          (while cols
  1487.            ;; And need to push these bogus placeholders on there
  1488.            ;; so that w3-display-node doesn't pop off the real face
  1489.            ;; or voice we just put in above.
  1490.            (push nil w3-active-faces)
  1491.            (push nil w3-active-voices)
  1492.            (let* ((node (car cols))
  1493.               (attributes (nth 1 node))
  1494.               (colspan (string-to-int
  1495.                     (or (cdr-safe (assq 'colspan attributes))
  1496.                     "1")))
  1497.               (rowspan (string-to-int
  1498.                     (or (cdr-safe (assq 'rowspan attributes))
  1499.                     "1")))
  1500.               fill-column column-width
  1501.               (fill-prefix "")
  1502.               (w3-do-incremental-display nil)
  1503.               (indent-tabs-mode nil)
  1504.               c e
  1505.               )
  1506.  
  1507.              (aset table-colspans i colspan)
  1508.              (aset table-rowspans i rowspan)
  1509.  
  1510.              (setq fill-column 0)
  1511.              (setq c i
  1512.                e (+ i colspan))
  1513.              (while (< c e)
  1514.                (setq fill-column (+ fill-column 
  1515.                         (aref column-dimensions c)
  1516.                         1)
  1517.                  c (1+ c)))
  1518.              (setq fill-column (1- fill-column))
  1519.              (aset table-colwidth i fill-column)
  1520.  
  1521.              (setq w3-last-fill-pos (point-min))
  1522.              (push (cons (nth 0 node) (nth 1 node))
  1523.                w3-display-open-element-stack)
  1524.              (w3-display-node node)
  1525.              (setq fill-column (aref table-colwidth i))
  1526.              (if w3-display-table-cut-words-p
  1527.              (w3-display-table-cut))
  1528.              (setq cols (cdr cols))
  1529.              (goto-char (point-min))
  1530.              (skip-chars-forward "\t\n\r")
  1531.              (beginning-of-line)
  1532.              (delete-region (point-min) (point))
  1533.              (goto-char (point-max))
  1534.              (skip-chars-backward " \t\n\r")
  1535.              (delete-region (point) (point-max))
  1536.              (if (>= fill-column (current-column))
  1537.              (insert-char ?  (- fill-column (current-column)) t))
  1538.              (goto-char (point-min))
  1539.              ;; This gets our text properties out to the
  1540.              ;; end of lines for table rows/cells with backgrounds
  1541.              (while (not (eobp))
  1542.                (re-search-forward "$" nil t)
  1543.                (if (>= fill-column (current-column))
  1544.                (insert-char ?  (- fill-column (current-column)) t))
  1545.                (or (eobp) (forward-char 1)))
  1546.              (aset formatted-cols i (extract-rectangle (point-min) (point-max)))
  1547.              (delete-region (point-min) (point-max))
  1548.              (let ((j (1- colspan)))
  1549.                (while (> j 0)
  1550.              (aset table-colspans (+ i j) 0)
  1551.              (setq j (1- j))))        
  1552.              (setq i (+ i colspan))
  1553.              ;; skip over columns that have leftover content
  1554.              (while (and (< i num-cols)
  1555.                  (/= 0 (aref table-rowspans i)))
  1556.                (setq i (+ i (max 1 (aref table-colspans i)))))
  1557.              ))
  1558.          (pop w3-display-open-element-stack)
  1559.          (pop w3-active-faces)
  1560.          (pop w3-active-voices)
  1561.          (w3-pop-all-face-info)
  1562.          ;; finish off the columns
  1563.          (while (< i num-cols)
  1564.            (aset table-colwidth i (aref column-dimensions i))
  1565.            (aset table-colspans i 1)
  1566.            (setq i (1+ i))
  1567.            (while (and (< i num-cols)
  1568.                    (/= 0 (aref table-rowspans i)))
  1569.              (setq i (+ i (max 1 (aref table-colspans i))))))
  1570.  
  1571.          ;; on the last row empty any pending rowspans per the rfc
  1572.          (if content nil
  1573.            (fillarray table-rowspans 1)) 
  1574.  
  1575.          ;; Find the tallest rectangle that isn't a rowspanning cell
  1576.          (setq height 0 
  1577.                i 0)
  1578.          (while (< i num-cols)
  1579.            (if (= 1 (aref table-rowspans i))
  1580.                (setq height (max height (length (aref formatted-cols i)))))
  1581.            (setq i (+ i (max 1 (aref table-colspans i)))))
  1582.  
  1583.          ;; Make all rectangles the same height
  1584.          (setq i 0)
  1585.          (while (< i num-cols)
  1586.            (setq this-rectangle (aref formatted-cols i))
  1587.            (if (> height (length this-rectangle))
  1588.                (let ((colspan-fill-line
  1589.                   (make-string (abs (aref table-colwidth i)) ? )))
  1590.              (case valign
  1591.                ((center middle)
  1592.                 (aset formatted-cols i
  1593.                   (append (make-list (/ (- height (length this-rectangle)) 2) 
  1594.                              colspan-fill-line)
  1595.                       this-rectangle)))
  1596.                (bottom
  1597.                 (aset formatted-cols i 
  1598.                   (append (make-list (- height (length this-rectangle))
  1599.                              colspan-fill-line)
  1600.                       this-rectangle))))))
  1601.            (setq i (+ i (max 1 (aref table-colspans i)))))))
  1602.          
  1603.  
  1604.          ;; fix broken colspans (this should only matter on illegal tables)
  1605.          (setq i 0)
  1606.          (while (< i num-cols)
  1607.            (if (= (aref table-colspans i) 0)
  1608.            (aset table-colspans i 1))
  1609.            (setq i (+ i (aref table-colspans i))))
  1610.  
  1611.          ;; Insert a separator 
  1612.          (insert fill-prefix)
  1613.          (setq i 0)
  1614.          (let (rflag bflag tflag lflag)
  1615.            (while (< i num-cols)
  1616.  
  1617.          (setq rflag (= (aref prev-rowspans i) 0)
  1618.                bflag (/= (aref table-colspans i) 0)
  1619.                tflag (/= (aref prev-colspans  i) 0))
  1620.          (w3-insert-terminal-char
  1621.           (w3-table-lookup-char lflag tflag rflag bflag border-char))
  1622.          (setq lflag t)
  1623.          (cond ((= (aref prev-rowspans i) 0)
  1624.             (w3-insert-terminal-char
  1625.              (w3-table-lookup-char t nil t nil border-char) 
  1626.              (aref column-dimensions i))
  1627.             (setq i (1+ i)))
  1628.                ((car (aref formatted-cols i))
  1629.             (insert (pop (aref formatted-cols i)))
  1630.             (setq lflag nil)
  1631.             (setq i (+ i (max (aref table-colspans i)
  1632.                       (aref prev-colspans  i) 1))))
  1633.                (t
  1634.             (insert-char ?  (aref table-colwidth i) t)
  1635.             (setq lflag nil)
  1636.             (setq i (+ i (max (aref table-colspans i)
  1637.                       (aref prev-colspans  i) 1))))))
  1638.            (w3-insert-terminal-char (w3-table-lookup-char lflag (/= row 1) nil t border-char))
  1639.            (insert "\n"))
  1640.          
  1641.          ;; recalculate height (in case we've shortened a rowspanning cell
  1642.          (setq height 0 
  1643.            i 0)
  1644.          (while (< i num-cols)
  1645.            (if (= 1 (aref table-rowspans i))
  1646.            (setq height (max height (length (aref formatted-cols i)))))
  1647.            (setq i (+ i (max 1 (aref table-colspans i)))))
  1648.  
  1649.          ;; Insert a row back in original buffer
  1650.          (while (> height 0)
  1651.            (insert fill-prefix)
  1652.            (w3-insert-terminal-char (w3-table-lookup-char nil t nil t border-char))
  1653.            (setq i 0)
  1654.            (while (< i num-cols)
  1655.          (if (car (aref formatted-cols i))
  1656.              (insert (pop (aref formatted-cols i))) 
  1657.            (insert-char ?  (aref table-colwidth i) t)) 
  1658.          (w3-insert-terminal-char (w3-table-lookup-char nil t nil t border-char))
  1659.          (setq i (+ i (max (aref table-colspans i) 1))))
  1660.            (insert "\n")
  1661.            ;;(and w3-do-incremental-display (w3-pause))
  1662.            (setq height (1- height)))
  1663.          
  1664.          (setq i 0)
  1665.          (while (< i num-cols)
  1666.            (if (> (aref table-rowspans i) 0)
  1667.            (decf (aref table-rowspans i)))
  1668.            (incf i))
  1669.          
  1670.          (setq prev-rowspans (copy-seq table-rowspans))
  1671.          (setq prev-colspans (copy-seq table-colspans))
  1672.      
  1673.          (and w3-do-incremental-display (w3-pause))
  1674.          )
  1675.         (caption
  1676.          (let ((left (length fill-prefix))
  1677.            (fill-prefix "")
  1678.            (fill-column table-width)
  1679.            (start (point)))
  1680.            (w3-display-node (pop content))
  1681.            (indent-rigidly start (point) left)))
  1682.         (otherwise            
  1683.          (delete-horizontal-space)
  1684.          (setq content (nth 2 (car content))))
  1685.         ))
  1686.     (if (= (length column-dimensions) 0) nil
  1687.       (insert fill-prefix)
  1688.       (setq i 0)
  1689.       (let (tflag lflag)
  1690.         (while (< i num-cols)
  1691.           (setq tflag (/= (aref prev-colspans  i) 0))
  1692.           (w3-insert-terminal-char (w3-table-lookup-char lflag tflag t nil border-char))
  1693.           (setq lflag t)
  1694.           (w3-insert-terminal-char
  1695.            (w3-table-lookup-char t nil t nil border-char)
  1696.            (aref column-dimensions i))
  1697.           (setq i (1+ i)))
  1698.         (w3-insert-terminal-char
  1699.          (w3-table-lookup-char t t nil nil border-char))
  1700.         (insert "\n")))
  1701.     )
  1702.       (pop w3-display-open-element-stack)))))
  1703.  
  1704.  
  1705.  
  1706. (defun w3-display-create-unique-id ()
  1707.   (let* ((date (current-time-string))
  1708.      (dateinfo (and date (timezone-parse-date date)))
  1709.      (timeinfo (and date (timezone-parse-time (aref dateinfo 3)))))
  1710.     (if (and dateinfo timeinfo)
  1711.     (concat (aref dateinfo 0)    ; Year
  1712.         (aref dateinfo 1)    ; Month
  1713.         (aref dateinfo 2)    ; Day
  1714.         (aref timeinfo 0)    ; Hour
  1715.         (aref timeinfo 1)    ; Minute 
  1716.         (aref timeinfo 2)    ; Second
  1717.         )
  1718.       "HoplesSLYCoNfUSED")))
  1719.  
  1720. (defun w3-display-chop-into-table (node cols)
  1721.   ;; Chop the content of 'node' up into 'cols' columns suitable for inclusion
  1722.   ;; as the content of a table
  1723.   (let ((content (nth 2 node))
  1724.     (items nil)
  1725.     (rows nil))
  1726.     (setq cols (max cols 1))
  1727.     (while content
  1728.       (push (list 'td nil (list (pop content))) items)
  1729.       (if (= (length items) cols)
  1730.       (setq rows (cons (nreverse items) rows)
  1731.         items nil)))
  1732.     (if items                ; Store any leftovers
  1733.     (setq rows (cons (nreverse items) rows)
  1734.           items nil))
  1735.     (while rows
  1736.       (push (list 'tr nil (pop rows)) items))
  1737.     items))
  1738.  
  1739. (defun w3-fix-color (color)
  1740.   (if (and color
  1741.        (string-match "^[0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F]$" color))
  1742.       (concat "#" color)
  1743.     color))
  1744.  
  1745. (defun w3-display-normalize-form-info (args)
  1746.   (let* ((plist (alist-to-plist args))
  1747.      (type (intern (downcase
  1748.             (or (plist-get plist 'type) "text"))))
  1749.      (name (plist-get plist 'name))
  1750.      (value (or (plist-get plist 'value) ""))
  1751.      (size (if (plist-get plist 'size)
  1752.            (string-to-int (plist-get plist 'size))))
  1753.      (maxlength (if (plist-get plist 'maxlength)
  1754.             (string-to-int
  1755.              (plist-get plist 'maxlength))))
  1756.      (default value)
  1757.      (checked (assq 'checked args)))
  1758.     (if (memq type '(checkbox radio)) (setq default checked))
  1759.     (if (and (eq type 'checkbox) (string= value ""))
  1760.     (setq value "on"))
  1761.     (if (and (not (memq type '(submit reset button)))
  1762.          (not name))
  1763.     (setq name (symbol-name type)))
  1764.     (while (and name (string-match "[\r\n]+" name))
  1765.       (setq name (concat (substring name 0 (match-beginning 0))
  1766.              (substring name (match-end 0) nil))))
  1767.     (setq plist (plist-put plist 'type type)
  1768.       plist (plist-put plist 'name name)
  1769.       plist (plist-put plist 'value value)
  1770.       plist (plist-put plist 'size size)
  1771.       plist (plist-put plist 'default default)
  1772.       plist (plist-put plist 'internal-form-number w3-current-form-number)
  1773.       plist (plist-put plist 'action w3-display-form-id)
  1774.       plist (plist-put plist 'maxlength maxlength))
  1775.     plist))
  1776.  
  1777. (defvar w3-resurrect-images-offset nil
  1778.   "A-list of alt offsets for widgets cut in tables, used in `w3-resurrect-images'")
  1779.  
  1780. (defun w3-resurrect-images ()
  1781.   (let ((st (point-min))
  1782.     (inhibit-read-only t)
  1783.     info nd node face widget)
  1784.     (while st
  1785.       (if (setq info (get-text-property st 'w3-hyperimage-info))
  1786.       (progn
  1787.         (setq nd (or (next-single-property-change st 'w3-hyperimage-info)
  1788.              (point-max)))
  1789.         (let* ((alt (widget-get info 'alt))
  1790.            (max (point-max))
  1791.            (offset-elt (assoc alt w3-resurrect-images-offset))
  1792.            (offset (if offset-elt (cdr offset-elt) 0))
  1793.            to-cut new-offset)
  1794.           (delete-region st nd)
  1795.           (goto-char st)
  1796.           (setq widget (apply (function widget-create) info))
  1797.           (if (not (zerop offset))
  1798.           ;; already started on this widget - remove beginning of alt
  1799.           (delete-region st (+ st offset)))
  1800.           (setq to-cut (- (point-max) max)
  1801.             new-offset (1+ (- nd st)))
  1802.           (cond ((not (zerop to-cut))
  1803.              ;; cut end of alt if too long after resurrection
  1804.              (delete-region nd (+ nd to-cut))
  1805.              (if offset-elt
  1806.              (setcdr offset-elt (+ offset new-offset))
  1807.                (setq w3-resurrect-images-offset
  1808.                  (cons (cons alt new-offset)
  1809.                    w3-resurrect-images-offset))))))
  1810.         (widget-put widget 'buffer (current-buffer))
  1811.         (w3-maybe-start-image-download widget)
  1812.         (if (widget-get widget :from)
  1813.         (add-text-properties (widget-get widget :from)
  1814.                      (widget-get widget :to)
  1815.                      (list 'html-stack w3-display-open-element-stack)))))
  1816.       (setq st (next-single-property-change st 'w3-hyperimage-info)))
  1817.     (setq w3-resurrect-images-offset nil)))
  1818.  
  1819. (defun w3-resurrect-hyperlinks ()
  1820.   (let ((st (point-min))
  1821.     (inhibit-read-only t)
  1822.     info nd node face)
  1823.     (while st
  1824.       (if (setq info (get-text-property st 'w3-hyperlink-info))
  1825.       (progn
  1826.         (setq nd (or (next-single-property-change st 'w3-hyperlink-info)
  1827.              (point-max)))
  1828.         (apply 'widget-convert-text 'link st nd st nd (nconc
  1829.                                (list :start st
  1830.                                  :end nd)
  1831.                                info))))
  1832.       (setq st (next-single-property-change st 'w3-hyperlink-info)))))
  1833.  
  1834. (defun w3-display-convert-arglist (args)
  1835.   (let ((rval nil)
  1836.     (newsym nil)
  1837.     (cur nil))
  1838.     (while (setq cur (pop args))
  1839.       (setq newsym (intern (concat ":" (symbol-name (car cur))))
  1840.         rval (plist-put rval newsym (cdr cur))))
  1841.     rval))
  1842.  
  1843. (defun w3-display-node (node &optional nofaces)
  1844.   (let (
  1845.     (content-stack (list (list node)))
  1846.     (right-margin-stack (list fill-column))
  1847.     (left-margin-stack (list 0))
  1848.     (inhibit-read-only t)
  1849.     (widget-push-button-gui nil)
  1850.     node
  1851.     insert-before
  1852.     insert-after
  1853.     tag
  1854.     args
  1855.     content
  1856.     hyperlink-info
  1857.     hyperimage-info
  1858.     break-style
  1859.     cur
  1860.     id
  1861.     class
  1862.     last-element
  1863.     )
  1864.     (while content-stack
  1865.       (setq content (pop content-stack))
  1866.       (pop w3-active-faces)
  1867.       (pop w3-active-voices)
  1868.       (w3-display-progress-meter)
  1869.       (setq last-element (pop w3-display-open-element-stack))
  1870.       (case (car last-element)
  1871.     ;; Any weird, post-display-of-content stuff for specific tags
  1872.     ;; goes here.   Couldn't think of any better way to do this when we
  1873.     ;; are iterative.  *sigh*
  1874.     (a
  1875.      (if (not hyperlink-info)
  1876.          nil
  1877.        (add-text-properties (car hyperlink-info) (point)
  1878.                 (list
  1879.                  'duplicable t
  1880.                  'start-open t
  1881.                  'end-open t
  1882.                  'rear-nonsticky t
  1883.                  'w3-hyperlink-info (cadr hyperlink-info))))
  1884.      (setq hyperlink-info nil))
  1885.     (img
  1886.      (if (not hyperimage-info)
  1887.          nil
  1888.        (add-text-properties (car hyperimage-info) (point)
  1889.                 (list
  1890.                  'duplicable t
  1891.                  'start-open t
  1892.                  'end-open t
  1893.                  'rear-nonsticky t
  1894.                  'w3-hyperimage-info (cadr hyperimage-info))))
  1895.      (setq hyperimage-info nil))
  1896.     ((ol ul dl dir menu)
  1897.      (pop w3-display-list-stack))
  1898.     (label
  1899.      (if (and (markerp w3-display-label-marker)
  1900.           (marker-position w3-display-label-marker)
  1901.           (marker-buffer w3-display-label-marker))
  1902.          (push (cons (or (cdr-safe (assq 'for (cdr last-element)))
  1903.                  (cdr-safe (assq 'id (cdr last-element)))
  1904.                  "unknown")
  1905.              (buffer-substring w3-display-label-marker (point)))
  1906.            w3-form-labels)))
  1907.     (otherwise
  1908.      nil))
  1909.       (if (car insert-after)
  1910.       (w3-handle-string-content (car insert-after)))
  1911.       (pop insert-after)
  1912.       (w3-display-handle-end-break)
  1913.       (w3-pop-all-face-info)
  1914.       ;; Handle the element's content
  1915.       (while content
  1916.     (w3-display-progress-meter)
  1917.     (if (stringp (car content))
  1918.         (w3-handle-string-content (pop content))
  1919.       (setq node (pop content)
  1920.         tag (nth 0 node)
  1921.         args (nth 1 node)
  1922.         id (or (w3-get-attribute 'name)
  1923.                (w3-get-attribute 'id))
  1924.         )
  1925.       ;; This little bit of magic takes care of inline styles.
  1926.       ;; Evil Evil Evil, but it appears to work.
  1927.       (if (w3-get-attribute 'style)
  1928.           (let ((unique-id (or (w3-get-attribute 'id)
  1929.                    (w3-display-create-unique-id)))
  1930.             (sheet "")
  1931.             (class (assq 'class args)))
  1932.         (setq sheet (format "%s.%s { %s }\n" tag unique-id
  1933.                     (w3-get-attribute 'style)))
  1934.         (if class
  1935.             (setcdr class (cons unique-id (cdr class)))
  1936.           (setf (nth 1 node) (cons (cons 'class (list unique-id))
  1937.                        (nth 1 node))))
  1938.         (setf (nth 1 node) (cons (cons 'id unique-id) (nth 1 node)))
  1939.         (w3-handle-style (list 'data sheet
  1940.                        'notation "text/css"))))
  1941.       (setq w3-display-css-properties (css-get
  1942.                        (nth 0 node)
  1943.                        (nth 1 node)
  1944.                        w3-current-stylesheet
  1945.                        w3-display-open-element-stack))
  1946.       (push (w3-get-style-info 'display node) break-style)
  1947.       (push (w3-get-style-info 'insert-after node) insert-after)
  1948.       (setq insert-before (w3-get-style-info 'insert-before node))
  1949.       (w3-display-handle-break)
  1950.       (if (w3-node-visible-p)
  1951.           nil
  1952.         (setq insert-before nil
  1953.           tag '*invisible)
  1954.         (setcar insert-after nil))
  1955.       (if insert-before
  1956.           (w3-handle-string-content insert-before))
  1957.       (if nofaces
  1958.           nil
  1959.         (push (w3-face-for-element node) w3-active-faces)
  1960.         (push (w3-voice-for-element node) w3-active-voices))
  1961.       (setq insert-before nil)
  1962.       (if id
  1963.           (setq w3-id-positions (cons
  1964.                      (cons (intern id)
  1965.                        (set-marker (make-marker)
  1966.                                (point-max)))
  1967.                      w3-id-positions)))
  1968.       (case tag
  1969.         (a                ; Hyperlinks
  1970.          (let* (
  1971.             (title (w3-get-attribute 'title))
  1972.             (name (or (w3-get-attribute 'id)
  1973.                   (w3-get-attribute 'name)))
  1974.             (btdt nil)
  1975.             class
  1976.             (before nil)
  1977.             (after nil)
  1978.             (face nil)
  1979.             (voice nil)
  1980.             (st nil)
  1981.             (old-props w3-display-css-properties)
  1982.             (active-face nil)
  1983.             (visited-face nil)
  1984.             (munged (copy-tree args)))
  1985.            (if (assq 'class munged)
  1986.            (push ":active" (cdr (assq 'class munged)))
  1987.          (setq munged (cons (cons 'class '(":active")) munged)))
  1988.            (setq w3-display-css-properties (css-get
  1989.                         tag
  1990.                         munged
  1991.                         w3-current-stylesheet
  1992.                         w3-display-open-element-stack))
  1993.            (setq active-face (w3-face-for-element (list tag munged nil)))
  1994.            (w3-pop-all-face-info)
  1995.            (setq munged (copy-tree args))
  1996.            (if (assq 'class munged)
  1997.            (push ":visited" (cdr (assq 'class munged)))
  1998.          (setq munged (cons (cons 'class '(":visited")) munged)))
  1999.            (setq w3-display-css-properties (css-get
  2000.                         tag
  2001.                         munged
  2002.                         w3-current-stylesheet
  2003.                         w3-display-open-element-stack))
  2004.            (setq visited-face (w3-face-for-element (list tag munged nil)))
  2005.            (w3-pop-all-face-info)
  2006.            (setq w3-display-css-properties old-props)
  2007.            (if (w3-get-attribute 'href)
  2008.            (setq st (point)
  2009.              hyperlink-info (list
  2010.                      st
  2011.                      (append
  2012.                       (list :args nil
  2013.                         :value "" :tag ""
  2014.                         :action 'w3-follow-hyperlink
  2015.                         :button-face '(nil)
  2016.                         :active-face active-face
  2017.                         :visited-face visited-face
  2018.                         :from (set-marker
  2019.                                (make-marker) st)
  2020.                         :help-echo 'w3-widget-echo
  2021.                         :emacspeak-help 'w3-widget-echo
  2022.                         )
  2023.                       (w3-display-convert-arglist args)))))
  2024.            (w3-handle-content node)
  2025.            )
  2026.          )
  2027.         ((ol ul dl menu)
  2028.          (push (if (w3-get-attribute 'seqnum)
  2029.                (1- (string-to-int (w3-get-attribute 'seqnum)))
  2030.              0) w3-display-list-stack)
  2031.          (w3-handle-content node))
  2032.         (dir
  2033.          (push 0 w3-display-list-stack)
  2034.          (setq node
  2035.            (list tag args
  2036.              (list
  2037.               (list 'table nil
  2038.                 (w3-display-chop-into-table node 3)))))
  2039.          (w3-handle-content node))
  2040.         (multicol
  2041.          (setq node (list tag args
  2042.                   (list
  2043.                    (list 'table nil
  2044.                      (w3-display-chop-into-table node 2)))))
  2045.          (w3-handle-content node))
  2046.         (img            ; inlined image
  2047.          (w3-handle-image)
  2048.          (w3-handle-empty-tag))
  2049.         (frameset
  2050.          (if w3-display-frames
  2051.          (let ((frames (nth 2 node))
  2052.                (frameset-cardinal 0)
  2053.                (cols (cdr-safe (assq 'cols args))))
  2054.            (while (and frames (memq (car (car frames)) '(frame frameset)))
  2055.               (setq frameset-cardinal (1+ frameset-cardinal)
  2056.                 frames (cdr frames)))
  2057.            (push (list 'frameset
  2058.                    frameset-cardinal
  2059.                    (if (w3-frameset-dimensions-p cols)
  2060.                    (assq 'cols args)
  2061.                  (assq 'rows args)))
  2062.              w3-frameset-structure)
  2063.            (w3-handle-content node))
  2064.            (w3-handle-content node)))
  2065.         (frame
  2066.          (if w3-display-frames
  2067.          (let* ((href (or (w3-get-attribute 'src)
  2068.                   (w3-get-attribute 'href)))
  2069.             (name (or (w3-get-attribute 'name)
  2070.                   (w3-get-attribute 'title)
  2071.                   (w3-get-attribute 'alt)
  2072.                   "Unknown frame name")))
  2073.            (push (list 'frame name href) w3-frameset-structure)
  2074.            (w3-handle-content
  2075.             (list tag args
  2076.               (list
  2077.                (list 'p nil
  2078.                  (list
  2079.                   (list 'a
  2080.                     (cons (cons 'href href)
  2081.                           args)
  2082.                     (list "Fetch frame: " name))))))))
  2083.            (w3-handle-empty-tag)))
  2084.         (noframes
  2085.          (if w3-display-frames
  2086.          (w3-handle-empty-tag)
  2087.            (w3-handle-content node)))
  2088.         (applet            ; Wow, Java
  2089.          (w3-handle-content node)
  2090.          )
  2091.         (script            ; Scripts
  2092.          (w3-handle-empty-tag))
  2093.         ((embed object)        ; Embedded images/content
  2094.          (w3-handle-content node)
  2095.          )
  2096.         (hr                ; Cause line break & insert rule
  2097.          (let* ((perc (or (w3-get-attribute 'width)
  2098.                   (w3-get-style-info 'width node)
  2099.                   "100%"))
  2100.             (width nil))
  2101.            (if (stringp perc)
  2102.            (setq perc (/ (min (string-to-int perc) 100) 100.0)
  2103.              width (truncate (* fill-column perc)))
  2104.          (setq width perc))
  2105.            (w3-insert-terminal-char (w3-horizontal-rule-char) width)
  2106.            (w3-handle-empty-tag)))
  2107.         (map            ; Client side imagemaps
  2108.          (let ((name (or (w3-get-attribute 'name)
  2109.                  (w3-get-attribute 'id)
  2110.                  "unnamed"))
  2111.            (areas
  2112.             (mapcar
  2113.              (function
  2114.               (lambda (node)
  2115.             (let* ((args (nth 1 node))
  2116.                    (type (downcase (or
  2117.                         (w3-get-attribute 'shape)
  2118.                         "rect")))
  2119.                    (coords (w3-decode-area-coords
  2120.                     (or (cdr-safe
  2121.                          (assq 'coords args)) "")))
  2122.                    (alt (w3-get-attribute 'alt))
  2123.                    (href (if (assq 'nohref args)
  2124.                      t
  2125.                        (or (w3-get-attribute 'src)
  2126.                        (w3-get-attribute 'href))))
  2127.                    )
  2128.               (vector type coords href alt))
  2129.             )
  2130.               )
  2131.              (nth 2 node))))
  2132.            (setq w3-imagemaps (cons (cons name areas) w3-imagemaps)))
  2133.          (w3-handle-empty-tag)
  2134.          )
  2135.         (note
  2136.          ;; Ewwwwhhh.  Looks gross, but it works.  This converts a
  2137.          ;; <note> into a two-cell table, so that things look all
  2138.          ;; pretty.
  2139.          (setq node
  2140.            (list 'note nil
  2141.              (list
  2142.               (list 'table nil
  2143.                 (list
  2144.                  (list 'tr nil
  2145.                        (list
  2146.                     (list 'td (list 'align 'right)
  2147.                           (list
  2148.                            (concat
  2149.                         (or (w3-get-attribute 'role)
  2150.                             "CAUTION") ":")))
  2151.                     (list 'td nil
  2152.                           (nth 2 node)))))))))
  2153.          (w3-handle-content node)
  2154.          )
  2155.         (table
  2156.          (w3-display-table node)
  2157.          (setq w3-last-fill-pos (point))
  2158.          (w3-handle-empty-tag)
  2159.          )
  2160.         (isindex
  2161.          (let ((prompt (or (w3-get-attribute 'prompt)
  2162.                    "Search on (+ separates keywords): "))
  2163.            action node)
  2164.            (setq action (or (w3-get-attribute 'src)
  2165.                 (w3-get-attribute 'href)
  2166.                 (url-view-url t)))
  2167.            (if (and prompt (string-match "[^: \t-]+$" prompt))
  2168.            (setq prompt (concat prompt ": ")))
  2169.            (setq node
  2170.              (list 'isindex nil
  2171.                (list
  2172.                 (list 'hr nil nil)
  2173.                 (list 'form
  2174.                   (list (cons 'action action)
  2175.                     (cons 'enctype
  2176.                           "application/x-w3-isindex")
  2177.                     (cons 'method "get"))
  2178.                   (list
  2179.                    prompt
  2180.                    (list 'input
  2181.                      (list (cons 'type "text")
  2182.                            (cons 'name "isindex"))))))))
  2183.            (w3-handle-content node)
  2184.            (setq w3-current-isindex (cons action prompt)))
  2185.          )
  2186.         ((html body)
  2187.          (let ((fore (car (delq nil (copy-list w3-face-color))))
  2188.            (back (car (delq nil (copy-list w3-face-background-color))))
  2189.            (pixm (car (delq nil (copy-list w3-face-background-image))))
  2190.            (alink (w3-get-attribute 'alink))
  2191.            (vlink (w3-get-attribute 'vlink))
  2192.            (link  (w3-get-attribute 'link))
  2193.            (sheet "")
  2194.            )
  2195.            (if link
  2196.            (setq sheet (format "%sa:link { color: %s }\n" sheet
  2197.                        (w3-fix-color link))))
  2198.            (if vlink
  2199.            (setq sheet (format "%sa:visited { color: %s }\n" sheet
  2200.                        (w3-fix-color vlink))))
  2201.            (if alink
  2202.            (setq sheet (format "%sa:active { color: %s }\n" sheet
  2203.                        (w3-fix-color alink))))
  2204.            (if w3-user-colors-take-precedence
  2205.            nil
  2206.          (if (/= (length sheet) 0)
  2207.              (w3-handle-style (list 'data sheet
  2208.                         'notation "text/css")))
  2209.          (if (and (w3-get-attribute 'background)
  2210.               (not pixm))
  2211.              (progn
  2212.                (setq pixm (w3-get-attribute 'background))
  2213.                (setf (car w3-face-background-image) pixm)))
  2214.          (if (and (w3-get-attribute 'text) (not fore))
  2215.              (progn
  2216.                (setq fore (w3-fix-color (w3-get-attribute 'text)))
  2217.                (setf (car w3-face-color) fore)))
  2218.          (if (not font-running-xemacs)
  2219.              (setq w3-display-background-properties (cons fore back))
  2220.            (if pixm
  2221.                (w3-maybe-start-background-image-download pixm 'default))
  2222.            (if fore
  2223.                (font-set-face-foreground 'default fore (current-buffer)))
  2224.            (if back
  2225.                (font-set-face-background 'default back (current-buffer)))))
  2226.            (w3-handle-content node)))
  2227.         (*document
  2228.          (let ((info (mapcar (lambda (x) (cons x (symbol-value x)))
  2229.                  w3-persistent-variables)))
  2230.            (if (not w3-display-same-buffer)
  2231.            (set-buffer (generate-new-buffer "Untitled")))
  2232.            (setq w3-current-form-number 0
  2233.              w3-display-open-element-stack nil
  2234.              w3-last-fill-pos (point-min))
  2235.            (setcar right-margin-stack
  2236.                (min (- (or w3-strict-width (window-width))
  2237.                    w3-right-margin)
  2238.                 (or w3-maximum-line-length
  2239.                 (window-width))))
  2240.            (condition-case nil
  2241.            (switch-to-buffer (current-buffer))
  2242.          (error (message  "W3 buffer %s is being drawn." (buffer-name (current-buffer)))))
  2243.  
  2244.            (buffer-disable-undo (current-buffer))
  2245.            (mapcar (function (lambda (x) (set (car x) (cdr x)))) info)
  2246.            ;; ACK!  We don't like filladapt mode!
  2247.            (set (make-local-variable 'filladapt-mode) nil)
  2248.            (set (make-local-variable 'adaptive-fill-mode) nil)
  2249.            (set (make-local-variable 'voice-lock-mode) t)
  2250.            (set (make-local-variable 'cur-viewing-pos) (point-min))
  2251.            (setq w3-current-stylesheet (css-copy-stylesheet
  2252.                         w3-user-stylesheet)
  2253.              w3-last-fill-pos (point)
  2254.              fill-prefix "")
  2255.            )
  2256.          (w3-handle-content node)
  2257.          )
  2258.         (*invisible
  2259.          (w3-handle-empty-tag))
  2260.         (meta
  2261.          (let* ((equiv (cdr-safe (assq 'http-equiv args)))
  2262.             (value (w3-get-attribute 'content))
  2263.             (name  (w3-get-attribute 'name))
  2264.             (node  (and equiv (assoc (setq equiv (downcase equiv))
  2265.                          url-current-mime-headers))))
  2266.            (if equiv
  2267.            (setq url-current-mime-headers (cons
  2268.                            (cons equiv value)
  2269.                            url-current-mime-headers)))
  2270.            (if name
  2271.            (setq w3-current-metainfo (cons
  2272.                           (cons name value)
  2273.                           w3-current-metainfo)))
  2274.  
  2275.            ;; Special-case the Set-Cookie header
  2276.            (if (and equiv (string= (downcase equiv) "set-cookie"))
  2277.            (url-cookie-handle-set-cookie value))
  2278.            ;; Special-case the refresh header
  2279.            (if (and equiv (string= (downcase equiv) "refresh"))
  2280.            (url-handle-refresh-header value)))
  2281.          (w3-handle-empty-tag)
  2282.          )
  2283.         (link
  2284.          ;; This doesn't handle blank-separated values per the RFC.
  2285.          (w3-parse-link args)
  2286.          (w3-handle-empty-tag))
  2287.         (title
  2288.          (let ((potential-title "")
  2289.            (content (nth 2 node)))
  2290.            (while content
  2291.          (setq potential-title (concat potential-title (car content))
  2292.                content (cdr content)))
  2293.            (setq potential-title (w3-normalize-spaces potential-title))
  2294.            (if (or w3-display-same-buffer
  2295.                (string-match "^[ \t]*$" potential-title))
  2296.            nil
  2297.          (rename-buffer (generate-new-buffer-name
  2298.                  (w3-fix-spaces potential-title)))))
  2299.          (w3-handle-empty-tag))
  2300.         (base
  2301.          (setq w3-base-target (cdr-safe (assq 'target args)))
  2302.          (w3-handle-content node))
  2303.         (form
  2304.          (setq w3-current-form-number (1+ w3-current-form-number))
  2305.          (let* (
  2306.             (action (w3-get-attribute 'action))
  2307.             (url nil))
  2308.            (if (not action)
  2309.            (setq args (cons (cons 'action (url-view-url t)) args)))
  2310.            (setq w3-display-form-id (cons
  2311.                      (cons 'form-number
  2312.                            w3-current-form-number)
  2313.                      args))
  2314.            (w3-handle-content node)))
  2315.         (keygen
  2316.          (w3-form-add-element 
  2317.           (w3-display-normalize-form-info 
  2318.            (cons '(type . "keygen")
  2319.              args))
  2320.           w3-active-faces)
  2321.          (w3-handle-empty-tag))
  2322.         (input
  2323.          (w3-form-add-element
  2324.           (w3-display-normalize-form-info args)
  2325.           w3-active-faces)
  2326.          (w3-handle-empty-tag)
  2327.          )
  2328.         (select
  2329.          (let* ((plist (w3-display-normalize-form-info args))
  2330.             (tmp nil)
  2331.             (multiple (assq 'multiple args))
  2332.             (value nil)
  2333.             (name (plist-get plist 'name))
  2334.             (options (mapcar
  2335.                   (function
  2336.                    (lambda (n)
  2337.                  (setq tmp (w3-normalize-spaces
  2338.                         (apply 'concat (nth 2 n)))
  2339.                        tmp (vector tmp
  2340.                            (or
  2341.                             (cdr-safe
  2342.                              (assq 'value (nth 1 n)))
  2343.                             tmp)
  2344.                            (assq 'selected (nth 1 n))))
  2345.                  (if (assq 'selected (nth 1 n))
  2346.                      (setq value (aref tmp 0)))
  2347.                  tmp))
  2348.                   (nth 2 node))))
  2349.            (if (not value)
  2350.            (setq value (and options (aref (car options) 0))))
  2351.            (setq plist (plist-put plist 'value value))
  2352.            (if multiple
  2353.            (progn
  2354.              (setq options
  2355.                (mapcar
  2356.                 (function
  2357.                  (lambda (opt)
  2358.                    (list 'div nil
  2359.                      (list
  2360.                       (list 'input
  2361.                         (list (cons 'name name)
  2362.                           (cons 'type "checkbox")
  2363.                           (cons (if (aref opt 2)
  2364.                                 'checked
  2365.                               '__bogus__) "yes")
  2366.                           (cons 'value (aref opt 1))))
  2367.                       " " (aref opt 0) (list 'br nil nil)))))
  2368.                 options))
  2369.              (setq node (list 'p nil options))
  2370.              (w3-handle-content node))
  2371.          (setq options (mapcar (function
  2372.                     (lambda (x)
  2373.                       (cons (aref x 0) (aref x 1))))
  2374.                        options))
  2375.          (setq plist (plist-put plist 'type 'option)
  2376.                plist (plist-put plist 'options options))
  2377.          (w3-form-add-element plist w3-active-faces)
  2378.          ;; This should really not be necessary, but some versions
  2379.          ;; of the widget library leave point _BEFORE_ the menu
  2380.          ;; widget instead of after.
  2381.          (goto-char (point-max))
  2382.          (w3-handle-empty-tag))))
  2383.         (textarea
  2384.          (let* ((plist (w3-display-normalize-form-info args))
  2385.             (value (apply 'concat (nth 2 node))))
  2386.            (setq plist (plist-put plist 'type 'multiline)
  2387.              plist (plist-put plist 'value value))
  2388.            (w3-form-add-element plist w3-active-faces))
  2389.          (w3-handle-empty-tag)
  2390.          )
  2391.         (style
  2392.          (w3-handle-style (alist-to-plist
  2393.                    (cons (cons 'data (apply 'concat (nth 2 node)))
  2394.                      (nth 1 node))))
  2395.          (w3-handle-empty-tag))
  2396.         (label
  2397.          (if (not (markerp w3-display-label-marker))
  2398.          (setq w3-display-label-marker (make-marker)))
  2399.          (set-marker w3-display-label-marker (point))
  2400.          (w3-handle-content node))
  2401.         ;; Emacs-W3 stuff that cannot be expressed in a stylesheet
  2402.         (pinhead
  2403.          ;; This check is so that we don't screw up table auto-layout
  2404.          ;; by changing our text midway through the parse/layout/display
  2405.          ;; steps.
  2406.          (if (nth 2 node)
  2407.          nil
  2408.            (setcar (cddr node)
  2409.                (list
  2410.             (if (fboundp 'yow)
  2411.                 (yow)
  2412.               "AIEEEEE!  I am having an UNDULATING EXPERIENCE!"))))
  2413.          (w3-handle-content node))
  2414.         (flame
  2415.          (if (nth 2 node)
  2416.          nil
  2417.            (setcar
  2418.         (cddr node)
  2419.         (list
  2420.          (condition-case ()
  2421.              (concat
  2422.               (sentence-ify
  2423.                (string-ify
  2424.             (append-suffixes-hack (flatten (*flame))))))
  2425.            (error
  2426.             "You know, everything is really a graphics editor.")))))
  2427.          (w3-handle-content node))
  2428.         (cookie
  2429.          (if (nth 2 node)
  2430.          nil
  2431.            (setcar
  2432.         (cddr node)
  2433.         (list
  2434.          (w3-display-get-cookie args))))
  2435.          (w3-handle-content node))
  2436.         ;; Generic formatting - all things that can be fully specified
  2437.         ;; by a CSS stylesheet.
  2438.         (otherwise
  2439.          (w3-handle-content node))
  2440.         )                ; case tag
  2441.       )                ; stringp content
  2442.     )                ; while content
  2443.       )                    ; while content-stack
  2444.     )
  2445.   )
  2446.  
  2447. (defun w3-draw-tree (tree)
  2448.   ;; The main entry point - wow complicated
  2449.   (setq w3-current-stylesheet w3-user-stylesheet)
  2450.   (while tree
  2451.     (w3-display-node (car tree))
  2452.     (setq tree (cdr tree)))
  2453.   (w3-display-fix-widgets)
  2454.   (let ((inhibit-read-only t))
  2455.     (w3-resurrect-images)
  2456.     (w3-resurrect-hyperlinks)
  2457.     (w3-form-resurrect-widgets)))
  2458.  
  2459. (defun time-display (&optional tree)
  2460.   ;; Return the # of seconds it took to draw 'tree'
  2461.   (let ((st (nth 1 (current-time)))
  2462.     (nd nil))
  2463.     (w3-draw-tree (or tree w3-last-parse-tree))
  2464.     (setq nd (nth 1 (current-time)))
  2465.     (- nd st)))
  2466.  
  2467.  
  2468. (defun w3-fixup-eol-faces ()
  2469.   ;; Remove 'face property at end of lines - underlining screws up stuff
  2470.   ;; also remove 'mouse-face property at the beginning and end of lines 
  2471.   (let ((inhibit-read-only t))
  2472.     (save-excursion
  2473.       (goto-char (point-min))
  2474.       (while (re-search-forward "[ \t]*\n[ \t]*" nil t)
  2475.     (remove-text-properties (match-beginning 0) (match-end 0)
  2476.                 '(face nil mouse-face nil) nil)))))
  2477.  
  2478. (defsubst w3-finish-drawing ()
  2479.   (let (url glyph widget)
  2480.     (while w3-image-widgets-waiting
  2481.       (setq widget (car w3-image-widgets-waiting)
  2482.         w3-image-widgets-waiting (cdr w3-image-widgets-waiting)
  2483.         url (widget-get widget :src)
  2484.         glyph (cdr-safe (assoc url w3-graphics-list)))
  2485.       (condition-case nil
  2486.       (widget-value-set widget glyph)
  2487.     (error nil))))
  2488.   (if (and url-current-object (url-target url-current-object))
  2489.       (progn
  2490.     (push-mark (point) t)
  2491.     (w3-find-specific-link (url-target url-current-object)))
  2492.     (goto-char (point-min)))
  2493.   (and (not w3-running-xemacs)
  2494.        (not (eq (device-type) 'tty))
  2495.        (w3-fixup-eol-faces))
  2496.   (message "Drawing... done"))
  2497.  
  2498. (defun w3-region (st nd)
  2499.   (if (not w3-setup-done) (w3-do-setup))
  2500.   (let* ((source (buffer-substring st nd))
  2501.      (w3-display-same-buffer t)
  2502.      (parse nil))
  2503.     (save-window-excursion
  2504.       (save-excursion
  2505.     (set-buffer (get-buffer-create " *w3-region*"))
  2506.     (erase-buffer)
  2507.     (insert source)
  2508.     (setq parse (w3-parse-buffer (current-buffer))))
  2509.       (narrow-to-region st nd)
  2510.       (delete-region (point-min) (point-max))
  2511.       (w3-draw-tree parse)
  2512.       (w3-finish-drawing)
  2513.       (widen))))
  2514.  
  2515. (defun w3-refresh-buffer ()
  2516.   (interactive)
  2517.   (let ((parse w3-current-parse)
  2518.     (inhibit-read-only t)
  2519.     (w3-display-same-buffer t))
  2520.     (if (not parse)
  2521.     (error "Could not find the parse tree for this buffer.  EEEEK!"))
  2522.     (erase-buffer)
  2523.     (w3-draw-tree parse)
  2524.     (w3-finish-drawing)
  2525.     (w3-mode)
  2526.     (set-buffer-modified-p nil)))
  2527.  
  2528. (defun w3-prepare-buffer (&rest args)
  2529.   ;; The text/html viewer - does all the drawing and displaying of the buffer
  2530.   ;; that is necessary to go from raw HTML to a good presentation.
  2531.   (let* ((source (buffer-string))
  2532.      (source-buf (current-buffer))
  2533.      (parse (w3-parse-buffer source-buf)))
  2534.     (set-buffer-modified-p nil)
  2535.     (w3-draw-tree parse)
  2536.     (kill-buffer source-buf)
  2537.     (set-buffer-modified-p nil)
  2538.     (setq w3-current-source source
  2539.       w3-current-parse parse)
  2540.     (w3-finish-drawing)
  2541.     (w3-mode)
  2542.     (set-buffer-modified-p nil)
  2543.     (if url-keep-history
  2544.     (let ((url (url-view-url t)))
  2545.       (if (not url-history-list)
  2546.           (setq url-history-list (make-hash-table :size 131 :test 'equal)))
  2547.       (cl-puthash url (buffer-name) url-history-list)
  2548.       (if (fboundp 'w3-shuffle-history-menu)
  2549.           (w3-shuffle-history-menu)))))
  2550.   (w3-maybe-fetch-frames))
  2551.  
  2552. (defun w3-maybe-fetch-frames ()
  2553.   (if w3-frameset-structure
  2554.       (cond ((or (eq w3-display-frames t)
  2555.          (and (eq w3-display-frames 'ask)
  2556.               (y-or-n-p "Fetch frames? ")))
  2557.          (w3-frames)
  2558.          t))))
  2559.  
  2560. (defun w3-frames (&optional new-frame)
  2561.   "Set up and fetch W3 frames. With optional prefix, do so in a new frame."
  2562.   (interactive "P")
  2563.   (if (not w3-display-frames)
  2564.       (let ((w3-display-frames t))
  2565.     (w3-refresh-buffer)))
  2566.   (let* ((old-asynch (default-value 'url-be-asynchronous))
  2567.      (structure (reverse w3-frameset-structure)))
  2568.     (if new-frame
  2569.     (select-frame (make-frame)))
  2570.     (unwind-protect
  2571.     (progn
  2572.       (setq-default url-be-asynchronous nil)
  2573.       ;; set up frames
  2574.       (while structure
  2575.         (if (eq (car (car structure)) 'frameset)
  2576.         (setq structure (w3-display-frameset structure))
  2577.           (pop structure)))
  2578.       ;; compute target window distances
  2579.       (let ((origin-buffer (current-buffer))
  2580.         (stop nil))
  2581.         (while (not stop)
  2582.           (or w3-target-window-distances
  2583.           (setq w3-target-window-distances
  2584.             (w3-compute-target-window-distances)))
  2585.           (other-window 1)
  2586.           (if (eq (current-buffer) origin-buffer)
  2587.           (setq stop t)))))
  2588.       (setq-default url-be-asynchronous old-asynch))))
  2589.  
  2590. (defun w3-frameset-dimensions-p (str)
  2591.   (and str (not (string-equal str "*")) (not (string-equal str "100%"))))
  2592.  
  2593. (defun w3-display-frameset (frameset-structure)
  2594.   (let* ((structure frameset-structure)
  2595.      (frameset-cardinal (nth 1 (car structure)))
  2596.      (current-dims (cdr (cdr (car structure))))
  2597.      (cols (cdr-safe (assq 'cols current-dims)))
  2598.      (rows (cdr-safe (assq 'rows current-dims)))
  2599.      (char-width (if (> (frame-char-width) 1)
  2600.               (frame-char-width)
  2601.             w3-tty-char-width))
  2602.      (char-height (if (> (frame-char-height) 1)
  2603.               (frame-char-height)
  2604.             w3-tty-char-height)))
  2605.     (pop structure)
  2606.     ;; columns ?
  2607.     (if (w3-frameset-dimensions-p cols)
  2608.     (setq cols (w3-decode-frameset-dimensions
  2609.             cols (window-width) window-min-width char-width))
  2610.       ;; rows ?
  2611.       (if (w3-frameset-dimensions-p rows)
  2612.       (setq rows (w3-decode-frameset-dimensions
  2613.               rows (window-height) window-min-height char-height))
  2614.     ;; default: columns of equal width
  2615.     (let ((fwidth (/ (window-width) frameset-cardinal)))
  2616.       (while (> frameset-cardinal 0)
  2617.         (push fwidth cols)
  2618.         (setq frameset-cardinal (1- frameset-cardinal))))))
  2619.     (while (> frameset-cardinal 0)
  2620.       (cond ((cdr cols)
  2621.          (split-window-horizontally (car cols))
  2622.          (pop cols))
  2623.         ((cdr rows)
  2624.          (split-window-vertically (car rows))
  2625.          (pop rows)))
  2626.       (cond ((eq (car (car structure)) 'frame)
  2627.          (let ((href (nth 2 (car structure)))
  2628.            (name (nth 1 (car structure)))
  2629.            (url-working-buffer url-default-working-buffer) ; in case url-multiple-p is t
  2630.            (w3-notify 'semibully))
  2631.            (pop structure)
  2632.            (w3-fetch href)
  2633.            (let ((buf (current-buffer)))
  2634.          (set-buffer (url-buffer-visiting href))
  2635.          (setq w3-frame-name name
  2636.                w3-target-window-distances nil)
  2637.          (set-buffer buf))
  2638.            (other-window 1)))
  2639.         ((eq (car (car structure)) 'frameset)
  2640.          (setq structure (w3-display-frameset structure))))
  2641.       (setq frameset-cardinal (1- frameset-cardinal)))
  2642.     structure))
  2643.  
  2644. (defun w3-compute-target-window-distances ()
  2645.   "Compute an alist of target names and window distances"
  2646.   (let ((origin-buffer (current-buffer))
  2647.     (distance 0)
  2648.     (stop nil)
  2649.     (window-distances nil))
  2650.     (while (not stop)
  2651.       (if w3-frame-name
  2652.       (push (cons (intern (downcase w3-frame-name)) distance)
  2653.         window-distances))
  2654.       (other-window 1)
  2655.       (setq distance (1+ distance))
  2656.       (if (eq (current-buffer) origin-buffer)
  2657.       (setq stop t)))
  2658.     window-distances))
  2659.  
  2660. (defun w3-decode-frameset-dimensions (dims available-dimension min-dim pixel-dim)
  2661.   "Returns numbers of lines or columns in Emacs, computed from specified frameset dimensions"
  2662.   (let ((dimensions nil))
  2663.     (if dims
  2664.     (let ((nb-stars 0)
  2665.           (norm-stars 0)
  2666.           (remaining-available-dimension available-dimension))
  2667.       (while (string-match "\\([0-9]*\\*\\|[0-9]+%?\\)" dims)
  2668.         (let ((match (substring dims (match-beginning 1) (match-end 1))))
  2669.           (setq dims (substring dims (match-end 1)))
  2670.           (cond ((string-match "\\([0-9]+\\)\\*" match)
  2671.              ;; divide rest with relative weights
  2672.              (let ((weight (car (read-from-string
  2673.                      (substring match (match-beginning 1) (match-end 1))))))
  2674.              (push (cons '* weight) dimensions)
  2675.              (setq nb-stars (1+ nb-stars)
  2676.                norm-stars (+ norm-stars weight))))
  2677.             ((string-match "\\*" match)
  2678.              ;; divide equally
  2679.              (push '* dimensions)
  2680.              (setq nb-stars (1+ nb-stars)
  2681.                norm-stars (1+ norm-stars)))
  2682.             (t
  2683.              (cond ((string-match "\\([0-9]+\\)%" match)
  2684.                 ;; percentage of available height
  2685.                 (push (/ (* (car (read-from-string (substring match 0 -1)))
  2686.                     available-dimension)
  2687.                      100)
  2688.                   dimensions))
  2689.                (t
  2690.                 ;; absolute number: pixel height
  2691.                 (push (max (1+ (/ (car (read-from-string match))
  2692.                           pixel-dim))
  2693.                        min-dim)
  2694.                   dimensions)))
  2695.              (setq remaining-available-dimension
  2696.                (- remaining-available-dimension (car dimensions)))))))
  2697.       (if (zerop nb-stars)
  2698.           ;; push => reverse order
  2699.           (reverse dimensions)
  2700.         ;; substitute numbers for *
  2701.         (let ((star-replacement (/ remaining-available-dimension norm-stars))
  2702.           (star-dimensions dimensions))
  2703.           (setq dimensions nil)
  2704.           (while star-dimensions
  2705.         (push (cond ((eq '* (car star-dimensions))
  2706.                  star-replacement)
  2707.                 ((listp (car star-dimensions))
  2708.                  (* (cdar star-dimensions) star-replacement))
  2709.                 (t
  2710.                  (car star-dimensions)))
  2711.               dimensions)
  2712.         (pop star-dimensions))
  2713.           ;; push + push => in order
  2714.           dimensions))))))
  2715.  
  2716. (provide 'w3-display)
  2717.