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