Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/hsys-hbase.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;!emacs
2 ;;
3 ;; FILE: hsys-hbase.el
4 ;; SUMMARY: Hyperbole support for the Hyperbase system.
5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: comm, hypermedia
7 ;;
8 ;; AUTHOR: Bob Weiner
9 ;; ORG: Brown U.
10 ;;
11 ;; ORIG-DATE: 16-Oct-91 at 04:35:09
12 ;; LAST-MOD: 30-Oct-95 at 22:31:23 by Bob Weiner
13 ;;
14 ;; This file is part of Hyperbole.
15 ;; Available for use and distribution under the same terms as GNU Emacs.
16 ;;
17 ;; Copyright (C) 1991, 1995, Free Software Foundation, Inc.
18 ;; Developed with support from Motorola Inc.
19 ;;
20 ;; DESCRIPTION:
21 ;;
22 ;; For information and the source to HyperBase and follow-on hypermedia
23 ;; work, see: ftp://ftp.iesd.auc.dk/pub/packages/hypertext/
24 ;;
25 ;; In order to use this package, you must have the HyperBase system
26 ;; and must start up a HyperBase server and then load the HyperBase
27 ;; Epoch support software that comes with the HyperBase system.
28 ;;
29 ;; Then load this package and Hyperbole will do the following when
30 ;; in a Hyperbase buffer:
31 ;;
32 ;; Action Key press on a button follows the link, within any other
33 ;; text, closes current Epoch screen and kills node buffer.
34 ;;
35 ;; Assist Key press shows attributes for the current button or
36 ;; for the current node buffer, if no current button.
37 ;;
38 ;; DESCRIP-END.
39
40 ;;; ************************************************************************
41 ;;; Other required Elisp libraries
42 ;;; ************************************************************************
43
44 (require 'hbut)
45
46 ;;; ************************************************************************
47 ;;; Public variables
48 ;;; ************************************************************************
49
50 (defib hyperbase ()
51 "Detects link buttons in buffers that communicate with the Hyperbase system.
52 Hyperbase is a hypertext database system that interfaces to Emacs."
53 (and (boundp 'ehts-mode) ehts-mode
54 (let ((lbl (or (ebut:label-p 'as-label "[-> " "]")
55 "no-but")))
56 (ibut:label-set lbl)
57 (hact 'hyperbase lbl))))
58
59 (defact hyperbase (linkname)
60 "Follows LINKNAME in a buffer that communicates with the Hyperbase system.
61 If LINKNAME equals t, closes the current Epoch screen and kill the
62 buffer of the current Hyperbase node.
63 Hyperbase is a hypertext database system that interfaces to Emacs."
64 ;; From hb-EHTS.el by:
65 ;; Uffe Kock Wiil (kock@iesd.auc.dk)
66 ;; Claus Bo Nielsen (cbn@cci.dk)
67 ;;
68 (if (equal linkname "no-but")
69 (progn (ehts-mouse-kill-screen-and-buffer t)
70 (and (fboundp 'epoch::select-screen)
71 (epoch::select-screen)))
72 (let ((linknum (cdr (assoc linkname ehts-node-link-alist))) tonode)
73 (ehts-command t)
74 (if (< (ehts-hb-sys-call "read" linknum "to data node no" nil t) 0)
75 (progn
76 (ehts-command nil)
77 (error "Can't read \"to data node no\" in link, panic !!!")))
78 (ehts-read-4bytes)
79 (setq tonode (ehts-read-4bytes))
80 (if (< (ehts-hb-sys-call "read" tonode "n name" nil t) 0)
81 (progn
82 (ehts-command nil)
83 (error "Can't read \"name\" in data node, panic !!!")))
84 (ehts-get-node (ehts-read-null-string))
85 (and (fboundp 'hproperty:but-create-all)
86 (hproperty:but-create-all "[-> " "]"))
87 (ehts-command nil))))
88
89 ;;; ************************************************************************
90 ;;; Public functions
91 ;;; ************************************************************************
92
93 (defun hyperbase:init ()
94 "Show initial set of Hyperbase buttons."
95 (if (assoc (user-full-name) ehts-node-name-alist)
96 (progn
97 (ehts-get-node (user-full-name))
98 (let (buffer screen)
99 (setq buffer "*Ehts Welcome*")
100 (setq screen (ehts-find-buffer-screen buffer))
101 (kill-buffer buffer)
102 (switch-to-buffer (user-full-name))
103 (remove-screen screen)))
104 (if (assoc "dir ehts help" ehts-node-name-alist)
105 (progn
106 (ehts-get-node "dir ehts help")
107 (let (buffer screen)
108 (setq buffer "*Ehts Welcome*")
109 (setq screen (ehts-find-buffer-screen buffer))
110 (kill-buffer buffer)
111 (switch-to-buffer "dir ehts help")
112 (remove-screen screen)
113 (hproperty:but-create "[-> " "]"))))))
114
115 (defun hyperbase:help (&optional but)
116 "Displays attributes of a link button BUT if on one or of the current node.
117 Hyperbase is a hypertext database system that interfaces to Emacs."
118 (interactive (list (ibut:at-p)))
119 (or (and (boundp 'ehts-mode) ehts-mode)
120 (error "(hyperbase:help): Not in a Hyperbase mode buffer."))
121 (hyperbase:attr-help
122 (or (and (symbolp but)
123 (let ((lbl (ebut:key-to-label (hattr:get but 'lbl-key))))
124 (if (not (equal lbl "no-but")) lbl)))
125 (current-buffer))))
126
127 ;;; ************************************************************************
128 ;;; Private functions
129 ;;; ************************************************************************
130
131 (defun hyperbase:already-displayed-p (name)
132 "Test if a buffer allready is displayed."
133 (let (screenid)
134 (setq screenid (ehts-find-buffer-screen name))
135 (if screenid
136 (progn
137 (switch-screen screenid)
138 t)
139 nil)))
140
141 (defun hyperbase:attr-help (node-link-spec)
142 "Show the attributes of a node or a button link from NODE-LINK-SPEC.
143 A string value of NODE-LINK-SPEC means show attributes for that button link.
144 A buffer value means show attributes for the node in that buffer."
145 (interactive)
146 (or (stringp node-link-spec) (bufferp node-link-spec)
147 (error "(hyperbase-show-attributes): Non-string or buffer argument."))
148 (let (entity name string number buffer screenid)
149 (setq buffer (if (bufferp node-link-spec) (buffer-name node-link-spec))
150 entity (cdr (assoc (if buffer "node" "link") node-link-list))
151 buffer (or buffer (buffer-name)))
152 (if (eq (string-match "Attributes - " buffer) 0)
153 nil
154 (if (= entity 0)
155 (progn
156 (setq name (concat "Attributes - " buffer))
157 (if (not (hyperbase:already-displayed-p name))
158 (progn
159 (setq number (cdr (assoc buffer ehts-node-name-alist))
160 string (ehts-create-node-attribute-string number))
161 (ehts-setup-attribute-screen name string entity buffer))))
162 (if (eq ehts-node-link-alist '())
163 (error "No links in this node."))
164 (setq name (concat "Attributes - "
165 (car (assoc node-link-spec ehts-node-link-alist))))
166 (if (not (hyperbase:already-displayed-p name))
167 (progn
168 (setq number (cdr (assoc (substring name 13)
169 ehts-node-link-alist))
170 string (ehts-create-link-attribute-string number))
171 (ehts-setup-attribute-screen name string entity buffer)))))))
172
173 ;;; ************************************************************************
174 ;;; Private variables
175 ;;; ************************************************************************
176
177 (provide 'hsys-hbase)