home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / hyperbole / hbdata.el < prev    next >
Encoding:
Text File  |  1995-04-17  |  16.7 KB  |  460 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         hbdata.el
  4. ;; SUMMARY:      Hyperbole button attribute accessor methods.
  5. ;; USAGE:        GNU Emacs Lisp Library
  6. ;; KEYWORDS:     hypermedia
  7. ;;
  8. ;; AUTHOR:       Bob Weiner
  9. ;; ORG:          Brown U.
  10. ;;
  11. ;; ORIG-DATE:     2-Apr-91
  12. ;; LAST-MOD:     14-Apr-95 at 15:59:49 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. ;;  This module handles Hyperbole button data/attribute storage.  In
  23. ;;  general, it should not be extended by anyone other than Hyperbole
  24. ;;  maintainers.  If you alter the formats or accessors herein, you are
  25. ;;  likely to make your buttons incompatible with future releases.
  26. ;;  System developers should instead work with and extend the "hbut.el"
  27. ;;  module which provides much of the Hyperbole application programming
  28. ;;  interface and which hides the low level details handled by this
  29. ;;  module.
  30. ;;
  31. ;;
  32. ;;  Button data is typically stored within a file that holds the button
  33. ;;  data for all files within that directory.  The name of this file is
  34. ;;  given by the variable 'hattr:filename,' usually it is ".hypb".
  35. ;;
  36. ;;  Here is a sample from a Hyperbole V2 button data file.  Each button
  37. ;;  data entry is a list of fields:
  38. ;;
  39. ;;    
  40. ;;    "TO-DO"
  41. ;;    (Key            Placeholders  LinkType      <arg-list>             creator and modifier with times)
  42. ;;    ("alt.mouse.el" nil nil       link-to-file  ("./ell/alt-mouse.el") "zzz@cs.brown.edu" "19911027:09:19:26" "zzz" "19911027:09:31:36")
  43. ;;
  44. ;;  which means:  button \<(alt.mouse.el)> found in file "TO-DO" in the current
  45. ;;  directory provides a link to the local file "./ell/alt-mouse.el".  It was
  46. ;;  created and last modified by zzz@cs.brown.edu.
  47. ;;
  48. ;;  All link entries that originate from the same source file are stored
  49. ;;  contiguously, one per line, in reverse order of creation.
  50. ;;  Preceding all such entries is the source name (in the case of a file
  51. ;;  used as a source, no directory information is included, since only
  52. ;;  sources within the same directory as the button data file are used as
  53. ;;  source files within it.
  54. ;;
  55. ;; DESCRIP-END.
  56.  
  57. ;;; ************************************************************************
  58. ;;; Other required Elisp libraries
  59. ;;; ************************************************************************
  60.  
  61. (require 'hbmap)
  62.  
  63. ;;; ************************************************************************
  64. ;;; Public functions
  65. ;;; ************************************************************************
  66.  
  67. ;;; ------------------------------------------------------------------------
  68. ;;; Button data accessor functions
  69. ;;; ------------------------------------------------------------------------
  70. (defun hbdata:action (hbdata)
  71.   "[Hyp V2] Returns action overriding button's action type or nil."
  72.   (nth 1 hbdata))
  73.  
  74. (defun hbdata:actype (hbdata)
  75.   "Returns the action type in HBDATA as a string."
  76.   (let ((nm (symbol-name (nth 3 hbdata))))
  77.     (and nm (if (or (= (length nm) 2) (string-match "::" nm))
  78.         nm (concat "actypes::" nm)))))
  79.  
  80. (defun hbdata:args (hbdata)
  81.   "Returns the list of any arguments given in HBDATA."
  82.   (nth 4 hbdata))
  83.  
  84. (defun hbdata:categ (hbdata)
  85.   "Returns the category of HBDATA's button."
  86.   'explicit)
  87.  
  88. (defun hbdata:creator (hbdata)
  89.   "Returns the user-id of the original creator of HBDATA's button."
  90.   (nth 5 hbdata))
  91.  
  92. (defun hbdata:create-time (hbdata)
  93.   "Returns the original creation time given for HBDATA's button."
  94.   (nth 6 hbdata))
  95.  
  96. (defun hbdata:key (hbdata)
  97.   "Returns the indexing key in HBDATA as a string."
  98.   (car hbdata))
  99.  
  100. (defun hbdata:loc-p (hbdata)
  101.   "[Hyp V1] Returns 'L iff HBDATA referent is within a local file system.
  102. Returns 'R if remote and nil if irrelevant for button action type."
  103.   (nth 1 hbdata))
  104.  
  105. (defun hbdata:modifier (hbdata)
  106.   "Returns the user-id of the most recent modifier of HBDATA's button.
  107. Nil is returned when button has not been modified."
  108.   (nth 7 hbdata))
  109.  
  110. (defun hbdata:mod-time (hbdata)
  111.   "Returns the time of the most recent change to HBDATA's button.
  112. Nil is returned when button has not beened modified."
  113.   (nth 8 hbdata))
  114.  
  115. (defun hbdata:referent (hbdata)
  116.   "Returns the referent name in HBDATA."
  117.   (nth 2 hbdata))
  118.  
  119. (defun hbdata:search (buf label partial)
  120.   "Go to Hyperbole hbdata BUF and find LABEL whole or PARTIAL matches.
  121.  Search is case-insensitive.  Returns list with elements:
  122.  (<button-src> <label-key1> ... <label-keyN>)."
  123.   (set-buffer buf)
  124.   (let ((case-fold-search t) (src-matches) (src) (matches) (end))
  125.     (goto-char (point-min))
  126.     (while (re-search-forward "^\^L\n\"\\([^\"]+\\)\"" nil t)
  127.       (setq src (buffer-substring (match-beginning 1)
  128.                   (match-end 1))
  129.         matches nil)
  130.       (save-excursion
  131.     (setq end (if (re-search-forward "^\^L" nil t)
  132.               (1- (point)) (point-max))))
  133.       (while (re-search-forward
  134.           (concat "^(\"\\(" (if partial "[^\"]*")
  135.               (regexp-quote (ebut:label-to-key label))
  136.               (if partial "[^\"]*") "\\)\"") nil t)
  137.     (setq matches (cons
  138.                (buffer-substring (match-beginning 1)
  139.                      (match-end 1))
  140.                matches)))
  141.       (if matches
  142.       (setq src-matches (cons (cons src matches) src-matches)))
  143.       (goto-char end))
  144.     src-matches))
  145.  
  146. ;;; ------------------------------------------------------------------------
  147. ;;; Button data operators
  148. ;;; ------------------------------------------------------------------------
  149.  
  150. (defun hbdata:build (&optional mod-lbl-key but-sym)
  151.   "Tries to construct button data from optional MOD-LBL-KEY and BUT-SYM.
  152. MOD-LBL-KEY nil means create a new entry, otherwise modify existing one.
  153. BUT-SYM nil means use 'hbut:current'.  If successful, returns a cons of
  154.  (button-data . button-instance-str), else nil."
  155.   (let* ((but) 
  156.      (b (hattr:copy (or but-sym 'hbut:current) 'but))
  157.      (l (hattr:get b 'loc))
  158.      (key (or mod-lbl-key (hattr:get b 'lbl-key)))
  159.      (new-key (if mod-lbl-key (hattr:get b 'lbl-key) key))
  160.      (lbl-instance) (creator) (create-time) (modifier) (mod-time)
  161.      (entry) loc dir)
  162.     (if (null l)
  163.     nil
  164.       (setq loc (if (bufferp l) l (file-name-nondirectory l))
  165.         dir (if (bufferp l) nil (file-name-directory l)))
  166.       (if (setq entry (hbdata:to-entry key loc dir (not mod-lbl-key)))
  167.       (if mod-lbl-key
  168.           (progn
  169.         (setq creator     (hbdata:creator entry)
  170.               create-time (hbdata:create-time entry)
  171.               modifier    (let* ((user (user-login-name))
  172.                      (addr (concat user
  173.                                hyperb:host-domain)))
  174.                     (if (equal creator addr)
  175.                     user addr))
  176.               mod-time    (htz:date-sortable-gmt)
  177.               entry       (cons new-key (cdr entry)))
  178.         (hbdata:delete-entry-at-point)
  179.         (if (setq lbl-instance (hbdata:instance-last new-key loc dir))
  180.             (progn
  181.               (setq lbl-instance (concat ebut:instance-sep
  182.                          (1+ lbl-instance)))
  183.               ;; This line is needed to ensure that the highest
  184.               ;; numbered instance of a label appears before
  185.               ;; other instances, so 'hbdata:instance-last' will work.
  186.               (if (hbdata:to-entry-buf loc dir) (forward-line 1))))
  187.         )
  188.         (let ((inst-num (hbdata:instance-last new-key loc dir)))
  189.           (setq lbl-instance (if inst-num
  190.                      (hbdata:instance-next 
  191.                       (concat new-key ebut:instance-sep
  192.                           (int-to-string inst-num))))))
  193.         ))
  194.       (if (or entry (not mod-lbl-key))
  195.       (cons
  196.        (list (concat new-key lbl-instance)
  197.          (hattr:get b 'action)
  198.          ;; Hyperbole V1 referent compatibility, always nil in V2
  199.          (hattr:get b 'referent)
  200.          ;; Save actype without class prefix
  201.          (let ((actype (hattr:get b 'actype)))
  202.            (and actype (symbolp actype)
  203.             (setq actype (symbol-name actype))
  204.             (intern
  205.              (substring actype (if (string-match "::" actype)
  206.                            (match-end 0) 0)))))
  207.          (let ((mail-dir (and (fboundp 'hmail:composing-dir)
  208.                       (hmail:composing-dir l)))
  209.                (args (hattr:get b 'args)))
  210.            ;; Replace matches for Emacs Lisp directory variable
  211.            ;; values with their variable names in any pathname args.
  212.            (mapcar 'hpath:substitute-var
  213.                (if mail-dir
  214.                    ;; Make pathname args absolute for outgoing mail and
  215.                    ;; news messages.
  216.                    (action:path-args-abs args mail-dir)
  217.                  args)))
  218.          (or creator (concat (user-login-name) hyperb:host-domain))
  219.          (or create-time (htz:date-sortable-gmt))
  220.          modifier
  221.          mod-time)
  222.        lbl-instance)
  223.     ))))
  224.  
  225. (defun hbdata:get-entry (lbl-key key-src &optional directory)
  226.   "Returns button data entry given by LBL-KEY, KEY-SRC and optional DIRECTORY.
  227. Returns nil if no matching entry is found.
  228. A button data entry is a list of attribute values.  Use methods from
  229. class 'hbdata' to operate on the entry."
  230.   (hbdata:apply-entry
  231.    (function (lambda () (read (current-buffer))))
  232.    lbl-key key-src directory))
  233.  
  234. (defun hbdata:instance-next (lbl-key)
  235.   "Returns string for button instance number following LBL-KEY's.
  236. nil if LBL-KEY is nil."
  237.   (and lbl-key
  238.        (if (string-match
  239.         (concat (regexp-quote ebut:instance-sep) "[0-9]+$") lbl-key)
  240.        (concat ebut:instance-sep
  241.            (int-to-string
  242.             (1+ (string-to-int
  243.              (substring lbl-key (1+ (match-beginning 0)))))))
  244.      ":2")))
  245.  
  246. (defun hbdata:instance-last (lbl-key key-src &optional directory)
  247.   "Returns highest instance number for repeated button label.
  248. 1 if not repeated, nil if no instance.
  249. Takes arguments LBL-KEY, KEY-SRC and optional DIRECTORY."
  250.   (hbdata:apply-entry
  251.    (function (lambda () 
  252.            (if (looking-at "[0-9]+")
  253.            (string-to-int (buffer-substring (match-beginning 0)
  254.                             (match-end 0)))
  255.          1)))
  256.    lbl-key key-src directory nil 'instance))
  257.  
  258. (defun hbdata:delete-entry (lbl-key key-src &optional directory)
  259.   "Deletes button data entry given by LBL-KEY, KEY-SRC and optional DIRECTORY.
  260. Returns entry deleted (a list of attribute values) or nil.
  261. Use methods from class 'hbdata' to operate on the entry."
  262.   (hbdata:apply-entry
  263.    (function
  264.     (lambda ()
  265.       (prog1 (read (current-buffer))
  266.     (let ((empty-file-entry "[ \t\n]*\\(\^L\\|\\'\\)")
  267.           (kill))
  268.       (beginning-of-line)
  269.       (hbdata:delete-entry-at-point)
  270.       (if (looking-at empty-file-entry)
  271.           (let ((end (point))
  272.             (empty-hbdata-file "[ \t\n]*\\'"))
  273.         (forward-line -1)
  274.         (if (= (following-char) ?\")
  275.             ;; Last button entry for filename, so del filename.
  276.             (progn (forward-line -1) (delete-region (point) end)))
  277.         (save-excursion
  278.           (goto-char (point-min))
  279.           (if (looking-at empty-hbdata-file)
  280.               (setq kill t)))
  281.         (if kill
  282.             (let ((fname buffer-file-name))
  283.               (erase-buffer) (save-buffer) (kill-buffer nil)
  284.               (hbmap:dir-remove (file-name-directory fname))
  285.               (call-process "rm" nil 0 nil "-f" fname)))))))))
  286.    lbl-key key-src directory))
  287.  
  288. (defun hbdata:delete-entry-at-point ()
  289.   (delete-region (point) (progn (forward-line 1) (point))))
  290.  
  291. (defun hbdata:to-entry (but-key key-src &optional directory instance)
  292.   "Returns button data entry indexed by BUT-KEY, KEY-SRC, optional DIRECTORY.
  293. Returns nil if entry is not found.  Leaves point at start of entry when
  294. successful or where entry should be inserted if unsuccessful.
  295. A button entry is a list.  Use methods from class 'hbdata' to operate on the
  296. entry.  Optional INSTANCE non-nil means search for any button instance matching
  297. but-key."
  298.   (let ((pos-entry-cons
  299.      (hbdata:apply-entry
  300.       (function
  301.        (lambda ()
  302.          (beginning-of-line)
  303.          (cons (point) (read (current-buffer)))))
  304.       but-key key-src directory 'create instance)))
  305.     (hbdata:to-entry-buf key-src directory)
  306.     (forward-line 1)
  307.     (if pos-entry-cons
  308.     (progn
  309.       (goto-char (car pos-entry-cons))
  310.       (cdr pos-entry-cons)))))
  311.  
  312. ;;; ************************************************************************
  313. ;;; Private functions
  314. ;;; ************************************************************************
  315.  
  316. (defun hbdata:apply-entry (function lbl-key key-src &optional directory
  317.                create instance)
  318.   "Invokes FUNCTION with point at hbdata entry given by LBL-KEY, KEY-SRC, optional DIRECTORY.
  319. With optional CREATE, if no such line exists, inserts a new file entry at the
  320. beginning of the hbdata file (which is created if necessary).
  321. INSTANCE non-nil means search for any button instance matching LBL-KEY and
  322. call FUNCTION with point right after any 'ebut:instance-sep' in match.
  323. Returns value of evaluation when a matching entry is found or nil."
  324.   (let ((found)
  325.     (rtn)
  326.     (opoint)
  327.     (end-func))
  328.     (save-excursion
  329.       (unwind-protect
  330.       (progn
  331.         (if (not (bufferp key-src))
  332.         nil
  333.           (set-buffer key-src)
  334.           (cond ((hmail:editor-p)
  335.              (setq end-func (function (lambda ()
  336.                         (hmail:msg-narrow)))))
  337.             ((and (hmail:lister-p)
  338.               (progn (rmail:summ-msg-to) (rmail:to)))
  339.              (setq opoint (point)
  340.                key-src (current-buffer)
  341.                end-func (function (lambda ()
  342.                         (hmail:msg-narrow)
  343.                         (goto-char opoint)
  344.                         (lmail:to)))))
  345.             ((and (hnews:lister-p)
  346.               (progn (rnews:summ-msg-to) (rnews:to)))
  347.              (setq opoint (point)
  348.                key-src (current-buffer)
  349.                end-func (function (lambda ()
  350.                         (hmail:msg-narrow)
  351.                         (goto-char opoint)
  352.                         (lnews:to)))))))
  353.         (setq found (hbdata:to-entry-buf key-src directory create)))
  354.     (if found
  355.         (let ((case-fold-search t)
  356.           (qkey (regexp-quote lbl-key))
  357.           (end (save-excursion (if (search-forward "\n\^L" nil t)
  358.                        (point) (point-max)))))
  359.           (if (if instance
  360.               (re-search-forward
  361.                (concat "\n(\"" qkey "["
  362.                    ebut:instance-sep "\"]") end t)
  363.             (search-forward (concat "\n(\"" lbl-key "\"") end t))
  364.           (progn
  365.             (or instance (beginning-of-line))
  366.             (let (buffer-read-only)
  367.               (setq rtn (funcall function)))))))
  368.     (if end-func (funcall end-func))))
  369.     rtn))
  370.  
  371. (defun hbdata:to-hbdata-buffer (dir &optional create)
  372.   "Reads in the file containing DIR's button data, if any, and returns buffer.
  373. If it does not exist and optional CREATE is non-nil, creates a new
  374. one and returns buffer, otherwise returns nil."
  375.   (let* ((file (expand-file-name hattr:filename (or dir default-directory)))
  376.      (existing-file (or (file-exists-p file) (get-file-buffer file)))
  377.      (buf (or (get-file-buffer file)
  378.           (and (or create existing-file)
  379.                (find-file-noselect file)))))
  380.     (if buf
  381.     (progn (set-buffer buf)
  382.            (or (verify-visited-file-modtime (get-file-buffer file))
  383.            (cond ((yes-or-no-p
  384.                "Hyperbole button data file has changed, read new contents? ") 
  385.               (revert-buffer t t)
  386.               )))
  387.            (or (= (point-max) 1) (eq (char-after 1) ?\^L)
  388.            (error "File %s is not a valid Hyperbole button data table." file))
  389.            (or (equal (buffer-name) file) (rename-buffer file))
  390.            (setq buffer-read-only nil)
  391.            (or existing-file (hbmap:dir-add (file-name-directory file)))
  392.            buf))))
  393.  
  394.  
  395. (defun hbdata:to-entry-buf (key-src &optional directory create)
  396.   "Moves point to end of line in but data buffer matching KEY-SRC.
  397. Uses hbdata file in KEY-SRC's directory, or optional DIRECTORY or if nil, uses
  398. default-directory.
  399. With optional CREATE, if no such line exists, inserts a new file entry at the
  400. beginning of the hbdata file (which is created if necessary).
  401. Returns non-nil if KEY-SRC is found or created, else nil."
  402.   (let ((rtn) (ln-dir))
  403.     (if (bufferp key-src)
  404.     ;; Button buffer has no file attached
  405.     (progn (setq rtn (set-buffer key-src)
  406.              buffer-read-only nil)
  407.            (if (not (hmail:hbdata-to-p))
  408.            (insert "\n" hmail:hbdata-sep "\n"))
  409.            (backward-char 1)
  410.            )
  411.       (setq directory (or (file-name-directory key-src) directory))
  412.       (let ((ln-file) (link-p key-src))
  413.     (while (setq link-p (file-symlink-p link-p))
  414.       (setq ln-file link-p))
  415.     (if ln-file
  416.         (setq ln-dir (file-name-directory ln-file)
  417.           key-src (file-name-nondirectory ln-file))
  418.       (setq key-src (file-name-nondirectory key-src))))
  419.       (if (or (hbdata:to-hbdata-buffer directory create)
  420.           (and ln-dir (hbdata:to-hbdata-buffer ln-dir nil)
  421.            (setq create nil
  422.              directory ln-dir)))
  423.       (progn
  424.         (goto-char 1)
  425.         (cond ((search-forward (concat "\^L\n\"" key-src "\"")
  426.                    nil t)
  427.            (setq rtn t))
  428.           (create
  429.            (setq rtn t)
  430.            (insert "\^L\n\"" key-src "\"\n")
  431.            (backward-char 1))
  432.           ))))
  433.     rtn
  434.     ))
  435.  
  436. (defun hbdata:write (&optional orig-lbl-key but-sym)
  437.   "Tries to write Hyperbole button data from optional ORIG-LBL-KEY and BUT-SYM.
  438. ORIG-LBL-KEY nil means create a new entry, otherwise modify existing one.
  439. BUT-SYM nil means use 'hbut:current'.  If successful, returns 
  440. a button instance string to append to button label or t when first instance.
  441. On failure, returns nil."
  442.   (let ((cns (hbdata:build orig-lbl-key but-sym))
  443.     entry lbl-instance)
  444.     (if (or (and buffer-file-name
  445.          (not (file-writable-p buffer-file-name)))
  446.         (null cns))
  447.     nil
  448.       (setq entry (car cns) lbl-instance (cdr cns))
  449.       (prin1 entry (current-buffer))
  450.       (terpri (current-buffer))
  451.       (or lbl-instance t)
  452.       )))
  453.  
  454.  
  455. ;;; ************************************************************************
  456. ;;; Private variables
  457. ;;; ************************************************************************
  458.  
  459. (provide 'hbdata)
  460.