xemacs-beta: lisp/w3/w3-display.el comparison

comparison lisp/w3/w3-display.el @ 26:441bb1e64a06 r19-15b96

Import from CVS: tag r19-15b96

author	cvs
date	Mon, 13 Aug 2007 08:51:32 +0200
parents	4103f0995bd7
children	ec9a17fef872

comparison

equal deleted inserted replaced

-:383a494979f8
+:441bb1e64a06
 ;;; w3-display.el --- display engine v99999
 ;; Author: wmperry
-;; Created: 1997/02/15 23:38:28
+;; Created: 1997/02/20 21:48:44
-;; Version: 1.128
+;; Version: 1.135
 ;; Keywords: faces, help, hypermedia
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Copyright (c) 1996 by William M. Perry (wmperry@cs.indiana.edu)
 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
 			 (skip-chars-forward " \t\r\n")
 			 (point)))))
 (goto-char (point-max))
 (add-text-properties w3-scratch-start-point
 		       (point) (list 'face w3-active-faces
+				     'html-stack w3-display-open-element-stack
 				     'start-open t
 				     'end-open t
 				     'rear-nonsticky t
 				     'duplicable t))
 (if (car w3-active-voices)
 	     (stringp (symbol-value (car check)))
 	     (throw 'exit (symbol-value (car check))))
 	(pop check)))))
 (defun w3-follow-hyperlink (widget &rest ignore)
-(let* ((target (widget-get widget 'target))
+(let* ((target (or (widget-get widget 'target)
+		     w3-base-target))
 	 (href (widget-get widget 'href)))
 (if target (setq target (intern (downcase target))))
 (case target
 ((_blank external)
 (w3-fetch-other-frame href))
 (_top
 (delete-other-windows)
 (w3-fetch href))
 (otherwise
+(and target
+	    (let ((window-distance (cdr-safe (assq target w3-target-window-distances))))
+	      (if (numberp window-distance)
+		  (other-window window-distance)
+		(error "target %S not found." target))))
 (w3-fetch href)))))
 (defun w3-balloon-help-callback (object &optional event)
 (let* ((widget (widget-at (extent-start-position object)))
 	 (href (and widget (widget-get widget 'href))))
 (let (
 	(content-stack (list (list node)))
 	(right-margin-stack (list fill-column))
 	(left-margin-stack (list 0))
 	(inhibit-read-only t)
+	(widget-push-button-gui nil)
 	node
 	insert-before
 	insert-after
 	tag
 	args
 	    (img			; inlined image
 	     (w3-handle-image)
 	     (w3-handle-empty-tag))
 	    (frameset
 	     (if w3-display-frames
-		 (w3-handle-content node)
+		 (progn
+		   (push 'frameset w3-frameset-structure)
+		   (let ((cols (assq 'cols args))
+			 (rows (assq 'rows args)))
+		     (if rows
+			 (setq w3-frameset-dimensions (push rows w3-frameset-dimensions)))
+		     (if cols
+			 (setq w3-frameset-dimensions (push cols w3-frameset-dimensions))))
+		   (w3-handle-content node))
 	       (w3-handle-empty-tag)))
 	    (frame
-	     (let* ((href (or (w3-get-attribute 'src)
+	     (if w3-display-frames
-			      (w3-get-attribute 'href)))
+		 (let* ((href (or (w3-get-attribute 'src)
-		    (name (or (w3-get-attribute 'name)
+				  (w3-get-attribute 'href)))
-			      (w3-get-attribute 'title)
+			(name (or (w3-get-attribute 'name)
-			      (w3-get-attribute 'alt)
+				  (w3-get-attribute 'title)
-			      "Unknown frame name")))
+				  (w3-get-attribute 'alt)
-	       (w3-handle-content
+				  "Unknown frame name")))
-		(list tag args
+		   (push 'frame w3-frameset-structure)
-		      (list
+		   (w3-handle-content
-		       (list 'p nil
+		    (list tag args
-			     (list
+			  (list
-			      (list 'a
+			   (list 'p nil
-				    (cons (cons 'href href)
+				 (list
-					  args)
+				  (list 'a
-				    (list
+					(cons (cons 'href href)
-				     "Fetch frame: "
+					      args)
-				     name)))))))))
+					(list
+					 (car w3-frame-labels)
+					 name
+					 (cdr w3-frame-labels)))))))))))
 	    (noframes
 	     (if w3-display-frames
 		 (w3-handle-empty-tag)
 	       (w3-handle-content node)))
 	    (script			; Scripts
 				 w3-persistent-variables)))
 	       (if (not w3-display-same-buffer)
 		   (set-buffer (generate-new-buffer "Untitled")))
 	       (setq w3-current-form-number 0
 		     w3-display-open-element-stack nil
-		     w3-last-fill-pos (point-min)
+		     w3-last-fill-pos (point-min))
-		     fill-column (min (- (or w3-strict-width (window-width))
+	       (setcar right-margin-stack
-					 w3-right-margin)
+		       (min (- (or w3-strict-width (window-width))
-				      (or w3-maximum-line-length
+			       w3-right-margin)
-					  (window-width))))
+			    (or w3-maximum-line-length
+				(window-width))))
 	       (switch-to-buffer (current-buffer))
 	       (buffer-disable-undo (current-buffer))
 	       (mapcar (function (lambda (x) (set (car x) (cdr x)))) info)
 	       ;; ACK!  We don't like filladapt mode!
 	       (set (make-local-variable 'filladapt-mode) nil)
 	       (set (make-local-variable 'adaptive-fill-mode) nil)
 	       (set (make-local-variable 'voice-lock-mode) t)
 	       (setq w3-current-stylesheet (css-copy-stylesheet
 					    w3-user-stylesheet)
 		     w3-last-fill-pos (point)
-		     fill-column (min (- (or w3-strict-width (window-width))
-					 w3-right-margin)
-				      (or w3-maximum-line-length
-					  (window-width)))
 		     fill-prefix "")
 	       (set (make-local-variable 'inhibit-read-only) t))
 	     (w3-handle-content node)
 	     )
 	    (*invisible
 		       (string-match "^[ \t]*$" potential-title))
 		   nil
 		 (rename-buffer (generate-new-buffer-name
 				 (w3-fix-spaces potential-title)))))
 	     (w3-handle-empty-tag))
+	    (base
+	     (setq w3-base-target (cdr-safe (assq 'target args)))
+	     (w3-handle-content node))
 	    (form
 	     (setq w3-current-form-number (1+ w3-current-form-number))
 	     (let* (
 		    (action (w3-get-attribute 'action))
 		    (url nil))
 	    url (widget-get widget 'src)
 	    glyph (cdr-safe (assoc url w3-graphics-list)))
 (condition-case nil
 	  (widget-value-set widget glyph)
 	(error nil))))
+(if (and url-current-object (url-target url-current-object))
+(progn
+	(push-mark (point) t)
+	(w3-find-specific-link (url-target url-current-object)))
+(goto-char (point-min)))
 (and (not w3-running-xemacs)
 (not (eq (device-type) 'tty))
 (w3-fixup-eol-faces))
+(message "Drawing... done")
 ;;(w3-handle-headers)
 )
 (defun w3-region (st nd)
 (if (not w3-setup-done) (w3-do-setup))
 (setq w3-current-source source
 	  w3-current-parse parse)
 (w3-finish-drawing)
 (w3-mode)
 (set-buffer-modified-p nil)
-(goto-char (point-min))
 (if url-keep-history
 	(let ((url (url-view-url t)))
 	  (if (not url-history-list)
 	      (setq url-history-list (make-hash-table :size 131 :test 'equal)))
 	  (cl-puthash url (buffer-name) url-history-list)
 	  (if (fboundp 'w3-shuffle-history-menu)
 	      (w3-shuffle-history-menu)))))
 )
+(defun w3-frames (&optional new-frame)
+"Set up and fetch W3 frames. With optional prefix, do so in a new frame."
+(interactive "P")
+(let* ((old-asynch url-be-asynchronous)
+	 (structure (reverse w3-frameset-structure))
+	 (dims (or (reverse w3-frameset-dimensions)
+		   t)))
+(if new-frame
+	(select-frame (make-frame-command)))
+(goto-char (point-min))
+(setq-default url-be-asynchronous nil)
+;; set up frames
+(while (and structure dims)
+(let* ((current-dims (list (car dims)))
+	     (cols (cdr-safe (assq 'cols current-dims)))
+	     (rows (cdr-safe (assq 'rows current-dims))))
+	(if (eq (car structure) 'frameset)
+	    (pop structure))
+	;; columns ?
+	(if cols
+	    (setq cols (w3-decode-frameset-dimensions cols (window-width)))
+	  ;; rows ?
+	  (if rows
+	      (setq rows (w3-decode-frameset-dimensions rows (window-height)))
+	    ;; default: columns of equal width
+	    (let ((nb-windows 0))
+	      (save-excursion
+		(while (re-search-forward w3-frame-regexp nil t)
+		  (setq nb-windows (1+ nb-windows))))
+	      (let ((fwidth (/ (window-width) nb-windows)))
+		(while (> nb-windows 0)
+		  (push fwidth cols)
+		  (setq nb-windows (1- nb-windows)))))))
+	(while (eq (car structure) 'frame)
+	  (if (re-search-forward w3-frame-regexp nil t)
+	      (progn
+		(if (cdr cols)
+		    (split-window-horizontally (min (car cols)
+						    (- (window-width) 12)))
+		  (if (cdr rows)
+		      (split-window-vertically (min (car rows)
+						    (- (window-height) 12)))))
+		(pop cols)
+		(pop rows)
+		(goto-char (+ (match-beginning 0) 5))
+		(let ((name (buffer-substring-no-properties (match-beginning 1) (match-end 1)))
+		      (w3-notify 'semibully))
+		  (w3-widget-button-press)
+		  (setq w3-frame-name name
+			w3-target-window-distances nil))
+		(other-window 1)))
+	  (pop structure)))
+(if (consp dims)
+	  (pop dims)
+	(setq dims nil)))
+;; compute target window distances
+(let ((origin-buffer (current-buffer))
+	  (stop nil))
+(while (not stop)
+	(or w3-target-window-distances
+	    (setq w3-target-window-distances
+		  (w3-compute-target-window-distances)))
+	(other-window 1)
+	(if (eq (current-buffer) origin-buffer)
+	    (setq stop t))))
+(setq-default url-be-asynchronous old-asynch)))
+(defun w3-compute-target-window-distances ()
+"Compute an alist of target names and window distances"
+(let ((origin-buffer (current-buffer))
+	(distance 0)
+	(stop nil)
+	(window-distances nil))
+(while (not stop)
+(if w3-frame-name
+	  (push (cons (intern (downcase w3-frame-name)) distance)
+		window-distances))
+(other-window 1)
+(setq distance (1+ distance))
+(if (eq (current-buffer) origin-buffer)
+	  (setq stop t)))
+window-distances))
+(defun w3-decode-frameset-dimensions (dims available-dimension)
+"Returns numbers of lines or columns in Emacs, computed from specified frameset dimensions"
+(let ((dimensions nil))
+(if dims
+	(let ((nb-stars 0)
+	      (remaining-available-dimension available-dimension))
+	  (while (string-match "\\(\\*\\|[0-9]+%?\\)" dims)
+	    (let ((match (substring dims (match-beginning 1) (match-end 1))))
+	      (setq dims (substring dims (match-end 1)))
+	      (cond ((string-match "\\*" match)
+		     ;; * : divide rest equally
+		     (push '* dimensions)
+		     (setq nb-stars (1+ nb-stars)))
+		    (t
+		     (cond ((string-match "\\([0-9]+\\)%" match)
+			    ;; percentage of available height
+			    (push (/ (* (car (read-from-string (substring match 0 -1)))
+					available-dimension)
+				     100)
+				  dimensions))
+			   (t
+			    ;; absolute number: pixel height
+			    (push (max (1+ (/ (car (read-from-string match))
+					      (frame-char-height)))
+				       window-min-height)
+				  dimensions)))
+		     (setq remaining-available-dimension
+			   (- remaining-available-dimension (car dimensions)))))))
+	  (if (zerop nb-stars)
+	      ;; push => reverse order
+	      (reverse dimensions)
+	    ;; substitute numbers for *
+	    (let ((star-replacement (/ remaining-available-dimension nb-stars))
+		    (star-dimensions dimensions))
+		(setq dimensions nil)
+		(while star-dimensions
+		  (push (if (eq '* (car star-dimensions))
+			    star-replacement
+			  (car star-dimensions))
+			dimensions)
+		  (pop star-dimensions))
+		;; push + push => in order
+		dimensions))))))
 (provide 'w3-display)

Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-display.el @ 26:441bb1e64a06 r19-15b96