home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / w3 / w3-draw.el < prev    next >
Encoding:
Text File  |  1995-08-31  |  72.2 KB  |  2,135 lines
  1. ;;; w3-draw.el,v --- Emacs-W3 drawing functions for new display engine
  2. ;; Author: wmperry
  3. ;; Created: 1995/08/31 05:05:03
  4. ;; Version: 1.257
  5. ;; Keywords: faces, help, hypermedia
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)
  9. ;;;
  10. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  11. ;;;
  12. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  13. ;;; it under the terms of the GNU General Public License as published by
  14. ;;; the Free Software Foundation; either version 2, or (at your option)
  15. ;;; any later version.
  16. ;;;
  17. ;;; GNU Emacs is distributed in the hope that it will be useful,
  18. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;;; GNU General Public License for more details.
  21. ;;;
  22. ;;; You should have received a copy of the GNU General Public License
  23. ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  24. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26.  
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28. ;;; This function will take a stream of HTML from w3-preparse-buffer
  29. ;;; and draw it out
  30. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31.  
  32. (require 'w3-vars)
  33. (or (boundp 'MULE) (fset 'string-width 'length))
  34.  
  35. (defmacro w3-get-state (tag)
  36.   (` (aref w3-state-vector (length (memq (, tag) w3-state-locator-variable)))))
  37.  
  38. (defmacro w3-put-state (tag val)
  39.   (` (aset w3-state-vector (length (memq (, tag) w3-state-locator-variable))
  40.        (, val))))
  41.  
  42. (defmacro w3-get-default-style-info (info)
  43.   (` (or
  44.       ;; Check for tag.class first!
  45.       (cdr-safe (assoc (, info)
  46.                (cdr-safe
  47.             (assoc (format "%s.%s" tag (cdr-safe
  48.                             (assoc "class" args)))
  49.                    w3-current-stylesheet))))
  50.      
  51.       ;; Then for global stuff with 'class'
  52.       (cdr-safe (assoc (, info)
  53.                (cdr-safe
  54.             (assoc (concat "doc." (cdr-safe (assoc "class" args)))
  55.                    w3-current-stylesheet))))
  56.      
  57.       ;; Fall back on the default styles for just this tag.
  58.       (cdr-safe (assoc (, info)
  59.                (cdr-safe (assoc tag w3-current-stylesheet)))))))
  60.       ;; Then try regular expressions
  61. ;      (cdr-safe (assoc (, info)
  62. ;               (cdr-safe (w3-in-assoc (symbol-name tag)
  63. ;                          w3-current-stylesheet)))))))
  64.  
  65. (defmacro w3-face-for-element ()
  66.   '(let ((x (cdr-safe (assoc "face"
  67.                  (cdr-safe
  68.                   (assoc (cdr-safe (assoc "class" args))
  69.                      w3-current-stylesheet))))))
  70.      (if (not x)
  71.      (car-safe (assoc tag w3-all-faces))
  72.        (cons tag x))))
  73.  
  74. ;; Hey, don't blame me!  Apply requires that its last argument be a list.
  75. (defun w3-munge-color-fore (face color &optional locale)
  76.   (cond
  77.    ((valid-color-name-p color)
  78.     (if locale
  79.     (apply 'set-face-foreground face color (list locale))
  80.       (apply 'set-face-foreground face (list color))))
  81.    ((valid-color-name-p (concat "#" color))
  82.     (if locale
  83.     (apply 'set-face-foreground face (concat "#" color) (list locale))
  84.       (apply 'set-face-foreground face (list (concat "#" color)))))
  85.    ((string-match "[ \t\r\n]" color)
  86.     (w3-munge-color-fore
  87.      face
  88.      (mapconcat (function (lambda (x) (if (memq x '(?\t ?\r ?\n ? )) ""
  89.                     (char-to-string x)))) color "")
  90.      locale))
  91.    (t 
  92.     (w3-warn 'html "Bad color specification: %s" color))))
  93.  
  94. ;; Hey, don't blame me!  Apply requires that its last argument be a list.
  95. (defun w3-munge-color-back (face color &optional locale)
  96.   (cond
  97.    ((valid-color-name-p color)
  98.     (if locale
  99.     (apply 'set-face-background face color (list locale))
  100.       (apply 'set-face-background face (list color))))
  101.    ((valid-color-name-p (concat "#" color))
  102.     (if locale
  103.     (apply 'set-face-background face (concat "#" color) (list locale))
  104.       (apply 'set-face-background face (list (concat "#" color)))))
  105.    ((string-match "[ \t\r\n]" color)
  106.     (w3-munge-color-back
  107.      face
  108.      (mapconcat (function (lambda (x) (if (memq x '(?\t ?\r ?\n ? )) ""
  109.                     (char-to-string x)))) color "")
  110.      locale))
  111.    (t 
  112.     (w3-warn 'html "Bad color specification: %s" color))))
  113.  
  114. (defun w3-get-resource (name class)
  115.   (cond
  116.    (w3-running-xemacs
  117.     (x-get-resource name class 'string))
  118.    (w3-running-epoch
  119.     (or
  120.      (epoch::get-default (concat "Emacs*" name) class)
  121.      (epoch::get-default (concat "epoch*" name) class)))
  122.    ((fboundp 'get-resource)
  123.     (get-resource name class))
  124.    ((and (eq (device-type) 'x)
  125.      (fboundp 'x-get-resource))
  126.     (x-get-resource name class))
  127.    (t nil)))
  128.  
  129. (defun face-would-differ-from-default-p (facename)
  130.   "Return non-nil iff face FACENAME would be different from the default face."
  131.   (let* ((name (if (symbolp facename) (symbol-name facename) facename))
  132.      (fn  (w3-get-resource (concat name ".attributeFont")
  133.                   "Face.AttributeFont"))
  134.      (fg  (w3-get-resource (concat name ".attributeForeground")
  135.                   "Face.AttributeForeground"))
  136.      (bg  (w3-get-resource (concat name ".attributeBackground")
  137.                   "Face.AttributeBackground"))
  138.      (bgp (w3-get-resource (concat name ".attributeBackgroundPixmap")
  139.                    "Face.AttributeBackgroundPixmap"))
  140.      (ulp (let ((resource (w3-get-resource
  141.                    (concat name ".attributeUnderline")
  142.                    "Face.AttributeUnderline")))
  143.         (if resource
  144.             (member (downcase resource) '("on" "true")) nil))))
  145.     (or fn fg bg bgp ulp)))
  146.  
  147. (if (not (fboundp 'face-differs-from-default-p ))
  148.     (fset 'face-differs-from-default-p 'face-would-differ-from-default-p))
  149.  
  150. (defun w3-pause ()
  151.   (cond
  152.    (w3-running-FSF19 (sit-for 0))
  153.    (w3-running-xemacs
  154.     (if (and (not (sit-for 0)) (input-pending-p))
  155.     (condition-case ()
  156.         (dispatch-event (next-command-event))
  157.       (error nil))))
  158.    (t (sit-for 0))))
  159.  
  160. (defvar w3-end-tags nil)
  161.  
  162. (defun w3-handle-single-tag (tag &optional args)
  163.   (save-excursion
  164.     (set-buffer w3-draw-buffer)
  165.     (let ((opos (point)))
  166.       (goto-char (point-max))
  167.       (if (and (w3-get-state 'next-break)
  168.            (not (memq tag '(p h1 h2 h3 h4 h5 h6 ol ul dl menu dir pre))))
  169.       (w3-handle-p))
  170.       (w3-put-state 'next-break nil)
  171.       (setq w3-current-formatter (get 'w3-formatters tag))
  172.       (if (not (eq tag 'text))
  173.       (let* ((data-before (w3-get-default-style-info "add.before"))
  174.          (tag (cdr-safe (assoc tag w3-end-tags)))
  175.          (w3-current-formatter w3-current-formatter)
  176.          (w3-draw-buffer (current-buffer))
  177.          (data-after (and tag
  178.                   (w3-get-default-style-info "add.after"))))
  179.         (if data-before
  180.         (progn
  181.           (setq data-before
  182.             (save-excursion
  183.               (set-buffer (get-buffer-create " *style*"))
  184.               (erase-buffer)
  185.               (insert data-before)
  186.               (w3-preparse-buffer (current-buffer) t)))
  187.           (while data-before
  188.             (w3-handle-single-tag (car (car data-before))
  189.                       (cdr (car data-before)))
  190.             (setq data-before (cdr data-before)))))
  191.         (if data-after
  192.         (progn
  193.           (setq data-after
  194.             (save-excursion
  195.               (set-buffer (get-buffer-create " *style*"))
  196.               (erase-buffer)
  197.               (insert data-after)
  198.               (w3-preparse-buffer (current-buffer) t)))
  199.           (while data-after
  200.             (w3-handle-single-tag (car (car data-after))
  201.                       (cdr (car data-after)))
  202.             (setq data-after (cdr data-after)))))))
  203.       (cond
  204.        ((eq w3-current-formatter 'ack) nil)
  205.        ((null w3-current-formatter) (w3-handle-unknown-tag tag args))
  206.        (t (funcall w3-current-formatter args)))
  207.       (if (not (eq tag 'text))
  208.       (setq w3-last-tag tag))
  209.       (goto-char opos))))
  210.  
  211. (defun w3-draw-html (stream)
  212.   (let (
  213.     chunk                ; Current 'chunk' of HTML
  214.     tag                ; The current HTML tag
  215.     args                ; Arguments to the html tag
  216.     formatter            ; The formatting function to call
  217.  
  218.     (len (length stream))        ; Length of parsed html
  219.     (ctr 0)                ; How much we've parsed
  220.     (fill-column (- (or w3-strict-width (window-width)) w3-right-border))
  221.     )
  222.     (set-buffer (get-buffer-create url-working-buffer))
  223.     (erase-buffer)
  224.     (w3-init-state)
  225.     (setq w3-draw-buffer (current-buffer))
  226.     (switch-to-buffer (current-buffer))
  227.     (setq w3-last-fill-pos (point)
  228.       fill-prefix "")
  229.     (while stream
  230.       (if (= (% ctr 10) 0)
  231.       (if w3-do-incremental-display
  232.           (w3-pause)
  233.         (url-lazy-message "Drawing... %d%% done."
  234.                   (url-percentage ctr len))))
  235.       (setq w3-last-tag tag
  236.         ctr (1+ ctr)
  237.         chunk (car stream)
  238.         tag (car chunk)
  239.         args (cdr chunk)
  240.         stream (cdr stream)
  241.         formatter (get 'w3-formatters tag)
  242.         )
  243.       (w3-handle-single-tag tag args))
  244.     (save-excursion
  245.       (goto-char (point-max))
  246.       (w3-handle-paragraph))
  247.     (w3-mode)
  248.     (w3-handle-annotations)
  249.     (w3-handle-headers)
  250.     (if (boundp 'MULE) (w3-mule-attribute-zones w3-zones-list))
  251.     (message "Drawing... done.")
  252.     (set-buffer-modified-p nil)
  253.     (setq buffer-read-only t)
  254.     (let ((window nil)
  255.       (pop-up-windows nil))
  256.       (switch-to-buffer (current-buffer))
  257.       (display-buffer (current-buffer))
  258.       (if (or w3-running-FSF19 w3-running-xemacs)
  259.       (setq window (get-buffer-window (current-buffer) t))
  260.     (setq window (get-buffer-window (current-buffer))))
  261.       (select-window window)
  262.       (if (and (fboundp 'select-frame)
  263.            (fboundp 'window-frame))
  264.       (select-frame (window-frame window))))
  265.     ))
  266.  
  267.  
  268. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  269. ;;; Set up basic fonts/stuff
  270. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  271.               
  272. (defun w3-init-state ()
  273.   ;; Reset the state of an HTML drawing buffer
  274.   (setq w3-state-vector (copy-sequence w3-state-vector))
  275.   (setq w3-current-stylesheet (copy-tree w3-user-stylesheet))
  276.   (setq w3-form-labels nil)
  277.   (if (not (get 'w3-state 'init)) (w3-draw-setup))
  278.   (fillarray w3-state-vector 0)
  279.   (w3-put-state 'bogus nil)        ; Make all fake ones return nil
  280.   (w3-put-state 'text-mangler nil)    ; Any text mangling routine 
  281.   (w3-put-state 'next-break nil)    ; Next item needs a paragraph break
  282.   (w3-put-state 'background nil)    ; Netscapism - gag
  283.   (w3-put-state 'table nil)        ; Table args
  284.   (w3-put-state 'figdata nil)        ; Data for <fig> tag
  285.   (w3-put-state 'figalt nil)        ; Alt data for <fig> tag
  286.   (w3-put-state 'pre-start nil)        ; Where current <pre> seg starts
  287.   (w3-put-state 'zone nil)        ; Zone of current href?
  288.   (w3-put-state 'center nil)        ; netscape tag
  289.   (w3-put-state 'select nil)        ; Data for current select field
  290.   (w3-put-state 'options nil)        ; Options in current select field
  291.   (w3-put-state 'nofill nil)        ; non-nil if in pre or xmp
  292.   (w3-put-state 'nowrap nil)        ; non-nil if in <p nowrap>
  293.   (w3-put-state 'href nil)        ; Current link destination
  294.   (w3-put-state 'name nil)        ; Current link ID tag
  295.   (w3-put-state 'image nil)        ; Current image destination
  296.   (w3-put-state 'mpeg nil)        ; Current mpeg destination
  297.   (w3-put-state 'form nil)        ; Current form information
  298.   (w3-put-state 'optarg nil)        ; Option arguments
  299.   (w3-put-state 'w3-graphic nil)    ; Image stuff for non-xemacs
  300.   (w3-put-state 'lists '())        ; Types of list currently in.
  301.   (w3-put-state 'align nil)        ; Current alignment of paragraphs
  302.   (w3-put-state 'title nil)        ; Whether we can have a title or not
  303.   (w3-put-state 'needspace 'never)    ; Spacing info
  304.   (setq w3-active-faces nil)        ; Face attributes to use
  305.   )
  306.  
  307. (defvar w3-rot13-display-table
  308.   (if (fboundp 'make-display-table)
  309.       (let ((table (make-display-table))
  310.         (i 0))
  311.     (while (< i 26)
  312.       (aset table (+ i ?a) (vector (+ (% (+ i 13) 26) ?a)))
  313.       (aset table (+ i ?A) (vector (+ (% (+ i 13) 26) ?A)))
  314.       (setq i (1+ i)))
  315.     table))
  316.   "Char table for rot 13 display.")
  317.  
  318. (defun w3-draw-setup ()
  319.   ;; Initialize stuff for drawing HTML.  This takes care of creating
  320.   ;; faces if necessary and scaling fonts, etc.  Also sets up all the
  321.   ;; character-level formatting handling functions from `w3-faces'
  322.  
  323.   ;; Set up the base list of end tags
  324.   (let ((plist (symbol-plist 'w3-formatters))
  325.     (name nil))
  326.     (while plist
  327.       (if (= (string-to-char (symbol-name (car plist))) ?/)
  328.       (setq w3-end-tags (cons (cons (car plist)
  329.                     (intern (substring
  330.                          (symbol-name (car plist)) 1)))
  331.                   w3-end-tags)))
  332.                   
  333.       (setq plist (cdr (cdr plist)))))
  334.        
  335.   ;; Convert the old style of list chars to our new symbol-based way
  336.   (mapcar
  337.    (function
  338.     (lambda (x)
  339.       (if (stringp (car x))
  340.       (setcar x (intern (downcase (car x)))))))
  341.    w3-list-chars-assoc)
  342.  
  343.   ;; Convert the old style of style tags to our new symbol-based way
  344.   (setq w3-style-tags-assoc
  345.     (mapcar '(lambda (x)
  346.            (cons (intern (downcase (car x)))
  347.              (cdr x)))
  348.         w3-style-chars-assoc))
  349.  
  350.   ;; Convert the old style of entities to our new symbol-based way
  351.   (mapcar
  352.    (function
  353.     (lambda (x)
  354.       (put 'w3-entities (read (substring (car x) 1 nil)) (cdr x))))
  355.    w3-html-entities)
  356.  
  357.   ;; Convert the old style graphic entities to new symbol-base
  358.   (mapcar
  359.    (function
  360.     (lambda (x)
  361.       (put 'w3-entities (read (substring (car x) 1 nil)) (cdr (cdr x)))))
  362.    w3-graphics-entities-alist)
  363.  
  364.   (if (and (fboundp 'make-face)
  365.        (or (not (eq 'tty (device-type)))
  366.            (fboundp 'valid-specifier-locale-p)))
  367.       (let ((faces (face-list)))
  368.     ;; Ensure that we have an underlined face (some versions of emacs
  369.     ;; do not supply one by default.
  370.     (if (not (memq 'underline faces))
  371.         (make-face 'underline))
  372.     (if (face-differs-from-default-p 'underline) nil
  373.       (cond
  374.        ((fboundp 'set-face-underline-p)
  375.         (funcall 'set-face-underline-p 'underline t))
  376.        (w3-running-epoch
  377.         (if (face-instance 'underline)
  378.         (set-style-underline (face-instance 'underline) "white")))
  379.        (t (w3-warn 'faces "Could not create an underlined face."))))
  380.     
  381.     ;; Create all the faces.
  382.     ;; To avoid creating a lot of copies of faces, we use the
  383.     ;; new `face-would-differ-from-default-p' function.  If the
  384.     ;; face is undefined, just store a pointer to the default face
  385.     ;; instead of creating a new face and copying the old one.
  386.     ;;
  387.     ;; This can lead to lossage under epoch, since we go by the
  388.     ;; X resources, not the actual faces (since you can't get to them
  389.     ;; directly), so if color or font allocation failed for some face
  390.     ;; we may lose.
  391.     (mapcar
  392.      (function
  393.       (lambda (x)
  394.         (let ((varname (intern (format "w3-%s-style" (car x)))))
  395.           (if (face-would-differ-from-default-p (car x))
  396.           (progn
  397.             (set varname (car x))
  398.             (make-face (car x)))
  399.         (set varname (cdr x)))
  400.           (make-variable-buffer-local varname)
  401.           (put varname 'variable-documentation
  402.            (concat "Face storage for <" (symbol-name (car x))
  403.                "> tags")))))
  404.      w3-faces)
  405.     
  406.     (make-face 'rot13)
  407.     (if (fboundp 'set-face-property)
  408.         (set-face-property 'rot13 'display-table w3-rot13-display-table)
  409.       (w3-munge-color-fore 'rot13 "white")
  410.       (w3-munge-color-back 'rot13 "white"))
  411.     
  412.     ;; Make sure that wired looks pretty ugly, even if there are
  413.     ;; no Xdefaults for it.
  414.     ;;
  415.     ;; This causes bad things to happen on Mono displays, so only
  416.     ;; do it if we are running on a color system.
  417.  
  418.     (setq w3-wired-style 'wired)
  419.     (make-face 'wired)
  420.     (if (and (not (eq 'mono (device-class)))
  421.          (not (face-differs-from-default-p 'wired)))
  422.         (progn
  423.           (w3-munge-color-fore 'wired "red")
  424.           (w3-munge-color-back 'wired "yellow")))
  425.  
  426.     ;; Make sure we don't blink a non-w3 face
  427.     (setq-default w3-blink-style 'blink)
  428.     (make-face 'blink)
  429.     (if (and (not (face-differs-from-default-p 'blink))
  430.          (fboundp 'copy-face))
  431.         (if (fboundp 'set-face-blinking-p)
  432.         (set-face-blinking-p 'blink t)
  433.           (copy-face 'italic 'blink)))
  434.  
  435.     (make-face 'w3-graphic-face)
  436.     (if (not (face-differs-from-default-p 'w3-graphic-face))
  437.         (progn
  438.           (copy-face 'w3-node-style 'w3-graphic-face)
  439.           (condition-case ()
  440.           (make-face-bold 'w3-graphic-face)
  441.         (error nil))))
  442.  
  443.     ;; Do some fancy scaling of fonts if we can.
  444.     ;;
  445.     ;; We allow the user preferences in their XDefaults file will
  446.     ;; of course override anything we try to do here.
  447.     ;;
  448.     (if (and (fboundp 'make-face-larger)
  449.          (or (not (fboundp 'device-list))
  450.              (memq 'x (mapcar 'device-type (device-list)))))
  451.         (let ((faces (face-list))
  452.           (face nil)
  453.           (amt nil))
  454.           (mapcar
  455.            (function
  456.         (lambda (face-pair)
  457.           (setq face (car face-pair)
  458.             amt  (cdr face-pair))
  459.           (if (and (memq face faces)
  460.                (face-differs-from-default-p face))
  461.               nil
  462.             (message "Scaling font for %s, please wait..."
  463.                  (symbol-name face))
  464.             (make-face face)
  465.             (eval (list 'setq-default
  466.                 (intern
  467.                  (concat "w3-" (symbol-name face) "-style"))
  468.                 (list 'quote face)))
  469.             (if (< amt 0)
  470.             (mapcar (function (lambda (x)
  471.                         (make-face-smaller face)))
  472.                 (make-list (abs amt) nil))
  473.               (mapcar (function (lambda (x) (make-face-larger face)))
  474.                   (make-list (abs amt) nil))))))
  475.            '((h1    .  3)     (h2    .  2)
  476.          (h3    .  0)     (h4    . -1)
  477.          (h5    . -2)     (h6    . -3)
  478.          (font0 . -3)    (font1 . -2)
  479.          (font2 . -1)     (font3 .  0)
  480.          (font4 .  2)    (font5 .  4)
  481.          (font6 .  6)    (font7 .  8)))))))
  482.               
  483.   (mapcar
  484.    (function
  485.     (lambda (x)
  486.       (if (memq (car x) '(h1 h2 h3 h4 h5 h6 q
  487.                  font0 font1 font2 font3 font4 font5 font6 font7))
  488.       nil
  489.     (let* ((foo (car x))
  490.            (bar (intern (concat "/" (symbol-name foo)))))
  491.       (put 'w3-formatters foo 'w3-handle-emphasis)
  492.       (put 'w3-formatters bar 'w3-handle-emphasis-end)
  493.       (setq w3-end-tags (cons (cons bar foo) w3-end-tags))))))
  494.    w3-faces)
  495.   (put 'w3-state 'init t)
  496.   (put 'w3-formatters 'blink 'w3-handle-blink)
  497.   (put 'w3-formatters '/blink 'w3-handle-/blink)
  498.   (cond
  499.    ((null w3-do-blinking) (message "Won't do blinking text."))
  500.    ((fboundp 'set-face-blinking-p)
  501.     (set-face-blinking-p 'blink t))
  502.    ((eq (device-type) 'tty)
  503.     (message "Cannot do blinking text."))
  504.    ((featurep 'itimer)
  505.     (let ((timer (get-itimer "w3-blink")))
  506.       (if timer (delete-itimer timer))
  507.       (start-itimer "w3-blink" 'w3-invert-face 1 1)))
  508.    ((or (featurep 'timer)
  509.     (condition-case ()
  510.         (require 'timer)
  511.       (error nil)))
  512.     (run-at-time 1 1 'w3-invert-face))
  513.    (t (message "Cannot do blinking text.")))
  514.   (w3-init-state))
  515.   
  516.  
  517. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  518. ;;; Mapping HTML tags to functions
  519. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  520. (put 'w3-formatters 'xmp 'w3-handle-xmp)
  521. (put 'w3-formatters '/xmp 'w3-handle-/pre)
  522. (put 'w3-formatters 'lit 'w3-handle-pre)
  523. (put 'w3-formatters '/lit 'w3-handle-/pre)
  524. (put 'w3-formatters 'li 'w3-handle-list-item)
  525. (put 'w3-formatters 'ul 'w3-handle-list-opening)
  526. (put 'w3-formatters 'ol 'w3-handle-list-opening)
  527. (put 'w3-formatters 'dl 'w3-handle-list-opening)
  528. (put 'w3-formatters '/dl 'w3-handle-list-ending)
  529. (put 'w3-formatters '/ul 'w3-handle-list-ending)
  530. (put 'w3-formatters '/ol 'w3-handle-list-ending)
  531. (put 'w3-formatters 'menu 'w3-handle-list-opening)
  532. (put 'w3-formatters '/menu 'w3-handle-list-ending)
  533. (put 'w3-formatters 'dir 'w3-handle-list-opening)
  534. (put 'w3-formatters '/dir 'w3-handle-list-ending)
  535. (put 'w3-formatters 'dt 'w3-handle-table-term)
  536. (put 'w3-formatters 'dd 'w3-handle-table-definition)
  537. (put 'w3-formatters 'a 'w3-handle-hyperlink)
  538. (put 'w3-formatters '/a 'w3-handle-hyperlink-end)
  539. (put 'w3-formatters 'h1 'w3-handle-header)
  540. (put 'w3-formatters 'h2 'w3-handle-header)
  541. (put 'w3-formatters 'h3 'w3-handle-header)
  542. (put 'w3-formatters 'h4 'w3-handle-header)
  543. (put 'w3-formatters 'h5 'w3-handle-header)
  544. (put 'w3-formatters 'h6 'w3-handle-header)
  545. (put 'w3-formatters '/h1 'w3-handle-header-end)
  546. (put 'w3-formatters '/h2 'w3-handle-header-end)
  547. (put 'w3-formatters '/h3 'w3-handle-header-end)
  548. (put 'w3-formatters '/h4 'w3-handle-header-end)
  549. (put 'w3-formatters '/h5 'w3-handle-header-end)
  550. (put 'w3-formatters '/h6 'w3-handle-header-end)
  551. (put 'w3-formatters 'img 'w3-handle-image)
  552. (put 'w3-formatters 'kill_sgml 'w3-handle-kill-sgml)
  553.  
  554. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  555. ;;; The main drawing routines
  556. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  557. (defun w3-handle-unknown-tag (tag args)
  558.   ;; A generic formatter for an unkown HTML tag.  This will only be
  559.   ;; called if TAG was not found in the property list of `w3-formatters'.
  560.   ;; If a function named `w3-handle-TAG' is defined, then it will be put
  561.   ;; into the `w3-formatters' property list, so it will be found next time
  562.   ;; the tag is run across.
  563.   (if (numberp tag) (setq tag (intern (int-to-string tag))))
  564.   (if (symbolp tag)
  565.       (let ((handler (intern (concat "w3-handle-" (symbol-name tag)))))
  566.     (if (= (string-to-char (symbol-name tag)) ?/)
  567.         (setq w3-end-tags (cons (cons tag
  568.                       (intern (substring (symbol-name tag)
  569.                                  1)))
  570.                     w3-end-tags)))
  571.     (if (and handler (fboundp handler))
  572.         (if (w3-get-state 'table)
  573.         (progn
  574.           (put 'w3-formatters tag 'w3-table-store-data)
  575.           (funcall 'w3-table-store-data args))
  576.           (put 'w3-formatters tag handler)
  577.           (funcall handler args))
  578.       (put 'w3-formatters tag 'ack)))))
  579.  
  580. (defun w3-handle-plaintext (&optional args)
  581.   (let ((x (w3-get-state 'nofill)))
  582.     (w3-put-state 'nofill t)
  583.     (w3-handle-text (cdr-safe (assoc "data" args)))
  584.     (setq w3-last-fill-pos (point))
  585.     (w3-put-state 'nofill x)))
  586.  
  587. (defun w3-handle-text (&optional args)
  588.   ;; This is the main workhorse of the display engine.
  589.   ;; It will figure out how a chunk of text should be displayed and
  590.   ;; put all the necessary extents/overlays/regions around it."
  591.   (cond
  592.    ((null args) nil)
  593.    ((string= args "")
  594.     (setq args nil)
  595.     (w3-put-state 'needspace nil))
  596.    ((or (eq (w3-get-state 'needspace) 'never)
  597.     (and (bolp) (not (w3-get-state 'nofill))
  598.          (= (string-to-char args) ? )))
  599.     (while (= (string-to-char args) ? )
  600.       (setq args (substring args 1)))))
  601.   (if args
  602.       (let ((st (point))
  603.         (mangler (w3-get-state 'text-mangler))
  604.         (sym nil))
  605.     (if (stringp args) (insert args) (apply 'insert args))
  606.     (and mangler w3-delimit-emphasis
  607.          (fboundp mangler) (funcall mangler st (point)))
  608.     (mapcar (function
  609.          (lambda (face)
  610.            (w3-add-zone st (point) face (cons 'w3emph face) nil)))
  611.         (delq nil
  612.               (mapcar
  613.                (function
  614.             (lambda (x)
  615.               (setq sym (cdr-safe (assoc x w3-all-faces)))
  616.               (or (and (boundp sym) (symbol-value sym))
  617.                   (and (consp x) (cdr x)))))
  618.                w3-active-faces)))
  619.     (cond
  620.      ((w3-get-state 'href)
  621.       (if (w3-get-state 'zone)
  622.           (w3-extend-zone (w3-get-state 'zone) (point))
  623.         (w3-put-state 'zone
  624.          (w3-add-zone
  625.           st (point)
  626.           (if (url-have-visited-url (w3-get-state 'href))
  627.               w3-visited-node-style
  628.             w3-node-style)
  629.           (list 'w3
  630.             (w3-get-state 'name)
  631.             (w3-get-state 'href)
  632.             (w3-get-state 'txt)
  633.             (w3-get-state 'urn)
  634.             (w3-get-state 'rel)
  635.             (w3-get-state 'rev)
  636.             (w3-get-state 'meth)
  637.             (w3-get-state 'title)) t))))
  638.      ((w3-get-state 'name)
  639.       (w3-add-zone st (point) nil
  640.                (cons 'w3 (list (w3-get-state 'name))))))
  641.     (if (w3-get-state 'w3-graphic)
  642.         (w3-add-zone st (point) nil (list 'w3graphic
  643.                           (w3-get-state 'w3-graphic)) t))
  644.     ;;    (if (and (not (w3-get-state 'nofill))
  645.     ;;         (>= (current-column) fill-column))
  646.     ;;    (do-auto-fill))
  647.     (if (not (memq (char-after (1- (point))) '(?  ?.)))
  648.         (w3-put-state 'needspace t))
  649.     )))
  650.  
  651. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  652. ;;; Paragraph breaks, and other things that can cause linebreaks and
  653. ;;; alignment changes.
  654. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  655. (defmacro w3-push-alignment ()
  656.   (` (if align
  657.      (w3-put-state 'align (cons (cons tag align) (w3-get-state 'align))))))
  658.  
  659. (defmacro w3-pop-alignment ()
  660.   (` (let ((flubber (memq (assq tag (w3-get-state 'align))
  661.               (w3-get-state 'align))))
  662.        (cond
  663.     ((null flubber) nil)
  664.     ((cdr flubber)
  665.      (w3-put-state 'align (cdr flubber)))
  666.     (t (w3-put-state 'align nil))))))
  667.  
  668. (defmacro w3-current-alignment ()
  669.   (` (cdr-safe (car-safe (w3-get-state 'align)))))
  670.  
  671. ;(defun w3-push-alignment ()
  672. ;  (if align
  673. ;      (w3-put-state 'align (cons (cons tag align) (w3-get-state 'align)))))
  674.  
  675. ;(defun w3-pop-alignment ()
  676. ;  (let ((flubber (memq (assq tag (w3-get-state 'align))
  677. ;               (w3-get-state 'align))))
  678. ;    (cond
  679. ;     ((null flubber) nil)
  680. ;     ((cdr flubber)
  681. ;      (w3-put-state 'align (cdr flubber)))
  682. ;     (t (w3-put-state 'align nil)))))
  683.  
  684. ;(defun w3-current-alignment ()
  685. ;  (cdr-safe (car-safe (w3-get-state 'align))))
  686.  
  687. (defun w3-handle-header (&optional args)
  688.   ;; Handle the creation of a header (of any level).  Causes a full
  689.   ;; paragraph break. 
  690.   (w3-handle-emphasis args)
  691.   (let ((name (or (cdr-safe (assoc "name" args))
  692.           (cdr-safe (assoc "id" args))))
  693.     (align (cdr-safe (assoc "align" args)))
  694.     (mangler (nth 2 (cdr-safe (assoc tag w3-header-chars-assoc)))))
  695.     (w3-handle-p)
  696.     (if align
  697.     (setq align (intern (downcase align)))
  698.       (setq align (w3-get-default-style-info "align")))
  699.     (w3-push-alignment)
  700.     (w3-put-state 'text-mangler mangler)
  701.     (if name (w3-put-state 'name name))))
  702.  
  703. (defun w3-handle-header-end (&optional args)
  704.   ;; Handle the closing of a header (of any level).  Causes a full
  705.   ;; paragraph break.
  706.   (w3-handle-emphasis-end)
  707.   (let ((mangler (w3-get-state 'text-mangler)))
  708.     (and mangler (funcall mangler nil nil t)))
  709.   (w3-put-state 'text-mangler nil)
  710.   (goto-char (point-max))
  711.   (w3-handle-p)
  712.   (let* ((info (car-safe (w3-get-state 'lists)))
  713.      (type (and info (car-safe info))))
  714.     (if (and type fill-prefix)
  715.     (insert fill-prefix (cond
  716.                  ((memq type '(ol dl)) "    ")
  717.                  (t "  ")))))
  718.   (let ((tag (cdr-safe (assoc tag w3-end-tags))))
  719.     (w3-pop-alignment)))
  720.  
  721. (defun w3-handle-pre (&optional args)
  722.   ;; Marks the start of a preformatted section of text.  No paragraph
  723.   ;; filling should be done from this point until a matching /pre has
  724.   ;; been encountered.
  725.   (w3-handle-p)
  726.   (w3-put-state 'nofill t)
  727.   (w3-put-state 'pre-start (set-marker (make-marker) (point)))
  728.   )
  729.  
  730. (defun w3-handle-xmp (&optional args)
  731.   ;; Marks the start of a preformatted section of text.  No paragraph
  732.   ;; filling should be done from this point until a matching /pre has
  733.   ;; been encountered.
  734.   (w3-handle-p)
  735.   (w3-put-state 'nofill t)
  736.   (w3-put-state 'needspace t)
  737.   (w3-put-state 'pre-start (set-marker (make-marker) (point)))
  738.   (if args
  739.       (w3-handle-text (cdr-safe (assoc "data" args))))
  740.   )
  741.  
  742. (defun w3-handle-/pre (&optional args)
  743.   (if (not (w3-get-state 'nofill))
  744.       (w3-handle-p)
  745.     (w3-put-state 'nofill nil)
  746.     (let* ((info (car-safe (w3-get-state 'lists)))
  747.        (type (and info (car-safe info)))
  748.        (st (w3-get-state 'pre-start)))
  749.       (if (not (bolp)) (insert "\n"))
  750.       (if (and type fill-prefix st)
  751.       (progn
  752.         (save-excursion
  753.           (goto-char st)
  754.           (while (re-search-forward "^" nil t)
  755.         (insert fill-prefix (cond
  756.                      ((memq type '(ol dl)) "    ")
  757.                      (t "  ")))))
  758.         (setq w3-last-fill-pos (point))
  759.         (insert fill-prefix (cond
  760.                  ((memq type '(ol dl)) "    ")
  761.                  (t "  "))))
  762.     (setq w3-last-fill-pos (point))))
  763.     (let ((tag 'p))
  764.       (w3-handle-p))
  765.     (setq w3-active-faces nil)
  766.     (w3-put-state 'pre-start nil)))  
  767.  
  768. (defun w3-handle-blockquote (&optional args)
  769.   ;; Start a section of quoted text.  This is done by causing the text
  770.   ;; to be indented from the right and left margins.  Nested
  771.   ;; blockquotes will cause further indentation.
  772.   (let ((align (or (w3-get-default-style-info "align") 'indent)))
  773.     (w3-handle-p)
  774.     (w3-push-alignment))
  775.   (w3-put-state 'fillcol fill-column)
  776.   (setq fill-column (max (- (or fill-column
  777.                 (1- (or w3-strict-width (window-width)))) 8)
  778.              10)))
  779.  
  780. (defun w3-handle-/blockquote (&optional args)
  781.   (w3-handle-paragraph)
  782.   (let ((tag (cdr-safe (assoc tag w3-end-tags))))
  783.     (w3-pop-alignment))
  784.   (setq fill-column (or (w3-get-state 'fillcol) (1- (or w3-strict-width
  785.                              (window-width)))))
  786.   (w3-put-state 'fillcol nil))
  787.  
  788. (defun w3-handle-align (&optional args)
  789.   ;; Cause a single line break (like <BR>) and replace the current
  790.   ;; alignment.
  791.   (let ((align (intern (or (cdr-safe (assoc "role" args))
  792.                (cdr-safe (assoc "align" args))
  793.                (cdr-safe (assoc "style" args))))))
  794.     (w3-handle-paragraph)
  795.     (w3-push-alignment)))
  796.  
  797. (defun w3-handle-/align (&optional args)
  798.   (w3-handle-paragraph)
  799.   (w3-pop-alignment))
  800.  
  801. (defun w3-handle-hr (&optional args)
  802.   ;; Cause a line break and insert a horizontal rule across the page.
  803.   (w3-handle-paragraph)
  804.   (let* ((perc (or (cdr-safe (assoc "width" args))
  805.            (w3-get-default-style-info "width")
  806.            "100%"))
  807.      (old-align (w3-current-alignment))
  808.      (talign (intern (downcase
  809.               (or (cdr-safe (assoc "textalign" args))
  810.                   (and old-align (symbol-name old-align))
  811.                   "center"))))
  812.      (text (cdr-safe (assoc "label" args)))
  813.      (align (cdr-safe (assoc "align" args)))
  814.      (rule nil)
  815.      (width nil))
  816.     (setq align (if align
  817.             (intern (downcase align))
  818.           (or
  819.            (w3-get-default-style-info "align")
  820.            old-align 'center)))
  821.     (w3-push-alignment)
  822.  
  823.     (setq perc (min (string-to-int perc) 100)
  824.       width (/ (* (- (or w3-strict-width
  825.                  (window-width))
  826.              w3-right-border) perc) 100))
  827.     (if text
  828.     (cond
  829.      ((>= (length text) width)
  830.       (setq rule (concat "-" text "-")))
  831.      ((eq talign 'right)
  832.       (setq rule (concat (make-string (- width 1 (length text))
  833.                       w3-horizontal-rule-char)
  834.                  text "-")))
  835.      ((eq talign 'center)
  836.       (let ((half (make-string (/ (- width (length text)) 2)
  837.                    w3-horizontal-rule-char)))
  838.         (setq rule (concat half text half))))
  839.      ((eq talign 'left)
  840.       (setq rule (concat "-" text (make-string (- width 1
  841.                               (length text))
  842.                            w3-horizontal-rule-char)))))
  843.       (setq rule (make-string width w3-horizontal-rule-char)))
  844.     (w3-handle-text rule)
  845.     (w3-handle-paragraph)
  846.     (w3-pop-alignment)
  847.     (setq w3-last-fill-pos (point))
  848.     (let* ((info (car-safe (w3-get-state 'lists)))
  849.        (type (and info (car-safe info)))
  850.        (cur (w3-current-alignment)))
  851.       (cond
  852.        ;;((eq cur 'indent)
  853.        ;;(insert (make-string w3-indent-level ? )))
  854.        ((and type fill-prefix (eq w3-last-tag 'dt))
  855.     (insert fill-prefix))
  856.        ((and type fill-prefix)
  857.     (insert fill-prefix (if (eq type 'ol) "    " "  ")))
  858.        (t nil)))))
  859.  
  860. (defun w3-handle-/p (&optional args)
  861.   ;; Marks the end of a paragraph.  Only causes a paragraph break if
  862.   ;; it is not followed by another paragraph or similar markup
  863.   ;; (headers, list openings, etc) that will already cause a new
  864.   ;; paragraph to be started.
  865.   (w3-handle-emphasis-end)
  866.   (let ((tag (cdr-safe (assoc tag w3-end-tags))))
  867.     (w3-handle-p)
  868.     (w3-pop-alignment)))
  869.  
  870. (defun w3-handle-p (&optional args)
  871.   (if (or (not (memq w3-last-tag '(li dt dd)))
  872.       (memq tag '(ol ul dl menu dir)))
  873.       (let ((name (or (cdr-safe (assoc "name" args))
  874.               (cdr-safe (assoc "id" args))))
  875.         (align (cdr-safe (assoc "align" args))))
  876.     (w3-handle-emphasis-end)
  877.     (w3-handle-emphasis args)
  878.     (w3-handle-paragraph)
  879.     (w3-put-state 'nowrap (assoc "nowrap" args))
  880.     (setq align (if align
  881.             (intern (downcase align))
  882.               (w3-get-default-style-info "align")))
  883.     (and (eq tag 'p) (progn
  884.                (w3-pop-alignment)
  885.                (w3-push-alignment)))
  886.     (if (not (bobp))
  887.         (progn
  888.           (insert (cond
  889.                ((and (eolp) (bolp)) "\n")
  890.                ((eolp) "\n\n")
  891.                (t "\n")))
  892.           (setq w3-last-fill-pos (point))
  893.           (insert (cond
  894.                ((null fill-prefix) "")
  895.                ((string= fill-prefix "") "")
  896.                ((eq (car (car (w3-get-state 'lists))) 'ol)
  897.             (concat fill-prefix "    "))
  898.                (t (concat fill-prefix "  "))))))
  899.     (if name (w3-put-state 'name name)))))
  900.  
  901. (defun w3-handle-br (&optional args)
  902.   ;; Cause a single line break.
  903.   ;; The alignment will only effect the chunk of text (generally to
  904.   ;; the last <br> or <p> tag) immediately before the <br>.  After
  905.   ;; that, the alignment will revert to the containers alignment.
  906.   (w3-handle-paragraph)
  907.   (let* ((info (car-safe (w3-get-state 'lists)))
  908.      (type (and info (car-safe info)))
  909.      (cur (w3-current-alignment)))
  910.     (cond
  911.      ;;((eq cur 'indent)
  912.      ;;(insert (make-string w3-indent-level ? )))
  913.      ((and type fill-prefix (eq w3-last-tag 'dt))
  914.       (insert fill-prefix))
  915.      ((and type fill-prefix)
  916.       (insert fill-prefix (if (eq type 'ol) "    " "  ")))
  917.      (t nil))))
  918.  
  919. (defmacro w3-fixup-punctuation (char)
  920.   (`
  921.    (let ((x (char-to-string (, char))))
  922.      (goto-char w3-last-fill-pos)
  923.      (while (search-forward x nil t)
  924.        (if (and (equal ?  (char-after (point)))
  925.         (not (equal (, char) (char-after (max (- (point) 2)
  926.                               w3-last-fill-pos)))))
  927.        (insert " "))))))
  928.  
  929. (defun w3-handle-paragraph (&optional args)
  930.   (if (not (bobp))
  931.       (let* ((align (w3-current-alignment))
  932.          (fill-prefix
  933.           (cond
  934.            ((eq align 'indent) (concat (or fill-prefix "")
  935.                        (make-string w3-indent-level ? )))
  936.            ((null fill-prefix) "")
  937.            ((string= fill-prefix "") "")
  938.            ((eq (car (car (w3-get-state 'lists))) 'ol)
  939.         (concat fill-prefix "    "))
  940.            (t (concat fill-prefix "  ")))))
  941.     (if (eq align 'indent)
  942.         (progn
  943.           (goto-char w3-last-fill-pos)
  944.           (insert fill-prefix)
  945.           (goto-char (point-max))))
  946.     (if (and (not (w3-get-state 'nofill))
  947.          (not (w3-get-state 'nowrap))
  948.          (> (current-column) fill-column))
  949.         (fill-region-as-paragraph w3-last-fill-pos (point)
  950.                       (eq align 'justify)))
  951. ;    (if (not (w3-get-state 'nofill))
  952. ;        (progn
  953. ;          (w3-fixup-punctuation ?.)
  954. ;          (w3-fixup-punctuation ?!)))
  955.     (goto-char (point-max))
  956.     (skip-chars-backward " \t\n")
  957.     (delete-region (point) (point-max))
  958.     (if (< w3-last-fill-pos (point))
  959.         (cond
  960.          ((or (eq align 'center) (w3-get-state 'center))
  961.           (center-region w3-last-fill-pos (point)))
  962.          ((eq align 'right)
  963.           (let ((x (point)))
  964.         (catch 'fill-exit
  965.           (save-excursion
  966.             (goto-char w3-last-fill-pos)
  967.             (while (re-search-forward "$" x t)
  968.               (if (/= (current-column) fill-column)
  969.               (let ((buff (- fill-column (current-column))))
  970.                 (beginning-of-line)
  971.                 (setq x (+ x buff))
  972.                 (if (> buff 0)
  973.                 (insert (make-string buff ? )))
  974.                 (end-of-line))
  975.             (end-of-line))
  976.               (if (eobp) (throw 'fill-exit t))
  977.               (condition-case ()
  978.               (forward-char 1)
  979.             (error (throw 'fill-exit t))))))))))
  980.     (insert "\n")
  981.     (setq w3-last-fill-pos (point))
  982.     (w3-put-state 'needspace 'never))))
  983.  
  984. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  985. ;;; List handling code
  986. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  987. (defun w3-handle-list-ending (&optional args)
  988.   ;; Handles all the list terminators (/ol /ul /dl).
  989.   ;; This just fills the last paragrpah, then reduces the depth in
  990.   ;; `w3-state' and truncates `fill-prefix'"
  991.   (w3-handle-paragraph)
  992.   (w3-put-state 'depth (max 0 (1- (w3-get-state 'depth))))
  993.   (w3-put-state 'next-break t)
  994.   (setq fill-prefix (make-string (* (w3-get-state 'depth)
  995.                     w3-indent-level) ? ))
  996.   (w3-put-state 'lists (cdr (w3-get-state 'lists)))
  997.   (if (/= 0 (length fill-prefix))
  998.       (insert fill-prefix "  ")))
  999.  
  1000. (defun w3-handle-list-opening (&optional args)
  1001.   ;; Handles all the list openers (ol ul dl).
  1002.   ;; This just fills the last paragraph, then increases the depth in
  1003.   ;; `w3-state' and adds to `fill-prefix'
  1004.   (w3-handle-p)
  1005.   (let ((style (and (not (assoc "style" args))
  1006.             (w3-get-default-style-info "style"))))
  1007.     (if style
  1008.     (setq args (cons (cons "style" style) args))))
  1009.   (w3-put-state 'depth (1+ (w3-get-state 'depth)))
  1010.   (setq fill-prefix (make-string (* (w3-get-state 'depth)
  1011.                     w3-indent-level) ? ))
  1012.   (insert "\n\n" fill-prefix "  ")
  1013.   (w3-put-state 'lists (cons (cons tag (copy-alist args))
  1014.                   (w3-get-state 'lists))))
  1015.  
  1016. (defun w3-handle-table-definition (&optional args)
  1017.   (w3-handle-paragraph)
  1018.   (insert fill-prefix "  "))
  1019.  
  1020. (defun w3-handle-table-term (&optional args)
  1021.   (w3-handle-paragraph)
  1022.   (insert "\n" fill-prefix))
  1023.  
  1024. (defun w3-handle-list-item (&optional args)
  1025.   (w3-handle-paragraph)
  1026.   (let* ((info (car (w3-get-state 'lists)))
  1027.      (type (car info))
  1028.      (endr (or (nth (1- (or (w3-get-state 'depth) 1))
  1029.             (cdr (or (assoc type w3-list-chars-assoc)
  1030.                  (car w3-list-chars-assoc))))
  1031.            "*")))
  1032.     (setq info (cdr info))
  1033.     (cond
  1034.      ((assoc "plain" info)
  1035.       ;; We still need to indent from the left margin for lists without
  1036.       ;; bullets.  This is especially important with nested lists.
  1037.       ;; Question: Do we want this to be equivalent to replacing the
  1038.       ;; bullet by a space (" ") or by indenting so that the text starts
  1039.       ;; where the bullet would have been?  I've chosen the latter after
  1040.       ;; looking at both kinds of output.
  1041.       (insert fill-prefix))
  1042.      ((eq type 'ol)
  1043.       (let ((next (assoc "value" info))
  1044.         (type (cdr-safe (assoc "style" info)))
  1045.         (uppr (assoc "upper" info))
  1046.         (user-spec (cdr-safe (assoc "value" args)))
  1047.         (tokn nil))
  1048.     (if user-spec (setcdr next (string-to-int user-spec)))
  1049.     (cond
  1050.      ((or (assoc "roman" info)
  1051.           (member type '("i" "I")))
  1052.       (setq tokn (concat
  1053.               (w3-pad-string (w3-decimal-to-roman (cdr next)) 3 ?
  1054.                      'left)
  1055.               endr)))
  1056.      ((or (assoc "arabic" info)
  1057.           (member (cdr-safe (assoc "style" info)) '("a" "A")))
  1058.       (setq tokn (concat (w3-pad-string
  1059.                   (w3-decimal-to-alpha (cdr next)) 3 ?  'left)
  1060.                  endr)))
  1061.      (t
  1062.       (setq tokn (concat (w3-pad-string (int-to-string (cdr next))
  1063.                         2 ?  'left)
  1064.                  endr))))
  1065.     (insert fill-prefix tokn " ")
  1066.     (setcdr next (1+ (cdr next)))
  1067.     (w3-put-state 'needspace 'never)))
  1068.      (t
  1069.       (insert fill-prefix endr " ")))))
  1070.  
  1071. (defun w3-pad-string (str len pad side)
  1072.   ;; Pads a string STR to a certain length LEN, using fill character
  1073.   ;; PAD by concatenating PAD to SIDE of the string.
  1074.   (let ((strlen (length str)))
  1075.     (cond
  1076.      ((>= strlen len) str)
  1077.      ((eq side 'right) (concat str (make-string (- len strlen) pad)))
  1078.      ((eq side 'left)  (concat (make-string (- len strlen) pad) str)))))
  1079.  
  1080. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1081. ;;; Routines to handle character-level formatting
  1082. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1083. (defun w3-handle-q (&optional args)
  1084.   (w3-handle-emphasis)
  1085.   (w3-handle-text (or (w3-get-default-style-info "startquote") "\"")))
  1086.  
  1087. (defun w3-handle-/q (&optional args)
  1088.   (let ((tag (cdr-safe (assoc tag w3-end-tags))))
  1089.     (w3-handle-text (or (w3-get-default-style-info "endquote") "\"")))
  1090.   (w3-handle-emphasis-end))
  1091.  
  1092. (defun w3-handle-emphasis (&optional args)
  1093.   ;; Generic handler for character-based emphasis.  Increments the state
  1094.   ;; of TAG (which must be bound by the calling procedure).  This
  1095.   ;; checks all the various stylesheet mechanisms that may cause an
  1096.   ;; alignment shift as well.
  1097.   (let ((align (or (w3-get-default-style-info "align")
  1098.            (and (eq tag 'address) w3-right-justify-address 'right))))
  1099.     (if (and align (not (memq tag '(h1 h2 h3 h4 h5 h6))))
  1100.     (progn
  1101.       (w3-handle-paragraph)
  1102.       (w3-push-alignment))))
  1103.   (let* ((spec (and w3-delimit-emphasis (assoc tag w3-style-tags-assoc)))
  1104.      (class (cdr-safe (assoc "class" args)))
  1105.      (face (w3-face-for-element))
  1106.      (beg (and spec (car (cdr spec)))))
  1107.     (if spec
  1108.     (insert beg))
  1109.     (if face
  1110.     (setq w3-active-faces (cons face w3-active-faces)))))
  1111.  
  1112. (defun w3-handle-emphasis-end (&optional args)
  1113.   ;; Generic handler for ending character-based emphasis.  Decrements
  1114.   ;; the state of TAG (which must be bound by the calling procedure).
  1115.   ;; Stylesheet mechanisms may cause arbitrary alignment changes.
  1116.   (let* ((tag (cdr-safe (assoc tag w3-end-tags)))
  1117.      (spec (and w3-delimit-emphasis (assoc tag w3-style-tags-assoc)))
  1118.      (end (and spec (cdr (cdr spec)))))
  1119.     (if (assq tag w3-active-faces)
  1120.     (setq w3-active-faces (cdr (memq (assq tag w3-active-faces)
  1121.                      w3-active-faces)))
  1122.       (setq w3-active-faces (delq tag w3-active-faces)))
  1123.     (if spec (insert end))
  1124.     (if (eq tag 'address)
  1125.     (progn
  1126.       (w3-handle-paragraph)
  1127.       (w3-pop-alignment)))))
  1128.  
  1129. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1130. ;;; HTML 3.0 compliance
  1131. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1132. (defun w3-handle-div (&optional args)
  1133.   (let ((align (cdr-safe (assoc "align" args))))
  1134.     (w3-handle-emphasis args)
  1135.     (w3-handle-paragraph)
  1136.     (setq align (and align (intern (downcase align))))
  1137.     (w3-push-alignment)))
  1138.  
  1139. (defun w3-handle-/div (&optional args)
  1140.   (w3-handle-emphasis-end)
  1141.   (let ((tag (cdr-safe (assoc tag w3-end-tags))))
  1142.     (w3-handle-paragraph)
  1143.     (w3-pop-alignment)))
  1144.  
  1145. (defun w3-handle-note (&optional args)
  1146.   (w3-handle-emphasis)
  1147.   (w3-handle-paragraph)
  1148.   (let ((align (or (w3-get-default-style-info "align") 'indent)))
  1149.     (w3-push-alignment))
  1150.   (w3-handle-text (concat (or (cdr-safe (assoc "role" args)) "CAUTION") ":")))
  1151.  
  1152. (defun w3-handle-/note (&optional args)
  1153.   (w3-handle-paragraph)
  1154.   (w3-handle-emphasis-end)
  1155.   (let ((tag (cdr-safe (assoc tag w3-end-tags))))
  1156.     (w3-pop-alignment)))
  1157.  
  1158. (defun w3-handle-fig (&optional args)
  1159.   (w3-put-state 'figdata args)
  1160.   (w3-put-state 'figalt (set-marker (make-marker) (point)))
  1161.   )
  1162.  
  1163. (defun w3-handle-caption (&optional args)
  1164.   )
  1165.  
  1166. (defun w3-handle-/caption (&optional args)
  1167.   )
  1168.  
  1169. (defun w3-handle-/fig (&optional args)
  1170.   (let* ((data (w3-get-state 'figdata))
  1171.      (src (cdr-safe (assoc "src" data)))
  1172.      (aln (cdr-safe (assoc "align" data)))
  1173.      (alt (if (w3-get-state 'figalt)
  1174.           (prog1
  1175.               (buffer-substring (w3-get-state 'figalt) (point))
  1176.             (delete-region (w3-get-state 'figalt) (point)))))
  1177.      (ack nil))
  1178.     (setq w3-last-fill-pos (point))
  1179.     (if (not src)
  1180.     (w3-warn 'html "Malformed <fig> tag.")
  1181.       (setq ack (list (cons "src" src)
  1182.               (cons "alt" alt)
  1183.               (cons "align" aln)))
  1184.       (w3-handle-pre nil)
  1185.       (w3-handle-image ack)
  1186.       (w3-handle-/pre nil))))
  1187.  
  1188. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1189. ;;; Netscape Compatibility
  1190. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1191. ; For some reason netscape treats </br> like <br> - ugh.
  1192. (fset 'w3-handle-/br 'w3-handle-br)
  1193.  
  1194. (defun w3-handle-font (&optional args)
  1195.   (let* ((sizearg (or (cdr-safe (assoc "size" args)) "5"))
  1196.      (sizenum (cond
  1197.            ((= ?+ (string-to-char sizearg))
  1198.             (+ 3 (string-to-int (substring sizearg 1))))
  1199.            ((= ?- (string-to-char sizearg))
  1200.             (- 3 (string-to-int (substring sizearg 1))))
  1201.            ((string= sizearg (int-to-string (string-to-int sizearg)))
  1202.             (string-to-int sizearg))
  1203.            (t 4)))
  1204.      (tag (if (integerp sizenum)
  1205.           (intern (concat "font" (int-to-string sizenum)))
  1206.         'font4)))
  1207.     (w3-handle-emphasis args)))
  1208.  
  1209. (defun w3-handle-/font (&optional args)
  1210.   (mapcar
  1211.    (function
  1212.     (lambda (num)
  1213.       (setq tag (intern (concat "font" num))
  1214.         w3-active-faces (delq tag w3-active-faces))))
  1215.    '("0" "1" "2" "3" "4" "5" "6" "7")))
  1216.  
  1217. (defun w3-handle-center (&optional args)
  1218.   (w3-handle-paragraph)
  1219.   (let ((align 'center))
  1220.     (w3-push-alignment)))
  1221.  
  1222. (defun w3-handle-/center (&optional args)
  1223.   (w3-handle-paragraph)
  1224.   (let ((tag 'center))
  1225.     (w3-pop-alignment)))
  1226.  
  1227. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1228. ;;; Bonus HTML Tags just for fun :)
  1229. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1230. (defun w3-handle-embed (&optional args)
  1231.   (let* ((buf (url-generate-new-buffer-name " *embed*"))
  1232.      (w3-draw-buffer (current-buffer))
  1233.      (url-working-buffer buf)
  1234.      (data (cdr-safe (assoc "data" args)))
  1235.      (href (and (not data)
  1236.             (url-expand-file-name
  1237.              (or (cdr-safe (assoc "src" args))
  1238.              (cdr-safe (assoc "href" args)))
  1239.              (cdr-safe (assoc (cdr-safe (assoc "base" args))
  1240.                       w3-base-alist)))))
  1241.      (type (or (cdr-safe (assoc "type" args)) "text/plain"))
  1242.      (parse nil))
  1243.     (if (and href (not (string= type "video/mpeg")))
  1244.     ;; MPEG movies can be _HUGE_, delay loading them as
  1245.     ;; long as possible
  1246.     (save-excursion
  1247.       (set-buffer (get-buffer-create buf))
  1248.       (setq url-be-asynchronous nil)
  1249.       (url-retrieve href)
  1250.       (setq data (buffer-string))
  1251.       (kill-buffer (current-buffer))))
  1252.     (cond
  1253.      ((string= type "text/plain")
  1254.       (insert data))
  1255.      ((string-match "^text/html" type)
  1256.       (save-excursion
  1257.     (set-buffer (get-buffer-create
  1258.              (url-generate-new-buffer-name " *embed*")))
  1259.     (erase-buffer)
  1260.     (insert data)
  1261.     (setq parse (w3-preparse-buffer (current-buffer) t))
  1262.     (kill-buffer (current-buffer)))
  1263.       (while parse
  1264.     (w3-handle-single-tag (car (car parse)) (cdr (car parse)))
  1265.     (setq parse (cdr parse))))
  1266.      ((string= type "video/mpeg")
  1267.       (let ((width (cdr-safe (assoc "width" args)))
  1268.         (height (cdr-safe (assoc "height" args))))
  1269.     (setq width (if width (string-to-int width))
  1270.           height (if height (string-to-int height)))
  1271.     (w3-add-delayed-mpeg href (point) width height))))))
  1272.  
  1273. (defun w3-handle-blink (&optional args)
  1274.   ;; Keep track of all the buffers with blinking in them, and do GC
  1275.   ;; of this list whenever a new <blink> tag is encountered.  The
  1276.   ;; timer checks this list to see if any of the buffers are visible,
  1277.   ;; and only blinks the face if there are any visible.  This cuts
  1278.   ;; down tremendously on the amount of X traffic, and frame !@#!age
  1279.   ;; due to lots of face munging.
  1280.   (w3-handle-emphasis args)
  1281.   (let ((buffs w3-blinking-buffs)
  1282.     (name1 (buffer-name))
  1283.     (name2 nil)
  1284.     (add t))
  1285.     (setq w3-blinking-buffs nil)
  1286.     ;; Get rid of old buffers
  1287.     (while buffs
  1288.       (setq name2 (buffer-name (car buffs)))
  1289.       (if (null name2)
  1290.       nil
  1291.     (setq w3-blinking-buffs (cons (car buffs) w3-blinking-buffs))
  1292.     (if (string= name1 name2)
  1293.         (setq add nil)))
  1294.       (setq buffs (cdr buffs)))
  1295.     (if add
  1296.     (setq w3-blinking-buffs (cons (current-buffer) w3-blinking-buffs)))))
  1297.  
  1298. (defun w3-handle-/blink (&optional args)
  1299.   (w3-handle-emphasis-end args))
  1300.  
  1301. (defun w3-handle-peek (&optional args)
  1302.   ;; Handle the peek tag.  Valid attributes are:
  1303.   ;; VARIABLE:: any valid lisp variable
  1304.   ;; If VARIABLE is bound and non-nil, then the value of the variable is
  1305.   ;; inserted at point.  This can handle variables whos values are any
  1306.   ;; arbitrary lisp type.
  1307.   (let* ((var-name (cdr-safe (assoc "variable" args)))
  1308.      (var-sym  (and var-name (intern var-name)))
  1309.      (val      (and var-sym (boundp var-sym) (symbol-value var-sym))))
  1310.     (cond
  1311.      ((null val) nil)
  1312.      ((stringp val) (w3-handle-text val))
  1313.      (t (w3-handle-text (format "%S" val))))))
  1314.  
  1315. (defun w3-rotate-region (st nd &optional rotation)
  1316.   "Ceasar rotate a region between ST and ND using ROTATION as the
  1317. amount to rotate the text.  Defaults to caesar (13)."
  1318.   (setq rotation (or rotation 13))
  1319.   (save-excursion
  1320.     (let (x)
  1321.       (while (< st nd)
  1322.     (setq x (char-after st))
  1323.     (cond
  1324.      ((and (>= x ?a) (<= x ?z))
  1325.       (setq x (- x ?a)
  1326.         x (char-to-string (+ (% (+ x rotation) 26) ?a))))
  1327.      ((and (>= x ?A) (<= x ?Z))
  1328.       (setq x (- x ?A)
  1329.         x (char-to-string (+ (% (+ x rotation) 26) ?A))))
  1330.      (t (setq x nil)))
  1331.     (if x (progn (goto-char st) (delete-char 1) (insert x)))
  1332.     (setq st (1+ st))))))
  1333.  
  1334. (defun w3-handle-kill-sgml (&optional args)
  1335.   (w3-handle-text "SGML is the spawn of evil!  It must be stopped!"))
  1336.  
  1337. (defun w3-handle-secret (&optional args)
  1338.   (if (fboundp 'valid-specifier-locale-p)
  1339.       (let ((tag 'rot13))
  1340.     (w3-handle-emphasis))
  1341.     (w3-put-state 'secret (set-marker (make-marker) (point)))))
  1342.  
  1343. (defun w3-handle-/secret (&optional args)
  1344.   "Close a secret region of text."
  1345.   (if (fboundp 'valid-specifier-locale-p)
  1346.       (let ((tag '/rot13))
  1347.     (w3-handle-emphasis-end))
  1348.     (if (integer-or-marker-p (w3-get-state 'secret))
  1349.     (progn
  1350.       (w3-rotate-region (w3-get-state 'secret) (point))
  1351.       (w3-put-state 'secret nil)))))
  1352.  
  1353. (defun w3-handle-hype (&optional args)
  1354.   (if (and (or (featurep 'nas-sound) (featurep 'native-sound))
  1355.        (assoc 'hype sound-alist))
  1356.       (play-sound 'hype 100)
  1357.     (w3-handle-text "Hey, has Marca A. told you how cool he is?")))
  1358.  
  1359. (defun w3-handle-yogsothoth (&optional args)
  1360.   (w3-handle-image (list (cons "src" "href-to-yogsothoth-pic")
  1361.              (cons "alt" "YOGSOTHOTH LIVES!!!"))))
  1362.  
  1363. (defun w3-handle-roach (&optional args)
  1364.   (w3-handle-text "Man, I am so wasted..."))
  1365.  
  1366. (defun w3-handle-/roach (&optional args)
  1367.   (w3-handle-text (concat "So, you wanna get some "
  1368.               (or (cdr-safe (assoc "munchy" args))
  1369.                   "nachos") "? ")))
  1370.  
  1371. (defun w3-invert-face (&optional face)
  1372.   (setq face (or face w3-blink-style))
  1373.   (let ((buffs w3-blinking-buffs)
  1374.     (blink nil)
  1375.     (buff nil))
  1376.     (if buffs
  1377.     (while buffs
  1378.       (setq buff (car buffs))
  1379.       (cond
  1380.        ((bufferp buff)
  1381.         (if (buffer-name buff)
  1382.         (setq buff (car buffs))
  1383.           (setq buff nil)))
  1384.        ((stringp buff)
  1385.         (setq buff (get-buffer buff)))
  1386.        (t
  1387.         (setq buff nil)))
  1388.       (setq buffs (cdr buffs)
  1389.         buff (and buff (get-buffer-window buff 'visible))
  1390.         buff (and buff (window-live-p buff)))
  1391.       (if buff (setq buffs nil
  1392.              blink t))))
  1393.     (if blink (invert-face face))))
  1394.  
  1395. (autoload 'sentence-ify "flame")
  1396. (autoload 'string-ify "flame")
  1397. (autoload '*flame "flame")
  1398. (if (not (fboundp 'flatten)) (autoload 'flatten "flame"))
  1399.  
  1400. (defvar w3-cookie-cache nil)
  1401.  
  1402. (defun w3-handle-cookie (&optional args)
  1403.   (if (not (fboundp 'cookie))
  1404.       (w3-handle-text "Sorry, no cookies today.")
  1405.     (let* ((url-working-buffer (url-generate-new-buffer-name " *cookie*"))
  1406.        (href (url-expand-file-name
  1407.           (or (cdr-safe (assoc "src" args))
  1408.               (cdr-safe (assoc "href" args)))
  1409.           (cdr-safe (assoc (cdr-safe (assoc "base" args))
  1410.                    w3-base-alist))))
  1411.        (fname (or (cdr-safe (assoc href w3-cookie-cache))
  1412.               (url-generate-unique-filename "%s.cki")))
  1413.        (st (or (cdr-safe (assoc "start" args)) "Loading cookies..."))
  1414.        (nd (or (cdr-safe (assoc "end" args))
  1415.            "Loading cookies... done.")))
  1416.       (if (not (assoc href w3-cookie-cache))
  1417.       (save-excursion
  1418.         (url-clear-tmp-buffer)
  1419.         (setq url-be-asynchronous nil)
  1420.         (url-retrieve href)
  1421.         (url-uncompress)
  1422.         (write-region (point-min) (point-max) fname 5)
  1423.         (setq w3-cookie-cache (cons (cons href fname) w3-cookie-cache))))
  1424.       (w3-handle-text (cookie fname st nd)))))
  1425.  
  1426. (defun w3-handle-flame (&optional args)
  1427.   (condition-case ()
  1428.       (w3-handle-text
  1429.        (concat
  1430.     (sentence-ify
  1431.      (string-ify
  1432.       (append-suffixes-hack (flatten (*flame)))))))
  1433.     (error nil)))
  1434.  
  1435. (defun w3-handle-pinhead (&optional args)
  1436.   (if (fboundp 'yow)
  1437.       (w3-handle-text (yow))))
  1438.    
  1439. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1440. ;;; Tags that don't really get drawn, etc.
  1441. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1442.  
  1443. (defun w3-handle-body (&optional args)
  1444.   (if (not w3-user-colors-take-precedence)
  1445.       (let* ((vlink (cdr-safe (assoc "vlink" args)))
  1446.          (link (cdr-safe (assoc "link" args)))
  1447.          (text (cdr-safe (assoc "text" args)))
  1448.          (backg (cdr-safe (assoc "background" args)))
  1449.          (rgb (or (cdr-safe (assoc "bgcolor" args))
  1450.               (cdr-safe (assoc "rgb" args))))
  1451.          (temp-face nil))
  1452.     (setq backg (url-expand-file-name
  1453.              backg
  1454.              (cdr-safe (assoc (cdr-safe (assoc "base" args))
  1455.                       w3-base-alist))))
  1456.     (cond
  1457.      (w3-running-epoch
  1458.       (if link
  1459.           (progn
  1460.         (setq temp-face (intern (concat "w3-temp-face-" link)))
  1461.         (make-face temp-face)
  1462.         (w3-munge-color-fore temp-face link)
  1463.         (setq w3-node-style temp-face)))
  1464.       (if vlink
  1465.           (progn
  1466.         (setq temp-face (intern (concat "w3-temp-face-" vlink)))
  1467.         (make-face temp-face)
  1468.         (w3-munge-color-fore temp-face vlink)
  1469.         (setq w3-visited-node-style temp-face)))
  1470.       (if (or text rgb)
  1471.           (let ((face nil)
  1472.             (ctr 0))
  1473.         (while (find-face (intern (format "w3-temp-face-%d" ctr)))
  1474.           (setq ctr (1+ ctr)))
  1475.         (setq face (intern (format "w3-temp-face-%d" ctr)))
  1476.         (make-face face)
  1477.         (and text (w3-munge-color-fore face text))
  1478.         (and rgb (w3-munge-color-back face rgb))
  1479.         (setq buffer-style (face-instance face)))))
  1480.      ;; Only XEmacs will be able to do the locale stuff for faces
  1481.      ((fboundp 'valid-specifier-locale-p)
  1482.       (w3-put-state 'background backg)
  1483.       (and text (w3-munge-color-fore 'default text (current-buffer)))
  1484.       (and rgb (w3-munge-color-back 'default rgb (current-buffer)))
  1485.       (and link (w3-munge-color-fore w3-node-style link (current-buffer)))
  1486.       (and vlink (w3-munge-color-fore w3-visited-node-style vlink
  1487.                       (current-buffer))))
  1488.      ((fboundp 'make-face)
  1489.       (if link
  1490.           (progn
  1491.         (setq temp-face (intern (concat "w3-temp-face-" link)))
  1492.         (make-face temp-face)
  1493.         (w3-munge-color-fore temp-face link)
  1494.         (setq w3-node-style temp-face)))
  1495.       (if vlink
  1496.           (progn
  1497.         (setq temp-face (intern (concat "w3-temp-face-" vlink)))
  1498.         (make-face temp-face)
  1499.         (w3-munge-color-back temp-face vlink)
  1500.         (setq w3-visited-node-style temp-face))))))))
  1501.  
  1502. (defun w3-handle-cryptopts (&optional args)
  1503.   (put 'w3-formatters 'text 'ack))
  1504.  
  1505. (defun w3-handle-/cryptopts (&optional args)
  1506.   (put 'w3-formatters 'text nil))
  1507.  
  1508. (defun w3-handle-certs (&optional args)
  1509.   (put 'w3-formatters 'text 'ack))
  1510.  
  1511. (defun w3-handle-/certs (&optional args)
  1512.   (put 'w3-formatters 'text nil))
  1513.  
  1514. (defun w3-handle-base (&optional args)
  1515.   (setq w3-base-alist (cons
  1516.                (cons (or (cdr-safe (assoc "name" args))
  1517.                  (cdr-safe (assoc "id" args)))
  1518.                  (or (cdr-safe (assoc "href" args))
  1519.                  (url-view-url t)))
  1520.                w3-base-alist)))
  1521.  
  1522. (defun w3-handle-isindex (&optional args)
  1523.   (let ((prompt (or (cdr-safe (assoc "prompt" args))
  1524.             "Search on (+ separates keywords): "))
  1525.     action)
  1526.     (setq action (url-expand-file-name
  1527.           (or (cdr-safe (assoc "src" args))
  1528.               (cdr-safe (assoc "href" args))
  1529.               (url-view-url t))
  1530.           (cdr-safe (assoc (cdr-safe (assoc "base" args))
  1531.                    w3-base-alist))))
  1532.     (if (and prompt (string-match "[^: \t-]+$" prompt))
  1533.     (setq prompt (concat prompt ": ")))
  1534.     (if w3-use-forms-index
  1535.     (progn
  1536.       (w3-handle-hr)
  1537.       (w3-handle-form (list (cons "action" action)
  1538.                 (cons "method" "get")))
  1539.       (w3-handle-text (concat prompt " "))
  1540.       (w3-handle-input (list (cons "type" "text")
  1541.                  (cons "name" "isindex")))))
  1542.     (setq w3-current-isindex (cons action prompt))))
  1543.  
  1544. (defun w3-handle-meta (&optional args)
  1545.   (let* ((equiv (cdr-safe (assoc "http-equiv" args)))
  1546.      (value (cdr-safe (assoc "content" args)))
  1547.      (node  (and equiv (assoc (setq equiv (downcase equiv))
  1548.                   url-current-mime-headers))))
  1549.     (cond
  1550.      ((and equiv node) (setcdr node value))
  1551.      (equiv (setq url-current-mime-headers (cons (cons equiv value)
  1552.                          url-current-mime-headers)))
  1553.      (t nil))
  1554.     ;; Special-case the refresh header
  1555.     (if (and equiv (string= (downcase equiv) "refresh"))
  1556.     (url-handle-refresh-header value))))
  1557.  
  1558. (defun w3-handle-link (&optional args)
  1559.   (let* ((dest (cdr-safe (assoc "href" args)))
  1560.      (type (if (assoc "rel" args) "Parent of" "Child of"))
  1561.      (desc (or (cdr-safe (assoc "rel" args))
  1562.            (cdr-safe (assoc "rev" args))))
  1563.      (node-1 (assoc type w3-current-links))
  1564.      (node-2 (and node-1 desc (assoc desc (cdr node-1))))
  1565.      (base (cdr-safe (assoc "base" args))))
  1566.     (if dest
  1567.     (progn
  1568.       (setq dest (url-expand-file-name
  1569.               dest
  1570.               (cdr-safe (assoc base w3-base-alist))))
  1571.       (cond
  1572.        (node-2 (setcdr node-2 dest)) ; Override old setting
  1573.        (node-1 (setcdr node-1 (cons (cons desc dest) (cdr node-1))))
  1574.        (t (setq w3-current-links
  1575.             (cons (cons type (list (cons desc dest)))
  1576.               w3-current-links))))
  1577.       (if (and dest desc (member (downcase desc)
  1578.                      '("style" "stylesheet")))
  1579.           (w3-handle-style (list (cons "src" dest))))))))
  1580.  
  1581. ;;; slightly modified by the MULE contributors
  1582. (defun w3-handle-image (&optional args)
  1583.   (let* ((parms args)
  1584.      (height (cdr-safe (assoc "height" parms)))
  1585.      (width (cdr-safe (assoc "width" parms)))
  1586.      (src (or (cdr-safe (assoc "src" parms))
  1587.           "Error Image"))
  1588.      (our-alt (cond
  1589.            ((null w3-auto-image-alt) "")
  1590.            ((eq t w3-auto-image-alt)
  1591.             (concat "[IMAGE(" (url-basepath src t) ")] "))
  1592.            ((stringp w3-auto-image-alt)
  1593.             (format w3-auto-image-alt (url-basepath src t)))))
  1594.      (alt (or (cdr-safe (assoc "alt" parms))
  1595.           our-alt))
  1596.      (ismap (and (assoc "ismap" args) 'ismap))
  1597.      (dest (w3-get-state 'href))
  1598.      (base (cdr-safe (assoc "base" args)))
  1599.      (align (intern (or (cdr-safe (assoc "align" parms)) "middle"))))
  1600.     (setq src (url-expand-file-name src
  1601.                     (cdr-safe (assoc base w3-base-alist))))
  1602.     (if (fboundp 'w3-insert-graphic)
  1603.     (w3-add-delayed-graphic (cons src (cons dest ismap))
  1604.                 (set-marker (make-marker) (point))
  1605.                 align alt)
  1606.       (w3-put-state 'w3-graphic src)
  1607.       (w3-handle-text alt)
  1608.       (w3-put-state 'w3-graphic nil)
  1609.       (and w3-auto-image-alt dest
  1610.        (progn
  1611.          (w3-handle-text " ")
  1612.          (setq w3-invisible-href-list
  1613.            (append w3-invisible-href-list
  1614.                (list
  1615.                 (list
  1616.                  (count-lines (point-min) (point))
  1617.                  dest
  1618.                  (url-basepath dest t))))))))))
  1619.  
  1620. (defun w3-handle-title (&optional args)
  1621.   (if (w3-get-state 'title)
  1622.       (w3-put-state 'title nil))
  1623.   (put 'w3-formatters 'text 'w3-handle-title-text))
  1624.  
  1625. (defun w3-handle-title-text (&optional args)
  1626.   (w3-put-state 'title
  1627.        (concat (w3-get-state 'title) args)))
  1628.  
  1629. (defun w3-handle-/title (&optional args)
  1630.   (put 'w3-formatters 'text nil)
  1631.   (let ((ttl (w3-get-state 'title)))
  1632.     (cond
  1633.      ((and (symbolp ttl) (eq ttl t))
  1634.       nil)
  1635.      ((stringp ttl)
  1636.       (setq ttl (w3-fix-spaces ttl))
  1637.       (if (and ttl (string= ttl ""))
  1638.       (setq ttl (w3-fix-spaces (url-view-url t))))
  1639.       (rename-buffer (url-generate-new-buffer-name ttl))
  1640.       (w3-put-state 'title t))
  1641.      (t nil))))
  1642.  
  1643. (fset 'w3-handle-/head 'w3-handle-/title)
  1644.  
  1645. (defun w3-handle-hyperlink (&optional args)
  1646.   (let ((href (cdr-safe (assoc "href" args)))
  1647.     (base (cdr-safe (assoc "base" args)))
  1648.     (name (or (cdr-safe (assoc "id" args))
  1649.           (cdr-safe (assoc "name" args)))))
  1650.     (if href
  1651.     (setq href (url-expand-file-name href
  1652.                      (cdr-safe
  1653.                       (assoc base w3-base-alist)))))
  1654.     (if (and w3-delimit-links (not (eq w3-delimit-links 'linkname)) href)
  1655.     (progn
  1656.       (if (url-have-visited-url href)
  1657.           (w3-handle-text (cdr w3-link-start-delimiter))
  1658.         (w3-handle-text (car w3-link-start-delimiter)))
  1659.       (w3-put-state 'needspace 'never)))
  1660.     (w3-put-state 'zone nil)
  1661.     (if href (w3-put-state 'href href))
  1662.     (if name (w3-put-state 'name name))))
  1663.  
  1664. (defun w3-handle-hyperlink-end (&optional args)
  1665.   (let* ((href (w3-get-state 'href))
  1666.      (name (w3-get-state 'name))
  1667.      (btdt (and href (url-have-visited-url href))))
  1668.     (w3-put-state 'zone nil)
  1669.     (w3-put-state 'href nil)
  1670.     (w3-put-state 'name nil)
  1671.  
  1672.     (if (and w3-delimit-links href)
  1673.     (progn
  1674.       (delete-region (point) (progn (skip-chars-backward " ")
  1675.                     (point)))
  1676.       (if (eq w3-delimit-links 'linkname)
  1677.           (w3-handle-text (concat (if btdt (cdr w3-link-start-delimiter)
  1678.                     (car w3-link-start-delimiter))
  1679.                       (or name "noname")
  1680.                       (if btdt (cdr w3-link-end-delimiter)
  1681.                     (car w3-link-end-delimiter))))
  1682.         (if btdt
  1683.         (w3-handle-text (cdr w3-link-end-delimiter))
  1684.           (w3-handle-text (car w3-link-end-delimiter)))))
  1685.       (goto-char (point-max)))
  1686.     (if (and w3-link-delimiter-info (fboundp w3-link-delimiter-info))
  1687.     (let ((info (condition-case ()
  1688.             (funcall w3-link-delimiter-info href)
  1689.               (error nil))))
  1690.       (if (and info (stringp info))
  1691.           (w3-handle-text (concat (if btdt (cdr w3-link-start-delimiter)
  1692.                     (car w3-link-start-delimiter))
  1693.                       info
  1694.                       (if btdt (cdr w3-link-end-delimiter)
  1695.                     (car w3-link-end-delimiter)))))))))
  1696.  
  1697. (defvar w3-tab-alist nil
  1698.   "An assoc list of tab stops and their respective IDs")
  1699. (make-variable-buffer-local 'w3-tab-alist)
  1700.  
  1701. (defun w3-handle-tab (&optional args)
  1702.   (let* ((id (cdr-safe (assoc "id" args)))
  1703.      (to (cdr-safe (assoc "to" args)))
  1704.      (pos (cdr-safe (assoc to w3-tab-alist))))
  1705.     (cond
  1706.      (id                ; Define a new tab stop
  1707.       (setq w3-tab-alist (cons (cons id (current-column)) w3-tab-alist)))
  1708.      ((and to pos)            ; Go to a currently defined tabstop
  1709.       (while (<= (current-column) pos)
  1710.     (insert " ")))
  1711.      (to                ; Tabstop 'to' is no defined yet
  1712.       (w3-warn 'html (format "Unkown tab stop -- `%s'" to)))
  1713.      (t                    ; Just do a tab
  1714.       (insert (make-string w3-indent-level ? ))))))
  1715.  
  1716. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1717. ;;;  Some bogus shit for pythia
  1718. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1719. (defun w3-handle-margin (&optional args)
  1720.   (if (assoc "reset" args)
  1721.       (w3-handle-/blockquote nil)
  1722.     (w3-handle-blockquote nil)))
  1723.   
  1724. (fset 'w3-handle-l 'w3-handle-br)
  1725.  
  1726. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1727. ;;; Guts of the forms interface for the new display engine
  1728. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1729. (defun w3-handle-form (&optional args)
  1730.   (let ((actn (cdr-safe (assoc "action" args)))
  1731.     (enct (cdr-safe (assoc "enctype" args)))
  1732.     (meth (cdr-safe (assoc "method" args))))
  1733.     (if (not meth) (setq args (cons (cons "method" "GET") args)))
  1734.     (if (not actn)
  1735.     (setq args (cons (cons "action"
  1736.                    (or
  1737.                 (cdr-safe (assoc (cdr-safe (assoc "base" args))
  1738.                          w3-base-alist))
  1739.                 (url-view-url t))) args))
  1740.       (setcdr (assoc "action" args)
  1741.           (url-expand-file-name
  1742.            actn
  1743.            (cdr-safe (assoc (cdr-safe (assoc "base" args))
  1744.                 w3-base-alist)))))
  1745.     (if (not enct)
  1746.     (setq args
  1747.           (cons (cons "enctype" "application/x-www-form-urlencoded")
  1748.             args)))
  1749.     (w3-put-state 'form args)))
  1750.  
  1751. (defun w3-handle-/form (&optional args)
  1752.   (w3-handle-paragraph)
  1753.   (w3-put-state 'form nil)
  1754.   (w3-put-state 'formnum (1+ (w3-get-state 'formnum)))
  1755.   )
  1756.  
  1757. (defun w3-handle-input (&optional args)
  1758.   (if (or (not (w3-get-state 'form))
  1759.       (w3-get-state 'select))
  1760.       (w3-warn
  1761.        'html
  1762.        "<input> outside of a <form> or inside <select> construct - ERROR!!")
  1763.     (let* ((type (upcase (or (cdr-safe (assoc "type" args)) "text")))
  1764.        (name (cdr-safe (assoc "name" args)))
  1765.        (value (or (cdr-safe (assoc "value" args)) ""))
  1766.        (size (string-to-int (or (cdr-safe (assoc "size" args)) "20")))
  1767.        (maxlength (cdr (assoc "maxlength" args)))
  1768.        (default value)
  1769.        (action (w3-get-state 'form))
  1770.        (options)
  1771.        (num (w3-get-state 'formnum))
  1772.        (id (cdr-safe (assoc "id" args)))
  1773.        (checked (assoc "checked" args)))
  1774.       (if maxlength (setq maxlength (string-to-int maxlength)))
  1775.       (if (and name (string-match "[\r\n]" name))
  1776.       (setq name (mapconcat (function
  1777.                  (lambda (x) (if (memq x '(?\r ?\n)) "" (char-to-string x))))
  1778.                 name "")))
  1779.       (if (member type '("CHECKBOX" "RADIO")) (setq default checked))
  1780.       (if (and (string= type "CHECKBOX") (string= value ""))
  1781.       (setq value "on"))
  1782.       (if (string= type "HIDDEN")
  1783.       (setq w3-hidden-forms (cons (list 'w3form action type name default
  1784.                         value checked size maxlength num
  1785.                         options id) w3-hidden-forms))
  1786.     (let ((formatfun nil)
  1787.           (prompt nil) pos)
  1788.       (setq formatfun (intern (concat "w3-form-format-"
  1789.                       (downcase type))))
  1790.       (if (not (fboundp formatfun))
  1791.           (setq formatfun 'w3-form-format-unknown))
  1792.       (if (string= type "IMAGE")
  1793.           (setq checked (cons (or (cdr-safe (assoc "alt" args))
  1794.                       "imageinput") name)))
  1795.       (if (and w3-delimit-links (member type '("RESET" "SUBMIT")))
  1796.           (w3-handle-text (car w3-link-start-delimiter)))
  1797.       (cond
  1798.        ((and (not value) (string= type "RESET"))
  1799.         (setq value "Reset form"))
  1800.        ((and (not value) (string= type "SUBMIT"))
  1801.         (setq value "Submit form"))
  1802.        ((string= type "RANGE")
  1803.         (let* ((arg (or (cdr-safe (assoc "size" args)) "1,10"))
  1804.            (min (string-to-int arg))
  1805.            (max nil))
  1806.           (setq max 
  1807.             (if (string-match ",\\(.*\\)" arg)
  1808.             (string-to-int (url-match arg 1))
  1809.               (+ min 10))
  1810.             maxlength (cons min max)
  1811.             size (string-width (int-to-string (max min max))))))
  1812.        (t nil))
  1813.       (setq prompt (funcall formatfun value size checked)
  1814.         pos (point))
  1815.       (if w3-running-FSF19 (insert prompt) (w3-insert prompt))
  1816.       (w3-add-zone pos (point) w3-node-style
  1817.                (list 'w3form
  1818.                  action type name default value
  1819.                  checked size maxlength num options id) t)
  1820.       (if (and w3-delimit-links (member type '("RESET" "SUBMIT")))
  1821.           (w3-handle-text (car w3-link-end-delimiter)))
  1822.       (w3-put-state 'needspace t))))))
  1823.  
  1824. (defun w3-handle-/select (&optional args)
  1825.   (if (not (and (w3-get-state 'form)
  1826.         (w3-get-state 'select)))
  1827.       (w3-warn 'html
  1828.            "</select> outside of a <form> or <select> construct - ERROR!!")
  1829.     (put 'w3-formatters 'text 'w3-handle-text)
  1830.     (let* ((args (w3-get-state 'select))
  1831.        (opts (w3-get-state 'options))
  1832.        (form (w3-get-state 'form))
  1833.        (max-size nil)
  1834.        (type "OPTION")
  1835.        (default nil)
  1836.        (tmp nil)
  1837.        (id (cdr-safe (assoc "id" args)))
  1838.        (checked nil)
  1839.        )
  1840.       (setq tmp (reverse opts))
  1841.       (if (assoc "multiple" args)
  1842.       (let ((tag 'ul)        ; Convert to a list of checkboxes
  1843.         (nam (or (cdr-safe (assoc "name" args)) "option"))
  1844.         (old (w3-get-state 'align))
  1845.         (first nil))
  1846.         (w3-put-state 'options nil)
  1847.         (w3-put-state 'select nil)
  1848.         (w3-handle-list-opening)
  1849.         (w3-put-state 'align nil)
  1850.         (while tmp
  1851.           (w3-handle-list-item)
  1852.           (w3-handle-input (list (cons "type" "checkbox")
  1853.                      (cons "name" nam)
  1854.                      (cons "value"
  1855.                        (or (cdr-safe
  1856.                         (assoc "value" (car tmp)))
  1857.                            (cdr-safe
  1858.                         (assoc "ack" (car tmp)))
  1859.                            "unknown"))
  1860.                      (if (or (assoc "checked" (car tmp))
  1861.                          (assoc "selected" (car tmp)))
  1862.                      (cons "checked" "checked"))))
  1863.           (w3-handle-text (concat " " (or
  1864.                        (cdr-safe (assoc "ack" (car tmp)))
  1865.                        "unknown")))
  1866.           (setq tmp (cdr tmp)))
  1867.         (w3-handle-list-ending)
  1868.         (w3-put-state 'align old))
  1869.     (while (and (not default) tmp)
  1870.       (if (or (assoc "checked" (car tmp))
  1871.           (assoc "selected" (car tmp)))
  1872.           (setq default (car tmp)))
  1873.       (setq tmp (cdr tmp)))
  1874.     (setq default (cdr (assoc "ack" (or default
  1875.                         (nth (1- (length opts)) opts))))
  1876.           checked (mapcar
  1877.                (function
  1878.             (lambda (x)
  1879.               (cons (cdr-safe (assoc "ack" x))
  1880.                 (or (cdr-safe (assoc "value" x))
  1881.                     (cdr-safe (assoc "ack" x))))))
  1882.                opts)
  1883.           max-size (car (sort (mapcar
  1884.                    (function
  1885.                     (lambda (x)
  1886.                       (length (cdr-safe (assoc "ack" x)))))
  1887.                    opts)
  1888.                   '>)))
  1889.     (if (and form args opts)
  1890.         (let ((pos (point))
  1891.           (siz (max max-size
  1892.                 (string-to-int
  1893.                  (or (cdr-safe (assoc "size" args)) "0")))))
  1894.           (insert (w3-form-format-text default siz))
  1895.           (w3-add-zone pos (point) w3-node-style
  1896.                (list 'w3form form type
  1897.                  (or (cdr-safe (assoc "name" args)) "option")
  1898.                  default default
  1899.                  checked
  1900.                  siz
  1901.                  (string-to-int
  1902.                   (or (cdr-safe (assoc "maxlength" args))
  1903.                       "1000"))
  1904.                  (w3-get-state 'formnum)
  1905.                  (mapcar
  1906.                   (function
  1907.                    (lambda (x)
  1908.                      (cons (cdr-safe (assoc "ack" x))
  1909.                        (cdr-safe (assoc "ack" x)))))
  1910.                   opts) id) t)))))
  1911.     (w3-put-state 'options nil)
  1912.     (w3-put-state 'select nil)))
  1913.  
  1914. (defun w3-handle-option-data (&optional args)
  1915.   (let ((text (cond
  1916.            ((null args) nil)
  1917.            ((stringp args) args)
  1918.            ((listp args) (mapconcat 'identity args " ")))))
  1919.     (if text
  1920.     (progn
  1921.       (setq text (url-strip-leading-spaces
  1922.               (url-eat-trailing-space text)))
  1923.       (w3-put-state 'options (cons (cons (cons "ack" text)
  1924.                           (w3-get-state 'optargs))
  1925.                     (w3-get-state 'options))))))
  1926.   (put 'w3-formatters 'text 'w3-handle-text))
  1927.                
  1928. (defun w3-handle-option (&optional args)
  1929.   (if (not (and (w3-get-state 'form)
  1930.         (w3-get-state 'select)))
  1931.       (w3-warn 'html
  1932.            "<option> outside of a <form> or <select> construct - ERROR!!")
  1933.     (w3-put-state 'optargs args)
  1934.     (put 'w3-formatters 'text 'w3-handle-option-data)))
  1935.                  
  1936. (defun w3-handle-select (&optional args)
  1937.   (if (not (w3-get-state 'form))
  1938.       (w3-warn 'html "<select> outside of a <FORM> construct - ERROR!!")
  1939.     (w3-put-state 'select args))
  1940.   )
  1941.  
  1942. (defun w3-handle-textarea (&optional args)
  1943.   (if (not (w3-get-state 'form))
  1944.       (w3-warn 'html "<textarea> outside of a <FORM> construct - ERROR!!")
  1945.     (let ((node (assoc "maxlength" args)))
  1946.       (cond
  1947.        ((null node)
  1948.     (setq args (cons (cons "maxlength" nil) args)))
  1949.        ((null (cdr-safe node))
  1950.     nil)
  1951.        ((string= (downcase (cdr-safe node)) "unlimited")
  1952.     (setcdr node nil))))
  1953.     (let* (
  1954.        (value (cdr-safe (assoc "data" args)))
  1955.        (type "TEXTAREA")
  1956.        (name (cdr-safe (assoc "name" args)))
  1957.        (size (string-to-int (or (cdr-safe (assoc "size" args)) "20")))
  1958.        (maxlength (string-to-int
  1959.                (or (cdr (assoc "maxlength" args)) "10000")))
  1960.        (default nil)
  1961.        (action (w3-get-state 'form))
  1962.        (options)
  1963.        (pos)
  1964.        (num (w3-get-state 'formnum))
  1965.        (id (cdr-safe (assoc "id" args)))
  1966.        (checked (assoc "checked" args)))
  1967.       (setq default value
  1968.         pos (point))
  1969.       (put 'w3-formatters 'text 'w3-handle-text)
  1970.       (w3-handle-text "Multiline text area")
  1971.       (w3-add-zone pos (point) w3-node-style
  1972.            (list 'w3form
  1973.              action type name default value
  1974.              checked size maxlength num options id) t))))
  1975.  
  1976. (defun w3-handle-label-text (&optional args)
  1977.   (setcdr (w3-get-state 'label-text)
  1978.       (concat (cdr (w3-get-state 'label-text)) args))
  1979.   (w3-handle-text args))
  1980.  
  1981. (defun w3-handle-/label (&optional args)
  1982.   (let ((num (w3-get-state 'formnum))
  1983.     (dat (w3-get-state 'label-text)))
  1984.     (setq w3-form-labels (cons (cons (format "%d:%s" num (car dat))
  1985.                      (cdr dat))
  1986.                    w3-form-labels))
  1987.     (put 'w3-formatters 'text 'w3-handle-text)))
  1988.  
  1989. (defun w3-handle-label (&optional args)
  1990.   (if (not (w3-get-state 'form))
  1991.       (w3-warn 'html "<label> outside of a <FORM> construct - ERROR!!")
  1992.     (put 'w3-formatters 'text 'w3-handle-label-text)
  1993.     (w3-put-state 'label-text (cons (or (cdr-safe (assoc "for" args))
  1994.                     "Unknown label") ""))))
  1995.  
  1996. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1997. ;;; For w3-beta
  1998. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1999. (defun w3-show-buffer ()
  2000.   (let ((potential-title
  2001.      (and (not (w3-get-state 'title))
  2002.           (url-generate-new-buffer-name
  2003.            (url-basepath url-current-file t)))))
  2004.     (if (and potential-title (string= potential-title ""))
  2005.     (setq potential-title
  2006.           (url-generate-new-buffer-name url-current-file)))
  2007.     (if (and potential-title (not (string= potential-title "")))
  2008.     (rename-buffer potential-title)))
  2009.   (if url-find-this-link
  2010.       (w3-find-specific-link url-find-this-link))
  2011.   (w3-fix-extent-endpoints)
  2012.   (cond
  2013.    ((not (fboundp 'w3-insert-graphic)) nil) ; No graphics abilities
  2014.    (w3-delay-image-loads 
  2015.     ;; (w3-maybe-load-images)
  2016.     )
  2017.    (t
  2018.     (message "Processing images...")    ; Grab the images
  2019.     (w3-load-delayed-images)
  2020.     (message "Done.")))
  2021.   (if (and (fboundp 'valid-specifier-locale-p)
  2022.        (fboundp 'w3-insert-graphic)
  2023.        (not w3-user-colors-take-precedence)
  2024.        (not w3-delay-image-loads)
  2025.        (not (eq (device-type) 'tty))
  2026.        (w3-get-state 'background))
  2027.       (let* ((buffer (get-buffer-create " *background*"))
  2028.          (url-working-buffer buffer)
  2029.          (ourbuf (current-buffer))
  2030.          (fname (url-generate-unique-filename "%s.xpm"))
  2031.          (bitmap (w3-get-state 'background)))
  2032.     (save-excursion
  2033.       (set-buffer buffer)
  2034.       (setq url-be-asynchronous nil)
  2035.       (erase-buffer)
  2036.       (url-retrieve bitmap)
  2037.       (w3-convert-graphic-to-useable-format buffer
  2038.                         fname
  2039.                         (not (featurep 'xpm)))
  2040.       (erase-buffer)
  2041.       (insert-file-contents fname)
  2042.       (setq bitmap (buffer-string))
  2043.       (kill-buffer buffer))
  2044.     (set-face-background-pixmap 'default
  2045.                     bitmap
  2046.                     (current-buffer))))
  2047.   (if (and w3-default-style
  2048.        (fboundp 'make-face)
  2049.        (face-differs-from-default-p w3-default-style))
  2050.       (if (not (fboundp 'valid-specifier-locale-p))
  2051.       (w3-add-zone (point-min) (point-max) w3-default-style nil nil)
  2052.     (copy-face w3-default-style 'default (current-buffer))))
  2053.   (let ((pop-up-windows nil))
  2054.     (display-buffer (current-buffer))))
  2055.  
  2056. ;;; from MULE contributors
  2057. (defun w3-show-invisible-href ()
  2058.   ;; Displaying `href', which is not seen in normal.
  2059.   (let ((buffer-read-only nil)
  2060.     hlist line beg props data ovl)
  2061.     (while w3-invisible-href-list
  2062.       (setq hlist (car w3-invisible-href-list)
  2063.         w3-invisible-href-list (cdr w3-invisible-href-list)
  2064.         line (car hlist)
  2065.         data nil)
  2066.       (goto-line line)
  2067.       (beginning-of-line)
  2068.       (setq beg (point))
  2069.       (end-of-line)
  2070.       (and (string-match
  2071.         (cond ((stringp w3-auto-image-alt)
  2072.            (concat
  2073.             (regexp-quote
  2074.              (substring w3-auto-image-alt 0
  2075.                 (string-match "%s" w3-auto-image-alt)))
  2076.             ".*"
  2077.             (regexp-quote
  2078.              (substring w3-auto-image-alt (match-end 0)
  2079.                 (string-match "[ \t]*$" w3-auto-image-alt)))
  2080.             "[ \t]*$")
  2081.            )
  2082.           (t
  2083.            (concat (regexp-quote "[IMAGE(") ".*"
  2084.                (regexp-quote ")]") "[ \t]*$")
  2085.            ))
  2086.         (buffer-substring beg (point)))
  2087.        (progn
  2088.          (setq data (w3-zone-at (+ beg (match-beginning 0)))
  2089.            data (if data (prog1
  2090.                      (w3-zone-data data)
  2091.                    (w3-delete-zone data)))
  2092.            data (if (and data (eq (car data) 'w3))
  2093.                 (cdr data)))
  2094.          (setq beg (point))
  2095.          (and data
  2096.           (progn
  2097.             (insert " ")
  2098.             (w3-put-state 'href (url-expand-file-name (nth 1 data)))
  2099.             (w3-handle-text (car (cdr (cdr hlist))))
  2100.             (w3-put-state 'href nil)
  2101.             (w3-add-zone (1+ beg) (point) 'w3-graphic-face nil nil)
  2102.             )))))
  2103.     (set-buffer-modified-p nil)))
  2104.  
  2105. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2106. ;;; Misc.
  2107. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2108. (defun w3-delimit-headers (st nd &optional end)
  2109.   (if (and end w3-delimit-emphasis)
  2110.       (let* ((tag (intern (substring (symbol-name tag) 1)))
  2111.          (beg-char (and w3-delimit-emphasis
  2112.                 end
  2113.                 (nth 1 (cdr-safe
  2114.                     (assoc tag w3-header-chars-assoc)))))
  2115.          (end-char (and w3-delimit-emphasis
  2116.                 end
  2117.                 (nth 0 (cdr-safe
  2118.                     (assoc tag w3-header-chars-assoc)))))
  2119.          (st-pos (w3-get-state 'header-start))
  2120.          (nd-pos (point)))
  2121.     (if end-char
  2122.         (progn
  2123.           (goto-char nd-pos)
  2124.           (insert "\n" (make-string (- nd-pos st-pos) end-char))))
  2125.     (if beg-char
  2126.         (progn
  2127.           (goto-char st-pos)
  2128.           (insert "\n" (make-string (- nd-pos st-pos) beg-char)))))))
  2129.  
  2130. (defun w3-upcase-region (st nd &optional end)
  2131.   (and st nd (upcase-region st nd)))
  2132.  
  2133. (provide 'w3-draw)
  2134.  
  2135.