cgit.sxemacs.org Git - packages/blob - xemacs-packages/hyperbole/hsys-hbase.el

   1 ;;; hsys-hbase.el --- Hyperbole support for the Hyperbase system.
   2
   3 ;; Copyright (C) 1991, 1995, Free Software Foundation, Inc.
   4 ;; Developed with support from Motorola Inc.
   5
   6 ;; Author: Bob Weiner, Brown U.
   7 ;; Maintainer: Mats Lidell <matsl@contactor.se>
   8 ;; Keywords: comm, hypermedia
   9
  10 ;; This file is part of GNU Hyperbole.
  11
  12 ;; GNU Hyperbole is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 3, or (at
  15 ;; your option) any later version.
  16
  17 ;; GNU Hyperbole is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28 ;;
  29 ;;   For information and the source to HyperBase and follow-on hypermedia
  30 ;;   work, see:  ftp://ftp.iesd.auc.dk/pub/packages/hypertext/
  31 ;;
  32 ;;   In order to use this package, you must have the HyperBase system
  33 ;;   and must start up a HyperBase server and then load the HyperBase
  34 ;;   Epoch support software that comes with the HyperBase system.
  35 ;;
  36 ;;   Then load this package and Hyperbole will do the following when
  37 ;;   in a Hyperbase buffer:
  38 ;;
  39 ;;     Action Key press on a button follows the link, within any other
  40 ;;     text, closes current Epoch screen and kills node buffer.
  41 ;;
  42 ;;     Assist Key press shows attributes for the current button or
  43 ;;     for the current node buffer, if no current button.
  44 ;;
  45
  46 ;;; Code:
  47
  48 ;;;
  49 ;;; Other required Elisp libraries
  50 ;;;
  51
  52 (require 'hbut)
  53
  54 ;;;
  55 ;;; Public variables
  56 ;;;
  57
  58 (defib hyperbase ()
  59   "Detects link buttons in buffers that communicate with the Hyperbase system.
  60 Hyperbase is a hypertext database system that interfaces to Emacs."
  61   (and (boundp 'ehts-mode) ehts-mode
  62        (let ((lbl (or (ebut:label-p 'as-label "[-> " "]")
  63                       "no-but")))
  64          (ibut:label-set lbl)
  65          (hact 'hyperbase lbl))))
  66
  67 (defact hyperbase (linkname)
  68   "Follows LINKNAME in a buffer that communicates with the Hyperbase system.
  69 If LINKNAME equals t, closes the current Epoch screen and kill the
  70 buffer of the current Hyperbase node.
  71 Hyperbase is a hypertext database system that interfaces to Emacs."
  72   ;; From hb-EHTS.el by:
  73   ;;    Uffe Kock Wiil          (kock@iesd.auc.dk)
  74   ;;    Claus Bo Nielsen        (cbn@cci.dk)
  75   ;;
  76   (if (equal linkname "no-but")
  77       (progn (ehts-mouse-kill-screen-and-buffer t)
  78              (and (fboundp 'epoch::select-screen)
  79                   (epoch::select-screen)))
  80     (let ((linknum (cdr (assoc linkname ehts-node-link-alist))) tonode)
  81       (ehts-command t)
  82       (if (< (ehts-hb-sys-call "read" linknum "to data node no" nil t) 0)
  83           (progn
  84             (ehts-command nil)
  85             (error "Can't read \"to data node no\" in link, panic !!!")))
  86       (ehts-read-4bytes)
  87       (setq tonode (ehts-read-4bytes))
  88       (if (< (ehts-hb-sys-call "read" tonode "n name" nil t) 0)
  89           (progn
  90             (ehts-command nil)
  91             (error "Can't read \"name\" in data node, panic !!!")))
  92       (ehts-get-node (ehts-read-null-string))
  93       (and (fboundp 'hproperty:but-create-all)
  94            (hproperty:but-create-all "[-> " "]"))
  95       (ehts-command nil))))
  96
  97 ;;;
  98 ;;; Public functions
  99 ;;;
 100
 101 (defun hyperbase:init ()
 102   "Show initial set of Hyperbase buttons."
 103   (if (assoc (user-full-name) ehts-node-name-alist)
 104       (progn
 105         (ehts-get-node (user-full-name))
 106         (let (buffer screen)
 107           (setq buffer "*Ehts Welcome*")
 108           (setq screen (ehts-find-buffer-screen buffer))
 109           (kill-buffer buffer)
 110           (switch-to-buffer (user-full-name))
 111           (remove-screen screen)))
 112     (if (assoc "dir ehts help" ehts-node-name-alist)
 113         (progn
 114           (ehts-get-node "dir ehts help")
 115           (let (buffer screen)
 116             (setq buffer "*Ehts Welcome*")
 117             (setq screen (ehts-find-buffer-screen buffer))
 118             (kill-buffer buffer)
 119             (switch-to-buffer "dir ehts help")
 120             (remove-screen screen)
 121             (hproperty:but-create "[-> " "]"))))))
 122
 123 (defun hyperbase:help (&optional but)
 124   "Displays attributes of a link button BUT if on one or of the current node.
 125 Hyperbase is a hypertext database system that interfaces to Emacs."
 126   (interactive (list (ibut:at-p)))
 127   (or (and (boundp 'ehts-mode) ehts-mode)
 128       (error "(hyperbase:help): Not in a Hyperbase mode buffer."))
 129   (hyperbase:attr-help
 130    (or (and (symbolp but)
 131             (let ((lbl (ebut:key-to-label (hattr:get but 'lbl-key))))
 132               (if (not (equal lbl "no-but")) lbl)))
 133        (current-buffer))))
 134
 135 ;;;
 136 ;;; Private functions
 137 ;;;
 138
 139 (defun hyperbase:already-displayed-p (name)
 140   "Test if a buffer allready is displayed."
 141   (let (screenid)
 142     (setq screenid (ehts-find-buffer-screen name))
 143     (if screenid
 144         (progn
 145           (switch-screen screenid)
 146           t)
 147       nil)))
 148
 149 (defun hyperbase:attr-help (node-link-spec)
 150   "Show the attributes of a node or a button link from NODE-LINK-SPEC.
 151 A string value of NODE-LINK-SPEC means show attributes for that button link.
 152 A buffer value means show attributes for the node in that buffer."
 153   (interactive)
 154   (or (stringp node-link-spec) (bufferp node-link-spec)
 155       (error "(hyperbase-show-attributes): Non-string or buffer argument."))
 156   (let (entity name string number buffer screenid)
 157     (setq buffer (if (bufferp node-link-spec) (buffer-name node-link-spec))
 158           entity (cdr (assoc (if buffer "node" "link") node-link-list))
 159           buffer (or buffer (buffer-name)))
 160     (if (eq (string-match "Attributes - " buffer) 0)
 161         nil
 162       (if (= entity 0)
 163           (progn
 164             (setq name (concat "Attributes - " buffer))
 165             (if (not (hyperbase:already-displayed-p name))
 166                 (progn
 167                   (setq number (cdr (assoc buffer ehts-node-name-alist))
 168                         string (ehts-create-node-attribute-string number))
 169                   (ehts-setup-attribute-screen name string entity buffer))))
 170         (if (eq ehts-node-link-alist '())
 171             (error "No links in this node."))
 172         (setq name (concat "Attributes - "
 173                            (car (assoc node-link-spec ehts-node-link-alist))))
 174         (if (not (hyperbase:already-displayed-p name))
 175             (progn
 176               (setq number (cdr (assoc (substring name 13)
 177                                        ehts-node-link-alist))
 178                     string (ehts-create-link-attribute-string number))
 179               (ehts-setup-attribute-screen name string entity buffer)))))))
 180
 181 ;;;
 182 ;;; Private variables
 183 ;;;
 184
 185 (provide 'hsys-hbase)
 186
 187 ;;; hsys-hbase.el ends here