xemacs-beta: lisp/help.el comparison

comparison lisp/help.el @ 442:abe6d1db359e r21-2-36

Import from CVS: tag r21-2-36

author	cvs
date	Mon, 13 Aug 2007 11:35:02 +0200
parents	8de8e3f6228a
children	576fb035e263

comparison

equal deleted inserted replaced

-:72a7cfa4a488
+:abe6d1db359e
 "Exit from help mode, possibly restoring the previous window configuration.
 If the optional argument BURY is non-nil, the help buffer is buried,
 otherwise it is killed."
 (interactive)
 (let ((buf (current-buffer)))
-(cond ((frame-property (selected-frame) 'help-window-config)
+(cond (help-window-config
-	   (set-window-configuration
+	   (set-window-configuration help-window-config))
-	    (frame-property (selected-frame) 'help-window-config))
-	   (set-frame-property  (selected-frame) 'help-window-config nil))
 	  ((not (one-window-p))
 	   (delete-window)))
 (if bury
 	(bury-buffer buf)
 (kill-buffer buf))))
 ;; #### BEFORE you rush to make this a macro, think about backward
 ;; compatibility.  The right way would be to create a macro with
 ;; another name (which is a shame, because w-d-h-b is a perfect name
 ;; for a macro) that uses with-displaying-help-buffer internally.
+(defcustom mode-for-help 'help-mode
+"*Mode that help buffers are put into.")
+(defvar help-sticky-window nil
+;; Window into which help buffers will be displayed, rather than
+;; always searching for a new one.  This is INTERNAL and liable to
+;; change its interface and/or name at any moment.  It should be
+;; bound, not set.
+)
+(defvar help-window-config nil)
+(make-variable-buffer-local 'help-window-config)
+(put 'help-window-config 'permanent-local t)
 (defun with-displaying-help-buffer (thunk &optional name)
 "Form which makes a help buffer with given NAME and evaluates BODY there.
 The actual name of the buffer is generated by the function `help-buffer-name'."
 (let* ((winconfig (current-window-configuration))
 	 (was-one-window (one-window-p))
 	  (not (and (windows-of-buffer buffer-name) ;shortcut
 		    (memq (selected-frame)
 			  (mapcar 'window-frame
 				  (windows-of-buffer buffer-name)))))))
 (help-register-and-maybe-prune-excess buffer-name)
-(prog1 (with-output-to-temp-buffer buffer-name
+;; if help-sticky-window is bogus or deleted, get rid of it.
-	     (prog1 (funcall thunk)
+(if (and help-sticky-window (or (not (windowp help-sticky-window))
-	       (save-excursion
+				    (not (window-live-p help-sticky-window))))
-		 (set-buffer standard-output)
+	(setq help-sticky-window nil))
-		 (help-mode))))
+(prog1
+	(let ((temp-buffer-show-function
+	       (if help-sticky-window
+		   #'(lambda (buffer)
+		       (set-window-buffer help-sticky-window buffer))
+		 temp-buffer-show-function)))
+	  (with-output-to-temp-buffer buffer-name
+	    (prog1 (funcall thunk)
+	      (save-excursion
+		(set-buffer standard-output)
+		(funcall mode-for-help)))))
 (let ((helpwin (get-buffer-window buffer-name)))
 	(when helpwin
-	  (with-current-buffer (window-buffer helpwin)
+	  ;; If the *Help* buffer is already displayed on this
-	    ;; If the *Help* buffer is already displayed on this
+	  ;; frame, don't override the previous configuration
-	    ;; frame, don't override the previous configuration
+	  (when help-not-visible
-	    (when help-not-visible
+	    (with-current-buffer (window-buffer helpwin)
-	      (set-frame-property (selected-frame)
+	      (setq help-window-config winconfig)))
-				  'help-window-config winconfig)))
 	  (when help-selects-help-window
 	    (select-window helpwin))
 	  (cond ((eq helpwin (selected-window))
 		 (display-message 'command
 		   (substitute-command-keys "Type \\[help-mode-quit] to remove help window, \\[scroll-up] to scroll the help.")))
 (interactive)
 (if (and (boundp 'Installation-string)
 	   (stringp Installation-string))
 (with-displaying-help-buffer
 (lambda ()
-	 (princ Installation-string))
+	 (princ
+	  (if (fboundp 'decode-coding-string)
+	      (decode-coding-string Installation-string 'automatic-conversion)
+	    Installation-string)))
 "Installation")
 (error "No Installation information available.")))
 (defun view-emacs-news ()
 "Display info on recent changes to XEmacs."
 (find-file (locate-data-file "NEWS")))
 (defun xemacs-www-page ()
 "Go to the XEmacs World Wide Web page."
 (interactive)
-(if (boundp 'browse-url-browser-function)
+(if (fboundp 'browse-url)
-(funcall browse-url-browser-function "http://www.xemacs.org/")
+(browse-url "http://www.xemacs.org/")
 (error "xemacs-www-page requires browse-url")))
 (defun xemacs-www-faq ()
 "View the latest and greatest XEmacs FAQ using the World Wide Web."
 (interactive)
-(if (boundp 'browse-url-browser-function)
+(if (fboundp 'browse-url)
-(funcall browse-url-browser-function
+(browse-url "http://www.xemacs.org/faq/index.html")
-	       "http://www.xemacs.org/faq/index.html")
 (error "xemacs-www-faq requires browse-url")))
 (defun xemacs-local-faq ()
 "View the local copy of the XEmacs FAQ.
 If you have access to the World Wide Web, you should use `xemacs-www-faq'
 	    (forward-char 1)
 	    (let (obj)
 	      (setq obj (read (current-buffer)))
 	      (and (symbolp obj) (fboundp obj) obj)))))))
+(defun function-at-event (event)
+"Return the function whose name is around the position of EVENT.
+EVENT should be a mouse event.  When calling from a popup or context menu,
+use `last-popup-menu-event' to find out where the mouse was clicked.
+\(You cannot use (interactive \"e\"), unfortunately.  This returns a
+misc-user event.)
+If the event contains no position, or the position is not over text, or
+there is no function around that point, nil is returned."
+(if (and event (event-buffer event) (event-point event))
+(save-excursion
+	(set-buffer (event-buffer event))
+	(goto-char (event-point event))
+	(function-at-point))))
 ;; Default to nil for the non-hackers?  Not until we find a way to
 ;; distinguish hackers from non-hackers automatically!
 (defcustom describe-function-show-arglist t
 "*If non-nil, describe-function will show its arglist,
 unless the function is autoloaded."
 	       (void-function ""))))
 (if (and strip-arglist
 	     (string-match "[\n\t ]*\narguments: ?(\\(.*\\))\n?\\'" doc))
 	(setq doc (substring doc 0 (match-beginning 0))))
 doc))
+;  (let ((name-char "[-+a-zA-Z0-9_*]") (sym-char "[-+a-zA-Z0-9_:*]"))
+;    (list
+;     ;;
+;     ;; The symbol itself.
+;     (list (concat "\\`\\(" name-char "+\\)\\(:\\)?")
+;	   '(1 (if (match-beginning 2)
+;		   'font-lock-function-name-face
+;		 'font-lock-variable-name-face)
+;	       nil t))
+;     ;;
+;     ;; Words inside `' which tend to be symbol names.
+;     (list (concat "`\\(" sym-char sym-char "+\\)'")
+;	   1 '(prog1
+;		  'font-lock-reference-face
+;		(add-list-mode-item (match-beginning 1)
+;			       (match-end 1)
+;			       nil
+;			       'help-follow-reference))
+;	   t)
+;     ;;
+;     ;; CLisp `:' keywords as references.
+;     (list (concat "\\<:" sym-char "+\\>") 0 'font-lock-reference-face t)))
+(defvar help-symbol-regexp
+(let ((sym-char "[+a-zA-Z0-9_:*]")
+	(sym-char-no-dash "[-+a-zA-Z0-9_:*]"))
+(concat "\\("
+	    ;; a symbol with a - in it.
+	    "\\<\\(" sym-char-no-dash "+\\(-" sym-char-no-dash "+\\)+\\)\\>"
+	    "\\|"
+	    "`\\(" sym-char "+\\)'"
+	    "\\)")))
+(defun help-symbol-run-function-1 (ev ex fun)
+(let ((help-sticky-window
+	 ;; if we were called from a help buffer, make sure the new help
+	 ;; goes in the same window.
+	 (if (and (event-buffer ev)
+		  (symbol-value-in-buffer 'help-window-config
+					  (event-buffer ev)))
+	     (event-window ev)
+	   help-sticky-window)))
+(funcall fun (extent-property ex 'help-symbol))))
+(defun help-symbol-run-function (fun)
+(let ((ex (extent-at-event last-popup-menu-event 'help-symbol)))
+(when ex
+(help-symbol-run-function-1 last-popup-menu-event ex fun))))
+(defvar help-symbol-function-context-menu
+'("---"
+["View %_Documentation" (help-symbol-run-function 'describe-function)]
+["Find %_Function Source" (help-symbol-run-function 'find-function)]
+))
+(defvar help-symbol-variable-context-menu
+'("---"
+["View %_Documentation" (help-symbol-run-function 'describe-variable)]
+["Find %_Variable Source" (help-symbol-run-function 'find-variable)]
+))
+(defvar help-symbol-function-and-variable-context-menu
+'("---"
+["View Function %_Documentation" (help-symbol-run-function
+				      'describe-function)]
+["View Variable D%_ocumentation" (help-symbol-run-function
+				      'describe-variable)]
+["Find %_Function Source" (help-symbol-run-function 'find-function)]
+["Find %_Variable Source" (help-symbol-run-function 'find-variable)]
+))
+(defun frob-help-extents (buffer)
+;; Look through BUFFER, starting at the buffer's point and continuing
+;; till end of file, and find documented functions and variables.
+;; any such symbol found is tagged with an extent, that sets up these
+;; properties:
+;; 1. mouse-face is 'highlight (so the extent gets highlighted on mouse over)
+;; 2. help-symbol is the name of the symbol.
+;; 3. context-menu is a list of context menu items, specific to whether
+;;    the symbol is a function, variable, or both.
+;; 4. activate-function will cause the function or variable to be described,
+;;    replacing the existing help contents.
+(save-excursion
+(set-buffer buffer)
+(let (b e name)
+(while (re-search-forward help-symbol-regexp nil t)
+	(setq b (or (match-beginning 2) (match-beginning 4)))
+	(setq e (or (match-end 2) (match-end 4)))
+	(setq name (buffer-substring b e))
+	(let* ((sym (intern-soft name))
+	       (var (and sym (boundp sym)
+			 (documentation-property sym
+						 'variable-documentation t)))
+	       (fun (and sym (fboundp sym)
+			 (documentation sym t))))
+	  (when (or var fun)
+	    (let ((ex (make-extent b e)))
+	      (set-extent-property ex 'mouse-face 'highlight)
+	      (set-extent-property ex 'help-symbol sym)
+	      (set-extent-property
+	       ex 'context-menu
+	       (cond ((and var fun)
+		      help-symbol-function-and-variable-context-menu)
+		     (var help-symbol-variable-context-menu)
+		     (fun help-symbol-function-context-menu)))
+	      (set-extent-property
+	       ex 'activate-function
+	       (if fun
+		   #'(lambda (ev ex)
+		       (help-symbol-run-function-1 ev ex 'describe-function))
+		 #'(lambda (ev ex)
+		     (help-symbol-run-function-1 ev ex 'describe-variable))))
+	      ))))))) ;; 11 parentheses!
 (defun describe-function-1 (function &optional nodoc)
 "This function does the work for `describe-function'."
 (princ (format "`%s' is " function))
 (let* ((def function)
 	       (terpri)
 	       (terpri))
 	     (unless (and obsolete aliases)
 	       (let ((doc (function-documentation function t)))
 		 (princ "Documentation:\n")
-		 (princ doc)
+		 (let ((oldp (point standard-output))
+		       newp)
+		   (princ doc)
+		   (setq newp (point standard-output))
+		   (goto-char oldp standard-output)
+		   (frob-help-extents standard-output)
+		   (goto-char newp standard-output))
 		 (unless (or (equal doc "")
 			     (eq ?\n (aref doc (1- (length doc)))))
 		   (terpri)))))))))
 (defun describe-function-arglist (function)
 (interactive (list (or (function-at-point)
 			 (error "no function call at point"))))
 (message nil)
 (message (function-arglist function)))
 (defun variable-at-point ()
 (ignore-errors
 (with-syntax-table emacs-lisp-mode-syntax-table
 (save-excursion
 	    (eq (char-syntax (char-after (point))) ?_)
 	    (forward-sexp -1))
 	(skip-chars-forward "'")
 	(let ((obj (read (current-buffer))))
 	  (and (symbolp obj) (boundp obj) obj))))))
+(defun variable-at-event (event)
+"Return the variable whose name is around the position of EVENT.
+EVENT should be a mouse event.  When calling from a popup or context menu,
+use `last-popup-menu-event' to find out where the mouse was clicked.
+\(You cannot use (interactive \"e\"), unfortunately.  This returns a
+misc-user event.)
+If the event contains no position, or the position is not over text, or
+there is no variable around that point, nil is returned."
+(if (and event (event-buffer event) (event-point event))
+(save-excursion
+	(set-buffer (event-buffer event))
+	(goto-char (event-point event))
+	(variable-at-point))))
 (defun variable-obsolete-p (variable)
 "Return non-nil if VARIABLE is obsolete."
 (not (null (get variable 'byte-obsolete-variable))))
 	   (terpri))
 	 ;; don't bother to print anything if variable is obsolete and aliased.
 	 (when (or (not obsolete) (not aliases))
 	   (if doc
 	       ;; note: documentation-property calls substitute-command-keys.
-	       (princ doc)
+	       (let ((oldp (point standard-output))
+		     newp)
+		 (princ doc)
+		 (setq newp (point standard-output))
+		 (goto-char oldp standard-output)
+		 (frob-help-extents standard-output)
+		 (goto-char newp standard-output))
 	     (princ "not documented as a variable."))))
 (terpri)))
 (format "variable `%s'" variable)))
 (defun sorted-key-descriptions (keys &optional separator)
 (let ((string (eval form)))
 (if (stringp string)
 	(with-displaying-help-buffer
 	 (insert string)))))
 ;;; help.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/help.el @ 442:abe6d1db359e r21-2-36