Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-display.el @ 114:8619ce7e4c50 r20-1b9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b9
author cvs
date Mon, 13 Aug 2007 09:21:54 +0200
parents fe104dbd9147
children 9f59509498e1
comparison
equal deleted inserted replaced
113:2ec2fe4a4c89 114:8619ce7e4c50
1 ;;; w3-display.el --- display engine v99999 1 ;;; w3-display.el --- display engine v99999
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/03/14 06:33:15 3 ;; Created: 1997/03/18 23:20:40
4 ;; Version: 1.147 4 ;; Version: 1.150
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.
1666 (w3-handle-image) 1666 (w3-handle-image)
1667 (w3-handle-empty-tag)) 1667 (w3-handle-empty-tag))
1668 (frameset 1668 (frameset
1669 (if w3-display-frames 1669 (if w3-display-frames
1670 (progn 1670 (progn
1671 (push 'frameset w3-frameset-structure) 1671 (push (list 'frameset
1672 (let ((cols (assq 'cols args)) 1672 (or (assq 'cols args) (assq 'rows args)))
1673 (rows (assq 'rows args))) 1673 w3-frameset-structure)
1674 (if rows
1675 (setq w3-frameset-dimensions (push rows w3-frameset-dimensions)))
1676 (if cols
1677 (setq w3-frameset-dimensions (push cols w3-frameset-dimensions))))
1678 (w3-handle-content node)) 1674 (w3-handle-content node))
1679 (w3-handle-content node))) 1675 (w3-handle-content node)))
1680 (frame 1676 (frame
1681 (if w3-display-frames 1677 (if w3-display-frames
1682 (let* ((href (or (w3-get-attribute 'src) 1678 (let* ((href (or (w3-get-attribute 'src)
1683 (w3-get-attribute 'href))) 1679 (w3-get-attribute 'href)))
1684 (name (or (w3-get-attribute 'name) 1680 (name (or (w3-get-attribute 'name)
1685 (w3-get-attribute 'title) 1681 (w3-get-attribute 'title)
1686 (w3-get-attribute 'alt) 1682 (w3-get-attribute 'alt)
1687 "Unknown frame name"))) 1683 "Unknown frame name")))
1688 (push 'frame w3-frameset-structure) 1684 (push (list 'frame name href) w3-frameset-structure)
1689 (w3-handle-content 1685 (w3-handle-content
1690 (list tag args 1686 (list tag args
1691 (list 1687 (list
1692 (list 'p nil 1688 (list 'p nil
1693 (list 1689 (list
1694 (list 'a 1690 (list 'a
1695 (cons (cons 'href href) 1691 (cons (cons 'href href)
1696 args) 1692 args)
1697 (list 1693 (list "Fetch frame: " name))))))))
1698 (car w3-frame-labels)
1699 name
1700 (cdr w3-frame-labels)))))))))
1701 (w3-handle-empty-tag))) 1694 (w3-handle-empty-tag)))
1702 (noframes 1695 (noframes
1703 (if w3-display-frames 1696 (if w3-display-frames
1704 (w3-handle-empty-tag) 1697 (w3-handle-empty-tag)
1705 (w3-handle-content node))) 1698 (w3-handle-content node)))
1916 (options (mapcar 1909 (options (mapcar
1917 (function 1910 (function
1918 (lambda (n) 1911 (lambda (n)
1919 (setq tmp (w3-normalize-spaces 1912 (setq tmp (w3-normalize-spaces
1920 (apply 'concat (nth 2 n))) 1913 (apply 'concat (nth 2 n)))
1921 tmp (cons tmp 1914 tmp (vector tmp
1922 (or 1915 (or
1923 (cdr-safe 1916 (cdr-safe
1924 (assq 'value (nth 1 n))) 1917 (assq 'value (nth 1 n)))
1925 tmp))) 1918 tmp)
1919 (assq 'selected (nth 1 n))))
1926 (if (assq 'selected (nth 1 n)) 1920 (if (assq 'selected (nth 1 n))
1927 (setq value (car tmp))) 1921 (setq value (aref tmp 0)))
1928 tmp)) 1922 tmp))
1929 (nth 2 node)))) 1923 (nth 2 node))))
1930 (if (not value) 1924 (if (not value)
1931 (setq value (caar options))) 1925 (setq value (aref (car options) 0)))
1932 (setq plist (plist-put plist 'value value)) 1926 (setq plist (plist-put plist 'value value))
1933 (if multiple 1927 (if multiple
1934 (progn 1928 (progn
1935 (setq options 1929 (setq options
1936 (mapcar 1930 (mapcar
1939 (list 'div nil 1933 (list 'div nil
1940 (list 1934 (list
1941 (list 'input 1935 (list 'input
1942 (list (cons 'name name) 1936 (list (cons 'name name)
1943 (cons 'type "checkbox") 1937 (cons 'type "checkbox")
1944 (cons 'value (car opt)))) 1938 (cons (if (aref opt 2)
1945 " " (car opt) (list 'br nil nil))))) 1939 'checked
1940 '__bogus__) "yes")
1941 (cons 'value (aref opt 1))))
1942 " " (aref opt 0) (list 'br nil nil)))))
1946 options)) 1943 options))
1947 (setq node (list 'p nil options)) 1944 (setq node (list 'p nil options))
1948 (w3-handle-content node)) 1945 (w3-handle-content node))
1946 (setq options (mapcar (function
1947 (lambda (x)
1948 (cons (aref x 0) (aref x 1))))
1949 options))
1949 (setq plist (plist-put plist 'type 'option) 1950 (setq plist (plist-put plist 'type 'option)
1950 plist (plist-put plist 'options options)) 1951 plist (plist-put plist 'options options))
1951 (w3-form-add-element plist w3-active-faces) 1952 (w3-form-add-element plist w3-active-faces)
1952 ;; This should really not be necessary, but some versions 1953 ;; This should really not be necessary, but some versions
1953 ;; of the widget library leave point _BEFORE_ the menu 1954 ;; of the widget library leave point _BEFORE_ the menu
2117 (if (not url-history-list) 2118 (if (not url-history-list)
2118 (setq url-history-list (make-hash-table :size 131 :test 'equal))) 2119 (setq url-history-list (make-hash-table :size 131 :test 'equal)))
2119 (cl-puthash url (buffer-name) url-history-list) 2120 (cl-puthash url (buffer-name) url-history-list)
2120 (if (fboundp 'w3-shuffle-history-menu) 2121 (if (fboundp 'w3-shuffle-history-menu)
2121 (w3-shuffle-history-menu))))) 2122 (w3-shuffle-history-menu)))))
2122 ) 2123 (w3-maybe-fetch-frames))
2124
2125 (defun w3-maybe-fetch-frames ()
2126 (if w3-frameset-structure
2127 (cond ((or (eq w3-display-frames t)
2128 (and (eq w3-display-frames 'ask)
2129 (y-or-n-p "Fetch frames? ")))
2130 (w3-frames)
2131 t))))
2123 2132
2124 (defun w3-frames (&optional new-frame) 2133 (defun w3-frames (&optional new-frame)
2125 "Set up and fetch W3 frames. With optional prefix, do so in a new frame." 2134 "Set up and fetch W3 frames. With optional prefix, do so in a new frame."
2126 (interactive "P") 2135 (interactive "P")
2136 (if (not w3-display-frames)
2137 (let ((w3-display-frames t))
2138 (w3-refresh-buffer)))
2127 (let* ((old-asynch url-be-asynchronous) 2139 (let* ((old-asynch url-be-asynchronous)
2128 (structure (reverse w3-frameset-structure)) 2140 (structure (reverse w3-frameset-structure)))
2129 (dims (or (reverse w3-frameset-dimensions)
2130 t)))
2131 (if new-frame 2141 (if new-frame
2132 (select-frame (make-frame-command))) 2142 (select-frame (make-frame-command)))
2133 (goto-char (point-min))
2134 (setq-default url-be-asynchronous nil) 2143 (setq-default url-be-asynchronous nil)
2135 ;; set up frames 2144 ;; set up frames
2136 (while (and structure dims) 2145 (while structure
2137 (let* ((current-dims (list (car dims))) 2146 (if (eq (car (car structure)) 'frameset)
2138 (cols (cdr-safe (assq 'cols current-dims))) 2147 (let* ((current-dims (cdr (car structure)))
2139 (rows (cdr-safe (assq 'rows current-dims)))) 2148 (cols (cdr-safe (assq 'cols current-dims)))
2140 (if (eq (car structure) 'frameset) 2149 (rows (cdr-safe (assq 'rows current-dims))))
2141 (pop structure)) 2150 (pop structure)
2142 ;; columns ? 2151 ;; columns ?
2143 (if cols 2152 (if cols
2144 (setq cols (w3-decode-frameset-dimensions cols (window-width))) 2153 (setq cols (w3-decode-frameset-dimensions cols (window-width) window-min-width))
2145 ;; rows ? 2154 ;; rows ?
2146 (if rows 2155 (if rows
2147 (setq rows (w3-decode-frameset-dimensions rows (window-height))) 2156 (setq rows (w3-decode-frameset-dimensions rows (window-height) window-min-height))
2148 ;; default: columns of equal width 2157 ;; default: columns of equal width
2149 (let ((nb-windows 0)) 2158 (let ((nb-windows 0)
2150 (save-excursion 2159 (frames structure))
2151 (while (re-search-forward w3-frame-regexp nil t) 2160 (while (and frames (eq (car (car frames)) 'frame))
2152 (setq nb-windows (1+ nb-windows)))) 2161 (setq nb-windows (1+ nb-windows)))
2153 (let ((fwidth (/ (window-width) nb-windows))) 2162 (let ((fwidth (/ (window-width) nb-windows)))
2154 (while (> nb-windows 0) 2163 (while (> nb-windows 0)
2155 (push fwidth cols) 2164 (push fwidth cols)
2156 (setq nb-windows (1- nb-windows))))))) 2165 (setq nb-windows (1- nb-windows)))))))
2157 (while (eq (car structure) 'frame) 2166 (while (eq (car (car structure)) 'frame)
2158 (if (re-search-forward w3-frame-regexp nil t) 2167 (cond ((cdr cols)
2159 (progn 2168 (split-window-horizontally (car cols))
2160 (if (cdr cols) 2169 (pop cols))
2161 (split-window-horizontally (min (car cols) 2170 ((cdr rows)
2162 (- (window-width) 12))) 2171 (split-window-vertically (car rows))
2163 (if (cdr rows) 2172 (pop rows)))
2164 (split-window-vertically (min (car rows) 2173 (let ((href (nth 2 (car structure)))
2165 (- (window-height) 12))))) 2174 (name (nth 1 (car structure)))
2166 (pop cols) 2175 (url-working-buffer url-default-working-buffer) ; in case url-multiple-p is t
2167 (pop rows) 2176 (w3-notify 'semibully))
2168 (goto-char (+ (match-beginning 0) 5)) 2177 (w3-fetch href)
2169 (let ((name (buffer-substring-no-properties (match-beginning 1) (match-end 1))) 2178 (setq w3-frame-name name
2170 (w3-notify 'semibully)) 2179 w3-target-window-distances nil))
2171 (w3-widget-button-press) 2180 (other-window 1)
2172 (setq w3-frame-name name 2181 (pop structure)))
2173 w3-target-window-distances nil)) 2182 (pop structure)))
2174 (other-window 1)))
2175 (pop structure)))
2176 (if (consp dims)
2177 (pop dims)
2178 (setq dims nil)))
2179 ;; compute target window distances 2183 ;; compute target window distances
2180 (let ((origin-buffer (current-buffer)) 2184 (let ((origin-buffer (current-buffer))
2181 (stop nil)) 2185 (stop nil))
2182 (while (not stop) 2186 (while (not stop)
2183 (or w3-target-window-distances 2187 (or w3-target-window-distances
2202 (setq distance (1+ distance)) 2206 (setq distance (1+ distance))
2203 (if (eq (current-buffer) origin-buffer) 2207 (if (eq (current-buffer) origin-buffer)
2204 (setq stop t))) 2208 (setq stop t)))
2205 window-distances)) 2209 window-distances))
2206 2210
2207 (defun w3-decode-frameset-dimensions (dims available-dimension) 2211 (if (not (fboundp 'frame-char-height))
2212 (defun frame-char-height (&optional frame)
2213 "Height in pixels of a line in the font in frame FRAME.
2214 If FRAME is omitted, the selected frame is used.
2215 For a terminal frame, the value is always 1."
2216 (font-height (face-font 'default frame))))
2217
2218 (if (not (fboundp 'frame-char-width))
2219 (defun frame-char-width (&optional frame)
2220 "Width in pixels of characters in the font in frame FRAME.
2221 If FRAME is omitted, the selected frame is used.
2222 For a terminal screen, the value is always 1."
2223 (font-width (face-font 'default frame))))
2224
2225 (defun w3-decode-frameset-dimensions (dims available-dimension min-dim)
2208 "Returns numbers of lines or columns in Emacs, computed from specified frameset dimensions" 2226 "Returns numbers of lines or columns in Emacs, computed from specified frameset dimensions"
2209 (let ((dimensions nil)) 2227 (let ((dimensions nil))
2210 (if dims 2228 (if dims
2211 (let ((nb-stars 0) 2229 (let ((nb-stars 0)
2212 (remaining-available-dimension available-dimension)) 2230 (remaining-available-dimension available-dimension))
2226 dimensions)) 2244 dimensions))
2227 (t 2245 (t
2228 ;; absolute number: pixel height 2246 ;; absolute number: pixel height
2229 (push (max (1+ (/ (car (read-from-string match)) 2247 (push (max (1+ (/ (car (read-from-string match))
2230 (frame-char-height))) 2248 (frame-char-height)))
2231 window-min-height) 2249 min-dim)
2232 dimensions))) 2250 dimensions)))
2233 (setq remaining-available-dimension 2251 (setq remaining-available-dimension
2234 (- remaining-available-dimension (car dimensions))))))) 2252 (- remaining-available-dimension (car dimensions)))))))
2235 (if (zerop nb-stars) 2253 (if (zerop nb-stars)
2236 ;; push => reverse order 2254 ;; push => reverse order