Mercurial > hg > xemacs-beta
view lisp/hyperbole/hactypes.el @ 183:e121b013d1f0 r20-3b18
Import from CVS: tag r20-3b18
author | cvs |
---|---|
date | Mon, 13 Aug 2007 09:54:23 +0200 |
parents | 4be1180a9e89 |
children |
line wrap: on
line source
;;!emacs ;; ;; FILE: hactypes.el ;; SUMMARY: Default action types for Hyperbole. ;; USAGE: GNU Emacs Lisp Library ;; KEYWORDS: extensions, hypermedia ;; ;; AUTHOR: Bob Weiner ;; 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: 20-Feb-97 at 11:16:36 by Bob Weiner ;;; ************************************************************************ ;;; Other required Elisp libraries ;;; ************************************************************************ (mapcar 'require '(hbut hpath hargs hact hmail)) ;;; ************************************************************************ ;;; Standard Hyperbole action types ;;; ************************************************************************ (defact annot-bib (key) "Follows internal ref KEY within an annotated bibliography, delimiters=[]." (interactive "sReference key (no []): ") (let ((opoint (point)) (key-regexp (concat "^[*]*[ \t]*\\\[" (ebut:key-to-label key) "\\\]"))) (goto-char (point-min)) (if (re-search-forward key-regexp nil t) (progn (hpath:display-buffer (current-buffer)) (beginning-of-line)) (goto-char opoint) (beep)))) (defact completion () "Inserts completion at point into the minibuffer or a buffer. Unless point is at the end of the buffer or if completion has already been inserted, the completions window is deleted." (interactive) (if (eobp) (progn (bury-buffer nil) (delete-window)) (hargs:completion))) (defact eval-elisp (lisp-expr) "Evaluates a Lisp expression LISP-EXPR." (interactive "xLisp to eval: ") (eval lisp-expr)) (defact exec-kbd-macro (kbd-macro &optional repeat-count) "Executes KBD-MACRO REPEAT-COUNT times. KBD-MACRO may be a string of editor command characters, a function symbol or nil to use the last defined keyboard macro. Optional REPEAT-COUNT nil means execute once, zero means repeat until error." (interactive (let (macro repeat) (setq macro (intern-soft (hargs:read-match "Unquoted macro name or nil for last one defined: " obarray (function (lambda (sym) (and (fboundp sym) (stringp (hypb:indirect-function sym))))) nil "nil" 'symbol))) (cond ((fboundp macro)) ((null last-kbd-macro) (hypb:error "(exec-kbd-macro): Define a keyboard macro first.")) (t (fset 'zzk last-kbd-macro) (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 'zzk) (setq repeat (hargs:read "Repeat count: " (function (lambda (repeat) (or (null repeat) (and (integerp repeat) (>= repeat 0))))) 1)) (list macro repeat))) (if (interactive-p) nil (or (and kbd-macro (or (stringp kbd-macro) (and (symbolp kbd-macro) (fboundp kbd-macro)))) (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 ;;; 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)) (fset 'shell-send-input 'comint-send-input)) (and (fboundp 'comint-kill-output) (not (fboundp 'kill-output-from-shell)) (fset 'kill-output-from-shell 'comint-kill-output)) (and (fboundp 'comint-show-output) (not (fboundp 'show-output-from-shell)) (fset 'show-output-from-shell 'comint-show-output)) (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 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-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))))) (let ((buf-name "*Hypb Shell*") (owind (selected-window))) (unwind-protect (progn (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 (hpath:display-buffer (current-buffer)) (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) ))) (hpath:display-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) (shell-send-input) (show-output-from-shell) (or internal-cmd (scroll-down 1))) (select-window owind)))) (defact exec-window-cmd (shell-cmd) "Asynchronously executes an external window-based SHELL-CMD string." (interactive (let ((default (car defaults))) (list (hargs:read "Shell cmd: " (function (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 ") &"))) (msg (format "Executing: %s" shell-cmd)) (shell-buf)) (message msg) (save-excursion (save-window-excursion (if (not (get-buffer buf-name)) (progn (save-excursion (save-window-excursion (shell) (setq shell-buf (current-buffer)))) (message msg) ;; Wait for shell to startup before sending it input. (sit-for 1) (set-buffer shell-buf) (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) (set-buffer buf-name)) (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 current buffer or optional OUT-BUF." (hypb:configuration out-buf)) (defact hyp-request (&optional out-buf) "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 in the *body* of your message:\n subscribe <mail-list-name> [<your-email-address>] or unsubscribe <mail-list-name> [<your-email-address>] where possible <mail-list-names> are: hyperbole - discussion of Hyperbole 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'." (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) (hpath:display-buffer (substring buf-str-or-file (match-beginning 1) (match-end 1)))) (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. Link is generally only good for current Emacs session. Use `link-to-file' instead for a permanent link." (interactive "bBuffer to link to: ") (if (or (stringp buffer) (bufferp 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." (interactive "DDirectory to link to: ") (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-equal but-file "") (progn (beep) t))) ((not (file-readable-p but-file)) (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-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) 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." func-symbol)) ((not (fboundp func-symbol)) (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." 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 file given by PATH scrolled to optional POINT. 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) (path (read-file-name "Path to link to: " default default)) (path-buf (get-file-buffer path))) (if path-buf (save-excursion (set-buffer path-buf) (setq hargs:reading-p 'character) (if (y-or-n-p (format "y = Display at present position (line %d); n = no position: " (count-lines 1 (point)))) (list path (point)) (list path))) (list path))) (setq hargs:reading-p prev-reading-p)))) (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 file given by PATH scrolled to LINE-NUM." (interactive "fPath to link to: \nnDisplay at line number: ") (if (setq path (smart-tags-file-path path)) (hpath:find-line path line-num))) (defact link-to-Info-node (node) "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))) (file (hpath:absolute-to (substring node (match-beginning 1) (match-end 1)) (if (boundp 'Info-directory-list) 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) (hpath:display-buffer (other-buffer))) (info) (Info-goto-node (concat "(" file ")" nodename))) (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 window top. 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) (> (length cell-ref) 0) (= ?| (aref cell-ref 0))) ;; Activate view spec in current window. (kotl-mode:goto-cell cell-ref)) ((if file (hpath:find file) (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. 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 ((wconfig (current-window-configuration))) (hpath:display-buffer (current-buffer)) ;; 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\"." 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 a buffer name or buffer. Returns t if found, signals an error if not." (interactive "sRegexp to match: \nnOccurrence number: \nfFile to search: ") (let ((orig-src source)) (if buffer-p (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'" 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) (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))))) (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 (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. Returns t if found, nil if not." (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>). If using the Superman manual entry package, see the documentation for `sm-notify' to control where the man page is displayed." (interactive "sManual 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." (interactive) (if buf-name (cond ((get-buffer buf-name) (switch-to-buffer buf-name)) ((let ((buf (get-file-buffer buf-name))) (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]") (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) (delete-region (point-min) (point)) (insert "Contents of " (buffer-name occur-buffer) ":\n") (set-buffer-modified-p nil) (set-buffer buf-name) (if opoint (goto-char opoint)))) (defact text-toc (section) "Jumps to the text file SECTION referenced by a table of contents entry at point." (interactive "sGo to section named: ") (if (stringp section) (progn (actypes::link-to-regexp-match (concat "^\\*+[ \t]*" (regexp-quote section)) 1 (current-buffer) t) (while (and (= (forward-line -1) 0) (looking-at "[ \t]*[-=][-=]"))) (forward-line 1) (recenter 0)))) (provide 'hactypes)