xemacs-beta: lisp/packages/hyper-apropos.el comparison

comparison lisp/packages/hyper-apropos.el @ 70:131b0175ea99 r20-0b30

Import from CVS: tag r20-0b30

author	cvs
date	Mon, 13 Aug 2007 09:02:59 +0200
parents	8d2a9b52c682
children	6a378aca36af

comparison

equal deleted inserted replaced

-:804d1389bcd6
+:131b0175ea99
 ;;  Mouse bindings and menus are provided for XEmacs.
 ;;
 ;; additions by Ben Wing <wing@666.com> July 1995:
 ;; added support for function aliases, made programmer's apropos be the
 ;; default, various other hacking.
-;; Massive changes by Christoph Wedler <wedler@fmi.uni-passau.de>
 ;;; Code:
 (or (fboundp 'pprint)
 (progn (autoload 'pp "pp")
 ;;;###autoload
 (defvar hypropos-show-brief-docs t
 "*If non-nil, `hyper-apropos' will display some documentation in the
 \"*Hyper Apropos*\" buffer.  Setting this to nil will speed up searches.")
-(defvar hypropos-shrink-window nil
-"*If non-nil, shrink *Hyper Help* buffer if possible.")
 (defvar hypropos-prettyprint-long-values t
 "*If non-nil, then try to beautify the printing of very long values.")
 ;; I changed this to true because I think it's more useful this way. --ben
 (defvar hypropos-programming-apropos t
 "*If non-nil, then `hyper-apropos' takes a bit longer and generates more
 output.  If nil, then only functions that are interactive and variables that
 are user variables are found by `hyper-apropos'.")
-(defvar hypropos-ref-buffer)
 (defvar hypropos-prev-wconfig)
 ;; #### - move this to subr.el
 (or (fboundp 'event-buffer)
 (defun event-buffer (event)
 			    (suppress-keymap map)
 			    (set-keymap-name map 'hypropos-help-map)
 			    ;; movement
 			    (define-key map " "     'scroll-up)
 			    (define-key map "b"     'scroll-down)
-			    (define-key map [delete] 'scroll-down)
-			    (define-key map [backspace] 'scroll-down)
 			    (define-key map "/"     'isearch-forward)
 			    (define-key map "?"     'isearch-backward)
 			    ;; follow links
 			    (define-key map "\r"    'hypropos-get-doc)
 			    (define-key map "s"     'hypropos-set-variable)
 "Keybindings for both the *Hyper Help* buffer and the *Hyper Apropos* buffer")
 (defvar hypropos-map (let ((map (make-sparse-keymap)))
 		       (set-keymap-name map 'hypropos-map)
 		       (set-keymap-parents map (list hypropos-help-map))
-		       ;; slightly different scrolling...
+		       ;; slightly differrent scrolling...
 		       (define-key map " "     'hypropos-scroll-up)
 		       (define-key map "b"     'hypropos-scroll-down)
-		       (define-key map [delete] 'hypropos-scroll-down)
-		       (define-key map [backspace] 'hypropos-scroll-down)
 		       ;; act on the current line...
 		       (define-key map "w"     'hypropos-where-is)
 		       (define-key map "i"     'hypropos-invoke-fn)
 		       (define-key map "s"     'hypropos-set-variable)
 		       ;; more administrativa...
 (defconst hypropos-junk-regexp "^Apropos\\|^Functions\\|^Variables\\|^$")
 (defvar hypropos-currently-showing nil)	; symbol documented in help buffer now
 (defvar hypropos-help-history nil)	; chain of symbols followed as links in
 					; help buffer
-(defvar hypropos-face-history nil)
-;;;(defvar hypropos-variable-history nil)
-;;;(defvar hypropos-function-history nil)
-(defvar hypropos-regexp-history nil)
 (defvar hypropos-last-regexp nil)	; regex used for last apropos
 (defconst hypropos-apropos-buf "*Hyper Apropos*")
 (defconst hypropos-help-buf "*Hyper Help*")
 ;;;###autoload
 (defun hyper-apropos (regexp toggle-apropos)
 "Display lists of functions and variables matching REGEXP
 in buffer \"*Hyper Apropos*\".  If optional prefix arg is given, then the value
 of `hypropos-programming-apropos' is toggled for this search.
 See also `hyper-apropos-mode'."
-(interactive (list (read-from-minibuffer "List symbols matching regexp: "
+(interactive "sList symbols matching regexp: \nP")
-					   nil nil nil 'hypropos-regexp-history)
-		     current-prefix-arg))
 (or (memq major-mode '(hyper-apropos-mode hyper-help-mode))
 (setq hypropos-prev-wconfig (current-window-configuration)))
 (if (string= "" regexp)
 (if (get-buffer hypropos-apropos-buf)
 	  (if toggle-apropos
 	 (not hypropos-programming-apropos)))
 (message "Re-running apropos...")
 (hyper-apropos hypropos-last-regexp nil))
 (defun hypropos-grok-functions (fns)
-(let (fn bind doc type)
+(let (fn bind type)
 (while (setq fn (car fns))
 (setq bind (symbol-function fn)
 	    type (cond ((subrp bind) ?i)
 		       ((compiled-function-p bind) ?b)
 		       ((consp bind) (or (cdr
 					 ??))
 		       (t ? )))
 (insert type (if (commandp fn) "* " "  "))
 (insert-face (format "%-30S" fn) 'hyperlink)
 (and hypropos-show-brief-docs
-	   (setq doc (documentation fn))
+	   (if (function-obsolete-p fn)
-	   (insert-face (if doc
+	       (insert-face " - Obsolete." 'documentation)
-			    (concat " - "
+	     (let ((doc (documentation fn)))
-				    (substring doc 0 (string-match "\n" doc)))
+	       (if (not doc)
-			  " Not documented.")
+		   (insert-face " - Not documented." 'documentation)
-			'documentation))
+		 (insert-face (concat " - "
+				      (substring doc 0
+						 (string-match "\n" doc)))
+			      'documentation)))))
 (insert ?\n)
 (setq fns (cdr fns))
 )))
 (defun hypropos-grok-variables (vars)
-(let (var doc userp)
+(let (var userp)
 (while (setq var (car vars))
 (setq userp (user-variable-p var)
 	    vars (cdr vars))
 (insert (if userp " * " "   "))
 (insert-face (format "%-30S" var) 'hyperlink)
 (and hypropos-show-brief-docs
-	   (setq doc (documentation-property var 'variable-documentation))
+	   (if (variable-obsolete-p var)
-	   (insert-face (if doc
+	       (insert-face " - Obsolete." 'documentation)
-			    (concat " - " (substring doc (if userp 1 0)
+	     (let ((doc (documentation-property var 'variable-documentation)))
-						     (string-match "\n" doc)))
+	       (if (not doc)
-			  " - Not documented.")
+		   (insert-face " - Not documented." 'documentation)
-			'documentation))
+		 (insert-face (concat " - "
+				      (substring doc (if userp 1 0)
+						 (string-match "\n" doc)))
+			      'documentation)))))
 (insert ?\n)
 )))
 ;; ---------------------------------------------------------------------- ;;
 (setq mode-name "Hyper-Apropos"
 	major-mode 'hyper-apropos-mode
 	buffer-read-only t
 	truncate-lines t
 	hypropos-last-regexp regexp
-	modeline-buffer-identification
+	modeline-buffer-identification (concat "Hyper Apropos: "
-	(list (cons modeline-buffer-id-left-extent "Hyper Apropos: ")
+					       "\"" regexp "\""))
-	      (cons modeline-buffer-id-right-extent (concat "\"" regexp "\""))))
 (setq mode-motion-hook 'mode-motion-highlight-line)
 (use-local-map hypropos-map)
 (run-hooks 'hyper-apropos-mode-hook))
 ;; ---------------------------------------------------------------------- ;;
-;; similar to `describe-key-briefly', copied from prim/help.el by CW
 ;;;###autoload
-(defun hyper-describe-key (key)
+(defun hyper-describe-variable (symbol)
-(interactive "kDescribe key: ")
+"Hypertext drop-in replacement for `describe-variable'.
-(hyper-describe-key-briefly key t))
-;;;###autoload
-(defun hyper-describe-key-briefly (key &optional show)
-(interactive "kDescribe key briefly: \nP")
-(let (menup defn interm final msg)
-(setq defn (key-or-menu-binding key 'menup))
-(if (or (null defn) (integerp defn))
-(or (numberp show) (message "%s is undefined" (key-description key)))
-(cond ((stringp defn)
-	     (setq interm defn
-		   final (key-binding defn)))
-	    ((vectorp defn)
-	     (setq interm (append defn nil))
-	     (while (and interm
-			 (member (key-binding (vector (car interm)))
-				 '(universal-argument digit-argument)))
-	       (setq interm (cdr interm)))
-	     (while (and interm
-			 (not (setq final (key-binding (vconcat interm)))))
-	       (setq interm (butlast interm)))
-	     (if final
-		 (setq interm (vconcat interm))
-	       (setq interm defn
-		     final (key-binding defn)))))
-(setq msg (format
-		 "%s runs %s%s%s"
-		 ;; This used to say 'This menu item' but it could also
-		 ;; be a scrollbar event.  We can't distinguish at the
-		 ;; moment.
-		 (if menup "This item" (key-description key))
-		 ;;(if (symbolp defn) defn (key-description defn))
-		 (if (symbolp defn) defn (prin1-to-string defn))
-		 (if final (concat ", " (key-description interm) " runs ") "")
-		 (if final
-		     (if (symbolp final) final (prin1-to-string final))
-		   "")))
-(if (numberp show)
-	  (or (not (symbolp defn))
-	      (memq (symbol-function defn)
-		    '(zkey-init-kbd-macro zkey-init-kbd-fn))
-	      (progn (princ msg) (princ "\n")))
-	(message "%s" msg)
-	(if final (setq defn final))
-	(if (and (or (symbolp defn) (symbolp (setq defn (car-safe defn))))
-		 defn
-		 show)
-	    (hypropos-get-doc defn t))))))
-;;;###autoload
-(defun hyper-describe-face (symbol &optional this-ref-buffer)
-"Describe face..
 See also `hyper-apropos' and `hyper-describe-function'."
 ;; #### - perhaps a prefix arg should suppress the prompt...
 (interactive
-(let (v val)
+(let* ((v (variable-at-point))
-(setq v (hypropos-this-symbol))	; symbol under point
+(val (let ((enable-recursive-minibuffers t))
-(or (find-face v)
-	 (setq v (variable-at-point)))
-(setq val (let ((enable-recursive-minibuffers t))
 (completing-read
-		  (concat (if (hypropos-follow-ref-buffer current-prefix-arg)
+		  (if v
-			      "Follow face"
+		      (format "Describe variable (default %s): " v)
-			    "Describe face")
+		    "Describe variable: ")
-			  (if v
+		  obarray 'boundp t))))
-			      (format " (default %s): " v)
+(list (if (string= val "") v (intern-soft val)))))
-			    ": "))
-		  (mapcar (function (lambda (x) (list (symbol-name x))))
-			  (face-list))
-		  nil t nil 'hypropos-face-history)))
-(list (if (string= val "")
-	       (progn (push (symbol-name v) hypropos-face-history) v)
-	     (intern-soft val))
-	   current-prefix-arg)))
 (if (null symbol)
 (message "Sorry, nothing to describe.")
 (or (memq major-mode '(hyper-apropos-mode hyper-help-mode))
 	(setq hypropos-prev-wconfig (current-window-configuration)))
-(hypropos-get-doc symbol t nil this-ref-buffer)))
+(hypropos-get-doc symbol t)))
 ;;;###autoload
-(defun hyper-describe-variable (symbol &optional this-ref-buffer)
+(defun hyper-describe-function (symbol)
-"Hypertext drop-in replacement for `describe-variable'.
+"Hypertext replacement for `describe-function'.  Unlike `describe-function'
-See also `hyper-apropos' and `hyper-describe-function'."
+in that the symbol under the cursor is the default if it is a function.
+See also `hyper-apropos' and `hyper-describe-variable'."
 ;; #### - perhaps a prefix arg should suppress the prompt...
-(interactive (list (hypropos-read-variable-symbol
+(interactive
-		      (if (hypropos-follow-ref-buffer current-prefix-arg)
+(let (fn val)
-			  "Follow variable"
+(setq fn (hypropos-this-symbol))	; symbol under point
-			"Describe variable"))
+(or (fboundp fn)
-		     current-prefix-arg))
+	 (setq fn (function-called-at-point)))
+(setq val (let ((enable-recursive-minibuffers t))
+		 (completing-read
+		  (if fn
+		      (format "Describe function (default %s): " fn)
+		    "Describe function: ")
+		  obarray 'fboundp t)))
+(list (if (equal val "") fn (intern-soft val)))))
 (if (null symbol)
 (message "Sorry, nothing to describe.")
 (or (memq major-mode '(hyper-apropos-mode hyper-help-mode))
 	(setq hypropos-prev-wconfig (current-window-configuration)))
-(hypropos-get-doc symbol t nil this-ref-buffer)))
+(hypropos-get-doc symbol t)))
-(defun hyper-where-is (symbol)
-"Print message listing key sequences that invoke specified command."
-(interactive (list (hypropos-read-function-symbol "Where is function")))
-(if (null symbol)
-(message "Sorry, nothing to describe.")
-(where-is symbol)))
-;;;###autoload
-(defun hyper-describe-function (symbol &optional this-ref-buffer)
-"Hypertext replacement for `describe-function'.  Unlike `describe-function'
-in that the symbol under the cursor is the default if it is a function.
-See also `hyper-apropos' and `hyper-describe-variable'."
-;; #### - perhaps a prefix arg should suppress the prompt...
-(interactive (list (hypropos-read-function-symbol
-		      (if (hypropos-follow-ref-buffer current-prefix-arg)
-			  "Follow function"
-			"Describe function"))
-		     current-prefix-arg))
-(if (null symbol)
-(message "Sorry, nothing to describe.")
-(or (memq major-mode '(hyper-apropos-mode hyper-help-mode))
-	(setq hypropos-prev-wconfig (current-window-configuration)))
-(hypropos-get-doc symbol t nil this-ref-buffer)))
-;;;###autoload
-(defun hypropos-read-variable-symbol (prompt &optional predicate)
-"Hypertext drop-in replacement for `describe-variable'.
-See also `hyper-apropos' and `hyper-describe-function'."
-;; #### - perhaps a prefix arg should suppress the prompt...
-(or predicate (setq predicate 'boundp))
-(let (v val)
-(setq v (hypropos-this-symbol))	; symbol under point
-(or (funcall predicate v)
-	(setq v (variable-at-point)))
-(or (funcall predicate v)
-	(setq v nil))
-(setq val (let ((enable-recursive-minibuffers t))
-		(completing-read
-		 (concat prompt
-			 (if v
-			     (format " (default %s): " v)
-			   ": "))
-		 obarray predicate t nil 'variable-history)))
-(if (string= val "")
-	(progn (push (symbol-name v) variable-history) v)
-(intern-soft val))))
-(defun hypropos-read-function-symbol (prompt)
-"Read function symbol from minibuffer."
-(let ((fn (hypropos-this-symbol))
-	val)
-(or (fboundp fn)
-	(setq fn (function-called-at-point)))
-(setq val (let ((enable-recursive-minibuffers t))
-		(completing-read (if fn
-				     (format "%s (default %s): " prompt fn)
-				   (format "%s: " prompt))
-				 obarray 'fboundp t nil
-				 'function-history)))
-(if (equal val "")
-	(progn (push (symbol-name fn) function-history) fn)
-(intern-soft val))))
 (defun hypropos-last-help (arg)
 "Go back to the last symbol documented in the *Hyper Help* buffer."
 (interactive "P")
-(let ((win (get-buffer-window hypropos-help-buf)))
+(let ((win (get-buffer-window hypropos-help-buf))
-(or arg (setq arg (if win 1 0)))
+	(n (prefix-numeric-value arg)))
-(cond ((= arg 0))
+(cond ((and (not win) (not arg))
-	  ((<= (length hypropos-help-history) arg)
+	   ;; don't alter the help-history, just redisplay
+	   )
+	  ((<= (length hypropos-help-history) n)
 	   ;; go back as far as we can...
 	   (setcdr (nreverse hypropos-help-history) nil))
 	  (t
-	   (setq hypropos-help-history (nthcdr arg hypropos-help-history))))
+	   (setq hypropos-help-history (nthcdr n hypropos-help-history))))
-(if (or win (> arg 0))
+(hypropos-get-doc (car hypropos-help-history) t)))
-	(hypropos-get-doc (car hypropos-help-history) t)
-(display-buffer hypropos-help-buf))))
+(defun hypropos-get-doc (&optional symbol force type)
-(defun hypropos-insert-face (string &optional face)
-"Insert STRING and fontify some parts with face `hyperlink'."
-(let ((beg (point)) end)
-(insert-face string (or face 'documentation))
-(setq end (point))
-(goto-char beg)
-(while (re-search-forward
-	    "`\\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)'"
-	    end 'limit)
-(set-extent-face (make-extent (match-beginning 1) (match-end 1))
-		       'hyperlink))
-(goto-char beg)
-(while (re-search-forward
-	    "M-x \\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)"
-	    end 'limit)
-(set-extent-face (make-extent (match-beginning 1) (match-end 1))
-		       'hyperlink))))
-(defun hypropos-insert-keybinding (keys string)
-(if keys
-(insert "  (" string " bound to \""
-	      (mapconcat 'key-description
-			 (sort keys #'(lambda (x y)
-					(< (length x) (length y))))
-			 "\", \"")
-	      "\")\n")))
-(defun hypropos-insert-section-heading (alias-desc &optional desc)
-(or desc (setq desc alias-desc
-		 alias-desc nil))
-(if alias-desc
-(setq desc (concat alias-desc
-			 (if (memq (aref desc 0)
-				   '(?a ?e ?i ?o ?u))
-			     ", an " ", a ")
-			 desc)))
-(aset desc 0 (upcase (aref desc 0))) ; capitalize
-(goto-char (point-max))
-(newline 3) (delete-blank-lines) (newline 2)
-(hypropos-insert-face desc 'section-heading))
-(defun hypropos-insert-value (string symbol val)
-(insert-face string 'heading)
-(insert (if (symbol-value symbol)
-	      (if (or (null val) (eq val t) (integerp val))
-		  (prog1
-		      (symbol-value symbol)
-		    (set symbol nil))
-		"see below")
-	    "is void")))
-(defun hypropos-follow-ref-buffer (this-ref-buffer)
-(and (not this-ref-buffer)
-(eq major-mode 'hyper-help-mode)
-hypropos-ref-buffer
-(buffer-live-p hypropos-ref-buffer)))
-(defun hypropos-get-alias (symbol alias-p next-symbol &optional use)
-"Return (TERMINAL-SYMBOL . ALIAS-DESC)."
-(let (aliases)
-(while (funcall alias-p symbol)
-(setq aliases (cons (if use (funcall use symbol) symbol) aliases))
-(setq symbol (funcall next-symbol symbol)))
-(cons symbol
-	  (and aliases
-	       (concat "an alias for `"
-		       (mapconcat 'symbol-name
-				  (nreverse aliases)
-				  "',\nwhich is an alias for `")
-		       "'")))))
-;;;###autoload
-(defun hypropos-get-doc (&optional symbol force type this-ref-buffer)
 ;; #### - update this docstring
 "Toggle display of documentation for the symbol on the current line."
 ;; SYMBOL is the symbol to document.  FORCE, if non-nil, means to
 ;; regenerate the documentation even if it already seems to be there.  And
 ;; TYPE, if present, forces the generation of only variable documentation
 		  ;; record that in the help history.
 		  (cons symbol hypropos-help-history)
 		;; otherwise clear the history because it's a new search.
 		(list symbol))))
 (save-excursion
-(if (hypropos-follow-ref-buffer this-ref-buffer)
+(set-buffer (get-buffer-create hypropos-help-buf))
-	  (set-buffer hypropos-ref-buffer)
+(setq buffer-read-only nil)
-	(setq hypropos-ref-buffer (current-buffer)))
+(erase-buffer)
-(let (standard-output
+(let ((standard-output (current-buffer))
-	    ok beg
+	    ok beg desc
-	    newsym symtype doc obsolete
+	    ftype macrop fndef
-	    (local mode-name)
+	    keys val doc
-	    global local-str global-str
+	    obsolete aliases alias-desc)
-	    font fore back undl
+	(insert-face (format "`%s'\n\n" symbol) 'major-heading)
-	    aliases alias-desc desc)
-	(save-excursion
-	  (set-buffer (get-buffer-create hypropos-help-buf))
-	  ;;(setq standard-output (current-buffer))
-	  (setq buffer-read-only nil)
-	  (erase-buffer)
-	  (insert-face (format "`%s'" symbol) 'major-heading)
-	  (insert (format " (buffer: %s, mode: %s)\n"
-			  (buffer-name hypropos-ref-buffer)
-			  local)))
-	;; function ----------------------------------------------------------
 	(and (memq 'function type)
 	     (fboundp symbol)
 	     (progn
-	       (setq ok t)
+	       (setq ok t
-	       (setq aliases (hypropos-get-alias (symbol-function symbol)
+		     fndef (symbol-function symbol))
-						 'symbolp
+	       (while (symbolp fndef)
-						 'symbol-function)
+		 (setq aliases (cons fndef aliases))
-		     newsym (car aliases)
+		 (setq fndef (symbol-function fndef)))
-		     alias-desc (cdr aliases))
+	       (if (eq 'macro (car-safe fndef))
-	       (if (eq 'macro (car-safe newsym))
+		   (setq macrop t
-		   (setq desc "macro"
+			 fndef (cdr fndef)))
-			 newsym (cdr newsym))
+	       (setq aliases (nreverse aliases))
-		 (setq desc "function"))
+	       ;; #### - the gods of internationalization shall strike me down!
-	       (setq symtype (cond ((subrp newsym)                   'subr)
+	       (while aliases
-				   ((compiled-function-p newsym)     'bytecode)
+		 (if alias-desc
-				   ((eq (car-safe newsym) 'autoload) 'autoload)
+		     (setq alias-desc (concat alias-desc ",\nwhich is ")))
-				   ((eq (car-safe newsym) 'lambda)   'lambda))
+		 (setq alias-desc (concat alias-desc
+					  (format "an alias for `%s'"
+						  (car aliases))))
+		 (setq aliases (cdr aliases)))
+	       (setq ftype (cond ((subrp fndef)                   'subr)
+				 ((compiled-function-p fndef)     'bytecode)
+				 ((eq (car-safe fndef) 'autoload) 'autoload)
+				 ((eq (car-safe fndef) 'lambda)	  'lambda))
 		     desc (concat (if (commandp symbol) "interactive ")
-				  (cdr (assq symtype
+				  (cdr (assq ftype
 					     '((subr     . "built-in ")
 					       (bytecode . "compiled Lisp ")
 					       (autoload . "autoloaded Lisp ")
 					       (lambda   . "Lisp "))))
-				  desc)
+				  (if macrop "macro" "function")
-		     local (current-local-map)
+				  ))
-		     global (current-global-map)
+	       (if alias-desc
-		     obsolete (get symbol 'byte-obsolete-info)
+		   (setq desc (concat alias-desc
+				      (if (memq (aref desc 0)
+						'(?a ?e ?i ?o ?u))
+					  ", an " ", a ")
+				      desc)))
+	       (aset desc 0 (upcase (aref desc 0))) ; capitalize
+	       (insert-face desc 'section-heading)
+	       (and (eq ftype 'autoload)
+		    (insert (format ", (autoloaded from \"%s\")"
+				    (nth 1 fndef))))
+	       ;; #### - should also show local binding in some other
+	       ;; buffer so that this function can be used in place of
+	       ;; describe-function and describe-variable.
+	       (if (setq keys (where-is-internal symbol (current-global-map)
+						 nil nil nil))
+		   (insert (format ", (globally bound to %s)"
+				   (mapconcat
+				    #'(lambda (x)
+					(format "\"%s\""
+						(key-description x)))
+				    (sort keys #'(lambda (x y)
+						   (< (length x) (length y))))
+				    ", "))))
+	       (insert ":\n\n")
+	       (setq beg (point)
 		     doc (or (documentation symbol) "function not documented"))
-	       (save-excursion
+	       (insert-face "arguments: " 'heading)
-		 (set-buffer hypropos-help-buf)
+	       (cond ((eq ftype 'lambda)
-		 (goto-char (point-max))
+		      (princ (or (nth 1 fndef) "()")))
-		 (setq standard-output (current-buffer))
+		     ((eq ftype 'bytecode)
-		 (hypropos-insert-section-heading alias-desc desc)
+		      (princ (or (if (fboundp 'compiled-function-arglist)
-		 (and (eq symtype 'autoload)
+				     (compiled-function-arglist fndef)
-		      (insert (format ", (autoloaded from \"%s\")"
+				   (aref fndef 0)) "()")))
-				      (nth 1 newsym))))
+		     ((and (eq ftype 'subr)
-		 (insert ":\n")
+			   (string-match
-		 (if local
+			    "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'"
-		     (hypropos-insert-keybinding
+			    doc))
-		      (where-is-internal symbol (list local) nil nil nil)
+		      (insert (substring doc
-		      "locally"))
+					 (match-beginning 1)
-		 (hypropos-insert-keybinding
+					 (match-end 1)))
-		  (where-is-internal symbol (list global) nil nil nil)
+		      (setq doc (substring doc 0 (match-beginning 0))))
-		  "globally")
+		     (t (princ "[not available]")))
-		 (insert "\n")
+	       (insert "\n\n")
-		 (if obsolete
+	       (let ((new
-		     (hypropos-insert-face
+		      ;; cookbook from bytecomp.el
-		      (format "%s is an obsolete function; %s\n\n" symbol
+		      (get symbol 'byte-obsolete-info)))
-			      (if (stringp (car obsolete))
+		 (and new
-				  (car obsolete)
+		      (insert-face
-				(format "use `%s' instead." (car obsolete))))
+		       (format "%s is an obsolete function; %s\n\n" symbol
-		      'warning))
+			       (if (stringp (car new))
-		 (setq beg (point))
+				   (car new)
-		 (insert-face "arguments: " 'heading)
+				 (format "use %s instead." (car new))))
-		 (cond ((eq symtype 'lambda)
+		       'warning)))
-			(princ (or (nth 1 newsym) "()")))
+	       (insert-face doc 'documentation)
-		       ((eq symtype 'bytecode)
+	       (indent-rigidly beg (point) 1)
-			(princ (or (aref newsym 0) "()")))
+	       (insert"\n\n")
-		       ((and (eq symtype 'subr)
+	       ))
-			     (string-match
-			      "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'"
-			      doc))
-			(insert (substring doc
-					   (match-beginning 1)
-					   (match-end 1)))
-			(setq doc (substring doc 0 (match-beginning 0))))
-		       ((and (eq symtype 'subr)
-			     (string-match
-			      "[\n\t ]*([^\n\t )]+[\t ]*\\([^\n)]+\\)?)\\(:[\t ]*\\|\n?\\'\\)"
-			      doc))
-			(insert "("
-				(if (match-end 1)
-				    (substring doc
-					       (match-beginning 1)
-					       (match-end 1)))
-				")")
-			(setq doc (substring doc (match-end 0))))
-		       (t (princ "[not available]")))
-		 (insert "\n\n")
-		 (hypropos-insert-face doc)
-		 (insert "\n")
-		 (indent-rigidly beg (point) 2))))
-	;; variable ----------------------------------------------------------
 	(and (memq 'variable type)
-	     (or (boundp symbol) (default-boundp symbol))
+	     (boundp symbol)
 	     (progn
 	       (setq ok t)
-	       (setq aliases (hypropos-get-alias symbol
+	       (insert-face (if (user-variable-p symbol)
-						 'variable-alias
+				"User variable"
-						 'variable-alias
+			      "Variable")
-						 'variable-alias)
+			    'section-heading)
-		     newsym (car aliases)
+	       (and (local-variable-p symbol nil t)
-		     alias-desc (cdr aliases))
+		    (insert ", local when set"))
-	       (setq symtype (or (local-variable-p newsym (current-buffer))
+	       (insert ":\n\n")
-				 (and (local-variable-p newsym
+	       (setq beg (point)
-							(current-buffer) t)
+		     val (prin1-to-string (symbol-value symbol))
-				      'auto-local))
+		     doc (or (documentation-property
-		     desc (concat (if (user-variable-p newsym)
+			      symbol 'variable-documentation)
-				      "user variable"
-				    "variable")
-				  (cond ((eq symtype t) ", buffer-local")
-					((eq symtype 'auto-local)
-					 ", local when set")))
-		     local (and (boundp newsym)
-				(symbol-value newsym))
-		     local-str (and (boundp newsym)
-				    (prin1-to-string local))
-		     global (and (eq symtype t)
-				 (default-boundp newsym)
-				 (default-value newsym))
-		     global-str (and (eq symtype t)
-				     (default-boundp newsym)
-				     (prin1-to-string global))
-		     obsolete (get symbol 'byte-obsolete-variable)
-		     doc (or (documentation-property symbol
-						     'variable-documentation)
 			     "variable not documented"))
-	       (save-excursion
-		 (set-buffer hypropos-help-buf)
+	       (let ((ob (get symbol 'byte-obsolete-variable)))
-		 (goto-char (point-max))
+		 (setq obsolete
-		 (setq standard-output (current-buffer))
+		       (and ob (format "%s is an obsolete variable; %s\n\n"
-		 (hypropos-insert-section-heading alias-desc desc)
+				       symbol
-		 (insert ":\n\n")
+				       (if (stringp ob)
-		 (setq beg (point))
+					   ob
-		 (if obsolete
+					 (format "use %s instead." ob))))))
-		     (hypropos-insert-face
+	       ;; generally, the value of the variable is short and the
-		      (format "%s is an obsolete function; %s\n\n" symbol
+	       ;; documentation of the variable long, so it's desirable
-			      (if (stringp obsolete)
+	       ;; to see all of the value and the start of the
-				  obsolete
+	       ;; documentation.  Some variables, though, have huge and
-				(format "use `%s' instead." obsolete)))
+	       ;; nearly meaningless values that force you to page
-		      'warning))
+	       ;; forward just to find the doc string.  That is
-		 ;; generally, the value of the variable is short and the
+	       ;; undesirable.
-		 ;; documentation of the variable long, so it's desirable
+	       (if (< (length val) 69)	; 80 cols.  docstrings assume this.
-		 ;; to see all of the value and the start of the
+		   (progn (insert-face "value: " 'heading)
-		 ;; documentation.  Some variables, though, have huge and
+			  (insert (format "%s\n\n" val))
-		 ;; nearly meaningless values that force you to page
+			  (and obsolete (insert-face obsolete 'warning))
-		 ;; forward just to find the doc string.  That is
+			  (insert-face doc 'documentation))
-		 ;; undesirable.
+		 (insert "(see below for value)\n\n")
-		 (if (and (or (null local-str) (< (length local-str) 69))
+		 (and obsolete (insert-face obsolete 'warning))
-			  (or (null global-str) (< (length global-str) 69)))
+		 (insert-face doc 'documentation)
-					; 80 cols.  docstrings assume this.
+		 (insert "\n\n")
-		     (progn (insert-face "value: " 'heading)
+		 (insert-face "value: " 'heading)
-			    (insert (or local-str "is void"))
+		 (if hypropos-prettyprint-long-values
-			    (if (eq symtype t)
+		     (let ((pp-print-readably nil))
-				(progn
+		       (pprint (symbol-value symbol)))
-				  (insert "\n")
+		   (insert val)))
-				  (insert-face "default value: " 'heading)
+	       (indent-rigidly beg (point) 2)
-				  (insert (or global-str "is void"))))
+	       ))
-			    (insert "\n\n")
-			    (hypropos-insert-face doc))
-		   (hypropos-insert-value "value: " 'local-str local)
-		   (if (eq symtype t)
-		       (progn
-			 (insert ", ")
-			 (hypropos-insert-value "default-value: "
-						'global-str global)))
-		   (insert "\n\n")
-		   (hypropos-insert-face doc)
-		   (if local-str
-		       (progn
-			 (newline 3) (delete-blank-lines) (newline 1)
-			 (insert-face "value: " 'heading)
-			 (if hypropos-prettyprint-long-values
-			     (condition-case nil
-				 (let ((pp-print-readably nil)) (pprint local))
-			       (error (insert local-str)))
-			   (insert local-str))))
-		   (if global-str
-		       (progn
-			 (newline 3) (delete-blank-lines) (newline 1)
-			 (insert-face "default value: " 'heading)
-			 (if hypropos-prettyprint-long-values
-			     (condition-case nil
-				 (let ((pp-print-readably nil)) (pprint global))
-			       (error (insert global-str)))
-			   (insert global-str)))))
-		 (indent-rigidly beg (point) 2))))
-	;; face --------------------------------------------------------------
 	(and (memq 'face type)
 	     (find-face symbol)
 	     (progn
 	       (setq ok t)
-	       (copy-face symbol 'hypropos-temp-face 'global)
-	       (mapcar (function
-			(lambda (property)
-			  (setq symtype (face-property-instance symbol
-								property))
-			  (if symtype
-			      (set-face-property 'hypropos-temp-face
-						 property
-						 symtype))))
-		       built-in-face-specifiers)
-	       (setq font (cons (face-property-instance symbol 'font nil 0 t)
-				(face-property-instance symbol 'font))
-		     fore (cons (face-foreground-instance symbol nil 0 t)
-				(face-foreground-instance symbol))
-		     back (cons (face-background-instance symbol nil 0 t)
-				(face-background-instance symbol))
-		     undl (cons (face-underline-p symbol nil 0 t)
-				(face-underline-p symbol))
-		     doc  (face-doc-string symbol))
 	       ;; #### - add some code here
-	       (save-excursion
+	       (insert "Face documentation is \"To be implemented.\"\n\n")
-		 (set-buffer hypropos-help-buf)
+	       )
-		 (setq standard-output (current-buffer))
+	     )
-		 (hypropos-insert-section-heading "Face:\n\n  ")
+	(or ok (insert-face "symbol is not currently bound" 'heading)))
-		 (insert-face "ABCDEFHIJKLMNOPQRSTUVWXYZ abcdefhijklmnopqrstuvwxyz 0123456789"
-			      'hypropos-temp-face)
-		 (newline 2)
-		 (insert-face "  Font: " 'heading)
-		 (insert (format (if (numberp (car font)) "(%s)\n" "%s\n")
-				 (and (cdr font)
-				      (font-instance-name (cdr font)))))
-		 (insert-face "  Foreground: " 'heading)
-		 (insert (format (if (numberp (car fore)) "(%s)\n" "%s\n")
-				 (and (cdr fore)
-				      (color-instance-name (cdr fore)))))
-		 (insert-face "  Background: " 'heading)
-		 (insert (format (if (numberp (car back)) "(%s)\n" "%s\n")
-				 (and (cdr back)
-				      (color-instance-name (cdr back)))))
-		 (insert-face "  Underline: " 'heading)
-		 (insert (format (if (numberp (car undl)) "(%s)\n" "%s\n")
-				 (cdr undl)))
-		 (if doc
-		     (progn
-		       (newline)
-		       (setq beg (point))
-		       (insert doc)
-		       (indent-rigidly beg (point) 2))))))
-	;; not bound & property list -----------------------------------------
-	(or ok
-	    (save-excursion
-	      (set-buffer hypropos-help-buf)
-	      (hypropos-insert-section-heading
-	       "symbol is not currently bound\n")))
-	(if (and (setq symtype (symbol-plist symbol))
-		 (or (> (length symtype) 2)
-		     (not (memq 'variable-documentation symtype))))
-	    (save-excursion
-	      (set-buffer hypropos-help-buf)
-	      (goto-char (point-max))
-	      (setq standard-output (current-buffer))
-	      (hypropos-insert-section-heading "property-list:\n\n")
-	      (while symtype
-		(if (memq (car symtype)
-			  '(variable-documentation byte-obsolete-info))
-		    (setq symtype (cdr symtype))
-		  (insert-face (concat "  " (symbol-name (car symtype))
-				       ": ")
-			       'heading)
-		  (setq symtype (cdr symtype))
-		  (indent-to 32)
-		  (insert (prin1-to-string (car symtype)) "\n"))
-		(setq symtype (cdr symtype)))))))
-(save-excursion
-(set-buffer hypropos-help-buf)
 (goto-char (point-min))
 ;; pop up window and shrink it if it's wasting space
-(if hypropos-shrink-window
+(shrink-window-if-larger-than-buffer
-	  (shrink-window-if-larger-than-buffer
+(display-buffer (current-buffer)))
-	   (display-buffer (current-buffer)))
+(hyper-help-mode))    )
-	(display-buffer (current-buffer)))
+(setq hypropos-currently-showing symbol))
-(hyper-help-mode))
-(setq hypropos-currently-showing symbol)))
 ; -----------------------------------------------------------------------------
 (defun hyper-help-mode ()
 "Major mode for hypertext XEmacs help.  In this mode, you can quickly
 			;; !@(*$^%%# stupid backquote implementation!!!
 			(skip-chars-forward "`")
 			(point)))
 		  (en (progn
 			(skip-syntax-forward "w_")
-			(skip-chars-backward ".':") ; : for Local Variables
+			(skip-chars-backward ".")
 			(point))))
 	     (and (not (eq st en))
 		  (intern-soft (buffer-substring st en))))))))
 (defun hypropos-where-is (symbol)
 (cond ((not (fboundp fn))
 	 (error "%S is not a function" fn))
 	(t (call-interactively fn))))
 ;;;###autoload
-(defun hyper-set-variable (var val &optional this-ref-buffer)
+(defun hypropos-set-variable (var val)
-(interactive
-(let ((var (hypropos-read-variable-symbol
-	       (if (hypropos-follow-ref-buffer current-prefix-arg)
-		   "In ref buffer, set user option"
-		 "Set user option")
-	       'user-variable-p)))
-(list var (hypropos-read-variable-value var) current-prefix-arg)))
-(hypropos-set-variable var val this-ref-buffer))
-;;;###autoload
-(defun hypropos-set-variable (var val &optional this-ref-buffer)
 "Interactively set the variable on the current line."
 (interactive
-(let ((var (hypropos-this-symbol)))
+(let ((var (save-excursion
-(or (and var (boundp var))
+		(and (eq major-mode 'hypropos-help-mode)
-	 (and (setq var (and (eq major-mode 'hyper-help-mode)
+		     (goto-char (point-min)))
-			     (save-excursion
+		(hypropos-this-symbol))))
-			       (goto-char (point-min))
+(or (boundp var)
-			       (hypropos-this-symbol))))
+	 (setq var (completing-read "Set variable: "
-	      (boundp var))
+				    obarray 'boundp t)))
-	 (setq var nil))
+(hypropos-get-doc var t)
-(list var (hypropos-read-variable-value var))))
+(list var
-(and var
+	   (let ((prop (get var 'variable-interactive))
-(boundp var)
+		 (print-readably t)
-(progn
+		 (val (symbol-value var)))
-	 (if (hypropos-follow-ref-buffer this-ref-buffer)
+	     (if prop
-	     (save-excursion
+		 (call-interactively (list 'lambda '(arg)
-	       (set-buffer hypropos-ref-buffer)
+					   (list 'interactive prop)
-	       (set var val))
+					   'arg))
-	   (set var val))
+	       (eval-minibuffer
-	 (hypropos-get-doc var t '(variable) this-ref-buffer))))
+		(format "Set `%s' to value (evaluated): " var)
+		(format (if (or (consp val)
-(defun hypropos-read-variable-value (var &optional this-ref-buffer)
+				(and (symbolp val)
-(and var
+				     (not (memq val '(t nil)))))
-(boundp var)
+			    "'%s" "%s")
-(let ((prop (get var 'variable-interactive))
+			(prin1-to-string val))))))
-	     (print-readably t)
+))
-	     val str)
+(set var val)
-	 (hypropos-get-doc var t '(variable) current-prefix-arg)
+(hypropos-get-doc var t))
-	 (if prop
-	     (call-interactively (list 'lambda '(arg)
-				       (list 'interactive prop)
-				       'arg))
-	   (setq val (if (hypropos-follow-ref-buffer this-ref-buffer)
-			 (save-excursion
-			   (set-buffer hypropos-ref-buffer)
-			   (symbol-value var))
-		       (symbol-value var))
-		 str (prin1-to-string val))
-	   (eval-minibuffer
-	    (format "Set %s `%s' to value (evaluated): "
-		    (if (user-variable-p var) "user option" "Variable")
-		    var)
-	    (condition-case nil
-		(progn
-		  (read str)
-		  (format (if (or (consp val)
-				  (and (symbolp val)
-				       (not (memq val '(t nil)))))
-			      "'%s" "%s")
-			  str))
-	      (error nil)))))))
 ;; ---------------------------------------------------------------------- ;;
 (defun hypropos-find-tag (&optional tag-name)
 "Find the tag for the symbol on the current line in other window.  In
 (popup-menu hypropos-menu)))
 (provide 'hyper-apropos)
 ;; end of hyper-apropos.el

Mercurial > hg > xemacs-beta

comparison lisp/packages/hyper-apropos.el @ 70:131b0175ea99 r20-0b30