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