xemacs-beta: lisp/hyperbole/hactypes.el comparison

comparison lisp/hyperbole/hactypes.el @ 24:4103f0995bd7 r19-15b95

Import from CVS: tag r19-15b95

author	cvs
date	Mon, 13 Aug 2007 08:51:03 +0200
parents	376386a54a3c
children	131b0175ea99

comparison

equal deleted inserted replaced

-:0edd3412f124
+:4103f0995bd7
 ;; SUMMARY:      Default action types for Hyperbole.
 ;; USAGE:        GNU Emacs Lisp Library
 ;; KEYWORDS:     extensions, hypermedia
 ;;
 ;; AUTHOR:       Bob Weiner
-;; ORG:          Brown U.
+;; ORG:          InfoDock Associates
+;;
+;; This file is part of Hyperbole.
+;; Available for use and distribution under the same terms as GNU Emacs.
+;;
+;; Copyright (C) 1991-1997  Free Software Foundation, Inc.
+;; Developed with support from Motorola Inc.
 ;;
 ;; ORIG-DATE:    23-Sep-91 at 20:34:36
-;; LAST-MOD:     28-Oct-95 at 02:33:45 by Bob Weiner
+;; LAST-MOD:     20-Feb-97 at 11:16:36 by Bob Weiner
 ;;; ************************************************************************
 ;;; Other required Elisp libraries
 ;;; ************************************************************************
 (mapcar 'require '(hbut hpath hargs hact hmail))
 ;;; ************************************************************************
 (defact annot-bib (key)
 "Follows internal ref KEY within an annotated bibliography, delimiters=[]."
 (interactive "sReference key (no []): ")
-(let ((opoint (point)))
+(let ((opoint (point))
-(goto-char 1)
+	(key-regexp (concat "^[*]*[ \t]*\\\[" (ebut:key-to-label key) "\\\]")))
-(if (re-search-forward
+(goto-char (point-min))
-	 (concat "^[*]*[ \t]*\\\[" (ebut:key-to-label key) "\\\]") nil t)
+(if (re-search-forward key-regexp nil t)
-	(progn
+	(progn (hpath:display-buffer (current-buffer))
-	  (beginning-of-line)
+	       (beginning-of-line))
-	  (delete-other-windows)
+(goto-char opoint)
-	  (split-window-vertically nil)
+(beep))))
-	  (goto-char opoint))
-(beep))
-(goto-char opoint)))
 (defact completion ()
-"Inserts completion at point into minibuffer or other window.
+"Inserts completion at point into the minibuffer or a buffer.
-Unless at end of buffer or if completion has already been inserted, then
+Unless point is at the end of the buffer or if completion has already been
-deletes completions window."
+inserted, the completions window is deleted."
 (interactive)
 (if (eobp)
 (progn (bury-buffer nil)
 	     (delete-window))
 (hargs:completion)))
 		   nil "nil" 'symbol)))
 (cond ((fboundp macro))
 	   ((null last-kbd-macro)
 	    (hypb:error
 	      "(exec-kbd-macro): Define a keyboard macro first."))
-	   (t (fset 'zzz last-kbd-macro)
+	   (t (fset 'zzk last-kbd-macro)
-	      (setq macro 'zzz)))
+	      (setq macro 'zzk)))
 (save-excursion
 (let ((standard-output (get-buffer-create "*macro-def*")))
 	 (unwind-protect
 	     (progn (set-buffer standard-output)
 		    (setq buffer-read-only nil)
 		    (erase-buffer)
 		    (insert-kbd-macro macro)
 		    (goto-char (point-min))
 		    (setq macro (car (cdr (cdr (read (current-buffer)))))))
 	   (kill-buffer standard-output))))
-(fmakunbound 'zzz)
+(fmakunbound 'zzk)
 (setq repeat (hargs:read "Repeat count: "
 			     (function
 			      (lambda (repeat)
 				(or (null repeat)
 				    (and (integerp repeat) (>= repeat 0)))))
 	(hypb:error "(exec-kbd-macro): Bad macro: %s" kbd-macro))
 (or (null repeat-count) (and (integerp repeat-count) (<= 0 repeat-count))
 	(hypb:error "(exec-kbd-macro): Bad repeat count: %s" repeat-count)))
 (execute-kbd-macro kbd-macro repeat-count))
-;;; Support next two actypes on systems which use the 'comint' shell package
+;;; Support next two actypes on systems which use the `comint' shell package
 ;;; rather than Emacs V18 shell.el.
 ;;;
 (if (or hyperb:lemacs-p hyperb:emacs19-p)
 (require 'comint))
 (and (fboundp 'comint-send-input) (not (fboundp 'shell-send-input))
 (defact exec-shell-cmd (shell-cmd &optional internal-cmd kill-prev)
 "Executes a SHELL-CMD string asynchronously.
 Optional non-nil second argument INTERNAL-CMD means do not display the shell
 command line executed.  Optional non-nil third argument KILL-PREV means
-kill last output to shell buffer before executing SHELL-CMD."
+kill the last output to the shell buffer before executing SHELL-CMD."
 (interactive
 (let ((default  (car defaults))
 	 (default1 (nth 1 defaults))
 	 (default2 (nth 2 defaults)))
 (list (hargs:read "Shell cmd: "
 		     (function
-		      (lambda (cmd) (not (string= cmd ""))))
+		      (lambda (cmd) (not (string-equal cmd ""))))
 		    default "Enter a shell command." 'string)
 	 (y-or-n-p (format "Omit cmd from output (default = %s): "
 			   default1))
 	 (y-or-n-p (format "Kill prior cmd's output (default = %s): "
 			   default2)))))
 	  (if (not (hpath:ange-ftp-p default-directory))
 	      (setq shell-cmd
 		    (concat "cd " default-directory "; " shell-cmd)))
 	  (if (not (get-buffer buf-name))
 	      (save-excursion
-		;; Ensure shell displays in other window unless in the
+		(hpath:display-buffer (current-buffer))
-		;; OO-Browser, then use selected window.
-		(if (br-in-browser)
-		    nil
-		  (if (= (length (hypb:window-list)) 1)
-		      (split-window-vertically))
-		  (other-window 1))
 		(if (eq (minibuffer-window) (selected-window))
 		    (other-window 1))
 		(shell) (rename-buffer buf-name)
 		(setq last-input-start (point-marker)
 		      last-input-end (point-marker))
 		(if (fboundp 'comint-kill-output)
 		    (setq comint-last-input-start last-input-start
 			  comint-last-input-end last-input-end)
 		  )))
-	  (or (equal (buffer-name (current-buffer)) buf-name)
+	  (hpath:display-buffer buf-name)
-	      (if (br-in-browser) (switch-to-buffer buf-name)
-		(pop-to-buffer buf-name)))
 	  (goto-char (point-max))
 	  (and kill-prev last-input-end
 	       (not (equal last-input-start last-input-end))
 	       (kill-output-from-shell))
 	  (insert shell-cmd)
 	  (show-output-from-shell)
 	  (or internal-cmd (scroll-down 1)))
 (select-window owind))))
 (defact exec-window-cmd (shell-cmd)
-"Executes an external window-based SHELL-CMD string asynchronously."
+"Asynchronously executes an external window-based SHELL-CMD string."
 (interactive
 (let ((default  (car defaults)))
 (list (hargs:read "Shell cmd: "
 		       (function
-			(lambda (cmd) (not (string= cmd ""))))
+			(lambda (cmd) (not (string-equal cmd ""))))
 		       default "Enter a shell command." 'string))))
 (let ((buf-name "*Hypb Shell*")
 	(cmd (if (hpath:ange-ftp-p default-directory)
 		 (concat "(" shell-cmd ") &")
 	       (concat "(cd " default-directory "; " shell-cmd ") &")))
 	(goto-char (point-max))
 	(insert cmd)
 	(shell-send-input)))
 (message msg)))
+(defact function-in-buffer (name pos)
+"Displays the definition of function NAME found at POS in the current buffer."
+(save-excursion
+(goto-char pos)
+(if (looking-at (regexp-quote name))
+	  nil
+	(let ((fume-scanning-message nil))
+	  (fume-rescan-buffer)
+	  (setq pos (cdr-safe (assoc name fume-funclist))))))
+(if pos
+(progn (hpath:display-buffer (current-buffer))
+	     (goto-char pos)
+	     ;; Move to beginning of the line for compatibility with find-tag.
+	     (beginning-of-line))))
 (defact hyp-config (&optional out-buf)
-"Inserts Hyperbole configuration info at end of optional OUT-BUF or current."
+"Inserts Hyperbole configuration info at end of current buffer or optional OUT-BUF."
 (hypb:configuration out-buf))
 (defact hyp-request (&optional out-buf)
-"Inserts Hyperbole mail list request help into optional OUT-BUF or current."
+"Inserts Hyperbole mail list request help into current buffer or optional OUT-BUF."
 (save-excursion
 (and out-buf (set-buffer out-buf))
 (goto-char (point-max))
 (delete-blank-lines) (delete-blank-lines)
-(insert "Use one of the following formats on your subject line:\n
+(insert "Use one of the following formats in the *body* of your message:\n
-Subject: Subscribe <joe@any.com> (Joe Williams).
+subscribe <mail-list-name> [<your-email-address>]
-Subject: Unsubscribe <joe@any.com>.
+or
+unsubscribe <mail-list-name> [<your-email-address>]
-To change your address, first unsubscribe by sending an unsubscribe
-request from your old address.  Then subscribe by sending a subscribe
+where possible <mail-list-names> are:
-request from your new address.
-Possible mail lists are:
 hyperbole          - discussion of Hyperbole
-hyperbole-announce - Hyperbole announcements only\n")))
+hyperbole-announce - Hyperbole announcements only
+For example:  subscribe hyperbole joe@nowhere.gov\n")))
 (defact hyp-source (buf-str-or-file)
-"Displays a buffer or file from a line beginning with 'hbut:source-prefix'."
+"Displays a buffer or file from a line beginning with `hbut:source-prefix'."
 (interactive
 (list (prin1-to-string (get-buffer-create
 			   (read-buffer "Buffer to link to: ")))))
 (if (stringp buf-str-or-file)
 (cond ((string-match "\\`#<buffer \"?\\([^ \n\"]+\\)\"?>" buf-str-or-file)
-	     (pop-to-buffer (substring buf-str-or-file
+	     (hpath:display-buffer
-				       (match-beginning 1) (match-end 1))))
+	      (substring buf-str-or-file (match-beginning 1) (match-end 1))))
-	    (t (hpath:find-other-window buf-str-or-file)))
+	    (t (hpath:find buf-str-or-file)))
 (hypb:error "(hyp-source): Non-string argument: %s" buf-str-or-file)))
 (defact link-to-buffer-tmp (buffer)
-"Displays a BUFFER in another window.
+"Displays a BUFFER.
 Link is generally only good for current Emacs session.
-Use 'link-to-file' instead for a permanent link."
+Use `link-to-file' instead for a permanent link."
 (interactive "bBuffer to link to: ")
 (if (or (stringp buffer) (bufferp buffer))
-(pop-to-buffer buffer)
+(hpath:display-buffer buffer)
 (hypb:error "(link-to-buffer-tmp): Not a current buffer: %s" buffer)))
 (defact link-to-directory (directory)
-"Displays a DIRECTORY in Dired mode in another window."
+"Displays a DIRECTORY in Dired mode."
 (interactive "DDirectory to link to: ")
-(hpath:find-other-window directory))
+(hpath:find directory))
 (defact link-to-ebut (key-file key)
 "Performs action given by another button, specified by KEY-FILE and KEY."
 (interactive
 (let (but-file but-lbl)
 (while (cond ((setq but-file
 			 (read-file-name
 			  "File of button to link to: " nil nil t))
-		   (if (string= but-file "")
+		   (if (string-equal but-file "")
 		       (progn (beep) t)))
 		  ((not (file-readable-p but-file))
-		   (message "(link-to-ebut): You cannot read '%s'."
+		   (message "(link-to-ebut): You cannot read `%s'."
 			    but-file)
 		   (beep) (sit-for 3))))
 (list but-file
 	   (progn
 	     (find-file-noselect but-file)
-	     (while (string= "" (setq but-lbl
+	     (while (string-equal "" (setq but-lbl
 				      (hargs:read-match
 				       "Button to link to: "
 				       (ebut:alist but-file)
 				       nil nil nil 'ebut)))
 	       (beep))
 	     (ebut:label-to-key but-lbl)))))
 (or (interactive-p)
 (setq key-file (hpath:validate (hpath:substitute-value key-file))))
 (let ((but (ebut:get key (find-file-noselect key-file))))
 (if but (hbut:act but)
-(hypb:error "(link-to-ebut): No button '%s' in '%s'." (ebut:key-to-label key)
+(hypb:error "(link-to-ebut): No button `%s' in `%s'." (ebut:key-to-label key)
 	     key-file))))
 (defact link-to-elisp-doc (func-symbol)
 "Displays documentation for FUNC-SYMBOL."
 (interactive "aFunction to display doc for: ")
 (cond ((not (symbolp func-symbol))
-	 (hypb:error "(link-to-elisp-doc): '%s' not a symbol."
+	 (hypb:error "(link-to-elisp-doc): `%s' not a symbol."
 		func-symbol))
 	((not (fboundp func-symbol))
-	 (hypb:error "(link-to-elisp-doc): '%s' not defined as a function."
+	 (hypb:error "(link-to-elisp-doc): `%s' not defined as a function."
 		func-symbol))
 	((not (documentation func-symbol))
-	 (hypb:error "(link-to-elisp-doc): '%s' has no documentation."
+	 (hypb:error "(link-to-elisp-doc): `%s' has no documentation."
 		func-symbol))
-	((describe-function func-symbol))))
+	(t (let ((temp-buffer-show-function 'switch-to-buffer))
+	     (hpath:display-buffer (current-buffer))
+	     (describe-function func-symbol)))))
 (defact link-to-file (path &optional point)
-"Displays a PATH in another window scrolled to optional POINT.
+"Displays file given by PATH scrolled to optional POINT.
-With POINT, buffer is displayed with POINT at the top of the window."
+With POINT, buffer is displayed with POINT at window top."
 (interactive
 (let ((prev-reading-p hargs:reading-p))
 (unwind-protect
 	 (let* ((default (car defaults))
 		(hargs:reading-p 'file)
 			      (count-lines 1 (point))))
 		     (list path (point))
 		   (list path)))
 	     (list path)))
 (setq hargs:reading-p prev-reading-p))))
-(and (hpath:find-other-window path)
+(and (hpath:find path)
 (integerp point)
 (progn (goto-char (min (point-max) point))
 	      (recenter 0))))
 (defact link-to-file-line (path line-num)
-"Displays a PATH in another window scrolled to LINE-NUM."
+"Displays a file given by PATH scrolled to LINE-NUM."
 (interactive "fPath to link to: \nnDisplay at line number: ")
-(and (setq path (smart-tags-file-path path))
+(if (setq path (smart-tags-file-path path))
-(hpath:find-other-window path)
+(hpath:find-line path line-num)))
-(integerp line-num)
-(progn (widen)
-	      (goto-line line-num))))
 (defact link-to-Info-node (node)
-"Displays an Info NODE in another window.
+"Displays an Info NODE.
 NODE must be a string of the form `(file)nodename'."
 (interactive "+IInfo (file)nodename to link to: ")
 (require 'info)
 (if (and (stringp node) (string-match "^(\\([^\)]+\\))\\(.*\\)" node))
 (let ((nodename (substring node (match-beginning 2) (match-end 2)))
 		       Info-directory-list
 		     Info-directory))))
 	(if (and file (setq file (hpath:substitute-value file)))
 	    (let ((wind (get-buffer-window "*info*")))
 	      (if wind (select-window wind)
-		(pop-to-buffer (other-buffer)))
+		(hpath:display-buffer (other-buffer)))
 	      (info) (Info-goto-node (concat "(" file ")" nodename)))
-	  (hypb:error "(link-to-Info-node): Bad node spec: '%s'" node)))))
+	  (hypb:error "(link-to-Info-node): Bad node spec: `%s'" node)))))
 (defact link-to-kcell (file cell-ref)
-"Displays FILE with kcell given by CELL-REF at the top of the window.
+"Displays FILE with kcell given by CELL-REF at window top.
-See documentation for 'kcell:ref-to-id' for valid cell-ref formats.
+See documentation for `kcell:ref-to-id' for valid cell-ref formats.
 If FILE is nil, the current buffer is used.
 If CELL-REF is nil, the first cell in the view is shown."
 (interactive "fKotl file to link to: \n+KKcell to link to: ")
 (require 'kfile)
-(cond ((and (stringp cell-ref) (= ?| (aref cell-ref 0)))
+(cond ((and (stringp cell-ref) (> (length cell-ref) 0)
+	      (= ?| (aref cell-ref 0)))
 	 ;; Activate view spec in current window.
 	 (kotl-mode:goto-cell cell-ref))
 	((if file
-	     (hpath:find-other-window file)
+	     (hpath:find file)
-	   (pop-to-buffer (current-buffer) t))
+	   (hpath:display-buffer (current-buffer)))
 	 (if cell-ref
 	     (kotl-mode:goto-cell cell-ref)
 	   (kotl-mode:beginning-of-buffer))
 	 (recenter 0))))
 (defact link-to-mail (mail-msg-id &optional mail-file)
-"Displays mail msg with MAIL-MSG-ID from optional MAIL-FILE in other window.
+"Displays mail msg with MAIL-MSG-ID from optional MAIL-FILE.
-See documentation for the variable 'hmail:init-function' for information on
+See documentation for the variable `hmail:init-function' for information on
 how to specify a mail reader to use."
 (interactive "+MMail Msg: ")
 (if (not (fboundp 'rmail:msg-to-p))
 (hypb:error "(link-to-mail): Invoke mail reader before trying to follow a mail link.")
 (if (and (listp mail-msg-id) (null mail-file))
 	(setq mail-file (car (cdr mail-msg-id))
 	      mail-msg-id (car mail-msg-id)))
-(let ((wind (selected-window))
+(let ((wconfig (current-window-configuration)))
-	  (wconfig (current-window-configuration)))
+(hpath:display-buffer (current-buffer))
-(other-window 1)
-(if (eq wind (selected-window))
-	  (progn (split-window-vertically nil) (other-window 1)))
 ;; Initialize user-specified mail reader if need be.
 (if (and (symbolp hmail:init-function)
 	       (fboundp hmail:init-function)
 	       (listp (symbol-function hmail:init-function))
 	       (eq 'autoload (car (symbol-function hmail:init-function))))
 	  (funcall hmail:init-function))
 (if (rmail:msg-to-p mail-msg-id mail-file)
 	  nil
 	;; Couldn't find message, restore old window config, report error
 	(set-window-configuration wconfig)
-	(hypb:error "(link-to-mail): No msg '%s' in file \"%s\"."
+	(hypb:error "(link-to-mail): No msg `%s' in file \"%s\"."
 		    mail-msg-id mail-file)))))
 (defact link-to-regexp-match (regexp n source &optional buffer-p)
 "Finds REGEXP's Nth occurrence in SOURCE and displays location at window top.
 SOURCE is a pathname unless optional BUFFER-P is non-nil, then SOURCE must be
 	(if (stringp source)
 	    (setq source (get-buffer source)))
 ;; Source is a pathname.
 (if (not (stringp source))
 	  (hypb:error
-	   "(link-to-regexp-match): Source parameter is not a filename: '%s'"
+	   "(link-to-regexp-match): Source parameter is not a filename: `%s'"
 	   orig-src)
 	(setq source (find-file-noselect (hpath:substitute-value source)))))
 (if (not (bufferp source))
 	(hypb:error
-	 "(link-to-regexp-match): Invalid source parameter: '%s'" orig-src)
+	 "(link-to-regexp-match): Invalid source parameter: `%s'" orig-src)
-(switch-to-buffer-other-window source)
+(hpath:display-buffer source)
 (widen)
 (goto-char (point-min))
 (if (re-search-forward regexp nil t n)
 	  (progn (beginning-of-line) (recenter 0) t)
 	(hypb:error
-	 "(link-to-regexp-match): Pattern not found: '%s'" regexp)))))
+	 "(link-to-regexp-match): Pattern not found: `%s'" regexp)))))
 (defact link-to-rfc (rfc-num)
 "Retrieves and displays an Internet rfc given by RFC-NUM.
 RFC-NUM may be a string or an integer.  Requires ange-ftp or efs for
 remote retrievals."
 (interactive "nRFC number to retrieve: ")
 (if (or (stringp rfc-num) (integerp rfc-num))
-(hpath:find-other-window (hpath:rfc rfc-num))))
+(hpath:find (hpath:rfc rfc-num))))
 (defact link-to-string-match (string n source &optional buffer-p)
 "Finds STRING's Nth occurrence in SOURCE and displays location at window top.
 SOURCE is a pathname unless optional BUFFER-P is non-nil, then SOURCE must be
 a buffer name or buffer.
 (interactive "sString to match: \nnOccurrence number: \nfFile to search: ")
 (funcall (actype:action 'link-to-regexp-match)
 	   (regexp-quote string) n source buffer-p))
 (defact man-show (topic)
-"Displays man page on TOPIC, which may be of the form <command>(<section>)."
+"Displays man page on TOPIC, which may be of the form <command>(<section>).
+If using the Superman manual entry package, see the documentation for
+`sm-notify' to control where the man page is displayed."
 (interactive "sManual topic: ")
-(manual-entry topic))
+(let ((display-buffer-function
+	 (function (lambda (buffer &rest unused) (hpath:display-buffer buffer)))))
+(manual-entry topic)))
 (defact rfc-toc (&optional buf-name opoint)
 "Computes and displays summary of an Internet rfc in BUF-NAME.
 Assumes point has already been moved to start of region to summarize.
 Optional OPOINT is point to return to in BUF-NAME after displaying summary."
 	       (if buf
 		   (progn (switch-to-buffer (setq buf-name buf))
 			  t))))
 	    (t (if opoint (goto-char opoint))
 	       (hypb:error "(rfc-toc): Invalid buffer name: %s" buf-name))))
-(let ((sect-regexp "^[ \t]*[1-9][0-9]*\\.[0-9.]*[ \t]+[^ \t\n]"))
+(let ((sect-regexp "^[ \t]*[1-9][0-9]*\\.[0-9.]*[ \t]+[^ \t\n]")
+	(temp-buffer-show-function 'switch-to-buffer))
+(hpath:display-buffer (current-buffer))
 (occur sect-regexp)
 (set-buffer "*Occur*")
 (rename-buffer (format "*%s toc*" buf-name))
 (re-search-forward "^[ ]*[0-9]+:" nil t)
 (beginning-of-line)

Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/hactypes.el @ 24:4103f0995bd7 r19-15b95