Mercurial > hg > xemacs-beta
comparison lisp/w3/w3-display.el @ 14:9ee227acff29 r19-15b90
Import from CVS: tag r19-15b90
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:48:42 +0200 |
| parents | |
| children | 0293115a14e9 6a378aca36af |
comparison
equal
deleted
inserted
replaced
| 13:13c6d0aaafe5 | 14:9ee227acff29 |
|---|---|
| 1 ;;; w3-display.el --- display engine v99999 | |
| 2 ;; Author: wmperry | |
| 3 ;; Created: 1997/01/02 20:20:45 | |
| 4 ;; Version: 1.90 | |
| 5 ;; Keywords: faces, help, hypermedia | |
| 6 | |
| 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 8 ;;; Copyright (c) 1996 by William M. Perry (wmperry@cs.indiana.edu) | |
| 9 ;;; Copyright (c) 1996 Free Software Foundation, Inc. | |
| 10 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 11 ;;; | |
| 12 ;;; This file is part of GNU Emacs. | |
| 13 ;;; | |
| 14 ;;; GNU Emacs is free software; you can redistribute it and/or modify | |
| 15 ;;; it under the terms of the GNU General Public License as published by | |
| 16 ;;; the Free Software Foundation; either version 2, or (at your option) | |
| 17 ;;; any later version. | |
| 18 ;;; | |
| 19 ;;; GNU Emacs is distributed in the hope that it will be useful, | |
| 20 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 21 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 22 ;;; GNU General Public License for more details. | |
| 23 ;;; | |
| 24 ;;; You should have received a copy of the GNU General Public License | |
| 25 ;;; along with GNU Emacs; see the file COPYING. If not, write to the | |
| 26 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 27 ;;; Boston, MA 02111-1307, USA. | |
| 28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 29 (require 'cl) | |
| 30 (require 'css) | |
| 31 (require 'font) | |
| 32 (require 'w3-widget) | |
| 33 (require 'w3-imap) | |
| 34 | |
| 35 (defmacro w3-d-s-var-def (var) | |
| 36 (` (make-variable-buffer-local (defvar (, var) nil)))) | |
| 37 | |
| 38 (w3-d-s-var-def w3-display-open-element-stack) | |
| 39 (w3-d-s-var-def w3-display-alignment-stack) | |
| 40 (w3-d-s-var-def w3-display-list-stack) | |
| 41 (w3-d-s-var-def w3-display-form-stack) | |
| 42 (w3-d-s-var-def w3-display-whitespace-stack) | |
| 43 (w3-d-s-var-def w3-display-font-family-stack) | |
| 44 (w3-d-s-var-def w3-display-font-weight-stack) | |
| 45 (w3-d-s-var-def w3-display-font-variant-stack) | |
| 46 (w3-d-s-var-def w3-display-font-size-stack) | |
| 47 (w3-d-s-var-def w3-face-color) | |
| 48 (w3-d-s-var-def w3-face-background) | |
| 49 (w3-d-s-var-def w3-active-faces) | |
| 50 (w3-d-s-var-def w3-active-voices) | |
| 51 (w3-d-s-var-def w3-current-form-number) | |
| 52 (w3-d-s-var-def w3-face-font-family) | |
| 53 (w3-d-s-var-def w3-face-font-weight) | |
| 54 (w3-d-s-var-def w3-face-font-variant) | |
| 55 (w3-d-s-var-def w3-face-font-size) | |
| 56 (w3-d-s-var-def w3-face-font-family) | |
| 57 (w3-d-s-var-def w3-face-font-size) | |
| 58 (w3-d-s-var-def w3-face-font-spec) | |
| 59 (w3-d-s-var-def w3-face-text-decoration) | |
| 60 (w3-d-s-var-def w3-face-face) | |
| 61 (w3-d-s-var-def w3-face-descr) | |
| 62 (w3-d-s-var-def w3-face-pixmap) | |
| 63 (w3-d-s-var-def w3-display-css-properties) | |
| 64 | |
| 65 (eval-when-compile | |
| 66 (defmacro w3-get-attribute (attr) | |
| 67 (` (cdr-safe (assq (, attr) args)))) | |
| 68 | |
| 69 (defmacro w3-get-face-info (info) | |
| 70 (let ((var (intern (format "w3-face-%s" info)))) | |
| 71 (` (push (w3-get-style-info (quote (, info)) node (car (, var))) | |
| 72 (, var))))) | |
| 73 | |
| 74 (defmacro w3-pop-face-info (info) | |
| 75 (let ((var (intern (format "w3-face-%s" info)))) | |
| 76 (` (pop (, var))))) | |
| 77 | |
| 78 (defmacro w3-get-all-face-info () | |
| 79 (` | |
| 80 (progn | |
| 81 (w3-get-face-info font-family) | |
| 82 (w3-get-face-info font-weight) | |
| 83 (w3-get-face-info font-variant) | |
| 84 (w3-get-face-info font-size) | |
| 85 (w3-get-face-info text-decoration) | |
| 86 ;;(w3-get-face-info pixmap) | |
| 87 (w3-get-face-info color) | |
| 88 (w3-get-face-info background) | |
| 89 (setq w3-face-font-spec (make-font | |
| 90 :weight (car w3-face-font-weight) | |
| 91 :family (car w3-face-font-family) | |
| 92 :size (car w3-face-font-size)))))) | |
| 93 | |
| 94 (defmacro w3-pop-all-face-info () | |
| 95 (` | |
| 96 (progn | |
| 97 (w3-pop-face-info font-family) | |
| 98 (w3-pop-face-info font-weight) | |
| 99 (w3-pop-face-info font-variant) | |
| 100 (w3-pop-face-info font-size) | |
| 101 (w3-pop-face-info text-decoration) | |
| 102 ;;(w3-pop-face-info pixmap) | |
| 103 (w3-pop-face-info color) | |
| 104 (w3-pop-face-info background)))) | |
| 105 | |
| 106 ) | |
| 107 | |
| 108 (defvar w3-face-cache nil "Cache for w3-face-for-element") | |
| 109 (defvar w3-face-index 0) | |
| 110 (defvar w3-image-widgets-waiting nil) | |
| 111 | |
| 112 (make-variable-buffer-local 'w3-last-fill-pos) | |
| 113 | |
| 114 (defconst w3-fill-prefixes-vector | |
| 115 (let ((len 0) | |
| 116 (prefix-vector (make-vector 80 nil))) | |
| 117 (while (< len 80) | |
| 118 (aset prefix-vector len (make-string len ? )) | |
| 119 (setq len (1+ len))) | |
| 120 prefix-vector)) | |
| 121 | |
| 122 (defconst w3-line-breaks-vector | |
| 123 (let ((len 0) | |
| 124 (breaks-vector (make-vector 10 nil))) | |
| 125 (while (< len 10) | |
| 126 (aset breaks-vector len (make-string len ?\n)) | |
| 127 (setq len (1+ len))) | |
| 128 breaks-vector)) | |
| 129 | |
| 130 (defun w3-pause () | |
| 131 (cond | |
| 132 (w3-running-FSF19 (sit-for 0)) | |
| 133 (w3-running-xemacs | |
| 134 (sit-for 0)) | |
| 135 ;; (if (and (not (sit-for 0)) (input-pending-p)) | |
| 136 ;; (condition-case () | |
| 137 ;; (dispatch-event (next-command-event)) | |
| 138 ;; (error nil))) | |
| 139 (t (sit-for 0)))) | |
| 140 | |
| 141 (defmacro w3-get-pad-string (len) | |
| 142 (` (cond | |
| 143 ((< (, len) 0) | |
| 144 "") | |
| 145 ((< (, len) 80) | |
| 146 (aref w3-fill-prefixes-vector (, len))) | |
| 147 (t (make-string (, len) ? ))))) | |
| 148 | |
| 149 (defsubst w3-set-fill-prefix-length (len) | |
| 150 (setq fill-prefix (if (< len (- (or w3-strict-width (window-width)) 4)) | |
| 151 (w3-get-pad-string len) | |
| 152 (url-warn | |
| 153 'html | |
| 154 "Runaway indentation! Too deep for window width!") | |
| 155 fill-prefix))) | |
| 156 | |
| 157 (defsubst w3-get-style-info (info node &optional default) | |
| 158 (or (cdr-safe (assq info w3-display-css-properties)) default)) | |
| 159 | |
| 160 (defun w3-decode-area-coords (str) | |
| 161 (let (retval) | |
| 162 (while (string-match "\\([ \t0-9]+\\),\\([ \t0-9]+\\)" str) | |
| 163 (setq retval (cons (vector (string-to-int (match-string 1 str)) | |
| 164 (string-to-int (match-string 2 str))) retval) | |
| 165 str (substring str (match-end 0) nil))) | |
| 166 (if (string-match "\\([0-9]+\\)" str) | |
| 167 (setq retval (cons (vector (+ (aref (car retval) 0) | |
| 168 (string-to-int (match-string 1 str))) | |
| 169 (aref (car retval) 1)) retval))) | |
| 170 (nreverse retval))) | |
| 171 | |
| 172 (defun w3-normalize-color (color) | |
| 173 (cond | |
| 174 ((valid-color-name-p color) | |
| 175 color) | |
| 176 ((valid-color-name-p (concat "#" color)) | |
| 177 (concat "#" color)) | |
| 178 ((string-match "[ \t\r\n]" color) | |
| 179 (w3-normalize-color | |
| 180 (mapconcat (function (lambda (x) (if (memq x '(?\t ?\r ?\n ? )) "" | |
| 181 (char-to-string x)))) color ""))) | |
| 182 ((valid-color-name-p (font-normalize-color color)) | |
| 183 (font-normalize-color color)) | |
| 184 (t | |
| 185 (w3-warn 'html (format "Bad color specification: %s" color)) | |
| 186 nil))) | |
| 187 | |
| 188 (defsubst w3-voice-for-element (node) | |
| 189 (if (featurep 'emacspeak) | |
| 190 (let (family gain left right pitch pitch-range stress richness voice) | |
| 191 (setq family (w3-get-style-info 'voice-family node) | |
| 192 gain (w3-get-style-info 'gain node) | |
| 193 left (w3-get-style-info 'left-volume node) | |
| 194 right (w3-get-style-info 'right-volume node) | |
| 195 pitch (w3-get-style-info 'pitch node) | |
| 196 pitch-range (w3-get-style-info 'pitch-range node) | |
| 197 stress (w3-get-style-info 'stress node) | |
| 198 richness (w3-get-style-info 'richness node)) | |
| 199 (if (or family gain left right pitch pitch-range stress richness) | |
| 200 (setq voice (dtk-personality-from-speech-style | |
| 201 (make-dtk-speech-style :family (or family 'paul) | |
| 202 :gain (or gain 5) | |
| 203 :left-volume (or left 5) | |
| 204 :right-volume (or right 5) | |
| 205 :average-pitch (or pitch 5) | |
| 206 :pitch-range (or pitch-range 5) | |
| 207 :stress (or stress 5) | |
| 208 :richness (or richness 5)))) | |
| 209 (setq voice nil)) | |
| 210 (or voice (car w3-active-voices))))) | |
| 211 | |
| 212 (defun w3-make-face-emacs19 (name &optional doc-string temporary) | |
| 213 "Defines and returns a new FACE described by DOC-STRING. | |
| 214 If the face already exists, it is unmodified. | |
| 215 If TEMPORARY is non-nil, this face will cease to exist if not in use." | |
| 216 (make-face name)) | |
| 217 | |
| 218 (cond | |
| 219 ((not (fboundp 'make-face)) | |
| 220 (fset 'w3-make-face 'ignore)) | |
| 221 (w3-running-xemacs | |
| 222 (fset 'w3-make-face 'make-face)) | |
| 223 (t | |
| 224 (fset 'w3-make-face 'w3-make-face-emacs19))) | |
| 225 | |
| 226 (defsubst w3-face-for-element (node) | |
| 227 (w3-get-all-face-info) | |
| 228 (if (car w3-face-text-decoration) | |
| 229 (set-font-style-by-keywords w3-face-font-spec | |
| 230 (car w3-face-text-decoration))) | |
| 231 (if w3-face-font-variant | |
| 232 (set-font-style-by-keywords w3-face-font-spec | |
| 233 (car w3-face-font-variant))) | |
| 234 (setq w3-face-descr (list w3-face-font-spec | |
| 235 (car w3-face-color) | |
| 236 (car w3-face-background)) | |
| 237 w3-face-face (cdr-safe (assoc w3-face-descr w3-face-cache))) | |
| 238 (if (or w3-face-face (not (or (car w3-face-color) | |
| 239 (car w3-face-background) | |
| 240 w3-face-font-spec))) | |
| 241 nil ; Do nothing, we got it already | |
| 242 (setq w3-face-face | |
| 243 (w3-make-face (intern (format "w3-style-face-%05d" w3-face-index)) | |
| 244 "An Emacs-W3 face... don't edit by hand." t) | |
| 245 w3-face-index (1+ w3-face-index)) | |
| 246 (if w3-face-font-spec | |
| 247 (set-face-font w3-face-face w3-face-font-spec)) | |
| 248 (if (car w3-face-color) | |
| 249 (set-face-foreground w3-face-face (car w3-face-color))) | |
| 250 (if (car w3-face-background) | |
| 251 (set-face-background w3-face-face (car w3-face-background))) | |
| 252 ;;(set-face-background-pixmap w3-face-face w3-face-pixmap) | |
| 253 (setq w3-face-cache (cons | |
| 254 (cons w3-face-descr w3-face-face) | |
| 255 w3-face-cache))) | |
| 256 w3-face-face) | |
| 257 | |
| 258 (defun w3-normalize-spaces (string) | |
| 259 ;; nuke spaces in the middle | |
| 260 (while (string-match "[ \t\r\n][ \r\t\n]+" string) | |
| 261 (setq string (concat (substring string 0 (1+ (match-beginning 0))) | |
| 262 (substring string (match-end 0))))) | |
| 263 | |
| 264 ;; nuke spaces at the beginning | |
| 265 (if (string-match "^[ \t\r\n]+" string) | |
| 266 (setq string (substring string (match-end 0)))) | |
| 267 | |
| 268 ;; nuke spaces at the end | |
| 269 (if (string-match "[ \t\n\r]+$" string) | |
| 270 (setq string (substring string 0 (match-beginning 0)))) | |
| 271 string) | |
| 272 | |
| 273 (defvar w3-bullets | |
| 274 '((disc . ?*) | |
| 275 (circle . ?o) | |
| 276 (square . ?#) | |
| 277 ) | |
| 278 "*An assoc list of unordered list types mapping to characters to use | |
| 279 as the bullet character.") | |
| 280 | |
| 281 | |
| 282 (defsubst w3-display-line-break (n) | |
| 283 (if (or | |
| 284 (memq (car w3-display-whitespace-stack) '(pre nowrap)) ; Been told | |
| 285 (= w3-last-fill-pos (point)) | |
| 286 (> w3-last-fill-pos (point-max))) | |
| 287 (if (/= (preceding-char) ?\n) (setq n (1+ n))) ; at least put one line in | |
| 288 (let ((fill-column (max (1+ (length fill-prefix)) fill-column)) | |
| 289 width) | |
| 290 (case (car w3-display-alignment-stack) | |
| 291 (center | |
| 292 (fill-region-as-paragraph w3-last-fill-pos (point)) | |
| 293 (center-region w3-last-fill-pos (point-max))) | |
| 294 ((justify full) | |
| 295 (fill-region-as-paragraph w3-last-fill-pos (point) t)) | |
| 296 (right | |
| 297 (fill-region-as-paragraph w3-last-fill-pos (point)) | |
| 298 (goto-char w3-last-fill-pos) | |
| 299 (catch 'fill-exit | |
| 300 (while (re-search-forward ".$" nil t) | |
| 301 (if (>= (setq width (current-column)) fill-column) | |
| 302 nil ; already justified, or error | |
| 303 (beginning-of-line) | |
| 304 (insert-char ? (- fill-column width)) | |
| 305 (end-of-line) | |
| 306 (if (eobp) | |
| 307 (throw 'fill-exit t)) | |
| 308 (condition-case () | |
| 309 (forward-char 1) | |
| 310 (error (throw 'fill-exit t)))))) | |
| 311 ) | |
| 312 (otherwise ; Default is left justification | |
| 313 (fill-region-as-paragraph w3-last-fill-pos (point))) | |
| 314 )) | |
| 315 (setq n (1- n))) | |
| 316 (setq w3-last-fill-pos (point-max)) | |
| 317 (insert (cond | |
| 318 ((<= n 0) "") | |
| 319 ((< n 10) | |
| 320 (aref w3-line-breaks-vector n)) | |
| 321 (t | |
| 322 (make-string n ?\n))))) | |
| 323 | |
| 324 (defsubst w3-munge-line-breaks-p () | |
| 325 (eq (car w3-display-whitespace-stack) 'pre)) | |
| 326 | |
| 327 (defvar w3-display-nil-face (w3-make-face nil "Stub face... don't ask." t)) | |
| 328 | |
| 329 (defvar w3-scratch-start-point nil) | |
| 330 | |
| 331 (defsubst w3-handle-string-content (string) | |
| 332 (setq w3-scratch-start-point (point)) | |
| 333 (insert string) | |
| 334 (if (w3-munge-line-breaks-p) | |
| 335 (progn | |
| 336 (goto-char w3-scratch-start-point) | |
| 337 (if (not (search-forward "\n" nil t)) | |
| 338 (subst-char-in-region w3-scratch-start-point (point-max) ?\r ?\n) | |
| 339 (subst-char-in-region w3-scratch-start-point (point-max) ?\r ? ))) | |
| 340 (goto-char w3-scratch-start-point) | |
| 341 (while (re-search-forward | |
| 342 " [ \t\n\r]+\\|[\t\n\r][ \t\n\r]*" | |
| 343 nil 'move) | |
| 344 (replace-match " ")) | |
| 345 (goto-char w3-scratch-start-point) | |
| 346 (if (and (memq (preceding-char) '(? ?\t ?\r ?\n)) | |
| 347 (looking-at "[ \t\r\n]")) | |
| 348 (delete-region (point) | |
| 349 (progn | |
| 350 (skip-chars-forward " \t\r\n") | |
| 351 (point))))) | |
| 352 (goto-char (point-max)) | |
| 353 (add-text-properties w3-scratch-start-point | |
| 354 (point) (list 'face w3-active-faces 'duplicable t)) | |
| 355 (if (car w3-active-voices) | |
| 356 (add-text-properties w3-scratch-start-point (point) | |
| 357 (list 'personality (car w3-active-voices)))) | |
| 358 ) | |
| 359 | |
| 360 (defun w3-widget-echo (widget &rest ignore) | |
| 361 (let ((href (widget-get widget 'href)) | |
| 362 (name (widget-get widget 'name)) | |
| 363 (text (buffer-substring (widget-get widget :from) | |
| 364 (widget-get widget :to))) | |
| 365 (title (widget-get widget 'title)) | |
| 366 (msg nil)) | |
| 367 (if href | |
| 368 (setq href (url-truncate-url-for-viewing href))) | |
| 369 (if name | |
| 370 (setq name (concat "anchor:" name))) | |
| 371 (case w3-echo-link | |
| 372 (url (or href title text name)) | |
| 373 (text (or text title href name)) | |
| 374 (title (or title text href name)) | |
| 375 (otherwise nil)))) | |
| 376 | |
| 377 (defun w3-follow-hyperlink (widget &rest ignore) | |
| 378 (let* ((target (widget-get widget 'target)) | |
| 379 (href (widget-get widget 'href))) | |
| 380 (if target (setq target (intern (downcase target)))) | |
| 381 (case target | |
| 382 ((_blank external) | |
| 383 (w3-fetch-other-frame href)) | |
| 384 (_top | |
| 385 (delete-other-windows) | |
| 386 (w3-fetch href)) | |
| 387 (otherwise | |
| 388 (w3-fetch href))))) | |
| 389 | |
| 390 (defun w3-balloon-help-callback (object &optional event) | |
| 391 (let* ((widget (widget-at (extent-start-position object))) | |
| 392 (href (and widget (widget-get widget 'href)))) | |
| 393 (if href | |
| 394 (url-truncate-url-for-viewing href) | |
| 395 nil))) | |
| 396 | |
| 397 | |
| 398 ;; Various macros | |
| 399 (eval-when-compile | |
| 400 (defmacro w3-expand-url (url) | |
| 401 (` | |
| 402 (url-expand-file-name (, url) | |
| 403 (cdr-safe | |
| 404 (assoc | |
| 405 (cdr-safe | |
| 406 (assq 'base args)) w3-base-alist))))) | |
| 407 | |
| 408 (defmacro w3-handle-empty-tag () | |
| 409 (` | |
| 410 (progn | |
| 411 (push (cons tag args) w3-display-open-element-stack) | |
| 412 (push content content-stack) | |
| 413 (setq content nil)))) | |
| 414 | |
| 415 (defmacro w3-handle-content (node) | |
| 416 (` | |
| 417 (progn | |
| 418 (push (cons tag args) w3-display-open-element-stack) | |
| 419 (push content content-stack) | |
| 420 (setq content (nth 2 node))))) | |
| 421 | |
| 422 (defmacro w3-display-handle-list-type () | |
| 423 (` | |
| 424 (case (car break-style) | |
| 425 (list-item | |
| 426 (let ((list-style (w3-get-style-info 'list-style node)) | |
| 427 (list-num (if (car w3-display-list-stack) | |
| 428 (incf (car w3-display-list-stack)) | |
| 429 1)) | |
| 430 (margin (1- (car left-margin-stack))) | |
| 431 (indent (w3-get-style-info 'text-indent node 0))) | |
| 432 (if (> indent 0) | |
| 433 (setq margin (+ margin indent)) | |
| 434 (setq margin (max 0 (- margin indent)))) | |
| 435 (beginning-of-line) | |
| 436 (case list-style | |
| 437 ((disc circle square) | |
| 438 (insert (format (format "%%%dc" margin) | |
| 439 (or (cdr-safe (assq list-style w3-bullets)) | |
| 440 ?o)))) | |
| 441 ((decimal lower-roman upper-roman lower-alpha upper-alpha) | |
| 442 (let ((x (case list-style | |
| 443 (lower-roman | |
| 444 (w3-decimal-to-roman list-num)) | |
| 445 (upper-roman | |
| 446 (upcase | |
| 447 (w3-decimal-to-roman list-num))) | |
| 448 (lower-alpha | |
| 449 (w3-decimal-to-alpha list-num)) | |
| 450 (upper-alpha | |
| 451 (upcase | |
| 452 (w3-decimal-to-alpha list-num))) | |
| 453 (otherwise | |
| 454 (int-to-string list-num))))) | |
| 455 (insert (format (format "%%%ds." margin) x)) | |
| 456 ) | |
| 457 ) | |
| 458 (otherwise | |
| 459 (insert (w3-get-pad-string margin))) | |
| 460 ) | |
| 461 ) | |
| 462 ) | |
| 463 (otherwise | |
| 464 (insert (w3-get-pad-string (+ (car left-margin-stack) | |
| 465 (w3-get-style-info 'text-indent node 0))))) | |
| 466 ) | |
| 467 ) | |
| 468 ) | |
| 469 | |
| 470 (defmacro w3-display-set-margins () | |
| 471 (` | |
| 472 (progn | |
| 473 (push (+ (w3-get-style-info 'margin-left node 0) | |
| 474 (car left-margin-stack)) left-margin-stack) | |
| 475 (push (- | |
| 476 (car right-margin-stack) | |
| 477 (w3-get-style-info 'margin-right node 0)) right-margin-stack) | |
| 478 (setq fill-column (car right-margin-stack)) | |
| 479 (w3-set-fill-prefix-length (car left-margin-stack)) | |
| 480 (w3-display-handle-list-type)))) | |
| 481 | |
| 482 (defmacro w3-display-restore-margins () | |
| 483 (` | |
| 484 (progn | |
| 485 (pop right-margin-stack) | |
| 486 (pop left-margin-stack)))) | |
| 487 | |
| 488 (defmacro w3-display-handle-break () | |
| 489 (` | |
| 490 (case (car break-style) | |
| 491 (block ; Full paragraph break | |
| 492 (if (eq (cadr break-style) 'list-item) | |
| 493 (setf (cadr break-style) 'line) | |
| 494 (w3-display-line-break 1)) | |
| 495 (w3-display-set-margins) | |
| 496 (push | |
| 497 (w3-get-style-info 'white-space node | |
| 498 (car w3-display-whitespace-stack)) | |
| 499 w3-display-whitespace-stack) | |
| 500 (push | |
| 501 (or (w3-get-attribute 'align) | |
| 502 (w3-get-style-info 'text-align node | |
| 503 (car w3-display-alignment-stack))) | |
| 504 w3-display-alignment-stack) | |
| 505 (and w3-do-incremental-display (w3-pause))) | |
| 506 ((line list-item) ; Single line break | |
| 507 (w3-display-line-break 0) | |
| 508 (w3-display-set-margins) | |
| 509 (push | |
| 510 (w3-get-style-info 'white-space node | |
| 511 (car w3-display-whitespace-stack)) | |
| 512 w3-display-whitespace-stack) | |
| 513 (push | |
| 514 (w3-get-style-info 'text-align node | |
| 515 (or (w3-get-attribute 'align) | |
| 516 (car w3-display-alignment-stack))) | |
| 517 w3-display-alignment-stack)) | |
| 518 (otherwise ; Assume 'inline' rendering as default | |
| 519 nil)) | |
| 520 ) | |
| 521 ) | |
| 522 | |
| 523 (defmacro w3-display-handle-end-break () | |
| 524 (` | |
| 525 (case (pop break-style) | |
| 526 (block ; Full paragraph break | |
| 527 (w3-display-line-break 1) | |
| 528 (w3-display-restore-margins) | |
| 529 (pop w3-display-whitespace-stack) | |
| 530 (pop w3-display-alignment-stack) | |
| 531 (and w3-do-incremental-display (w3-pause))) | |
| 532 ((line list-item) ; Single line break | |
| 533 (w3-display-restore-margins) | |
| 534 (w3-display-line-break 0) | |
| 535 (pop w3-display-whitespace-stack) | |
| 536 (pop w3-display-alignment-stack)) | |
| 537 (otherwise ; Assume 'inline' rendering as default | |
| 538 nil)) | |
| 539 ) | |
| 540 ) | |
| 541 ) | |
| 542 | |
| 543 ;; <link> handling | |
| 544 (defun w3-parse-link (args) | |
| 545 (let* ((type (if (w3-get-attribute 'rel) 'rel 'rev)) | |
| 546 (desc (w3-get-attribute type)) | |
| 547 (dc-desc (and desc (downcase desc))) ; canonical case | |
| 548 (dest (w3-get-attribute 'href)) | |
| 549 (plist (alist-to-plist args)) | |
| 550 (node-1 (assq type w3-current-links)) | |
| 551 (node-2 (and node-1 desc (or (assoc desc | |
| 552 (cdr node-1)) | |
| 553 (assoc dc-desc | |
| 554 (cdr node-1))))) | |
| 555 ) | |
| 556 ;; Canonicalize the case of link types we may look for | |
| 557 ;; specifically (toolbar etc.) since that's done with | |
| 558 ;; assoc. See `w3-mail-document-author' and | |
| 559 ;; `w3-link-toolbar', at least. | |
| 560 (if (member dc-desc w3-defined-link-types) | |
| 561 (setq desc dc-desc)) | |
| 562 (if dest ; ignore if HREF missing | |
| 563 (cond | |
| 564 (node-2 ; Add to old value | |
| 565 (setcdr node-2 (cons plist (cdr node-2)))) | |
| 566 (node-1 ; first rel/rev | |
| 567 (setcdr node-1 (cons (cons desc (list plist)) | |
| 568 (cdr node-1)))) | |
| 569 (t (setq w3-current-links | |
| 570 (cons (cons type (list (cons desc (list plist)))) | |
| 571 w3-current-links))))) | |
| 572 (setq desc (and desc (intern dc-desc))) | |
| 573 (case desc | |
| 574 ((style stylesheet) | |
| 575 (w3-handle-style args)) | |
| 576 (otherwise | |
| 577 ) | |
| 578 ) | |
| 579 ) | |
| 580 ) | |
| 581 | |
| 582 | |
| 583 ;; Image handling | |
| 584 (defun w3-maybe-start-image-download (widget) | |
| 585 (let* ((src (widget-get widget 'src)) | |
| 586 (cached-glyph (w3-image-cached-p src))) | |
| 587 (if (and cached-glyph (widget-glyphp cached-glyph)) | |
| 588 (setq w3-image-widgets-waiting (cons widget w3-image-widgets-waiting)) | |
| 589 (cond | |
| 590 ((or w3-delay-image-loads ; Delaying images | |
| 591 (not (fboundp 'valid-specifier-domain-p)) ; Can't do images | |
| 592 (eq (device-type) 'tty)) ; Why bother? | |
| 593 (w3-add-delayed-graphic widget)) | |
| 594 ((not (w3-image-loadable-p src nil)) ; Hey, we can't load it! | |
| 595 (w3-warn 'images (format "Skipping image %s" (url-basepath src t))) | |
| 596 (w3-add-delayed-graphic widget)) | |
| 597 (t ; Grab the images | |
| 598 (let ( | |
| 599 (url-request-method "GET") | |
| 600 (old-asynch url-be-asynchronous) | |
| 601 (url-request-data nil) | |
| 602 (url-request-extra-headers nil) | |
| 603 (url-source t) | |
| 604 (url-mime-accept-string (substring | |
| 605 (mapconcat | |
| 606 (function | |
| 607 (lambda (x) | |
| 608 (if x | |
| 609 (concat (car x) ",") | |
| 610 ""))) | |
| 611 w3-allowed-image-types "") | |
| 612 0 -1)) | |
| 613 (url-working-buffer (generate-new-buffer-name " *W3GRAPH*"))) | |
| 614 (setq-default url-be-asynchronous t) | |
| 615 (setq w3-graphics-list (cons (cons src (make-glyph)) | |
| 616 w3-graphics-list)) | |
| 617 (save-excursion | |
| 618 (set-buffer (get-buffer-create url-working-buffer)) | |
| 619 (setq url-current-callback-data (list widget) | |
| 620 url-be-asynchronous t | |
| 621 url-current-callback-func 'w3-finalize-image-download) | |
| 622 (url-retrieve src)) | |
| 623 (setq-default url-be-asynchronous old-asynch))))))) | |
| 624 | |
| 625 (defun w3-finalize-image-download (widget) | |
| 626 (let ((glyph nil) | |
| 627 (url (widget-get widget 'src)) | |
| 628 (node nil) | |
| 629 (buffer (widget-get widget 'buffer))) | |
| 630 (message "Enhancing image...") | |
| 631 (setq glyph (image-normalize (cdr-safe (assoc url-current-mime-type | |
| 632 w3-image-mappings)) | |
| 633 (buffer-string))) | |
| 634 (message "Enhancing image... done") | |
| 635 (kill-buffer (current-buffer)) | |
| 636 (cond | |
| 637 ((w3-image-invalid-glyph-p glyph) | |
| 638 (setq glyph nil) | |
| 639 (w3-warn 'image (format "Reading of %s failed." url))) | |
| 640 ((eq (aref glyph 0) 'xbm) | |
| 641 (let ((temp-fname (url-generate-unique-filename "%s.xbm"))) | |
| 642 (save-excursion | |
| 643 (set-buffer (generate-new-buffer " *xbm-garbage*")) | |
| 644 (erase-buffer) | |
| 645 (insert (aref glyph 2)) | |
| 646 (setq glyph temp-fname) | |
| 647 (write-region (point-min) (point-max) temp-fname) | |
| 648 (kill-buffer (current-buffer))) | |
| 649 (setq glyph (make-glyph (list (cons 'x glyph)))) | |
| 650 (condition-case () | |
| 651 (delete-file temp-fname) | |
| 652 (error nil)))) | |
| 653 (t | |
| 654 (setq glyph (make-glyph glyph)))) | |
| 655 (setq node (assoc url w3-graphics-list)) | |
| 656 (cond | |
| 657 ((and node glyph) | |
| 658 (set-glyph-image (cdr node) (glyph-image glyph))) | |
| 659 (glyph | |
| 660 (setq w3-graphics-list (cons (cons url glyph) w3-graphics-list))) | |
| 661 (t nil)) | |
| 662 | |
| 663 (if (and (buffer-name buffer) ; Dest. buffer exists | |
| 664 (widget-glyphp glyph)) ; got a valid glyph | |
| 665 (save-excursion | |
| 666 (set-buffer buffer) | |
| 667 (if (eq major-mode 'w3-mode) | |
| 668 (widget-value-set widget glyph) | |
| 669 (setq w3-image-widgets-waiting | |
| 670 (cons widget w3-image-widgets-waiting))))))) | |
| 671 | |
| 672 (defmacro w3-node-visible-p () | |
| 673 (` (not (eq (car break-style) 'none)))) | |
| 674 | |
| 675 (defmacro w3-handle-image () | |
| 676 (` | |
| 677 (let* ((height (w3-get-attribute 'height)) | |
| 678 (width (w3-get-attribute 'width)) | |
| 679 (src (or (w3-get-attribute 'src) "Error Image")) | |
| 680 (our-alt (cond | |
| 681 ((null w3-auto-image-alt) "") | |
| 682 ((eq t w3-auto-image-alt) | |
| 683 (concat "[IMAGE(" (url-basepath src t) ")] ")) | |
| 684 ((stringp w3-auto-image-alt) | |
| 685 (format w3-auto-image-alt (url-basepath src t))))) | |
| 686 (alt (or (w3-get-attribute 'alt) our-alt)) | |
| 687 (ismap (and (assq 'ismap args) 'ismap)) | |
| 688 (usemap (w3-get-attribute 'usemap)) | |
| 689 (base (w3-get-attribute 'base)) | |
| 690 (href (and hyperlink-info (widget-get (cadr hyperlink-info) 'href))) | |
| 691 (widget nil) | |
| 692 (align (or (w3-get-attribute 'align) | |
| 693 (w3-get-style-info 'vertical-align node)))) | |
| 694 (setq widget (widget-create 'image | |
| 695 :value-face w3-active-faces | |
| 696 'src src ; Where to load the image from | |
| 697 'alt alt ; Textual replacement | |
| 698 'ismap ismap ; Is it a server-side map? | |
| 699 'usemap usemap ; Is it a client-side map? | |
| 700 'href href ; Hyperlink destination | |
| 701 )) | |
| 702 (widget-put widget 'buffer (current-buffer)) | |
| 703 (w3-maybe-start-image-download widget) | |
| 704 (goto-char (point-max))))) | |
| 705 | |
| 706 ;; The table handling | |
| 707 | |
| 708 (defvar w3-display-table-cut-words-p nil | |
| 709 "*Whether to cut words that are oversized in table cells") | |
| 710 | |
| 711 (defvar w3-display-table-force-borders nil | |
| 712 "*Whether to always draw table borders") | |
| 713 | |
| 714 (defun w3-display-table-cut () | |
| 715 (save-excursion | |
| 716 (goto-char (point-min)) | |
| 717 (let ((offset -1)) | |
| 718 (while (< offset 0) | |
| 719 (end-of-line) | |
| 720 (setq offset (- fill-column (current-column))) | |
| 721 (cond ((< offset 0) | |
| 722 (condition-case nil | |
| 723 (progn (forward-char offset) | |
| 724 (insert ?\n)) | |
| 725 (error (setq offset 0)))) | |
| 726 ((not (eobp)) | |
| 727 (forward-line 1) | |
| 728 (setq offset -1))))))) | |
| 729 | |
| 730 | |
| 731 (defun w3-display-fix-widgets () | |
| 732 ;; Make markers belong to the right buffer | |
| 733 (save-excursion | |
| 734 (let ((st (point-min)) | |
| 735 (nd nil) | |
| 736 (widget nil) parent | |
| 737 (to-marker nil) | |
| 738 (from-marker nil)) | |
| 739 (while (setq st (next-single-property-change st 'button)) | |
| 740 (setq nd (or (next-single-property-change st 'button) (point-max)) | |
| 741 widget (widget-at st) | |
| 742 to-marker (and widget (widget-get widget :to)) | |
| 743 from-marker (and widget (widget-get widget :from)) | |
| 744 parent (and widget (widget-get widget :parent)) | |
| 745 ) | |
| 746 (if (not widget) | |
| 747 nil | |
| 748 (widget-put widget :from (set-marker (make-marker) st)) | |
| 749 (widget-put widget :to (set-marker (make-marker) nd)) | |
| 750 (if (not parent) | |
| 751 nil | |
| 752 (widget-put parent :from (set-marker (make-marker) st)) | |
| 753 (widget-put parent :to (set-marker (make-marker) nd)))) | |
| 754 (if (condition-case () | |
| 755 (get-text-property (1+ nd) 'button) | |
| 756 (error nil)) | |
| 757 (setq st nd) | |
| 758 (setq st (min (point-max) (1+ nd)))))))) | |
| 759 | |
| 760 (defun w3-size-of-tree (tree minmax) | |
| 761 (save-excursion | |
| 762 (save-restriction | |
| 763 (narrow-to-region (point) (point)) | |
| 764 ;; XXX fill-column set to 1 fails when fill-prefix is set | |
| 765 ;; XXX setting fill-column at all isn't really right | |
| 766 ;; for example <hr>s shouldn't be especially wide | |
| 767 ;; we should set a flag that makes w3 never wrap a line | |
| 768 (let ((fill-column (cond ((eq minmax 'min) | |
| 769 3) | |
| 770 ((eq minmax 'max) | |
| 771 400))) | |
| 772 (fill-prefix "") | |
| 773 (w3-last-fill-pos (point-min)) | |
| 774 a retval | |
| 775 (w3-do-incremental-display nil) | |
| 776 (hr-regexp (concat "^" | |
| 777 (regexp-quote | |
| 778 (make-string 5 w3-horizontal-rule-char)) | |
| 779 "*$")) | |
| 780 ) | |
| 781 ;;(push 'left w3-display-alignment-stack) | |
| 782 (push (if (eq minmax 'max) 'nowrap) w3-display-whitespace-stack) | |
| 783 (while tree | |
| 784 (push (cons '*td args) w3-display-open-element-stack) | |
| 785 (w3-display-node (pop tree))) | |
| 786 (pop w3-display-whitespace-stack) | |
| 787 (goto-char (point-min)) | |
| 788 (while (re-search-forward hr-regexp nil t) | |
| 789 (replace-match "" t t)) | |
| 790 (goto-char (point-min)) | |
| 791 (while (not (eobp)) | |
| 792 ;; loop invariant: at beginning of uncounted line | |
| 793 (end-of-line) | |
| 794 (skip-chars-backward " ") | |
| 795 (setq retval (cons (current-column) | |
| 796 retval)) | |
| 797 (beginning-of-line 2)) | |
| 798 (if (= (point-min) (point-max)) | |
| 799 (setq retval 0) | |
| 800 (setq retval (apply 'max (cons 0 retval)))) | |
| 801 (delete-region (point-min) (point-max)) | |
| 802 retval)))) | |
| 803 | |
| 804 (defun w3-display-table-dimensions (node) | |
| 805 ;; fill-column sets maximum width | |
| 806 (let (min-vector | |
| 807 max-vector | |
| 808 rows cols | |
| 809 ;;(w3-form-elements (and (boundp 'w3-form-elements) w3-form-elements)) | |
| 810 (table-info (assq 'w3-table-info (cadr node)))) | |
| 811 | |
| 812 (if table-info | |
| 813 (setq min-vector (nth 1 table-info) | |
| 814 max-vector (nth 2 table-info) | |
| 815 rows (nth 3 table-info) | |
| 816 cols (nth 4 table-info)) | |
| 817 | |
| 818 (push (cons '*table-autolayout args) w3-display-open-element-stack) | |
| 819 (let (content | |
| 820 cur | |
| 821 (table-spans (list nil)) ; don't make this '(nil) | |
| 822 ptr | |
| 823 col | |
| 824 constraints | |
| 825 | |
| 826 colspan rowspan min max) | |
| 827 (setq content (nth 2 node)) | |
| 828 (setq rows 0 cols 0) | |
| 829 (while content | |
| 830 (setq cur (pop content)) | |
| 831 (if (stringp cur) | |
| 832 nil | |
| 833 (case (car cur) | |
| 834 (tr | |
| 835 (setq col 0) | |
| 836 (setq rows (1+ rows)) | |
| 837 (setq ptr table-spans) | |
| 838 (mapcar | |
| 839 (function | |
| 840 (lambda (td) | |
| 841 (setq colspan (string-to-int (or (cdr-safe (assq 'colspan (nth 1 td))) "1")) | |
| 842 rowspan (string-to-int (or (cdr-safe (assq 'rowspan (nth 1 td))) "1")) | |
| 843 min (w3-size-of-tree (nth 2 td) 'min) | |
| 844 max (w3-size-of-tree (nth 2 td) 'max) | |
| 845 ) | |
| 846 (while (eq (car-safe (car-safe (cdr ptr))) col) | |
| 847 (setq col (+ col (cdr (cdr (car (cdr ptr)))))) | |
| 848 (if (= 0 (decf (car (cdr (car (cdr ptr)))))) | |
| 849 (pop (cdr ptr)) | |
| 850 (setq ptr (cdr ptr)))) | |
| 851 (push (list col colspan min max) | |
| 852 constraints) | |
| 853 (if (= rowspan 1) nil | |
| 854 (push (cons col (cons (1- rowspan) colspan)) (cdr ptr)) | |
| 855 (setq ptr (cdr ptr))) | |
| 856 (setq col (+ col colspan)) | |
| 857 )) | |
| 858 (nth 2 cur)) | |
| 859 (while (cdr ptr) | |
| 860 (if (= 0 (decf (car (cdr (car (cdr ptr)))))) | |
| 861 (pop (cdr ptr)) | |
| 862 (setq ptr (cdr ptr)))) | |
| 863 (setq cols (max cols col)) | |
| 864 ) | |
| 865 (caption | |
| 866 nil) | |
| 867 (otherwise | |
| 868 (setq content (nth 2 cur))) | |
| 869 ) | |
| 870 ) | |
| 871 ) | |
| 872 (setq constraints (sort constraints | |
| 873 (function | |
| 874 (lambda (a b) | |
| 875 (< (cadr a) (cadr b))))) | |
| 876 min-vector (make-vector cols 0) | |
| 877 max-vector (make-vector cols 0)) | |
| 878 (let (start end i mincellwidth maxcellwidth) | |
| 879 (mapcar (function (lambda (c) | |
| 880 (cond ((= (cadr c) 1) | |
| 881 (aset min-vector (car c) | |
| 882 (max (aref min-vector (car c)) | |
| 883 (nth 2 c))) | |
| 884 (aset max-vector (car c) | |
| 885 (max (aref max-vector (car c)) | |
| 886 (nth 3 c)))) | |
| 887 (t | |
| 888 (setq start (car c) | |
| 889 end (+ (car c) (cadr c)) | |
| 890 mincellwidth 0 | |
| 891 maxcellwidth 0 | |
| 892 i start) | |
| 893 (while (< i end) | |
| 894 (setq mincellwidth (+ mincellwidth | |
| 895 (aref min-vector i)) | |
| 896 maxcellwidth (+ | |
| 897 maxcellwidth | |
| 898 (aref max-vector i)) | |
| 899 i (1+ i))) | |
| 900 (setq i start) | |
| 901 (if (= mincellwidth 0) | |
| 902 ;; if existing width is 0 divide evenly | |
| 903 (while (< i end) | |
| 904 (aset min-vector i | |
| 905 (/ (nth 2 c) (cadr c))) | |
| 906 (aset max-vector i | |
| 907 (/ (nth 3 c) (cadr c))) | |
| 908 (setq i (1+ i))) | |
| 909 ;; otherwise weight it by existing widths | |
| 910 (while (< i end) | |
| 911 (aset min-vector i | |
| 912 (max (aref min-vector i) | |
| 913 (/ (* (nth 2 c) | |
| 914 (aref min-vector i)) | |
| 915 mincellwidth))) | |
| 916 (aset max-vector i | |
| 917 (max (aref max-vector i) | |
| 918 (/ (* (nth 3 c) | |
| 919 (aref max-vector i)) | |
| 920 maxcellwidth))) | |
| 921 (setq i (1+ i)))) | |
| 922 )))) | |
| 923 constraints))) | |
| 924 (push (cons 'w3-table-info | |
| 925 (list min-vector max-vector rows cols)) | |
| 926 (cadr node)) | |
| 927 (pop w3-display-open-element-stack)) | |
| 928 | |
| 929 (let (max-width | |
| 930 min-width | |
| 931 ret-vector | |
| 932 col | |
| 933 ) | |
| 934 | |
| 935 | |
| 936 (setq max-width (apply '+ (append max-vector (list cols 1)))) | |
| 937 (setq min-width (apply '+ (append min-vector (list cols 1)))) | |
| 938 | |
| 939 ;; the comments in the cond are excerpts from rfc1942 itself | |
| 940 (cond | |
| 941 ;; 1. The minimum table width is equal to or wider than the available | |
| 942 ;; space. In this case, assign the minimum widths and allow the | |
| 943 ;; user to scroll horizontally. For conversion to braille, it will | |
| 944 ;; be necessary to replace the cells by references to notes | |
| 945 ;; containing their full content. By convention these appear | |
| 946 ;; before the table. | |
| 947 ((>= min-width fill-column) | |
| 948 (setq ret-vector min-vector)) | |
| 949 | |
| 950 ;; 2. The maximum table width fits within the available space. In | |
| 951 ;; this case, set the columns to their maximum widths. | |
| 952 ((<= max-width fill-column) | |
| 953 (setq ret-vector max-vector)) | |
| 954 | |
| 955 ;; 3. The maximum width of the table is greater than the available | |
| 956 ;; space, but the minimum table width is smaller. In this case, | |
| 957 ;; find the difference between the available space and the minimum | |
| 958 ;; table width, lets call it W. Lets also call D the difference | |
| 959 ;; between maximum and minimum width of the table. | |
| 960 | |
| 961 ;; For each column, let d be the difference between maximum and | |
| 962 ;; minimum width of that column. Now set the column's width to the | |
| 963 ;; minimum width plus d times W over D. This makes columns with | |
| 964 ;; large differences between minimum and maximum widths wider than | |
| 965 ;; columns with smaller differences. | |
| 966 (t | |
| 967 (setq ret-vector (make-vector cols 0)) | |
| 968 (let ((W (- fill-column min-width)) | |
| 969 (D (- max-width min-width)) | |
| 970 d extra) | |
| 971 (setq col 0) | |
| 972 (while (< col (length ret-vector)) | |
| 973 (setq d (- (aref max-vector col) | |
| 974 (aref min-vector col))) | |
| 975 (aset ret-vector col | |
| 976 (+ (aref min-vector col) | |
| 977 (/ (* d W) D))) | |
| 978 (setq col (1+ col))) | |
| 979 (setq extra (- fill-column | |
| 980 (apply '+ (append ret-vector | |
| 981 (list (length ret-vector) 1)))) | |
| 982 col 0) | |
| 983 (while (and (< col (length ret-vector)) (> extra 0)) | |
| 984 (if (= 1 (- (aref max-vector col) (aref ret-vector col) )) | |
| 985 (aset ret-vector col (1+ (aref ret-vector col)))) | |
| 986 (setq extra (1- extra) | |
| 987 col (1+ col))) | |
| 988 ))) | |
| 989 (list rows cols ret-vector)))) | |
| 990 | |
| 991 (defvar w3-table-ascii-border-chars | |
| 992 [? ? ? ?/ ? ?- ?\\ ?- ? ?\\ ?| ?| ?/ ?- ?| ?-] | |
| 993 "Vector of ascii characters to use to draw table borders. | |
| 994 w3-table-unhack-border-chars uses this to restore w3-table-border-chars.") | |
| 995 | |
| 996 (defvar w3-table-border-chars w3-table-ascii-border-chars | |
| 997 "Vector of characters to use to draw table borders. | |
| 998 If you set this you should set w3-table-ascii-border-chars to the same value | |
| 999 so that w3-table-unhack-borders can restore the value if necessary. | |
| 1000 | |
| 1001 A reasonable value is [? ? ? ?/ ? ?- ?\\\\ ?^ ? ?\\\\ ?| ?< ?/ ?- ?> ?-] | |
| 1002 Though i recommend replacing the ^ with - and the < and > with |") | |
| 1003 | |
| 1004 (defsubst w3-table-lookup-char (l u r b) | |
| 1005 (aref w3-table-border-chars (logior (if l 1 0) | |
| 1006 (if u 2 0) | |
| 1007 (if r 4 0) | |
| 1008 (if b 8 0)))) | |
| 1009 | |
| 1010 (defun w3-table-hack-borders nil | |
| 1011 "Try to find the best set of characters to draw table borders with. | |
| 1012 I definitely recommend trying this on X. | |
| 1013 On a console, this can trigger some Emacs display bugs. | |
| 1014 | |
| 1015 I haven't tried this on XEmacs or any window-system other than X." | |
| 1016 (interactive) | |
| 1017 (case (device-type) | |
| 1018 (x | |
| 1019 (let ((id (or (and (find-face 'w3-table-hack-x-face) | |
| 1020 (face-id 'w3-table-hack-x-face)) | |
| 1021 (progn | |
| 1022 (make-face 'w3-table-hack-x-face) | |
| 1023 (set-face-font 'w3-table-hack-x-face | |
| 1024 (make-font :family "terminal")) | |
| 1025 (face-id 'w3-table-hack-x-face))))) | |
| 1026 (if (not (face-differs-from-default-p 'w3-table-hack-x-face)) | |
| 1027 nil | |
| 1028 (aset standard-display-table 1 (vector (+ (* 256 id) ?l))) | |
| 1029 (aset standard-display-table 2 (vector (+ (* 256 id) ?q))) | |
| 1030 (aset standard-display-table 3 (vector (+ (* 256 id) ?k))) | |
| 1031 (aset standard-display-table 4 (vector (+ (* 256 id) ?t))) | |
| 1032 (aset standard-display-table 5 (vector (+ (* 256 id) ?n))) | |
| 1033 (aset standard-display-table 6 (vector (+ (* 256 id) ?u))) | |
| 1034 (aset standard-display-table 7 (vector (+ (* 256 id) ?m))) | |
| 1035 (aset standard-display-table 8 (vector (+ (* 256 id) ?x))) | |
| 1036 (aset standard-display-table 11 (vector (+ (* 256 id) ?j))) | |
| 1037 (aset standard-display-table 14 (vector (+ (* 256 id) ?v))) | |
| 1038 (aset standard-display-table 15 (vector (+ (* 256 id) ?w))) | |
| 1039 (setq w3-table-border-chars [? ? ? 11 ? 2 7 14 ? 3 8 6 1 15 4 5]) | |
| 1040 (setq w3-horizontal-rule-char 2)))) | |
| 1041 (tty | |
| 1042 (standard-display-g1 1 108) ; ulcorner | |
| 1043 (standard-display-g1 2 113) ; hline | |
| 1044 (standard-display-g1 3 107) ; urcorner | |
| 1045 (standard-display-g1 4 116) ; leftt | |
| 1046 (standard-display-g1 5 110) ; intersection | |
| 1047 (standard-display-g1 6 117) ; rightt | |
| 1048 (standard-display-g1 7 109) ; llcorner | |
| 1049 (standard-display-g1 8 120) ; vline | |
| 1050 (standard-display-g1 11 106) ; lrcorner | |
| 1051 (standard-display-g1 14 118) ; upt | |
| 1052 (standard-display-g1 15 119) ; downt | |
| 1053 (setq w3-table-border-chars [? ? ? 11 ? 2 7 14 ? 3 8 6 1 15 4 5]) | |
| 1054 (setq w3-horizontal-rule-char 2)) | |
| 1055 (otherwise | |
| 1056 (error "Unknown window-system, can't do any better than ascii borders"))) | |
| 1057 ) | |
| 1058 | |
| 1059 (defun w3-table-unhack-borders nil | |
| 1060 (interactive) | |
| 1061 (w3-table-excise-hack (buffer-list)) | |
| 1062 (standard-display-default 1 15) | |
| 1063 (setq w3-table-border-chars w3-table-ascii-border-chars) | |
| 1064 (setq w3-horizontal-rule-char ?-)) | |
| 1065 | |
| 1066 (defun w3-table-excise-hack (buffs) | |
| 1067 "Replace hacked characters with ascii characters in buffers BUFFS. | |
| 1068 Should be run before restoring w3-table-border-chars to ascii characters." | |
| 1069 (interactive (list (list (current-buffer)))) | |
| 1070 (let ((inhibit-read-only t) | |
| 1071 (tr (make-string 16 ? )) | |
| 1072 (i 0)) | |
| 1073 (while (< i (length tr)) | |
| 1074 (aset tr i i) | |
| 1075 (setq i (1+ i))) | |
| 1076 (setq i 0) | |
| 1077 (while (< i (length w3-table-border-chars)) | |
| 1078 (if (< (aref w3-table-border-chars i) 16) | |
| 1079 (aset tr | |
| 1080 (aref w3-table-border-chars i) | |
| 1081 (aref w3-table-ascii-border-chars i))) | |
| 1082 (setq i (1+ i))) | |
| 1083 (mapcar (function (lambda (buf) | |
| 1084 (save-excursion | |
| 1085 (set-buffer buf) | |
| 1086 (if (eq major-mode 'w3-mode) | |
| 1087 (translate-region (point-min) | |
| 1088 (point-max) | |
| 1089 tr))))) | |
| 1090 buffs))) | |
| 1091 | |
| 1092 (defun w3-display-table (node) | |
| 1093 (let* ((dimensions (w3-display-table-dimensions node)) | |
| 1094 (num-cols (max (cadr dimensions) 1)) | |
| 1095 (num-rows (max (car dimensions) 1)) | |
| 1096 (column-dimensions (caddr dimensions)) | |
| 1097 (table-width (apply '+ (append column-dimensions (list num-cols 1))))) | |
| 1098 (cond | |
| 1099 ((or (<= (cadr dimensions) 0) (<= (car dimensions) 0)) | |
| 1100 ;; We have an invalid table | |
| 1101 nil) | |
| 1102 ((assq '*table-autolayout w3-display-open-element-stack) | |
| 1103 ;; don't bother displaying the table if all we really need is the size | |
| 1104 (progn (insert-char ?T table-width) (insert "\n"))) | |
| 1105 (t | |
| 1106 (let* ((tag (nth 0 node)) | |
| 1107 (args (nth 1 node)) | |
| 1108 (border-node (cdr-safe (assq 'border args))) | |
| 1109 (border (or w3-display-table-force-borders | |
| 1110 (and border-node | |
| 1111 (or (/= 0 (string-to-int border-node)) | |
| 1112 (string= "border" border-node))))) | |
| 1113 (w3-table-border-chars | |
| 1114 (if border | |
| 1115 w3-table-border-chars | |
| 1116 (make-vector (length w3-table-border-chars) ? ))) | |
| 1117 valign align | |
| 1118 (content (nth 2 node)) | |
| 1119 (avgwidth (/ (- fill-column num-cols num-cols) num-cols)) | |
| 1120 (formatted-cols (make-vector num-cols nil)) | |
| 1121 (table-rowspans (make-vector num-cols 0)) | |
| 1122 (table-colspans (make-vector num-cols 1)) | |
| 1123 (prev-colspans (make-vector num-cols 0)) | |
| 1124 (prev-rowspans (make-vector num-cols 0)) | |
| 1125 (table-colwidth (make-vector num-cols 0)) | |
| 1126 (fill-prefix "") | |
| 1127 (height nil) | |
| 1128 (cur-height nil) | |
| 1129 (cols nil) | |
| 1130 (rows nil) | |
| 1131 (row 0) | |
| 1132 (this-rectangle nil) | |
| 1133 (i 0) | |
| 1134 ) | |
| 1135 | |
| 1136 (push (cons tag args) w3-display-open-element-stack) | |
| 1137 | |
| 1138 (if (memq 'nowrap w3-display-whitespace-stack) | |
| 1139 (setq fill-prefix "") | |
| 1140 (case (car w3-display-alignment-stack) | |
| 1141 (center | |
| 1142 (w3-set-fill-prefix-length | |
| 1143 (max 0 (/ (- fill-column table-width) 2)))) | |
| 1144 (right | |
| 1145 (w3-set-fill-prefix-length | |
| 1146 (max 0 (- fill-column table-width)))) | |
| 1147 (t | |
| 1148 (setq fill-prefix "")))) | |
| 1149 (while content | |
| 1150 (case (caar content) | |
| 1151 (tr | |
| 1152 (setq w3-display-css-properties (css-get | |
| 1153 (nth 0 (car content)) | |
| 1154 (nth 1 (car content)) | |
| 1155 w3-current-stylesheet | |
| 1156 w3-display-open-element-stack)) | |
| 1157 (setq cols (nth 2 (car content)) | |
| 1158 valign (or (cdr-safe (assq 'valign (nth 1 (car content)))) | |
| 1159 (w3-get-style-info 'vertical-align node)) | |
| 1160 align (or (cdr-safe (assq 'align (nth 1 (car content)))) | |
| 1161 (w3-get-style-info 'text-align node)) | |
| 1162 content (cdr content) | |
| 1163 row (1+ row)) | |
| 1164 (if (and valign (stringp valign)) | |
| 1165 (setq valign (intern (downcase valign)))) | |
| 1166 ;; this is iffy | |
| 1167 ;;(if align (push (intern (downcase align)) w3-display-alignment-stack)) | |
| 1168 (save-excursion | |
| 1169 (save-restriction | |
| 1170 (narrow-to-region (point) (point)) | |
| 1171 (setq fill-column avgwidth | |
| 1172 inhibit-read-only t | |
| 1173 w3-last-fill-pos (point-min) | |
| 1174 i 0) | |
| 1175 ;; skip over columns that have leftover content | |
| 1176 (while (and (< i num-cols) | |
| 1177 (/= 0 (aref table-rowspans i))) | |
| 1178 (setq i (+ i (max 1 (aref table-colspans i))))) | |
| 1179 (while cols | |
| 1180 (let* ((node (car cols)) | |
| 1181 (attributes (nth 1 node)) | |
| 1182 (colspan (string-to-int | |
| 1183 (or (cdr-safe (assq 'colspan attributes)) | |
| 1184 "1"))) | |
| 1185 (rowspan (string-to-int | |
| 1186 (or (cdr-safe (assq 'rowspan attributes)) | |
| 1187 "1"))) | |
| 1188 fill-column column-width | |
| 1189 (fill-prefix "") | |
| 1190 (w3-do-incremental-display nil) | |
| 1191 (indent-tabs-mode nil) | |
| 1192 c e | |
| 1193 ) | |
| 1194 | |
| 1195 (aset table-colspans i colspan) | |
| 1196 (aset table-rowspans i rowspan) | |
| 1197 | |
| 1198 (setq fill-column 0) | |
| 1199 (setq c i | |
| 1200 e (+ i colspan)) | |
| 1201 (while (< c e) | |
| 1202 (setq fill-column (+ fill-column | |
| 1203 (aref column-dimensions c) | |
| 1204 1) | |
| 1205 c (1+ c))) | |
| 1206 (setq fill-column (1- fill-column)) | |
| 1207 (aset table-colwidth i fill-column) | |
| 1208 | |
| 1209 (setq w3-last-fill-pos (point-min)) | |
| 1210 (push (cons (nth 0 node) (nth 1 node)) | |
| 1211 w3-display-open-element-stack) | |
| 1212 (w3-display-node node) | |
| 1213 (setq fill-column (aref table-colwidth i)) | |
| 1214 (if w3-display-table-cut-words-p | |
| 1215 (w3-display-table-cut)) | |
| 1216 (setq cols (cdr cols)) | |
| 1217 (goto-char (point-min)) | |
| 1218 (skip-chars-forward "\t\n\r") | |
| 1219 (beginning-of-line) | |
| 1220 (delete-region (point-min) (point)) | |
| 1221 (goto-char (point-max)) | |
| 1222 (skip-chars-backward " \t\n\r") | |
| 1223 (delete-region (point) (point-max)) | |
| 1224 (if (>= fill-column (current-column)) | |
| 1225 (insert-char ? (- fill-column (current-column)))) | |
| 1226 (aset formatted-cols i (extract-rectangle (point-min) (point-max))) | |
| 1227 (delete-region (point-min) (point-max)) | |
| 1228 (let ((j (1- colspan))) | |
| 1229 (while (> j 0) | |
| 1230 (aset table-colspans (+ i j) 0) | |
| 1231 (setq j (1- j)))) | |
| 1232 (setq i (+ i colspan)) | |
| 1233 ;; skip over columns that have leftover content | |
| 1234 (while (and (< i num-cols) | |
| 1235 (/= 0 (aref table-rowspans i))) | |
| 1236 (setq i (+ i (max 1 (aref table-colspans i))))) | |
| 1237 )) | |
| 1238 | |
| 1239 ;; finish off the columns | |
| 1240 (while (< i num-cols) | |
| 1241 (aset table-colwidth i (aref column-dimensions i)) | |
| 1242 (aset table-colspans i 1) | |
| 1243 (setq i (1+ i)) | |
| 1244 (while (and (< i num-cols) | |
| 1245 (/= 0 (aref table-rowspans i))) | |
| 1246 (setq i (+ i (max 1 (aref table-colspans i)))))) | |
| 1247 | |
| 1248 ;; on the last row empty any pending rowspans per the rfc | |
| 1249 (if content nil | |
| 1250 (fillarray table-rowspans 1)) | |
| 1251 | |
| 1252 ;; Find the tallest rectangle that isn't a rowspanning cell | |
| 1253 (setq height 0 | |
| 1254 i 0) | |
| 1255 (while (< i num-cols) | |
| 1256 (if (= 1 (aref table-rowspans i)) | |
| 1257 (setq height (max height (length (aref formatted-cols i))))) | |
| 1258 (setq i (+ i (max 1 (aref table-colspans i))))) | |
| 1259 | |
| 1260 ;; Make all rectangles the same height | |
| 1261 (setq i 0) | |
| 1262 (while (< i num-cols) | |
| 1263 (setq this-rectangle (aref formatted-cols i)) | |
| 1264 (if (> height (length this-rectangle)) | |
| 1265 (let ((colspan-fill-line | |
| 1266 (make-string (aref table-colwidth i) ? ))) | |
| 1267 (case valign | |
| 1268 ((center middle) | |
| 1269 (aset formatted-cols i | |
| 1270 (append (make-list (/ (- height (length this-rectangle)) 2) | |
| 1271 colspan-fill-line) | |
| 1272 this-rectangle))) | |
| 1273 (bottom | |
| 1274 (aset formatted-cols i | |
| 1275 (append (make-list (- height (length this-rectangle)) | |
| 1276 colspan-fill-line) | |
| 1277 this-rectangle)))))) | |
| 1278 (setq i (+ i (max 1 (aref table-colspans i))))))) | |
| 1279 | |
| 1280 | |
| 1281 ;; fix broken colspans (this should only matter on illegal tables) | |
| 1282 (setq i 0) | |
| 1283 (while (< i num-cols) | |
| 1284 (if (= (aref table-colspans i) 0) | |
| 1285 (aset table-colspans i 1)) | |
| 1286 (setq i (+ i (aref table-colspans i)))) | |
| 1287 | |
| 1288 ;; Insert a separator | |
| 1289 (insert fill-prefix) | |
| 1290 (setq i 0) | |
| 1291 (let (rflag bflag tflag lflag) | |
| 1292 (while (< i num-cols) | |
| 1293 | |
| 1294 (setq rflag (= (aref prev-rowspans i) 0)) | |
| 1295 (setq bflag (/= (aref table-colspans i) 0)) | |
| 1296 (setq tflag (/= (aref prev-colspans i) 0)) | |
| 1297 | |
| 1298 (insert (w3-table-lookup-char lflag tflag rflag bflag)) | |
| 1299 (setq lflag t) | |
| 1300 (cond ((= (aref prev-rowspans i) 0) | |
| 1301 (insert-char (w3-table-lookup-char t nil t nil) | |
| 1302 (aref column-dimensions i)) | |
| 1303 (setq i (1+ i))) | |
| 1304 ((car (aref formatted-cols i)) | |
| 1305 (insert (pop (aref formatted-cols i))) | |
| 1306 (setq lflag nil) | |
| 1307 (setq i (+ i (max (aref table-colspans i) | |
| 1308 (aref prev-colspans i) 1)))) | |
| 1309 (t | |
| 1310 (insert-char ? (aref table-colwidth i)) | |
| 1311 (setq lflag nil) | |
| 1312 (setq i (+ i (max (aref table-colspans i) | |
| 1313 (aref prev-colspans i) 1)))))) | |
| 1314 (insert (w3-table-lookup-char lflag (/= row 1) nil t) "\n")) | |
| 1315 | |
| 1316 ;; recalculate height (in case we've shortened a rowspanning cell | |
| 1317 (setq height 0 | |
| 1318 i 0) | |
| 1319 (while (< i num-cols) | |
| 1320 (if (= 1 (aref table-rowspans i)) | |
| 1321 (setq height (max height (length (aref formatted-cols i))))) | |
| 1322 (setq i (+ i (max 1 (aref table-colspans i))))) | |
| 1323 | |
| 1324 ;; Insert a row back in original buffer | |
| 1325 (while (> height 0) | |
| 1326 (insert fill-prefix (w3-table-lookup-char nil t nil t)) | |
| 1327 (setq i 0) | |
| 1328 (while (< i num-cols) | |
| 1329 (if (car (aref formatted-cols i)) | |
| 1330 (insert (pop (aref formatted-cols i))) | |
| 1331 (insert-char ? (aref table-colwidth i))) | |
| 1332 (insert (w3-table-lookup-char nil t nil t)) | |
| 1333 (setq i (+ i (max (aref table-colspans i) 1)))) | |
| 1334 (insert "\n") | |
| 1335 ;;(and w3-do-incremental-display (w3-pause)) | |
| 1336 (setq height (1- height))) | |
| 1337 | |
| 1338 (setq i 0) | |
| 1339 (while (< i num-cols) | |
| 1340 (if (> (aref table-rowspans i) 0) | |
| 1341 (decf (aref table-rowspans i))) | |
| 1342 (incf i)) | |
| 1343 | |
| 1344 (setq prev-rowspans (copy-seq table-rowspans)) | |
| 1345 (setq prev-colspans (copy-seq table-colspans)) | |
| 1346 | |
| 1347 (and w3-do-incremental-display (w3-pause)) | |
| 1348 | |
| 1349 ) | |
| 1350 (caption | |
| 1351 (let ((left (length fill-prefix)) | |
| 1352 (fill-prefix "") | |
| 1353 (fill-column table-width) | |
| 1354 (start (point))) | |
| 1355 (w3-display-node (pop content)) | |
| 1356 (indent-rigidly start (point) left))) | |
| 1357 (otherwise | |
| 1358 (delete-horizontal-space) | |
| 1359 (setq content (nth 2 (car content)))) | |
| 1360 )) | |
| 1361 (if (= (length column-dimensions) 0) nil | |
| 1362 (insert fill-prefix) | |
| 1363 (setq i 0) | |
| 1364 (let (tflag lflag) | |
| 1365 (while (< i num-cols) | |
| 1366 (setq tflag (/= (aref prev-colspans i) 0)) | |
| 1367 (insert (w3-table-lookup-char lflag tflag t nil)) | |
| 1368 (setq lflag t) | |
| 1369 (insert-char (w3-table-lookup-char t nil t nil) | |
| 1370 (aref column-dimensions i)) | |
| 1371 (setq i (1+ i))) | |
| 1372 (insert (w3-table-lookup-char t t nil nil) "\n"))) | |
| 1373 ) | |
| 1374 (pop w3-display-open-element-stack))))) | |
| 1375 | |
| 1376 | |
| 1377 | |
| 1378 (defun w3-display-create-unique-id () | |
| 1379 (let* ((date (current-time-string)) | |
| 1380 (dateinfo (and date (timezone-parse-date date))) | |
| 1381 (timeinfo (and date (timezone-parse-time (aref dateinfo 3))))) | |
| 1382 (if (and dateinfo timeinfo) | |
| 1383 (concat (aref dateinfo 0) ; Year | |
| 1384 (aref dateinfo 1) ; Month | |
| 1385 (aref dateinfo 2) ; Day | |
| 1386 (aref timeinfo 0) ; Hour | |
| 1387 (aref timeinfo 1) ; Minute | |
| 1388 (aref timeinfo 2) ; Second | |
| 1389 ) | |
| 1390 "HoplesSLYCoNfUSED"))) | |
| 1391 | |
| 1392 (defun w3-display-node (node &optional nofaces) | |
| 1393 (let ( | |
| 1394 (content-stack (list (list node))) | |
| 1395 (right-margin-stack (list fill-column)) | |
| 1396 (left-margin-stack (list 0)) | |
| 1397 node | |
| 1398 insert-before | |
| 1399 insert-after | |
| 1400 tag | |
| 1401 args | |
| 1402 content | |
| 1403 hyperlink-info | |
| 1404 break-style | |
| 1405 cur | |
| 1406 id | |
| 1407 class | |
| 1408 ) | |
| 1409 (while content-stack | |
| 1410 (setq content (pop content-stack)) | |
| 1411 (pop w3-active-faces) | |
| 1412 (pop w3-active-voices) | |
| 1413 (case (car (pop w3-display-open-element-stack)) | |
| 1414 ;; Any weird, post-display-of-content stuff for specific tags | |
| 1415 ;; goes here. Couldn't think of any better way to do this when we | |
| 1416 ;; are iterative. *sigh* | |
| 1417 (a | |
| 1418 (if (not hyperlink-info) | |
| 1419 nil | |
| 1420 (add-text-properties (car hyperlink-info) (point) | |
| 1421 (list | |
| 1422 'mouse-face 'highlight | |
| 1423 'duplicable t | |
| 1424 'help-echo 'w3-balloon-help-callback | |
| 1425 'balloon-help 'w3-balloon-help-callback)) | |
| 1426 (fillin-text-property (car hyperlink-info) (point) | |
| 1427 'button 'button (cadr hyperlink-info)) | |
| 1428 (widget-put (cadr hyperlink-info) :to (set-marker | |
| 1429 (make-marker) (point)))) | |
| 1430 (setq hyperlink-info nil)) | |
| 1431 (form | |
| 1432 (pop w3-display-form-stack)) | |
| 1433 ((ol ul dl dir menu) | |
| 1434 (pop w3-display-list-stack)) | |
| 1435 (otherwise | |
| 1436 nil)) | |
| 1437 (if (car insert-after) | |
| 1438 (w3-handle-string-content (car insert-after))) | |
| 1439 (pop insert-after) | |
| 1440 (w3-display-handle-end-break) | |
| 1441 (w3-pop-all-face-info) | |
| 1442 ;; Handle the element's content | |
| 1443 (while content | |
| 1444 (if (stringp (car content)) | |
| 1445 (w3-handle-string-content (pop content)) | |
| 1446 (setq node (pop content) | |
| 1447 tag (nth 0 node) | |
| 1448 args (nth 1 node) | |
| 1449 id (or (w3-get-attribute 'name) | |
| 1450 (w3-get-attribute 'id)) | |
| 1451 ) | |
| 1452 ;; This little bit of magic takes care of inline styles. | |
| 1453 ;; Evil Evil Evil, but it appears to work. | |
| 1454 (if (w3-get-attribute 'style) | |
| 1455 (let ((unique-id (or (w3-get-attribute 'id) | |
| 1456 (w3-display-create-unique-id))) | |
| 1457 (sheet "")) | |
| 1458 (setq sheet (format "%s.%s { %s }\n" tag unique-id | |
| 1459 (w3-get-attribute 'style))) | |
| 1460 (setf (nth 1 node) (cons (cons 'id unique-id) args)) | |
| 1461 (w3-handle-style (list (cons 'data sheet) | |
| 1462 (cons 'notation "css"))))) | |
| 1463 (setq w3-display-css-properties (css-get | |
| 1464 (nth 0 node) (nth 1 node) | |
| 1465 w3-current-stylesheet | |
| 1466 w3-display-open-element-stack)) | |
| 1467 (if nofaces | |
| 1468 nil | |
| 1469 (push (w3-face-for-element node) w3-active-faces) | |
| 1470 (push (w3-voice-for-element node) w3-active-voices)) | |
| 1471 (push (w3-get-style-info 'display node) break-style) | |
| 1472 (push (w3-get-style-info 'insert-after node) insert-after) | |
| 1473 (setq insert-before (w3-get-style-info 'insert-before node)) | |
| 1474 (w3-display-handle-break) | |
| 1475 (if (w3-node-visible-p) | |
| 1476 nil | |
| 1477 (setq insert-before nil | |
| 1478 tag '*invisible) | |
| 1479 (setcar insert-after nil)) | |
| 1480 (if insert-before | |
| 1481 (w3-handle-string-content insert-before)) | |
| 1482 (setq insert-before nil) | |
| 1483 (if id | |
| 1484 (setq w3-id-positions (cons | |
| 1485 (cons (intern id) | |
| 1486 (set-marker (make-marker) | |
| 1487 (point-max))) | |
| 1488 w3-id-positions))) | |
| 1489 (case tag | |
| 1490 (a ; Hyperlinks | |
| 1491 (let* ( | |
| 1492 (title (w3-get-attribute 'title)) | |
| 1493 (name (or (w3-get-attribute 'id) | |
| 1494 (w3-get-attribute 'name))) | |
| 1495 (btdt nil) | |
| 1496 class | |
| 1497 (before nil) | |
| 1498 (after nil) | |
| 1499 (face nil) | |
| 1500 (voice nil) | |
| 1501 (st nil)) | |
| 1502 (setq st (point) | |
| 1503 hyperlink-info (list | |
| 1504 st | |
| 1505 (append | |
| 1506 (list 'link :args nil | |
| 1507 :value "" :tag "" | |
| 1508 :action 'w3-follow-hyperlink | |
| 1509 :from | |
| 1510 (set-marker (make-marker) st) | |
| 1511 :help-echo 'w3-widget-echo | |
| 1512 ) | |
| 1513 (alist-to-plist args)))) | |
| 1514 (w3-handle-content node) | |
| 1515 ) | |
| 1516 ) | |
| 1517 ((ol ul dl dir menu) | |
| 1518 (push 0 w3-display-list-stack) | |
| 1519 (w3-handle-content node)) | |
| 1520 (img ; inlined image | |
| 1521 (w3-handle-image) | |
| 1522 (w3-handle-empty-tag)) | |
| 1523 (script ; Scripts | |
| 1524 (w3-handle-empty-tag)) | |
| 1525 ((embed object) ; Embedded images/content | |
| 1526 (w3-handle-content node) | |
| 1527 ) | |
| 1528 (hr ; Cause line break & insert rule | |
| 1529 (let* ((perc (or (w3-get-attribute 'width) | |
| 1530 (w3-get-style-info 'width node) | |
| 1531 "100%")) | |
| 1532 (rule nil) | |
| 1533 (width nil)) | |
| 1534 (setq perc (/ (min (string-to-int perc) 100) 100.0) | |
| 1535 width (* fill-column perc) | |
| 1536 rule (make-string (max (truncate width) 0) | |
| 1537 w3-horizontal-rule-char) | |
| 1538 node (list 'hr nil (list rule))) | |
| 1539 (w3-handle-content node))) | |
| 1540 (map ; Client side imagemaps | |
| 1541 (let ((name (or (w3-get-attribute 'name) | |
| 1542 (w3-get-attribute 'id) | |
| 1543 "unnamed")) | |
| 1544 (areas | |
| 1545 (mapcar | |
| 1546 (function | |
| 1547 (lambda (node) | |
| 1548 (let* ((args (nth 1 node)) | |
| 1549 (type (downcase (or | |
| 1550 (w3-get-attribute 'shape) | |
| 1551 "rect"))) | |
| 1552 (coords (w3-decode-area-coords | |
| 1553 (or (cdr-safe | |
| 1554 (assq 'coords args)) ""))) | |
| 1555 (alt (w3-get-attribute 'alt)) | |
| 1556 (href (if (assq 'nohref args) | |
| 1557 t | |
| 1558 (or (w3-get-attribute 'src) | |
| 1559 (w3-get-attribute 'href)))) | |
| 1560 ) | |
| 1561 (vector type coords href alt)) | |
| 1562 ) | |
| 1563 ) | |
| 1564 (nth 2 node)))) | |
| 1565 (setq w3-imagemaps (cons (cons name areas) w3-imagemaps))) | |
| 1566 (w3-handle-empty-tag) | |
| 1567 ) | |
| 1568 (table ; Yeeee-hah! | |
| 1569 (w3-display-table node) | |
| 1570 (setq w3-last-fill-pos (point)) | |
| 1571 (w3-handle-empty-tag) | |
| 1572 ) | |
| 1573 (isindex | |
| 1574 (let ((prompt (or (w3-get-attribute 'prompt) | |
| 1575 "Search on (+ separates keywords): ")) | |
| 1576 action node) | |
| 1577 (setq action (or (w3-get-attribute 'src) | |
| 1578 (w3-get-attribute 'href) | |
| 1579 (url-view-url t))) | |
| 1580 (if (and prompt (string-match "[^: \t-]+$" prompt)) | |
| 1581 (setq prompt (concat prompt ": "))) | |
| 1582 (setq node | |
| 1583 (list 'isindex nil | |
| 1584 (list | |
| 1585 (list 'hr nil nil) | |
| 1586 (list 'form | |
| 1587 (list (cons 'action action) | |
| 1588 (cons 'enctype | |
| 1589 "application/x-w3-isindex") | |
| 1590 (cons 'method "get")) | |
| 1591 (list | |
| 1592 prompt | |
| 1593 (list 'input | |
| 1594 (list (cons 'type "text") | |
| 1595 (cons 'name "isindex")))))))) | |
| 1596 (w3-handle-content node) | |
| 1597 (setq w3-current-isindex (cons action prompt))) | |
| 1598 ) | |
| 1599 (*document | |
| 1600 (let ((info (mapcar (lambda (x) (cons x (symbol-value x))) | |
| 1601 w3-persistent-variables))) | |
| 1602 (set-buffer (generate-new-buffer "Untitled")) | |
| 1603 (setq w3-current-form-number 0 | |
| 1604 w3-display-open-element-stack nil | |
| 1605 w3-last-fill-pos (point-min) | |
| 1606 fill-column (min (- (or w3-strict-width (window-width)) | |
| 1607 w3-right-margin) | |
| 1608 (or w3-maximum-line-length | |
| 1609 (window-width)))) | |
| 1610 (switch-to-buffer (current-buffer)) | |
| 1611 (buffer-disable-undo (current-buffer)) | |
| 1612 (mapcar (function (lambda (x) (set (car x) (cdr x)))) info) | |
| 1613 ;; ACK! We don't like filladapt mode! | |
| 1614 (set (make-local-variable 'filladapt-mode) nil) | |
| 1615 (set (make-local-variable 'adaptive-fill-mode) nil) | |
| 1616 (setq w3-current-stylesheet (css-copy-stylesheet | |
| 1617 w3-user-stylesheet) | |
| 1618 w3-last-fill-pos (point) | |
| 1619 fill-column (min (- (or w3-strict-width (window-width)) | |
| 1620 w3-right-margin) | |
| 1621 (or w3-maximum-line-length | |
| 1622 (window-width))) | |
| 1623 fill-prefix "") | |
| 1624 (set (make-local-variable 'inhibit-read-only) t)) | |
| 1625 (w3-handle-content node) | |
| 1626 ) | |
| 1627 (*invisible | |
| 1628 (w3-handle-empty-tag)) | |
| 1629 (meta | |
| 1630 (let* ((equiv (cdr-safe (assq 'http-equiv args))) | |
| 1631 (value (w3-get-attribute 'content)) | |
| 1632 (name (w3-get-attribute 'name)) | |
| 1633 (node (and equiv (assoc (setq equiv (downcase equiv)) | |
| 1634 url-current-mime-headers)))) | |
| 1635 (if equiv | |
| 1636 (setq url-current-mime-headers (cons | |
| 1637 (cons equiv value) | |
| 1638 url-current-mime-headers))) | |
| 1639 (if name | |
| 1640 (setq w3-current-metainfo (cons | |
| 1641 (cons name value) | |
| 1642 w3-current-metainfo))) | |
| 1643 | |
| 1644 ;; Special-case the Set-Cookie header | |
| 1645 (if (and equiv (string= (downcase equiv) "set-cookie")) | |
| 1646 (url-cookie-handle-set-cookie value)) | |
| 1647 ;; Special-case the refresh header | |
| 1648 (if (and equiv (string= (downcase equiv) "refresh")) | |
| 1649 (url-handle-refresh-header value))) | |
| 1650 (w3-handle-empty-tag) | |
| 1651 ) | |
| 1652 (link | |
| 1653 ;; This doesn't handle blank-separated values per the RFC. | |
| 1654 (w3-parse-link args) | |
| 1655 (w3-handle-empty-tag)) | |
| 1656 (title | |
| 1657 (let ((potential-title "") | |
| 1658 (content (nth 2 node))) | |
| 1659 (while content | |
| 1660 (setq potential-title (concat potential-title (car content)) | |
| 1661 content (cdr content))) | |
| 1662 (setq potential-title (w3-normalize-spaces potential-title)) | |
| 1663 (if (string-match "^[ \t]*$" potential-title) | |
| 1664 nil | |
| 1665 (rename-buffer (generate-new-buffer-name | |
| 1666 (w3-fix-spaces potential-title))))) | |
| 1667 (w3-handle-empty-tag)) | |
| 1668 (form | |
| 1669 (setq w3-current-form-number (1+ w3-current-form-number)) | |
| 1670 (let* ( | |
| 1671 (action (w3-get-attribute 'action)) | |
| 1672 (url nil)) | |
| 1673 (if (not action) | |
| 1674 (setq args (cons (cons 'action (url-view-url t)) args))) | |
| 1675 (push (cons | |
| 1676 (cons 'form-number | |
| 1677 w3-current-form-number) | |
| 1678 args) w3-display-form-stack) | |
| 1679 (w3-handle-content node))) | |
| 1680 (input | |
| 1681 (if (not (assq 'form w3-display-open-element-stack)) | |
| 1682 (message "Input field outside of a <form>") | |
| 1683 (let* ( | |
| 1684 (type (intern (downcase (or (w3-get-attribute 'type) | |
| 1685 "text")))) | |
| 1686 (name (w3-get-attribute 'name)) | |
| 1687 (value (or (w3-get-attribute 'value) "")) | |
| 1688 (size (if (w3-get-attribute 'size) | |
| 1689 (string-to-int (w3-get-attribute 'size)))) | |
| 1690 (maxlength (cdr (assoc 'maxlength args))) | |
| 1691 (default value) | |
| 1692 (action (car w3-display-form-stack)) | |
| 1693 (options) | |
| 1694 (id (w3-get-attribute 'id)) | |
| 1695 (checked (assq 'checked args))) | |
| 1696 (if (and (string-match "^[ \t\n\r]+$" value) | |
| 1697 (not (eq type 'hidden))) | |
| 1698 (setq value "")) | |
| 1699 (if maxlength (setq maxlength (string-to-int maxlength))) | |
| 1700 (if (and name (string-match "[\r\n]" name)) | |
| 1701 (setq name (mapconcat (function | |
| 1702 (lambda (x) | |
| 1703 (if (memq x '(?\r ?\n)) | |
| 1704 "" | |
| 1705 (char-to-string x)))) | |
| 1706 name ""))) | |
| 1707 (if (memq type '(checkbox radio)) (setq default checked)) | |
| 1708 (if (and (eq type 'checkbox) (string= value "")) | |
| 1709 (setq value "on")) | |
| 1710 (w3-form-add-element type name | |
| 1711 value size maxlength default action | |
| 1712 options w3-current-form-number id checked | |
| 1713 (car w3-active-faces)) | |
| 1714 ) | |
| 1715 ) | |
| 1716 (w3-handle-empty-tag) | |
| 1717 ) | |
| 1718 (select | |
| 1719 (if (not (assq 'form w3-display-open-element-stack)) | |
| 1720 (message "Input field outside of a <form>") | |
| 1721 (let* ( | |
| 1722 (name (w3-get-attribute 'name)) | |
| 1723 (size (string-to-int (or (w3-get-attribute 'size) | |
| 1724 "20"))) | |
| 1725 (maxlength (cdr (assq 'maxlength args))) | |
| 1726 (value nil) | |
| 1727 (tmp nil) | |
| 1728 (action (car w3-display-form-stack)) | |
| 1729 (options) | |
| 1730 (id (w3-get-attribute 'id)) | |
| 1731 (checked (assq 'checked args))) | |
| 1732 (if maxlength (setq maxlength (string-to-int maxlength))) | |
| 1733 (if (and name (string-match "[\r\n]" name)) | |
| 1734 (setq name (mapconcat (function | |
| 1735 (lambda (x) | |
| 1736 (if (memq x '(?\r ?\n)) | |
| 1737 "" | |
| 1738 (char-to-string x)))) | |
| 1739 name ""))) | |
| 1740 (setq options | |
| 1741 (mapcar | |
| 1742 (function | |
| 1743 (lambda (n) | |
| 1744 (setq tmp (w3-normalize-spaces | |
| 1745 (apply 'concat (nth 2 n))) | |
| 1746 tmp (cons tmp | |
| 1747 (or | |
| 1748 (cdr-safe (assq 'value (nth 1 n))) | |
| 1749 tmp))) | |
| 1750 (if (assq 'selected (nth 1 n)) | |
| 1751 (setq value (car tmp))) | |
| 1752 tmp)) | |
| 1753 (nth 2 node))) | |
| 1754 (if (not value) | |
| 1755 (setq value (caar options))) | |
| 1756 (w3-form-add-element 'option name | |
| 1757 value size maxlength value action | |
| 1758 options w3-current-form-number id nil | |
| 1759 (car w3-active-faces)) | |
| 1760 ;; This should really not be necessary, but some versions | |
| 1761 ;; of the widget library leave point _BEFORE_ the menu | |
| 1762 ;; widget instead of after. | |
| 1763 (goto-char (point-max)) | |
| 1764 ) | |
| 1765 ) | |
| 1766 (w3-handle-empty-tag) | |
| 1767 ) | |
| 1768 (textarea | |
| 1769 (if (not (assq 'form w3-display-open-element-stack)) | |
| 1770 (message "Input field outside of a <form>") | |
| 1771 (let* ( | |
| 1772 (name (w3-get-attribute 'name)) | |
| 1773 (size (string-to-int (or (w3-get-attribute 'size) | |
| 1774 "20"))) | |
| 1775 (maxlength (cdr (assq 'maxlength args))) | |
| 1776 (value (w3-normalize-spaces | |
| 1777 (apply 'concat (nth 2 node)))) | |
| 1778 (default value) | |
| 1779 (tmp nil) | |
| 1780 (action (car w3-display-form-stack)) | |
| 1781 (options) | |
| 1782 (id (w3-get-attribute 'id)) | |
| 1783 (checked (assq 'checked args))) | |
| 1784 (if maxlength (setq maxlength (string-to-int maxlength))) | |
| 1785 (if (and name (string-match "[\r\n]" name)) | |
| 1786 (setq name (mapconcat (function | |
| 1787 (lambda (x) | |
| 1788 (if (memq x '(?\r ?\n)) | |
| 1789 "" | |
| 1790 (char-to-string x)))) | |
| 1791 name ""))) | |
| 1792 (w3-form-add-element 'multiline name | |
| 1793 value size maxlength value action | |
| 1794 options w3-current-form-number id nil | |
| 1795 (car w3-active-faces)) | |
| 1796 ) | |
| 1797 ) | |
| 1798 (w3-handle-empty-tag) | |
| 1799 ) | |
| 1800 (style | |
| 1801 (w3-handle-style (cons (cons 'data (apply 'concat (nth 2 node))) | |
| 1802 (nth 1 node))) | |
| 1803 (w3-handle-empty-tag)) | |
| 1804 (otherwise | |
| 1805 ;; Generic formatting | |
| 1806 (w3-handle-content node)) | |
| 1807 ) ; case tag | |
| 1808 ) ; stringp content | |
| 1809 ) ; while content | |
| 1810 ) ; while content-stack | |
| 1811 ) | |
| 1812 ) | |
| 1813 | |
| 1814 (defun w3-draw-tree (tree) | |
| 1815 ;; The main entry point - wow complicated | |
| 1816 (setq w3-current-stylesheet w3-user-stylesheet) | |
| 1817 (while tree | |
| 1818 (w3-display-node (car tree)) | |
| 1819 (setq tree (cdr tree))) | |
| 1820 (w3-display-fix-widgets) | |
| 1821 (w3-form-resurrect-widgets)) | |
| 1822 | |
| 1823 (defun time-display (&optional tree) | |
| 1824 ;; Return the # of seconds it took to draw 'tree' | |
| 1825 (let ((st (nth 1 (current-time))) | |
| 1826 (nd nil)) | |
| 1827 (w3-draw-tree (or tree w3-last-parse-tree)) | |
| 1828 (setq nd (nth 1 (current-time))) | |
| 1829 (- nd st))) | |
| 1830 | |
| 1831 | |
| 1832 (defun w3-prepare-buffer (&rest args) | |
| 1833 ;; The text/html viewer - does all the drawing and displaying of the buffer | |
| 1834 ;; that is necessary to go from raw HTML to a good presentation. | |
| 1835 (let* ((source (buffer-string)) | |
| 1836 (source-buf (current-buffer)) | |
| 1837 (parse (w3-parse-buffer source-buf))) | |
| 1838 (set-buffer-modified-p nil) | |
| 1839 (w3-draw-tree parse) | |
| 1840 (kill-buffer source-buf) | |
| 1841 (set-buffer-modified-p nil) | |
| 1842 (setq w3-current-source source | |
| 1843 w3-current-parse parse) | |
| 1844 (if (and (boundp 'w3-image-widgets-waiting) w3-image-widgets-waiting) | |
| 1845 (let (url glyph widget) | |
| 1846 (while w3-image-widgets-waiting | |
| 1847 (setq widget (car w3-image-widgets-waiting) | |
| 1848 w3-image-widgets-waiting (cdr w3-image-widgets-waiting) | |
| 1849 url (widget-get widget 'src) | |
| 1850 glyph (cdr-safe (assoc url w3-graphics-list))) | |
| 1851 (widget-value-set widget glyph)))) | |
| 1852 (w3-mode) | |
| 1853 ;;(w3-handle-annotations) | |
| 1854 ;;(w3-handle-headers) | |
| 1855 (set-buffer-modified-p nil) | |
| 1856 (goto-char (point-min)) | |
| 1857 (if url-keep-history | |
| 1858 (let ((url (url-view-url t))) | |
| 1859 (if (not url-history-list) | |
| 1860 (setq url-history-list (make-hash-table :size 131 :test 'equal))) | |
| 1861 (cl-puthash url (buffer-name) url-history-list) | |
| 1862 (if (fboundp 'w3-shuffle-history-menu) | |
| 1863 (w3-shuffle-history-menu))))) | |
| 1864 ) | |
| 1865 | |
| 1866 (provide 'w3-display) |