Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-display.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents 821dec489c24
children 4be1180a9e89
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
1 ;;; w3-display.el --- display engine v99999 1 ;;; w3-display.el --- display engine v99999
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/01/31 04:26:17 3 ;; Created: 1997/02/14 17:51:17
4 ;; Version: 1.115 4 ;; Version: 1.127
5 ;; Keywords: faces, help, hypermedia 5 ;; Keywords: faces, help, hypermedia
6 6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1996 by William M. Perry (wmperry@cs.indiana.edu) 8 ;;; Copyright (c) 1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc. 9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
30 (require 'css) 30 (require 'css)
31 (require 'font) 31 (require 'font)
32 (require 'w3-widget) 32 (require 'w3-widget)
33 (require 'w3-imap) 33 (require 'w3-imap)
34 34
35 (define-widget-keywords :emacspeak-help)
35 (autoload 'sentence-ify "flame") 36 (autoload 'sentence-ify "flame")
36 (autoload 'string-ify "flame") 37 (autoload 'string-ify "flame")
37 (autoload '*flame "flame") 38 (autoload '*flame "flame")
38 (if (not (fboundp 'flatten)) (autoload 'flatten "flame")) 39 (if (not (fboundp 'flatten)) (autoload 'flatten "flame"))
39 (defvar w3-cookie-cache nil) 40 (defvar w3-cookie-cache nil)
363 (progn 364 (progn
364 (skip-chars-forward " \t\r\n") 365 (skip-chars-forward " \t\r\n")
365 (point))))) 366 (point)))))
366 (goto-char (point-max)) 367 (goto-char (point-max))
367 (add-text-properties w3-scratch-start-point 368 (add-text-properties w3-scratch-start-point
368 (point) (list 'face w3-active-faces 'duplicable t)) 369 (point) (list 'face w3-active-faces
370 'start-open t
371 'end-open t
372 'rear-nonsticky t
373 'duplicable t))
369 (if (car w3-active-voices) 374 (if (car w3-active-voices)
370 (add-text-properties w3-scratch-start-point (point) 375 (add-text-properties w3-scratch-start-point (point)
371 (list 'personality (car w3-active-voices)))) 376 (list 'personality (car w3-active-voices))))
372 ) 377 )
373 378
616 621
617 ;; Image handling 622 ;; Image handling
618 (defun w3-maybe-start-image-download (widget) 623 (defun w3-maybe-start-image-download (widget)
619 (let* ((src (widget-get widget 'src)) 624 (let* ((src (widget-get widget 'src))
620 (cached-glyph (w3-image-cached-p src))) 625 (cached-glyph (w3-image-cached-p src)))
621 (if (and cached-glyph (widget-glyphp cached-glyph)) 626 (cond
622 (setq w3-image-widgets-waiting (cons widget w3-image-widgets-waiting)) 627 ((and cached-glyph
623 (cond 628 (widget-glyphp cached-glyph)
624 ((or w3-delay-image-loads ; Delaying images 629 (not (eq 'nothing
625 (not (fboundp 'valid-specifier-domain-p)) ; Can't do images 630 (image-instance-type
626 (eq (device-type) 'tty)) ; Why bother? 631 (glyph-image-instance cached-glyph)))))
627 (w3-add-delayed-graphic widget)) 632 (setq w3-image-widgets-waiting (cons widget w3-image-widgets-waiting)))
628 ((not (w3-image-loadable-p src nil)) ; Hey, we can't load it! 633 ((or w3-delay-image-loads ; Delaying images
629 (w3-warn 'images (format "Skipping image %s" (url-basepath src t))) 634 (not (fboundp 'valid-specifier-domain-p)) ; Can't do images
630 (w3-add-delayed-graphic widget)) 635 (eq (device-type) 'tty)) ; Why bother?
631 (t ; Grab the images 636 (w3-add-delayed-graphic widget))
632 (let ( 637 ((not (w3-image-loadable-p src nil)) ; Hey, we can't load it!
633 (url-request-method "GET") 638 (message "Skipping image %s" (url-basepath src t))
634 (old-asynch url-be-asynchronous) 639 (w3-add-delayed-graphic widget))
635 (url-request-data nil) 640 (t ; Grab the images
636 (url-request-extra-headers nil) 641 (let (
637 (url-source t) 642 (url-request-method "GET")
638 (url-mime-accept-string (substring 643 (old-asynch url-be-asynchronous)
639 (mapconcat 644 (url-request-data nil)
640 (function 645 (url-request-extra-headers nil)
641 (lambda (x) 646 (url-source t)
642 (if x 647 (url-mime-accept-string (substring
643 (concat (car x) ",") 648 (mapconcat
644 ""))) 649 (function
645 w3-allowed-image-types "") 650 (lambda (x)
646 0 -1)) 651 (if x
647 (url-working-buffer (generate-new-buffer-name " *W3GRAPH*"))) 652 (concat (car x) ",")
648 (setq-default url-be-asynchronous t) 653 "")))
649 (setq w3-graphics-list (cons (cons src (make-glyph)) 654 w3-allowed-image-types "")
650 w3-graphics-list)) 655 0 -1))
651 (save-excursion 656 (url-working-buffer (generate-new-buffer-name " *W3GRAPH*")))
652 (set-buffer (get-buffer-create url-working-buffer)) 657 (setq-default url-be-asynchronous t)
653 (setq url-current-callback-data (list widget) 658 (setq w3-graphics-list (cons (cons src (make-glyph))
654 url-be-asynchronous t 659 w3-graphics-list))
655 url-current-callback-func 'w3-finalize-image-download) 660 (save-excursion
656 (url-retrieve src)) 661 (set-buffer (get-buffer-create url-working-buffer))
657 (setq-default url-be-asynchronous old-asynch))))))) 662 (setq url-current-callback-data (list widget)
663 url-be-asynchronous t
664 url-current-callback-func 'w3-finalize-image-download)
665 (url-retrieve src))
666 (setq-default url-be-asynchronous old-asynch))))))
658 667
659 (defun w3-finalize-image-download (widget) 668 (defun w3-finalize-image-download (widget)
660 (let ((glyph nil) 669 (let ((glyph nil)
661 (url (widget-get widget 'src)) 670 (url (widget-get widget 'src))
662 (node nil) 671 (node nil)
668 (message "Enhancing image... done") 677 (message "Enhancing image... done")
669 (kill-buffer (current-buffer)) 678 (kill-buffer (current-buffer))
670 (cond 679 (cond
671 ((w3-image-invalid-glyph-p glyph) 680 ((w3-image-invalid-glyph-p glyph)
672 (setq glyph nil) 681 (setq glyph nil)
673 (w3-warn 'image (format "Reading of %s failed." url))) 682 (message "Reading of %s failed." url))
674 ((eq (aref glyph 0) 'xbm) 683 ((eq (aref glyph 0) 'xbm)
675 (let ((temp-fname (url-generate-unique-filename "%s.xbm"))) 684 (let ((temp-fname (url-generate-unique-filename "%s.xbm")))
676 (save-excursion 685 (save-excursion
677 (set-buffer (generate-new-buffer " *xbm-garbage*")) 686 (set-buffer (generate-new-buffer " *xbm-garbage*"))
678 (erase-buffer) 687 (erase-buffer)
792 (error nil)) 801 (error nil))
793 (setq st nd) 802 (setq st nd)
794 (setq st (min (point-max) (1+ nd)))))))) 803 (setq st (min (point-max) (1+ nd))))))))
795 804
796 (defun w3-size-of-tree (tree minmax) 805 (defun w3-size-of-tree (tree minmax)
806 (declare (special args))
797 (save-excursion 807 (save-excursion
798 (save-restriction 808 (save-restriction
799 (narrow-to-region (point) (point)) 809 (narrow-to-region (point) (point))
800 ;; XXX fill-column set to 1 fails when fill-prefix is set 810 ;; XXX fill-column set to 1 fails when fill-prefix is set
801 ;; XXX setting fill-column at all isn't really right 811 ;; XXX setting fill-column at all isn't really right
837 (delete-region (point-min) (point-max)) 847 (delete-region (point-min) (point-max))
838 retval)))) 848 retval))))
839 849
840 (defun w3-display-table-dimensions (node) 850 (defun w3-display-table-dimensions (node)
841 ;; fill-column sets maximum width 851 ;; fill-column sets maximum width
852 (declare (special args))
842 (let (min-vector 853 (let (min-vector
843 max-vector 854 max-vector
844 rows cols 855 rows cols
845 ;;(w3-form-elements (and (boundp 'w3-form-elements) w3-form-elements)) 856 ;;(w3-form-elements (and (boundp 'w3-form-elements) w3-form-elements))
846 (table-info (assq 'w3-table-info (cadr node)))) 857 (table-info (assq 'w3-table-info (cadr node))))
1203 ;;(if align (push (intern (downcase align)) w3-display-alignment-stack)) 1214 ;;(if align (push (intern (downcase align)) w3-display-alignment-stack))
1204 (save-excursion 1215 (save-excursion
1205 (save-restriction 1216 (save-restriction
1206 (narrow-to-region (point) (point)) 1217 (narrow-to-region (point) (point))
1207 (setq fill-column avgwidth 1218 (setq fill-column avgwidth
1208 inhibit-read-only t 1219 ;; inhibit-read-only t
1209 w3-last-fill-pos (point-min) 1220 w3-last-fill-pos (point-min)
1210 i 0) 1221 i 0)
1211 ;; skip over columns that have leftover content 1222 ;; skip over columns that have leftover content
1212 (while (and (< i num-cols) 1223 (while (and (< i num-cols)
1213 (/= 0 (aref table-rowspans i))) 1224 (/= 0 (aref table-rowspans i)))
1297 (setq i 0) 1308 (setq i 0)
1298 (while (< i num-cols) 1309 (while (< i num-cols)
1299 (setq this-rectangle (aref formatted-cols i)) 1310 (setq this-rectangle (aref formatted-cols i))
1300 (if (> height (length this-rectangle)) 1311 (if (> height (length this-rectangle))
1301 (let ((colspan-fill-line 1312 (let ((colspan-fill-line
1302 (make-string (aref table-colwidth i) ? ))) 1313 (make-string (abs (aref table-colwidth i)) ? )))
1303 (case valign 1314 (case valign
1304 ((center middle) 1315 ((center middle)
1305 (aset formatted-cols i 1316 (aset formatted-cols i
1306 (append (make-list (/ (- height (length this-rectangle)) 2) 1317 (append (make-list (/ (- height (length this-rectangle)) 2)
1307 colspan-fill-line) 1318 colspan-fill-line)
1479 (defun w3-display-node (node &optional nofaces) 1490 (defun w3-display-node (node &optional nofaces)
1480 (let ( 1491 (let (
1481 (content-stack (list (list node))) 1492 (content-stack (list (list node)))
1482 (right-margin-stack (list fill-column)) 1493 (right-margin-stack (list fill-column))
1483 (left-margin-stack (list 0)) 1494 (left-margin-stack (list 0))
1495 ;; (inhibit-read-only t)
1484 node 1496 node
1485 insert-before 1497 insert-before
1486 insert-after 1498 insert-after
1487 tag 1499 tag
1488 args 1500 args
1598 st 1610 st
1599 (append 1611 (append
1600 (list 'link :args nil 1612 (list 'link :args nil
1601 :value "" :tag "" 1613 :value "" :tag ""
1602 :action 'w3-follow-hyperlink 1614 :action 'w3-follow-hyperlink
1603 :from 1615 :from (set-marker (make-marker) st)
1604 (set-marker (make-marker) st)
1605 :help-echo 'w3-widget-echo 1616 :help-echo 'w3-widget-echo
1617 :emacspeak-help 'w3-widget-echo
1606 ) 1618 )
1607 (alist-to-plist args)))) 1619 (alist-to-plist args))))
1608 (w3-handle-content node) 1620 (w3-handle-content node)
1609 ) 1621 )
1610 ) 1622 )
1749 fill-column (min (- (or w3-strict-width (window-width)) 1761 fill-column (min (- (or w3-strict-width (window-width))
1750 w3-right-margin) 1762 w3-right-margin)
1751 (or w3-maximum-line-length 1763 (or w3-maximum-line-length
1752 (window-width))) 1764 (window-width)))
1753 fill-prefix "") 1765 fill-prefix "")
1754 (set (make-local-variable 'inhibit-read-only) t)) 1766 ;; (set (make-local-variable 'inhibit-read-only) t)
1767 )
1755 (w3-handle-content node) 1768 (w3-handle-content node)
1756 ) 1769 )
1757 (*invisible 1770 (*invisible
1758 (w3-handle-empty-tag)) 1771 (w3-handle-empty-tag))
1759 (meta 1772 (meta
1806 (setq w3-display-form-id (cons 1819 (setq w3-display-form-id (cons
1807 (cons 'form-number 1820 (cons 'form-number
1808 w3-current-form-number) 1821 w3-current-form-number)
1809 args)) 1822 args))
1810 (w3-handle-content node))) 1823 (w3-handle-content node)))
1811 (keygen 1824 ; (keygen
1812 (w3-form-add-element 'keygen 1825 ; (w3-form-add-element 'keygen
1813 (or (w3-get-attribute 'name) 1826 ; (or (w3-get-attribute 'name)
1814 (w3-get-attribute 'id) 1827 ; (w3-get-attribute 'id)
1815 "keygen") 1828 ; "keygen")
1816 nil ; value 1829 ; nil ; value
1817 nil ; size 1830 ; nil ; size
1818 nil ; maxlength 1831 ; nil ; maxlength
1819 nil ; default 1832 ; nil ; default
1820 w3-display-form-id ; action 1833 ; w3-display-form-id ; action
1821 nil ; options 1834 ; nil ; options
1822 w3-current-form-number 1835 ; w3-current-form-number
1823 (w3-get-attribute 'id) ; id 1836 ; (w3-get-attribute 'id) ; id
1824 nil ; checked 1837 ; nil ; checked
1825 (car w3-active-faces))) 1838 ; (car w3-active-faces)))
1826 (input 1839 (input
1827 (w3-form-add-element 1840 (w3-form-add-element
1828 (w3-display-normalize-form-info args) 1841 (w3-display-normalize-form-info args)
1829 (car w3-active-faces)) 1842 w3-active-faces)
1830 (w3-handle-empty-tag) 1843 (w3-handle-empty-tag)
1831 ) 1844 )
1832 (select 1845 (select
1833 (let* ((plist (w3-display-normalize-form-info args)) 1846 (let* ((plist (w3-display-normalize-form-info args))
1834 (tmp nil) 1847 (tmp nil)
1868 options)) 1881 options))
1869 (setq node (list 'p nil options)) 1882 (setq node (list 'p nil options))
1870 (w3-handle-content node)) 1883 (w3-handle-content node))
1871 (setq plist (plist-put plist 'type 'option) 1884 (setq plist (plist-put plist 'type 'option)
1872 plist (plist-put plist 'options options)) 1885 plist (plist-put plist 'options options))
1873 (w3-form-add-element plist (car w3-active-faces)) 1886 (w3-form-add-element plist w3-active-faces)
1874 ;; This should really not be necessary, but some versions 1887 ;; This should really not be necessary, but some versions
1875 ;; of the widget library leave point _BEFORE_ the menu 1888 ;; of the widget library leave point _BEFORE_ the menu
1876 ;; widget instead of after. 1889 ;; widget instead of after.
1877 (goto-char (point-max)) 1890 (goto-char (point-max))
1878 (w3-handle-empty-tag)))) 1891 (w3-handle-empty-tag))))
1880 (let* ((plist (w3-display-normalize-form-info args)) 1893 (let* ((plist (w3-display-normalize-form-info args))
1881 (value (w3-normalize-spaces 1894 (value (w3-normalize-spaces
1882 (apply 'concat (nth 2 node))))) 1895 (apply 'concat (nth 2 node)))))
1883 (setq plist (plist-put plist 'type 'multiline) 1896 (setq plist (plist-put plist 'type 'multiline)
1884 plist (plist-put plist 'value value)) 1897 plist (plist-put plist 'value value))
1885 (w3-form-add-element plist (car w3-active-faces))) 1898 (w3-form-add-element plist w3-active-faces))
1886 (w3-handle-empty-tag) 1899 (w3-handle-empty-tag)
1887 ) 1900 )
1888 (style 1901 (style
1889 (w3-handle-style (alist-to-plist 1902 (w3-handle-style (alist-to-plist
1890 (cons (cons 'data (apply 'concat (nth 2 node))) 1903 (cons (cons 'data (apply 'concat (nth 2 node)))
1952 (w3-draw-tree (or tree w3-last-parse-tree)) 1965 (w3-draw-tree (or tree w3-last-parse-tree))
1953 (setq nd (nth 1 (current-time))) 1966 (setq nd (nth 1 (current-time)))
1954 (- nd st))) 1967 (- nd st)))
1955 1968
1956 1969
1970 (defun w3-fixup-eol-faces ()
1971 ;; Remove 'face property at end of lines - underlining screws up stuff
1972 (let ((inhibit-read-only t))
1973 (save-excursion
1974 (goto-char (point-min))
1975 (while (search-forward "\n" nil t)
1976 (put-text-property (match-beginning 0) (match-end 0) 'face nil)))))
1977
1957 (defsubst w3-finish-drawing () 1978 (defsubst w3-finish-drawing ()
1958 (if (and (boundp 'w3-image-widgets-waiting) w3-image-widgets-waiting) 1979 (let (url glyph widget)
1959 (let (url glyph widget) 1980 (while w3-image-widgets-waiting
1960 (while w3-image-widgets-waiting 1981 (setq widget (car w3-image-widgets-waiting)
1961 (setq widget (car w3-image-widgets-waiting) 1982 w3-image-widgets-waiting (cdr w3-image-widgets-waiting)
1962 w3-image-widgets-waiting (cdr w3-image-widgets-waiting) 1983 url (widget-get widget 'src)
1963 url (widget-get widget 'src) 1984 glyph (cdr-safe (assoc url w3-graphics-list)))
1964 glyph (cdr-safe (assoc url w3-graphics-list))) 1985 (condition-case nil
1965 (widget-value-set widget glyph))) 1986 (widget-value-set widget glyph)
1966 ;;(w3-handle-annotations) 1987 (error nil))))
1967 ;;(w3-handle-headers) 1988 (and (not w3-running-xemacs)
1968 ) 1989 (not (eq (device-type) 'tty))
1990 (w3-fixup-eol-faces))
1991 ;;(w3-handle-headers)
1969 ) 1992 )
1970 1993
1971 (defun w3-region (st nd) 1994 (defun w3-region (st nd)
1972 (if (not w3-setup-done) (w3-do-setup)) 1995 (if (not w3-setup-done) (w3-do-setup))
1973 (let* ((source (buffer-substring st nd)) 1996 (let* ((source (buffer-substring st nd))
1974 (w3-display-same-buffer t) 1997 (w3-dislplay-same-buffer t)
1975 (parse nil)) 1998 (parse nil))
1976 (save-excursion 1999 (save-window-excursion
1977 (set-buffer (get-buffer-create " *w3-region*")) 2000 (save-excursion
1978 (erase-buffer) 2001 (set-buffer (get-buffer-create " *w3-region*"))
1979 (insert source) 2002 (erase-buffer)
1980 (setq parse (w3-parse-buffer (current-buffer)))) 2003 (insert source)
1981 (narrow-to-region st nd) 2004 (setq parse (w3-parse-buffer (current-buffer))))
1982 (delete-region (point-min) (point-max)) 2005 (narrow-to-region st nd)
1983 (w3-draw-tree parse) 2006 (delete-region (point-min) (point-max))
1984 (w3-finish-drawing))) 2007 (w3-draw-tree parse)
2008 (w3-finish-drawing)
2009 (widen))))
1985 2010
1986 (defun w3-refresh-buffer () 2011 (defun w3-refresh-buffer ()
1987 (interactive) 2012 (interactive)
1988 (let ((parse w3-current-parse) 2013 (let ((parse w3-current-parse)
1989 (inhibit-read-only t) 2014 (inhibit-read-only t)