;;!emacs ;; $Id: ;; ;; FILE: hactypes.el ;; SUMMARY: Default action types for Hyperbole. ;; USAGE: GNU Emacs Lisp Library ;; ;; AUTHOR: Bob Weiner ;; ORG: Brown U. ;; ;; ORIG-DATE: 23-Sep-91 at 20:34:36 ;; LAST-MOD: 21-May-93 at 20:03:37 by Bob Weiner ;; ;; This file is part of Hyperbole. ;; ;; Copyright (C) 1991, Brown University, Providence, RI ;; Developed with support from Motorola Inc. ;; ;; Permission to use, modify and redistribute this software and its ;; documentation for any purpose other than its incorporation into a ;; commercial product is hereby granted without fee. A distribution fee ;; may be charged with any redistribution. Any distribution requires ;; that the above copyright notice appear in all copies, that both that ;; copyright notice and this permission notice appear in supporting ;; documentation, and that neither the name of Brown University nor the ;; author's name be used in advertising or publicity pertaining to ;; distribution of the software without specific, written prior permission. ;; ;; Brown University makes no representations about the suitability of this ;; software for any purpose. It is provided "as is" without express or ;; implied warranty. ;; ;; ;; DESCRIPTION: ;; ;; Although the following Hyperbole action type definitions look just ;; like function definitions by design, they do not define functions ;; bound to the symbol name following the 'defact', so don't try to call ;; them. Instead, use them as Hyperbole button action types and let ;; the Hyperbole engine evaluate their action bodies. ;; ;; defact interactive forms are used when buttons are created to prompt ;; for necessary button arguments. These arguments are then bound to ;; an action type's parameters whenever its action is invoked, e.g. a ;; button is selected. ;; ;; DESCRIP-END. ;;; ************************************************************************ ;;; Other required Elisp libraries ;;; ************************************************************************ (require 'hbut) (require 'hpath) (require 'hargs) (require 'hact) (require '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))) (goto-char 1) (if (re-search-forward (concat "^[*]*[ \t]*\\\[" (ebut:key-to-label key) "\\\]") nil t) (progn (beginning-of-line) (delete-other-windows) (split-window-vertically nil) (goto-char opoint) ) (beep)) (goto-char opoint) )) (defact eval-elisp (lisp-expr) "Evaluates a Lisp expression LISP-EXPR." (interactive "xLisp to eval: ") (eval lisp-expr)) ;;; Support next two actypes on systems which use the 'comint' shell package ;;; rather than Emacs V18 shell.el. ;;; (if hyperb:lemacs-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 last output to shell buffer before executing SHELL-CMD." (interactive (let ((default (car defaults)) (default1 (nth 1 defaults)) (default2 (nth 2 defaults))) (list (hargs:read "Shell cmd: " '(lambda (cmd) (not (string= 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 (setq shell-cmd (concat "cd " default-directory "; " shell-cmd)) (if (not (get-buffer buf-name)) (save-excursion (shell) (rename-buffer buf-name) (setq last-input-start (dot-marker) last-input-end (dot-marker)))) (or (equal (buffer-name (current-buffer)) buf-name) (pop-to-buffer buf-name)) (end-of-buffer) (and kill-prev 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) "Executes an external window-based SHELL-CMD string asynchronously." (interactive (let ((default (car defaults))) (list (hargs:read "Shell cmd: " '(lambda (cmd) (not (string= cmd ""))) default "Enter a shell command." 'string)))) (let ((buf-name "*Hypb Shell*") (cmd (concat "cd " default-directory "; " shell-cmd))) (save-excursion (if (not (get-buffer buf-name)) (progn (shell) (rename-buffer buf-name) (setq last-input-start (dot-marker) last-input-end (dot-marker)))) (or (equal (buffer-name (current-buffer)) buf-name) (set-buffer buf-name)) (end-of-buffer) (insert cmd) (shell-send-input) (message "Executing: %s" shell-cmd) ))) (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 or a function symbol. 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 '(lambda (sym) (and (fboundp sym) (stringp (symbol-function sym)))) nil "nil" 'symbol))) (or macro (if (null last-kbd-macro) (hypb:error "(exec-kbd-macro): Define a keyboard macro first.") (setq macro last-kbd-macro))) (setq repeat (hargs:read "Repeat count: " '(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)) (defact hyp-config (&optional out-buf) "Inserts Hyperbole configuration info at end of optional OUT-BUF or current." (save-excursion (and out-buf (set-buffer out-buf)) (goto-char (point-max)) (delete-blank-lines) (delete-blank-lines) (let ((start (point))) (insert (format "I use:\tHyperbole: %s\n\tEditor: %s\n" hyperb:version (if (boundp 'epoch::version) epoch::version (hypb:replace-match-string " of .+" (emacs-version) "") )) (format "\tSys Type: %s\n\tWindow Sys: %s\n" system-type (or window-system hyperb:window-system "None"))) (if (and (boundp 'hmail:reader) hmail:reader) (insert (format "\tMailer: %s\n" (cond ((eq hmail:reader 'rmail-mode) "RMAIL") ((eq hmail:reader 'vm-mode) (concat "VM " vm-version)) ((and (eq hmail:reader 'mh-folder-mode) (string-match "v ?\\([0-9]+.[0-9]+\\)" mh-e-RCS-id)) (concat "MH-e " (substring mh-e-RCS-id (match-beginning 1) (match-end 1)))) ((eq hmail:reader 'pm-fdr-mode) (concat "PM " pm-version)) )))) (if (and (boundp 'hnews:reader) (boundp 'gnus-version) hnews:reader) (insert (format "\tNews Rdr: %s\n" gnus-version))) (untabify start (point)) ))) (defact hyp-request (&optional out-buf) "Inserts Hyperbole mail list request help into optional OUT-BUF or current." (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 Subject: Add Joe Williams to hyperbole. Subject: Remove from hyperbole. Subject: Change to in hyperbole. Possible mail lists are: hyperbole - discussion of Hyperbole hyperbole-announce - Hyperbole announcements only\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 "\\`#" buf-str-or-file) (pop-to-buffer (substring buf-str-or-file (match-beginning 1) (match-end 1)))) (t (hpath:find-other-window 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. 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)) (pop-to-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." (interactive "DDirectory to link to: ") (hpath:find-other-window 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 "Loc file of but to link to: " nil nil t)) (if (string= 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= "" (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) (hpath:validate (setq key-file (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)) ((describe-function func-symbol)))) (defact link-to-file (path &optional point) "Displays a PATH in another window scrolled to optional POINT. With POINT, buffer is displayed with POINT at the top of the window." (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 (if (eq system-type 'vax-vms) nil 'existing))) (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-other-window 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." (interactive "fPath to link to: \nnDisplay at line number: ") (and (hpath:find-other-window path) (integerp line-num) (goto-line line-num))) (defact link-to-Info-node (node) "Displays an Info NODE in another window. 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)) (hpath:validate file)) (progn (pop-to-buffer (other-buffer)) (info) (Info-goto-node (concat "(" file ")" nodename))) (hypb:error "(link-to-Info-node): Bad node spec: '%s'" node))))) (defact link-to-mail (mail-msg-id &optional mail-file) "Displays mail msg with MAIL-MSG-ID from optional MAIL-FILE in other window." (interactive "MMail Msg: ") (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)) (wconfig (current-window-configuration))) (other-window 1) (if (eq wind (selected-window)) (progn (split-window-vertically nil) (other-window 1))) (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 file) "Finds REGEXP's Nth occurrence in FILE and displays location at window top. Returns t if found, signals an error if not." (interactive "sRegexp to match: \nnOccurrence number: \nfFile to search: ") (if (stringp file) (progn (setq file (hpath:substitute-value file)) (find-file-other-window file) (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))) (hypb:error "(link-to-regexp-match): file parameter not a string: '%s'" file))) (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." (interactive "nRFC number to retrieve: ") (if (or (stringp rfc-num) (integerp rfc-num)) (hpath:find-other-window (format "/anonymous@ftp.nisc.sri.com:rfc/rfc%s.txt" rfc-num)))) (defact link-to-string-match (string n file) "Finds STRING's Nth occurrence in FILE and displays location at window top. 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 file)) (defact man-show (topic) "Displays man page on TOPIC, which may be of the form (
)." (interactive "sManual topic: ") (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]")) (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)) )) (provide 'hactypes)