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

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