Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-display.el @ 38:1a767b41a199 r19-15b102

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b102
author cvs
date Mon, 13 Aug 2007 08:54:01 +0200
parents c53a95d3c46d
children 8d2a9b52c682
comparison
equal deleted inserted replaced
37:ad40ac360d14 38:1a767b41a199
1 ;;; w3-display.el --- display engine v99999 1 ;;; w3-display.el --- display engine v99999
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/03/17 20:09:50 3 ;; Created: 1997/03/18 23:20:40
4 ;; Version: 1.148 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")
2127 (if (not w3-display-frames) 2136 (if (not w3-display-frames)
2128 (let ((w3-display-frames t)) 2137 (let ((w3-display-frames t))
2129 (w3-refresh-buffer))) 2138 (w3-refresh-buffer)))
2130 (let* ((old-asynch url-be-asynchronous) 2139 (let* ((old-asynch url-be-asynchronous)
2131 (structure (reverse w3-frameset-structure)) 2140 (structure (reverse w3-frameset-structure)))
2132 (dims (or (reverse w3-frameset-dimensions)
2133 t)))
2134 (if new-frame 2141 (if new-frame
2135 (select-frame (make-frame-command))) 2142 (select-frame (make-frame-command)))
2136 (goto-char (point-min))
2137 (setq-default url-be-asynchronous nil) 2143 (setq-default url-be-asynchronous nil)
2138 ;; set up frames 2144 ;; set up frames
2139 (while (and structure dims) 2145 (while structure
2140 (let* ((current-dims (list (car dims))) 2146 (if (eq (car (car structure)) 'frameset)
2141 (cols (cdr-safe (assq 'cols current-dims))) 2147 (let* ((current-dims (cdr (car structure)))
2142 (rows (cdr-safe (assq 'rows current-dims)))) 2148 (cols (cdr-safe (assq 'cols current-dims)))
2143 (if (eq (car structure) 'frameset) 2149 (rows (cdr-safe (assq 'rows current-dims))))
2144 (pop structure)) 2150 (pop structure)
2145 ;; columns ? 2151 ;; columns ?
2146 (if cols 2152 (if cols
2147 (setq cols (w3-decode-frameset-dimensions cols (window-width))) 2153 (setq cols (w3-decode-frameset-dimensions cols (window-width) window-min-width))
2148 ;; rows ? 2154 ;; rows ?
2149 (if rows 2155 (if rows
2150 (setq rows (w3-decode-frameset-dimensions rows (window-height))) 2156 (setq rows (w3-decode-frameset-dimensions rows (window-height) window-min-height))
2151 ;; default: columns of equal width 2157 ;; default: columns of equal width
2152 (let ((nb-windows 0)) 2158 (let ((nb-windows 0)
2153 (save-excursion 2159 (frames structure))
2154 (while (re-search-forward w3-frame-regexp nil t) 2160 (while (and frames (eq (car (car frames)) 'frame))
2155 (setq nb-windows (1+ nb-windows)))) 2161 (setq nb-windows (1+ nb-windows)))
2156 (let ((fwidth (/ (window-width) nb-windows))) 2162 (let ((fwidth (/ (window-width) nb-windows)))
2157 (while (> nb-windows 0) 2163 (while (> nb-windows 0)
2158 (push fwidth cols) 2164 (push fwidth cols)
2159 (setq nb-windows (1- nb-windows))))))) 2165 (setq nb-windows (1- nb-windows)))))))
2160 (while (eq (car structure) 'frame) 2166 (while (eq (car (car structure)) 'frame)
2161 (if (re-search-forward w3-frame-regexp nil t) 2167 (cond ((cdr cols)
2162 (progn 2168 (split-window-horizontally (car cols))
2163 (if (cdr cols) 2169 (pop cols))
2164 (split-window-horizontally (min (car cols) 2170 ((cdr rows)
2165 (- (window-width) 12))) 2171 (split-window-vertically (car rows))
2166 (if (cdr rows) 2172 (pop rows)))
2167 (split-window-vertically (min (car rows) 2173 (let ((href (nth 2 (car structure)))
2168 (- (window-height) 12))))) 2174 (name (nth 1 (car structure)))
2169 (pop cols) 2175 (url-working-buffer url-default-working-buffer) ; in case url-multiple-p is t
2170 (pop rows) 2176 (w3-notify 'semibully))
2171 (goto-char (+ (match-beginning 0) 5)) 2177 (w3-fetch href)
2172 (let ((name (buffer-substring-no-properties (match-beginning 1) (match-end 1))) 2178 (setq w3-frame-name name
2173 (w3-notify 'semibully)) 2179 w3-target-window-distances nil))
2174 (w3-widget-button-press) 2180 (other-window 1)
2175 (setq w3-frame-name name 2181 (pop structure)))
2176 w3-target-window-distances nil)) 2182 (pop structure)))
2177 (other-window 1)))
2178 (pop structure)))
2179 (if (consp dims)
2180 (pop dims)
2181 (setq dims nil)))
2182 ;; compute target window distances 2183 ;; compute target window distances
2183 (let ((origin-buffer (current-buffer)) 2184 (let ((origin-buffer (current-buffer))
2184 (stop nil)) 2185 (stop nil))
2185 (while (not stop) 2186 (while (not stop)
2186 (or w3-target-window-distances 2187 (or w3-target-window-distances
2219 "Width in pixels of characters in the font in frame FRAME. 2220 "Width in pixels of characters in the font in frame FRAME.
2220 If FRAME is omitted, the selected frame is used. 2221 If FRAME is omitted, the selected frame is used.
2221 For a terminal screen, the value is always 1." 2222 For a terminal screen, the value is always 1."
2222 (font-width (face-font 'default frame)))) 2223 (font-width (face-font 'default frame))))
2223 2224
2224 (defun w3-decode-frameset-dimensions (dims available-dimension) 2225 (defun w3-decode-frameset-dimensions (dims available-dimension min-dim)
2225 "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"
2226 (let ((dimensions nil)) 2227 (let ((dimensions nil))
2227 (if dims 2228 (if dims
2228 (let ((nb-stars 0) 2229 (let ((nb-stars 0)
2229 (remaining-available-dimension available-dimension)) 2230 (remaining-available-dimension available-dimension))
2243 dimensions)) 2244 dimensions))
2244 (t 2245 (t
2245 ;; absolute number: pixel height 2246 ;; absolute number: pixel height
2246 (push (max (1+ (/ (car (read-from-string match)) 2247 (push (max (1+ (/ (car (read-from-string match))
2247 (frame-char-height))) 2248 (frame-char-height)))
2248 window-min-height) 2249 min-dim)
2249 dimensions))) 2250 dimensions)))
2250 (setq remaining-available-dimension 2251 (setq remaining-available-dimension
2251 (- remaining-available-dimension (car dimensions))))))) 2252 (- remaining-available-dimension (car dimensions)))))))
2252 (if (zerop nb-stars) 2253 (if (zerop nb-stars)
2253 ;; push => reverse order 2254 ;; push => reverse order