Mercurial > hg > xemacs-beta
comparison lisp/hyperbole/hbut.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | 4103f0995bd7 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 1 ;;!emacs | |
| 2 ;; | |
| 3 ;; FILE: hbut.el | |
| 4 ;; SUMMARY: Hyperbole button constructs. | |
| 5 ;; USAGE: GNU Emacs Lisp Library | |
| 6 ;; KEYWORDS: extensions, hypermedia | |
| 7 ;; | |
| 8 ;; AUTHOR: Bob Weiner | |
| 9 ;; ORG: Brown U. | |
| 10 ;; | |
| 11 ;; ORIG-DATE: 18-Sep-91 at 02:57:09 | |
| 12 ;; LAST-MOD: 25-Oct-95 at 04:12:59 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 ;; DESCRIP-END. | |
| 22 | |
| 23 ;;; ************************************************************************ | |
| 24 ;;; Other required Elisp libraries | |
| 25 ;;; ************************************************************************ | |
| 26 | |
| 27 (require 'hmoccur) | |
| 28 (require 'hbmap) | |
| 29 (require 'htz) | |
| 30 (require 'hbdata) | |
| 31 (require 'hact) | |
| 32 | |
| 33 ;;; ************************************************************************ | |
| 34 ;;; Public definitions | |
| 35 ;;; ************************************************************************ | |
| 36 | |
| 37 ;;; ======================================================================== | |
| 38 ;;; ebut class - Explicit Hyperbole buttons | |
| 39 ;;; ======================================================================== | |
| 40 | |
| 41 (defvar ebut:hattr-save t | |
| 42 "*Non-nil value saves button data when button source is saved. | |
| 43 Nil disables saving.") | |
| 44 | |
| 45 (defconst ebut:max-len 100 | |
| 46 "Maximum length of a hyper-button label.") | |
| 47 | |
| 48 | |
| 49 (defun ebut:alist (&optional file) | |
| 50 "Returns alist with each element a list containing a button label. | |
| 51 For use as a completion table. Gets labels from optional FILE or current | |
| 52 buffer." | |
| 53 (mapcar 'list (ebut:list file))) | |
| 54 | |
| 55 (defun ebut:at-p (&optional start-delim end-delim) | |
| 56 "Returns explicit Hyperbole button at point or nil. | |
| 57 Assumes point is within first line of button label, if at all. | |
| 58 Optional START-DELIM and END-DELIM are strings that override default | |
| 59 button delimiters." | |
| 60 (let ((key (ebut:label-p nil start-delim end-delim))) | |
| 61 (and key (ebut:get key)))) | |
| 62 | |
| 63 (defun ebut:create (&optional but-sym) | |
| 64 "Creates Hyperbole explicit button based on optional BUT-SYM. | |
| 65 Default is 'hbut:current'. | |
| 66 Button should hold the following attributes (see 'hattr:set'): | |
| 67 lbl-key (normalized button label string), | |
| 68 loc (filename or buffer where button is located), | |
| 69 dir (directory name where button is located), | |
| 70 actype (action type that provides a default action for the button), | |
| 71 action (optional action that overrides the default), | |
| 72 args (list of arguments for action, if action takes a single | |
| 73 argument of the button lbl-key, args may be nil). | |
| 74 | |
| 75 If successful returns any instance number to append to button label | |
| 76 except when instance number would be 1, then returns t. On failure, | |
| 77 returns nil. | |
| 78 | |
| 79 If successful, leaves point in button data buffer, so caller should use | |
| 80 'save-excursion'. Does not save button data buffer." | |
| 81 (let ((lbl-instance (hbdata:write nil but-sym))) | |
| 82 (run-hooks 'ebut:create-hook) | |
| 83 lbl-instance)) | |
| 84 | |
| 85 (defun ebut:delete (&optional but-sym) | |
| 86 "Deletes Hyperbole explicit button based on optional BUT-SYM. | |
| 87 Default is 'hbut:current'. | |
| 88 Returns entry deleted (a list of attribute values) or nil." | |
| 89 (if (null but-sym) (setq but-sym 'hbut:current)) | |
| 90 (if (ebut:is-p but-sym) | |
| 91 (let* ((but-key (hattr:get but-sym 'lbl-key)) | |
| 92 (loc (hattr:get but-sym 'loc)) | |
| 93 (entry (hbdata:delete-entry but-key loc))) | |
| 94 (run-hooks 'ebut:delete-hook) | |
| 95 entry))) | |
| 96 | |
| 97 (defun ebut:get (&optional lbl-key buffer key-src) | |
| 98 "Returns explicit Hyperbole button symbol given by LBL-KEY and BUFFER. | |
| 99 KEY-SRC is given when retrieving global buttons and is full source pathname. | |
| 100 Retrieves button data, converts into a button object and returns a symbol | |
| 101 which references the button. | |
| 102 | |
| 103 All arguments are optional. When none are given, returns symbol for | |
| 104 button that point is within or nil. BUFFER defaults to the current | |
| 105 buffer." | |
| 106 (hattr:clear 'hbut:current) | |
| 107 (save-excursion | |
| 108 (let ((key-file) (key-dir) (but-data) (actype)) | |
| 109 (or lbl-key (setq lbl-key (ebut:label-p))) | |
| 110 (if buffer | |
| 111 (if (bufferp buffer) (set-buffer buffer) | |
| 112 (error "(ebut:get): Invalid buffer argument: %s" buffer))) | |
| 113 (if key-src | |
| 114 nil | |
| 115 (if (equal lbl-key (ebut:label-p)) | |
| 116 nil | |
| 117 (goto-char (point-min)) | |
| 118 (ebut:next-occurrence lbl-key)) | |
| 119 (if (setq key-src (ebut:key-src 'full)) | |
| 120 ;; 'ebut:key-src' sets current buffer to key-src buffer. | |
| 121 (setq buffer (current-buffer))) | |
| 122 ) | |
| 123 (if (and (stringp lbl-key) key-src) | |
| 124 (progn | |
| 125 (if (stringp key-src) | |
| 126 (setq key-dir (file-name-directory key-src) | |
| 127 key-file (file-name-nondirectory key-src))) | |
| 128 (setq but-data (and key-src | |
| 129 (hbdata:get-entry lbl-key (or key-file key-src) | |
| 130 key-dir))) | |
| 131 (if (null but-data) | |
| 132 nil | |
| 133 (hattr:set 'hbut:current 'lbl-key lbl-key) | |
| 134 (hattr:set 'hbut:current 'loc key-src) | |
| 135 (hattr:set 'hbut:current 'categ 'explicit) | |
| 136 (hattr:set 'hbut:current 'action nil) | |
| 137 (hattr:set 'hbut:current 'actype | |
| 138 (intern (setq actype (hbdata:actype but-data)))) | |
| 139 ;; Hyperbole V1 referent compatibility | |
| 140 (if (= (length actype) 2) | |
| 141 (hattr:set 'hbut:current 'referent | |
| 142 (hbdata:referent but-data))) | |
| 143 (hattr:set 'hbut:current 'args (hbdata:args but-data)) | |
| 144 (hattr:set 'hbut:current 'creator (hbdata:creator but-data)) | |
| 145 (hattr:set 'hbut:current | |
| 146 'create-time (hbdata:create-time but-data)) | |
| 147 (hattr:set 'hbut:current | |
| 148 'modifier (hbdata:modifier but-data)) | |
| 149 (hattr:set 'hbut:current | |
| 150 'mod-time (hbdata:mod-time but-data)) | |
| 151 'hbut:current) | |
| 152 ))))) | |
| 153 | |
| 154 (defun ebut:is-p (object) | |
| 155 "Returns non-nil if OBJECT denotes an explicit Hyperbole button." | |
| 156 (and (symbolp object) | |
| 157 (eq (hattr:get object 'categ) 'explicit))) | |
| 158 | |
| 159 (defun ebut:key-of-label-p (key label) | |
| 160 "Returns t iff KEY matches to LABEL in a case insensitive manner." | |
| 161 (and (stringp key) (stringp label) | |
| 162 (equal key (downcase (ebut:label-to-key label))))) | |
| 163 | |
| 164 (defun ebut:key-src (&optional full) | |
| 165 "Return key source (usually unqualified) for current Hyperbole button. | |
| 166 Also sets current buffer to key source. | |
| 167 With optional FULL when source is a pathname, the full pathname is returned." | |
| 168 (let ((src (cond ((hmail:mode-is-p) (current-buffer)) | |
| 169 ((ebut:key-src-fmt)) | |
| 170 ((save-excursion | |
| 171 (save-restriction | |
| 172 (widen) | |
| 173 (if (and (search-backward hbut:source-prefix nil t) | |
| 174 (or (memq (preceding-char) '(?\n ?\^M)) | |
| 175 (= (point) (point-min)))) | |
| 176 (hbut:source full))))) | |
| 177 (buffer-file-name | |
| 178 (if full buffer-file-name | |
| 179 (file-name-nondirectory buffer-file-name))) | |
| 180 (t (current-buffer)) | |
| 181 ))) | |
| 182 (cond ((null src) nil) | |
| 183 ((bufferp src) | |
| 184 (set-buffer src) | |
| 185 src) | |
| 186 ((file-readable-p src) | |
| 187 (set-buffer (find-file-noselect src)) | |
| 188 src) | |
| 189 ((file-readable-p (setq src (hpath:symlink-referent src))) | |
| 190 (set-buffer (find-file-noselect src)) | |
| 191 src)))) | |
| 192 | |
| 193 (defun ebut:key-src-fmt () | |
| 194 "Returns unformatted filename associated with formatted current buffer. | |
| 195 This is used to obtain the source of explicit buttons for buffers that | |
| 196 represent the output of particular document formatters." | |
| 197 (cond ((or (eq major-mode 'Info-mode) | |
| 198 (string-match "\\.info\\(-[0-9]+\\)?$" (buffer-name))) | |
| 199 (let ((src (and buffer-file-name | |
| 200 (substring | |
| 201 buffer-file-name | |
| 202 0 (string-match "\\.[^.]+$" buffer-file-name))))) | |
| 203 (cond ((file-exists-p (concat src ".texi")) | |
| 204 (concat src ".texi")) | |
| 205 ((file-exists-p (concat src ".texinfo")) | |
| 206 (concat src ".texinfo")) | |
| 207 ((current-buffer))))) | |
| 208 )) | |
| 209 | |
| 210 (defun ebut:key-to-label (lbl-key) | |
| 211 "Unnormalizes LBL-KEY and returns a label string approximating actual label." | |
| 212 (if lbl-key | |
| 213 (let* ((pos 0) (len (length lbl-key)) (lbl) c) | |
| 214 (while (< pos len) | |
| 215 (setq c (aref lbl-key pos) | |
| 216 lbl (concat lbl | |
| 217 (if (= c ?_) | |
| 218 (if (or (= (1+ pos) len) | |
| 219 (/= (aref lbl-key (1+ pos)) ?_)) | |
| 220 " " | |
| 221 (setq pos (1+ pos)) | |
| 222 "_") | |
| 223 (char-to-string c))) | |
| 224 pos (1+ pos))) | |
| 225 lbl))) | |
| 226 | |
| 227 (defun ebut:label-p (&optional as-label start-delim end-delim pos-flag) | |
| 228 "Returns key for Hyperbole button label that point is within. | |
| 229 Returns nil if not within a label. | |
| 230 Assumes point is within first line of button label, if at all. | |
| 231 If optional AS-LABEL is non-nil, label is returned rather than the key | |
| 232 derived from the label. Optional START-DELIM and END-DELIM are strings | |
| 233 that override default button delimiters. With optional POS-FLAG non-nil, | |
| 234 returns list of label-or-key, but-start-position, but-end-position. | |
| 235 Positions include delimiters." | |
| 236 (let ((opoint (point)) | |
| 237 (npoint (1+ (point))) | |
| 238 (quoted "\\(^\\|[^\\{]\\)") | |
| 239 (start) | |
| 240 lbl-key end but-start but-end) | |
| 241 (or start-delim (setq start-delim ebut:start)) | |
| 242 (or end-delim (setq end-delim ebut:end)) | |
| 243 (save-excursion | |
| 244 (beginning-of-line) | |
| 245 (while (and (progn | |
| 246 (while (re-search-forward | |
| 247 (concat quoted (regexp-quote start-delim)) | |
| 248 npoint t) | |
| 249 (setq start t)) | |
| 250 start) | |
| 251 (re-search-forward (concat "[^\\{]" (regexp-quote end-delim)) | |
| 252 npoint t)) | |
| 253 (setq start nil)) | |
| 254 (if start | |
| 255 (progn | |
| 256 (setq start (point) | |
| 257 but-start (match-end 1)) | |
| 258 (if (= ?\( (char-syntax (preceding-char))) | |
| 259 (condition-case () | |
| 260 (progn | |
| 261 (forward-char -1) | |
| 262 (forward-list) | |
| 263 (forward-char -2)) | |
| 264 (error (goto-char (1- opoint)))) | |
| 265 (goto-char (1- opoint))) | |
| 266 (and (< (point) (+ start ebut:max-len)) | |
| 267 (re-search-forward (concat quoted (regexp-quote end-delim)) | |
| 268 (+ start ebut:max-len) t) | |
| 269 (setq but-end (point) | |
| 270 end (- (point) (length end-delim)) | |
| 271 lbl-key (ebut:label-to-key (buffer-substring start end))) | |
| 272 (cond (pos-flag | |
| 273 (if as-label | |
| 274 (list (ebut:key-to-label lbl-key) but-start but-end) | |
| 275 (list lbl-key but-start but-end))) | |
| 276 (t (if as-label (ebut:key-to-label lbl-key) lbl-key))))))))) | |
| 277 | |
| 278 (defun ebut:label-regexp (lbl-key &optional no-delim) | |
| 279 "Unnormalizes LBL-KEY. Returns regular expr matching delimited but label. | |
| 280 Optional NO-DELIM leaves off delimiters and leading and trailing space." | |
| 281 (if lbl-key | |
| 282 (let* ((pos 0) | |
| 283 (len (length lbl-key)) | |
| 284 (c) | |
| 285 (sep0 "[ \t\n\^M]*") | |
| 286 (sep "[ \t\n\^M]+") | |
| 287 (regexp (if no-delim "" (concat (regexp-quote ebut:start) sep0))) | |
| 288 (case-fold-search)) | |
| 289 (while (< pos len) | |
| 290 (setq c (aref lbl-key pos) | |
| 291 regexp (concat regexp | |
| 292 (if (= c ?_) | |
| 293 (if (or (= (1+ pos) len) | |
| 294 (/= (aref lbl-key (1+ pos)) ?_)) | |
| 295 sep | |
| 296 (setq pos (1+ pos)) | |
| 297 "_") | |
| 298 (regexp-quote (char-to-string c)))) | |
| 299 pos (1+ pos))) | |
| 300 (if no-delim regexp | |
| 301 (setq regexp (concat regexp sep0 (regexp-quote ebut:end))))))) | |
| 302 | |
| 303 (defun ebut:label-to-key (label) | |
| 304 "Normalizes LABEL for use as a Hyperbole button key and returns key. | |
| 305 Eliminates any fill prefix in the middle of the label, replaces '_' with | |
| 306 '__', removes leading and trailing whitespace and replaces each other | |
| 307 whitespace sequence with '_'." | |
| 308 (if (null label) | |
| 309 nil | |
| 310 (setq label (hbut:fill-prefix-remove label) | |
| 311 ;; Remove leading and trailing space. | |
| 312 label (hypb:replace-match-string "\\`[ \t\n\^M]+\\|[ \t\n\^M]+\\'" | |
| 313 label "" t) | |
| 314 label (hypb:replace-match-string "_" label "__" t)) | |
| 315 (hypb:replace-match-string "[ \t\n\^M]+" label "_" t))) | |
| 316 | |
| 317 (defun ebut:list (&optional file loc-p) | |
| 318 "Returns list of button labels from given FILE or current buffer. | |
| 319 Removes duplicate labels if optional LOC-P is omitted. With LOC-P, returns | |
| 320 list of elements (label start end) where start and end are the buffer | |
| 321 positions at which the starting button delimiter begins and ends." | |
| 322 (interactive) | |
| 323 (setq file (if file (and (file-exists-p file) (find-file-noselect file)) | |
| 324 (current-buffer))) | |
| 325 (if file | |
| 326 (progn | |
| 327 (set-buffer file) | |
| 328 (let ((buts (ebut:map (if loc-p | |
| 329 (function | |
| 330 (lambda (lbl start end) | |
| 331 ;; Normalize label spacing | |
| 332 (list (ebut:key-to-label | |
| 333 (ebut:label-to-key lbl)) | |
| 334 start end))) | |
| 335 (function | |
| 336 (lambda (lbl start end) | |
| 337 ;; Normalize label spacing | |
| 338 (ebut:key-to-label | |
| 339 (ebut:label-to-key lbl)))))))) | |
| 340 (if loc-p buts (nreverse (set:create buts))))))) | |
| 341 | |
| 342 (fset 'map-ebut 'ebut:map) | |
| 343 (defun ebut:map (but-func &optional start-delim end-delim | |
| 344 regexp-match include-delims) | |
| 345 "Applies BUT-FUNC to buttons delimited by optional START-DELIM and END-DELIM. | |
| 346 If REGEXP-MATCH is non-nil, only buttons which match this argument are | |
| 347 considered. | |
| 348 Maps over portion of buffer visible under any current restriction. | |
| 349 BUT-FUNC must take precisely three arguments: the button label, the | |
| 350 start position of the delimited button label and its end position (positions | |
| 351 include delimiters when INCLUDE-DELIMS is non-nil). | |
| 352 If END-DELIM is a symbol, e.g. t, then START-DELIM is taken as a regular | |
| 353 expression which matches an entire button string." | |
| 354 (or start-delim (setq start-delim ebut:start)) | |
| 355 (or end-delim (setq end-delim ebut:end)) | |
| 356 (let* ((regexp (symbolp end-delim)) | |
| 357 (end-sym (or regexp (substring end-delim -1))) | |
| 358 (rtn) | |
| 359 (quoted) | |
| 360 start end but lbl) | |
| 361 (save-excursion | |
| 362 (goto-char (point-min)) | |
| 363 (setq include-delims (if include-delims 0 1)) | |
| 364 (while (re-search-forward | |
| 365 (if regexp start-delim | |
| 366 (concat (regexp-quote start-delim) | |
| 367 "\\([^" end-sym "\"][^" end-sym "]*\\)" | |
| 368 (regexp-quote end-delim))) | |
| 369 nil t) | |
| 370 (setq start (match-beginning include-delims) | |
| 371 end (match-end include-delims) | |
| 372 but (buffer-substring (match-beginning 0) (match-end 0)) | |
| 373 lbl (buffer-substring (match-beginning 1) (match-end 1))) | |
| 374 (save-excursion | |
| 375 (goto-char start) | |
| 376 (if (or (= (preceding-char) ?\\) (= (preceding-char) ?\{)) | |
| 377 ;; Ignore matches with quoted delimiters. | |
| 378 (setq quoted t))) | |
| 379 (cond (quoted (setq quoted nil)) | |
| 380 ((or (not regexp-match) | |
| 381 (string-match regexp-match but)) | |
| 382 (setq rtn (cons (funcall but-func lbl start end) rtn)))))) | |
| 383 (nreverse rtn))) | |
| 384 | |
| 385 (defun ebut:modify (&optional lbl-key but-sym) | |
| 386 "Modifies existing Hyperbole button from optional LBL-KEY and BUT-SYM. | |
| 387 Defaults are the key for any button label at point and 'hbut:current'. | |
| 388 If successful, returns button's instance number except when instance | |
| 389 number is 1, then returns t. On failure, as when button does not exist, | |
| 390 returns nil. | |
| 391 | |
| 392 If successful, leaves point in button data buffer, so caller should use | |
| 393 'save-excursion'. Does not save button data buffer." | |
| 394 (save-excursion | |
| 395 (let ((lbl-instance (hbdata:write lbl-key but-sym))) | |
| 396 (run-hooks 'ebut:modify-hook) | |
| 397 lbl-instance))) | |
| 398 | |
| 399 (defun ebut:next-occurrence (lbl-key &optional buffer) | |
| 400 "Moves point to next occurrence of button with LBL-KEY in optional BUFFER. | |
| 401 BUFFER defaults to current buffer. It may be a buffer name. | |
| 402 Returns non-nil iff occurrence is found. | |
| 403 | |
| 404 Remember to use (goto-char (point-min)) before calling this in order to | |
| 405 move to the first occurrence of the button." | |
| 406 (if buffer | |
| 407 (if (not (or (bufferp buffer) | |
| 408 (and (stringp buffer) (get-buffer buffer)))) | |
| 409 (error "(ebut:next-occurrence): Invalid buffer arg: %s" buffer) | |
| 410 (switch-to-buffer buffer))) | |
| 411 (if (re-search-forward (ebut:label-regexp lbl-key) nil t) | |
| 412 (goto-char (+ (match-beginning 0) (length ebut:start))))) | |
| 413 | |
| 414 (defun ebut:operate (curr-label new-label) | |
| 415 "Operates on a new or existing Hyperbole button given by CURR-LABEL. | |
| 416 When NEW-LABEL is non-nil, this is substituted for CURR-LABEL and the | |
| 417 associated button is modified. Otherwise, a new button is created. | |
| 418 Returns instance string appended to label to form unique label, nil if | |
| 419 label is already unique. Signals an error when no such button is found | |
| 420 in the current buffer." | |
| 421 (let* ((lbl-key (ebut:label-to-key curr-label)) | |
| 422 (lbl-regexp (ebut:label-regexp lbl-key)) | |
| 423 (modify new-label) | |
| 424 (instance-flag)) | |
| 425 (or new-label (setq new-label curr-label)) | |
| 426 (hattr:set 'hbut:current 'lbl-key (ebut:label-to-key new-label)) | |
| 427 (save-excursion | |
| 428 (if (setq instance-flag | |
| 429 (if modify (ebut:modify lbl-key) (ebut:create))) | |
| 430 (if (hmail:editor-p) (hmail:msg-narrow)))) | |
| 431 (if instance-flag | |
| 432 (progn | |
| 433 ;; Rename all occurrences of button - those with same label. | |
| 434 (if modify | |
| 435 (let* ((but-key-and-pos (ebut:label-p nil nil nil 'pos)) | |
| 436 (at-but (equal (car but-key-and-pos) | |
| 437 (ebut:label-to-key new-label)))) | |
| 438 (if at-but | |
| 439 (ebut:delimit (nth 1 but-key-and-pos) | |
| 440 (nth 2 but-key-and-pos) | |
| 441 instance-flag)) | |
| 442 (cond ((ebut:map | |
| 443 (function | |
| 444 (lambda (lbl start end) | |
| 445 (delete-region start end) | |
| 446 (ebut:delimit | |
| 447 (point) | |
| 448 (progn (insert new-label) (point)) | |
| 449 instance-flag))) | |
| 450 nil nil lbl-regexp 'include-delims)) | |
| 451 (at-but) | |
| 452 ((hypb:error "(ebut:operate): No button matching: %s" curr-label)))) | |
| 453 ;; Add a new button. | |
| 454 (let (start end buf-lbl) | |
| 455 (cond ((and (marker-position (hypb:mark-marker t)) | |
| 456 (setq start (region-beginning) | |
| 457 end (region-end) | |
| 458 buf-lbl (buffer-substring start end)) | |
| 459 (equal buf-lbl curr-label)) | |
| 460 nil) | |
| 461 ((looking-at (regexp-quote curr-label)) | |
| 462 (setq start (point) | |
| 463 end (match-end 0))) | |
| 464 (t (setq start (point)) | |
| 465 (insert curr-label) | |
| 466 (setq end (point)))) | |
| 467 (ebut:delimit start end instance-flag)) | |
| 468 ) | |
| 469 ;; Position point | |
| 470 (let ((new-key (ebut:label-to-key new-label))) | |
| 471 (cond ((equal (ebut:label-p) new-key) | |
| 472 (forward-char 1) (search-backward ebut:start nil t) | |
| 473 (goto-char (match-end 0))) | |
| 474 ((let ((regexp (ebut:label-regexp new-key))) | |
| 475 (or (re-search-forward regexp nil t) | |
| 476 (re-search-backward regexp nil t))) | |
| 477 (goto-char (+ (match-beginning 0) (length ebut:start)))))) | |
| 478 ;; instance-flag might be 't which we don't want to return. | |
| 479 (if (stringp instance-flag) instance-flag)) | |
| 480 (hypb:error | |
| 481 "(ebut:operate): Operation failed. Check button attribute permissions: %s" | |
| 482 hattr:filename)))) | |
| 483 | |
| 484 (defun ebut:search (string out-buf &optional match-part) | |
| 485 "Writes explicit button lines matching STRING to OUT-BUF. | |
| 486 Uses Hyperbole space into which user has written buttons for the search. | |
| 487 By default, only matches for whole button labels are found, optional MATCH-PART | |
| 488 enables partial matches." | |
| 489 (let* ((buffers (mapcar (function | |
| 490 (lambda (dir) | |
| 491 (expand-file-name hattr:filename dir))) | |
| 492 (hbmap:dir-list))) | |
| 493 (total 0) | |
| 494 (firstmatch)) | |
| 495 (save-excursion | |
| 496 (set-buffer out-buf) | |
| 497 (setq buffer-read-only nil) | |
| 498 (widen) | |
| 499 (erase-buffer) | |
| 500 (let (currbuf currfile kill-buf src-matches dir) | |
| 501 (while buffers | |
| 502 (setq currbuf (car buffers) | |
| 503 currfile (if (stringp currbuf) currbuf) | |
| 504 kill-buf (and currfile (not (get-file-buffer currfile))) | |
| 505 buffers (cdr buffers)) | |
| 506 (if currfile | |
| 507 (setq currbuf (and (file-readable-p currfile) | |
| 508 (find-file-noselect currfile)) | |
| 509 dir (file-name-directory currfile)) | |
| 510 (setq currfile (buffer-file-name currbuf))) | |
| 511 (and currfile currbuf | |
| 512 (unwind-protect | |
| 513 (setq src-matches | |
| 514 (hbdata:search currbuf string match-part)) | |
| 515 (if kill-buf (kill-buffer currbuf)))) | |
| 516 (if src-matches | |
| 517 (let (elt matches) | |
| 518 (while src-matches | |
| 519 (setq elt (car src-matches)) | |
| 520 (if (null elt) nil | |
| 521 (setq src-matches (cdr src-matches) | |
| 522 currfile (expand-file-name (car elt) dir) | |
| 523 matches (cdr elt) | |
| 524 currbuf (get-file-buffer currfile) | |
| 525 kill-buf (not currbuf) | |
| 526 currbuf (or currbuf | |
| 527 (and (file-readable-p currfile) | |
| 528 (find-file-noselect currfile)))) | |
| 529 (if (null currbuf) | |
| 530 (progn (set-buffer out-buf) | |
| 531 (insert "ERROR: (ebut:search): \"" currfile | |
| 532 "\" is not readable.\n\n")) | |
| 533 (set-buffer currbuf) | |
| 534 (unwind-protect | |
| 535 (save-excursion | |
| 536 (widen) (goto-char 1) | |
| 537 (let ((case-fold-search t) | |
| 538 (regexp | |
| 539 (ebut:match-regexp matches match-part))) | |
| 540 (setq firstmatch t) | |
| 541 (while (re-search-forward regexp nil t) | |
| 542 (setq total (1+ total)) | |
| 543 (let* ((linenum (count-lines (point-min) | |
| 544 (point))) | |
| 545 (tag (format "\n%4d:" linenum)) | |
| 546 lns start end) | |
| 547 (setq end (progn (end-of-line) (point)) | |
| 548 start (progn | |
| 549 (goto-char (match-beginning 0)) | |
| 550 (beginning-of-line) (point)) | |
| 551 lns (buffer-substring start end)) | |
| 552 (goto-char end) | |
| 553 (save-excursion | |
| 554 (set-buffer out-buf) | |
| 555 (if firstmatch | |
| 556 (progn | |
| 557 (insert hbut:source-prefix "\"" | |
| 558 currfile "\"\n") | |
| 559 (setq firstmatch nil))) | |
| 560 (insert tag lns)))) | |
| 561 (set-buffer out-buf) | |
| 562 (if (not firstmatch) (insert "\n\n")))) | |
| 563 (if kill-buf (kill-buffer currbuf))))))))))) | |
| 564 total)) | |
| 565 | |
| 566 ;;; ------------------------------------------------------------------------ | |
| 567 (defun ebut:delimit (start end instance-str) | |
| 568 "Delimits button label spanning region START to END in current buffer. | |
| 569 If button is already delimited or delimit fails, returns nil, else t. | |
| 570 Inserts INSTANCE-STR after END, before ending delimiter." | |
| 571 (goto-char start) | |
| 572 (if (looking-at (regexp-quote ebut:start)) | |
| 573 (forward-char (length ebut:start))) | |
| 574 (if (ebut:label-p) | |
| 575 nil | |
| 576 (if (not (stringp instance-str)) (setq instance-str "")) | |
| 577 (insert ebut:start) | |
| 578 (goto-char (setq end (+ end (length ebut:start)))) | |
| 579 (insert instance-str ebut:end) | |
| 580 (setq end (+ end (length instance-str) (length ebut:end))) | |
| 581 (and (fboundp 'hproperty:but-add) (hproperty:but-add start end hproperty:but)) | |
| 582 (hbut:comment start end) | |
| 583 (goto-char end) | |
| 584 t)) | |
| 585 | |
| 586 (defun ebut:match-regexp (match-keys match-part) | |
| 587 "Returns regexp to match to all explicit button keys from MATCH-KEYS." | |
| 588 (setq match-part (if match-part | |
| 589 (concat "[^" (substring ebut:end -1) "]*") | |
| 590 "[ \t\n]*")) | |
| 591 (concat | |
| 592 (regexp-quote ebut:start) match-part | |
| 593 "\\(" (mapconcat (function | |
| 594 (lambda (key) (ebut:label-regexp key 'no-delim))) | |
| 595 match-keys "\\|") | |
| 596 "\\)" match-part (regexp-quote ebut:end))) | |
| 597 | |
| 598 (defconst ebut:start "<(" | |
| 599 "String matching the start of a hyper-button.") | |
| 600 (defconst ebut:end ")>" | |
| 601 "String matching the end of a hyper-button.") | |
| 602 (defconst ebut:instance-sep ":" | |
| 603 "String of one character, separates an ebut label from its instance num.") | |
| 604 | |
| 605 ;;; ======================================================================== | |
| 606 ;;; gbut class - Global Hyperbole buttons - activated by typing label name | |
| 607 ;;; ======================================================================== | |
| 608 | |
| 609 (defvar gbut:file (expand-file-name hbmap:filename hbmap:dir-user) | |
| 610 "File that stores Hyperbole buttons accessible by name, global buttons.") | |
| 611 | |
| 612 (defun gbut:act (label) | |
| 613 "Activates Hyperbole global button with LABEL." | |
| 614 (interactive (list (hargs:read-match "Activate global button labeled: " | |
| 615 (mapcar 'list (gbut:lbl-list)) | |
| 616 nil t nil 'ebut))) | |
| 617 (let* ((lbl-key (hbut:label-to-key label)) | |
| 618 (but (ebut:get lbl-key nil gbut:file))) | |
| 619 (if but | |
| 620 (hbut:act but) | |
| 621 (error "(gbut:act): No global button labeled: %s" label)))) | |
| 622 | |
| 623 (defun gbut:help (label) | |
| 624 "Displays help for Hyperbole global button with LABEL." | |
| 625 (interactive (list (hargs:read-match "Report on global button labeled: " | |
| 626 (mapcar 'list (gbut:lbl-list)) | |
| 627 nil t nil 'ebut))) | |
| 628 (let* ((lbl-key (hbut:label-to-key label)) | |
| 629 (but (ebut:get lbl-key nil gbut:file))) | |
| 630 (if but | |
| 631 (hbut:report but) | |
| 632 (error "(gbut:help): No global button labeled: %s" label)))) | |
| 633 | |
| 634 ;;; ------------------------------------------------------------------------ | |
| 635 (defun gbut:key-list () | |
| 636 "Returns list of global button label keys." | |
| 637 (save-excursion | |
| 638 (if (hbdata:to-entry-buf gbut:file) | |
| 639 (let ((gbuts)) | |
| 640 (save-restriction | |
| 641 (narrow-to-region (point) (if (search-forward "\^L" nil t) | |
| 642 (point) (point-max))) | |
| 643 (goto-char (point-min)) | |
| 644 (condition-case () | |
| 645 (while (setq gbuts (cons (car (read (current-buffer))) gbuts))) | |
| 646 (error nil)) | |
| 647 gbuts))))) | |
| 648 | |
| 649 (defun gbut:lbl-list () | |
| 650 "Returns list of global button labels." | |
| 651 (mapcar 'hbut:key-to-label (gbut:key-list))) | |
| 652 | |
| 653 ;;; ======================================================================== | |
| 654 ;;; hattr class | |
| 655 ;;; ======================================================================== | |
| 656 | |
| 657 (defun hattr:attributes (obj-symbol) | |
| 658 "Returns a list of OBJ-SYMBOL's attributes as symbols." | |
| 659 (if (symbolp obj-symbol) | |
| 660 (let* ((attr-val-list (symbol-plist obj-symbol)) | |
| 661 (i -1)) | |
| 662 (delq nil (mapcar (function | |
| 663 (lambda (elt) | |
| 664 (setq i (1+ i)) | |
| 665 (and (= (% i 2) 0) elt))) | |
| 666 attr-val-list))))) | |
| 667 | |
| 668 (defun hattr:clear (hbut) | |
| 669 "Removes all of HBUT's attributes except `variable-documentation'." | |
| 670 (let (sublist) | |
| 671 (or (symbolp hbut) | |
| 672 (error "(hattr:clear): Argument not a Hyperbole button: %s" hbut)) | |
| 673 (if (setq sublist (memq 'variable-documentation (symbol-plist hbut))) | |
| 674 (progn | |
| 675 (setcdr (cdr sublist) nil) | |
| 676 (setplist hbut sublist)) | |
| 677 (setplist hbut nil) | |
| 678 ))) | |
| 679 | |
| 680 (defun hattr:copy (from-hbut to-hbut) | |
| 681 "Copies attributes FROM-HBUT TO-HBUT, eliminating attributes TO-HBUT had. | |
| 682 Returns TO-HBUT." | |
| 683 (mapcar | |
| 684 (function | |
| 685 (lambda (hbut) | |
| 686 (or (and hbut (symbolp hbut)) | |
| 687 (error "(hattr:clear): Argument not a Hyperbole button: %s" hbut)))) | |
| 688 (list from-hbut to-hbut)) | |
| 689 (unwind-protect | |
| 690 nil | |
| 691 (hattr:clear to-hbut) | |
| 692 (setplist to-hbut (copy-sequence (symbol-plist from-hbut)))) | |
| 693 to-hbut) | |
| 694 | |
| 695 (defun hattr:get (obj-symbol attr-symbol) | |
| 696 "Returns value of OBJ-SYMBOL's attribute ATTR-SYMBOL." | |
| 697 (get obj-symbol attr-symbol)) | |
| 698 | |
| 699 (defun hattr:list (obj-symbol) | |
| 700 "Returns a property list of OBJ-SYMBOL's attributes. | |
| 701 Each pair of elements is: <attrib-name> <attrib-value>." | |
| 702 (if (symbolp obj-symbol) | |
| 703 (symbol-plist obj-symbol) | |
| 704 (error "(hattr:list): Argument not a symbol: %s" obj-symbol))) | |
| 705 | |
| 706 (defun hattr:memq (attr-symbol obj-symbol) | |
| 707 "Returns t if ATTR-SYMBOL is in OBJ-SYMBOL's attribute list, else nil." | |
| 708 (and (symbolp obj-symbol) (symbolp attr-symbol) | |
| 709 (let* ((attr-val-list (symbol-plist obj-symbol)) | |
| 710 (attr-list (let ((i -1)) | |
| 711 (delq nil (mapcar | |
| 712 (function | |
| 713 (lambda (elt) | |
| 714 (setq i (1+ i)) | |
| 715 (and (= (% i 2) 0) elt))) | |
| 716 attr-val-list))))) | |
| 717 (if (memq attr-symbol attr-list) t)))) | |
| 718 | |
| 719 (defun hattr:report (attrib-list) | |
| 720 "Pretty prints to standard-output attribute-value pairs from ATTRIB-LIST. | |
| 721 Ignores nil valued attributes. Returns t unless no attributes are printed." | |
| 722 (let ((has-attr) attr val len) | |
| 723 (if (or (null attrib-list) (not (listp attrib-list)) | |
| 724 ;; odd number of elements? | |
| 725 (= (% (length attrib-list) 2) 1)) | |
| 726 nil | |
| 727 (while (setq attr (car attrib-list)) | |
| 728 (setq val (car (setq attrib-list (cdr attrib-list))) | |
| 729 attrib-list (cdr attrib-list)) | |
| 730 (if val | |
| 731 (progn | |
| 732 (setq has-attr t | |
| 733 attr (symbol-name attr) | |
| 734 len (max (- 16 (length attr)) 1)) | |
| 735 (princ " ") (princ attr) (princ ":") | |
| 736 (princ (make-string len ? )) | |
| 737 (let (str) | |
| 738 (prin1 (cond ((string-match "time" attr) | |
| 739 (htz:date-unix val | |
| 740 (and (>= (aref val 0) ?0) | |
| 741 (<= (aref val 0) ?9) | |
| 742 "GMT") htz:local)) | |
| 743 ((and (setq str (if (stringp val) val | |
| 744 (prin1-to-string val))) | |
| 745 (string-match "\\`actypes::" str)) | |
| 746 (intern (substring str (match-end 0)))) | |
| 747 (t val)))) | |
| 748 (terpri)))) | |
| 749 has-attr))) | |
| 750 | |
| 751 (defun hattr:save () | |
| 752 "Saves button attribute file for current directory, if modified. | |
| 753 Suitable for use as part of 'write-file-hooks'." | |
| 754 (let* ((bd-file (expand-file-name hattr:filename default-directory)) | |
| 755 (buf (and (stringp default-directory) | |
| 756 (get-file-buffer bd-file)))) | |
| 757 (if (and ebut:hattr-save buf (not (eq buf (current-buffer)))) | |
| 758 (let ((ebut:hattr-save));; Prevents 'write-file-hooks' looping. | |
| 759 (and (buffer-modified-p buf) | |
| 760 (save-excursion | |
| 761 (set-buffer buf) (save-buffer) | |
| 762 ;; Unlock button attribute file; kill buffer so user is | |
| 763 ;; never holding a buffer which is out of sync with file, | |
| 764 ;; due to some other user's edits. | |
| 765 ;; Maybe this should be user or site configurable. | |
| 766 (or (buffer-modified-p buf) (kill-buffer buf)) | |
| 767 ))))) | |
| 768 ;; Must return nil, so can be used as part of write-file-hooks. | |
| 769 nil) | |
| 770 | |
| 771 (defun hattr:set (obj-symbol attr-symbol attr-value) | |
| 772 "Sets OBJ-SYMBOL's attribute ATTR-SYMBOL to ATTR-VALUE." | |
| 773 (put obj-symbol attr-symbol attr-value)) | |
| 774 | |
| 775 (fset 'hattr:summarize 'hattr:report) | |
| 776 | |
| 777 (defvar hattr:filename | |
| 778 (if (memq system-type '(ms-windows windows-nt ms-dos)) "_hypb" ".hypb") | |
| 779 "Per directory file name in which explicit button attributes are stored. | |
| 780 If you change its value, you will be unable to use buttons created by | |
| 781 others who use a different value!") | |
| 782 | |
| 783 ;;; ======================================================================== | |
| 784 ;;; hbut class - abstract | |
| 785 ;;; ======================================================================== | |
| 786 | |
| 787 (defun hbut:act (hbut) | |
| 788 "Performs action for explicit or implicit Hyperbole button symbol HBUT." | |
| 789 (and hbut (apply 'actype:act (hattr:get hbut 'actype) | |
| 790 (hattr:get hbut 'args)))) | |
| 791 | |
| 792 (defun hbut:action (hbut) | |
| 793 "Returns appropriate action for Hyperbole button symbol HBUT." | |
| 794 (let ((categ (hattr:get hbut 'categ)) (atype) (action)) | |
| 795 (if (eq categ 'explicit) | |
| 796 (progn (setq action (hattr:get hbut 'action) | |
| 797 atype (hattr:get hbut 'actype)) | |
| 798 (if (= (length (symbol-name atype)) 2) | |
| 799 atype | |
| 800 (or action (actype:action atype)))) | |
| 801 ;; Must be an implicit button. | |
| 802 (if (fboundp atype) atype)))) | |
| 803 | |
| 804 (defun hbut:at-p () | |
| 805 "Returns symbol for explicit or implicit Hyperbole button at point or nil." | |
| 806 (or (ebut:at-p) (ibut:at-p))) | |
| 807 | |
| 808 | |
| 809 (defun hbut:comment (start end) | |
| 810 "Comment button label spanning region START to END in current buffer. | |
| 811 Use buffer commenting grammar, if any, otherwise don't comment." | |
| 812 (save-excursion | |
| 813 (if comment-start | |
| 814 (if (or (equal comment-end "") | |
| 815 (null comment-end)) | |
| 816 (progn | |
| 817 (beginning-of-line) | |
| 818 (if (search-forward comment-start start t) | |
| 819 nil | |
| 820 (goto-char start) | |
| 821 (insert comment-start) | |
| 822 (if (/= (preceding-char) ? ) | |
| 823 (insert ? )))) | |
| 824 ;; Comments have both start and end delimiters | |
| 825 (if (and (re-search-backward | |
| 826 (concat (regexp-quote comment-start) "\\|" | |
| 827 (regexp-quote comment-end)) | |
| 828 nil t) | |
| 829 (looking-at (regexp-quote comment-start))) | |
| 830 nil | |
| 831 (goto-char start) | |
| 832 (insert comment-start) | |
| 833 (if (/= (preceding-char) ? ) | |
| 834 (insert ? )) | |
| 835 (goto-char (+ (point) (- end start))) | |
| 836 (if (/= (following-char) ? ) | |
| 837 (insert ? )) | |
| 838 (insert comment-end) | |
| 839 ))))) | |
| 840 | |
| 841 ;;; Regexps derived in part from "filladapt.el" under the GPL, Copyright | |
| 842 ;;; 1989 Kyle E. Jones. | |
| 843 (defvar hbut:fill-prefix-regexps | |
| 844 '( | |
| 845 ;; Included text in news or mail messages | |
| 846 "\n[ \t]*\\([:|<>]+ *\\)+" | |
| 847 ;; Included text generated by SUPERCITE. We can't hope to match all | |
| 848 ;; the possible variations. | |
| 849 "\n[ \t]*[^'`\"< \t]*> *" | |
| 850 ;; Lisp comments | |
| 851 "\n[ \t]*\\(;+[ \t]*\\)+" | |
| 852 ;; UNIX shell comments | |
| 853 "\n[ \t]*\\(#+[ \t]*\\)+" | |
| 854 ;; C++ comments | |
| 855 "\n[ \t]*//[/ \t]+" | |
| 856 ;; C or Pascal comments, one open and close per line, so match close | |
| 857 ;; then open. | |
| 858 "\\*+[/\)][ \t]*\n+[ \t]*[/\(]\\*+" | |
| 859 "}[ \t]*\n+[ \t]*{" | |
| 860 ;; Eiffel or Sather comments | |
| 861 "\n[ \t]*--[ \t]+" | |
| 862 ;; Fortran comments | |
| 863 "\n[Cc][ \t]+" | |
| 864 ;; Postscript comments | |
| 865 "\n[ \t]*\\(%+[ \t]*\\)+" | |
| 866 ) | |
| 867 "List of regexps of fill prefixes to remove from the middle of buttons.") | |
| 868 | |
| 869 (defun hbut:fill-prefix-remove (label) | |
| 870 "Removes any recognized fill prefix from within LABEL. | |
| 871 'hbut:fill-prefix-regexps' is a list of fill prefixes to recognize." | |
| 872 (if (string-match "\n" label) | |
| 873 (mapcar | |
| 874 (function | |
| 875 (lambda (fill-prefix) | |
| 876 (and (string-match "\n" label) | |
| 877 (setq label | |
| 878 (hypb:replace-match-string fill-prefix label " " t))))) | |
| 879 hbut:fill-prefix-regexps)) | |
| 880 label) | |
| 881 | |
| 882 (defun hbut:is-p (object) | |
| 883 "Returns non-nil if object denotes a Hyperbole button." | |
| 884 (and (symbolp object) (hattr:get object 'categ))) | |
| 885 | |
| 886 (fset 'hbut:key-src 'ebut:key-src) | |
| 887 (fset 'hbut:key-to-label 'ebut:key-to-label) | |
| 888 | |
| 889 (defun hbut:label (hbut) | |
| 890 "Returns the label for Hyperbole button symbol HBUT." | |
| 891 (if (hbut:is-p hbut) | |
| 892 (hbut:key-to-label (hattr:get hbut 'lbl-key)) | |
| 893 (error "(hbut:label): Argument is not a Hyperbole button symbol, '%s'" | |
| 894 hbut))) | |
| 895 | |
| 896 (fset 'hbut:label-p 'ebut:label-p) | |
| 897 (fset 'hbut:label-to-key 'ebut:label-to-key) | |
| 898 | |
| 899 (defun hbut:report (&optional arg) | |
| 900 "Pretty prints the attributes of a button or buttons. | |
| 901 | |
| 902 Takes an optional ARG interpreted as follows: | |
| 903 a button symbol - report on that button; | |
| 904 nil - report on button at point, if any; | |
| 905 integer > 0 - report on all explicit buttons in buffer, alphabetize; | |
| 906 integer < 1 - report on all explicit buttons in occurrence order; | |
| 907 | |
| 908 Returns number of buttons reported on or nil if none." | |
| 909 (setq arg (cond ((or (integerp arg) (symbolp arg)) arg) | |
| 910 ((listp arg) | |
| 911 (if (integerp (setq arg (car arg))) arg 1)) | |
| 912 (t 1))) | |
| 913 (let* ((but (if (and arg (symbolp arg)) arg (hbut:at-p))) | |
| 914 (curr-key (and but (hattr:get but 'lbl-key))) | |
| 915 (key-src (or (and but (hattr:get but 'loc)) (hbut:key-src))) | |
| 916 (lbl-lst (cond ((not arg) | |
| 917 (if curr-key (list (ebut:key-to-label curr-key)))) | |
| 918 ((symbolp arg) (if curr-key | |
| 919 (list (hbut:key-to-label | |
| 920 (hattr:get arg 'lbl-key))))) | |
| 921 ((< arg 1) (ebut:list)) | |
| 922 (t (sort (ebut:list) | |
| 923 (function | |
| 924 (lambda (s1 s2) | |
| 925 (string< (downcase s1) (downcase s2)))))))) | |
| 926 (key-buf (current-buffer)) | |
| 927 (buf-name (hypb:help-buf-name)) | |
| 928 (attribs)) | |
| 929 (if lbl-lst | |
| 930 (progn | |
| 931 (with-output-to-temp-buffer buf-name | |
| 932 (princ hbut:source-prefix) | |
| 933 (prin1 key-src) | |
| 934 (terpri) | |
| 935 (terpri) | |
| 936 (mapcar | |
| 937 (function | |
| 938 (lambda (lbl) | |
| 939 (if (setq but | |
| 940 (cond ((or (null arg) (symbolp arg)) but) | |
| 941 (t (ebut:get (ebut:label-to-key lbl) key-buf))) | |
| 942 attribs (hattr:list but)) | |
| 943 (progn | |
| 944 (princ (if (ibut:is-p but) | |
| 945 lbl | |
| 946 (concat ebut:start lbl ebut:end))) | |
| 947 (terpri) | |
| 948 (let ((doc (actype:doc but (= 1 (length lbl-lst))))) | |
| 949 (if doc | |
| 950 (progn | |
| 951 (princ " ") | |
| 952 (princ doc) | |
| 953 (terpri)))) | |
| 954 (hattr:report | |
| 955 ;; (if (eq (car (cdr (memq 'categ attribs))) 'explicit) | |
| 956 ;; (memq 'action attribs) | |
| 957 ;; (memq 'categ attribs)) | |
| 958 attribs) | |
| 959 (terpri)) | |
| 960 ))) | |
| 961 lbl-lst)) | |
| 962 (length lbl-lst))))) | |
| 963 | |
| 964 (defun hbut:source (&optional full) | |
| 965 "Returns Hyperbole source buffer or file given at point. | |
| 966 If a file, always returns a full path if optional FULL is non-nil." | |
| 967 (goto-char (match-end 0)) | |
| 968 (cond ((looking-at "#<buffer \\([^ \n]+\\)>") | |
| 969 (get-buffer (buffer-substring (match-beginning 1) | |
| 970 (match-end 1)))) | |
| 971 ((looking-at "\".+\"") | |
| 972 (let* ((file (buffer-substring (1+ (match-beginning 0)) | |
| 973 (1- (match-end 0)))) | |
| 974 (absolute (file-name-absolute-p file))) | |
| 975 (if (and full (not absolute)) | |
| 976 (expand-file-name file default-directory) | |
| 977 file))))) | |
| 978 | |
| 979 (fset 'hbut:summarize 'hbut:report) | |
| 980 | |
| 981 (defvar hbut:current nil | |
| 982 "Currently selected Hyperbole button. | |
| 983 Available to action routines.") | |
| 984 | |
| 985 (defconst hbut:source-prefix moccur-source-prefix | |
| 986 "String found at start of a buffer containing only a hyper-button menu. | |
| 987 This expression should be followed immediately by a file-name indicating the | |
| 988 source file for the buttons in the menu, if any.") | |
| 989 | |
| 990 ;;; ======================================================================== | |
| 991 ;;; htype class - Hyperbole Types, e.g. action and implicit button types | |
| 992 ;;; ======================================================================== | |
| 993 | |
| 994 (require 'set) | |
| 995 | |
| 996 (defun htype:body (htype-sym) | |
| 997 "Return body for HTYPE-SYM. If HTYPE-SYM is nil, return nil." | |
| 998 (and htype-sym (hypb:indirect-function htype-sym))) | |
| 999 | |
| 1000 (defun htype:category (type-category) | |
| 1001 "Return list of symbols in Hyperbole TYPE-CATEGORY in priority order. | |
| 1002 Symbols contain category component. | |
| 1003 TYPE-CATEGORY should be 'actypes, 'ibtypes or nil for all." | |
| 1004 (let ((types (symset:get type-category 'symbols)) | |
| 1005 (categ-name (symbol-name type-category))) | |
| 1006 (mapcar (function | |
| 1007 (lambda (type) | |
| 1008 (intern (concat categ-name "::" (symbol-name type))))) | |
| 1009 types))) | |
| 1010 | |
| 1011 ;; Thanks to JWZ for help on this. | |
| 1012 (defmacro htype:create (type type-category doc params body property-list) | |
| 1013 "Create a new Hyperbole TYPE within TYPE-CATEGORY (both unquoted symbols). | |
| 1014 Third arg DOC is a string describing the type. | |
| 1015 Fourth arg PARAMS is a list of parameters to send to the fifth arg BODY, | |
| 1016 which is a list of forms executed when the type is evaluated. | |
| 1017 Sixth arg PROPERTY-LIST is attached to the new type's symbol. | |
| 1018 | |
| 1019 This symbol is returned." | |
| 1020 (let* ((sym (htype:symbol type type-category)) | |
| 1021 (action (nconc (list 'defun sym params doc) body))) | |
| 1022 (` (progn | |
| 1023 (, action) | |
| 1024 (setplist '(, sym) (, property-list)) | |
| 1025 (symset:add '(, type) '(, type-category) 'symbols) | |
| 1026 (run-hooks 'htype:create-hook) | |
| 1027 '(, sym))))) | |
| 1028 | |
| 1029 (defun htype:delete (type type-category) | |
| 1030 "Delete a Hyperbole TYPE derived from TYPE-CATEGORY (both symbols). | |
| 1031 Return the Hyperbole symbol for the TYPE if it existed, else nil." | |
| 1032 (let* ((sym (htype:symbol type type-category)) | |
| 1033 (exists (fboundp 'sym))) | |
| 1034 (setplist sym nil) | |
| 1035 (symset:delete type type-category 'symbols) | |
| 1036 (fmakunbound sym) | |
| 1037 (run-hooks 'htype:delete-hook) | |
| 1038 (and exists sym))) | |
| 1039 | |
| 1040 (defun htype:doc (type) | |
| 1041 "Return documentation for Hyperbole TYPE, a symbol." | |
| 1042 (documentation type)) | |
| 1043 | |
| 1044 (defun htype:names (type-category &optional sym) | |
| 1045 "Return list of current names for Hyperbole TYPE-CATEGORY in priority order. | |
| 1046 Names do not contain category component. | |
| 1047 TYPE-CATEGORY should be 'actypes, 'ibtypes or nil for all. | |
| 1048 When optional SYM is given, return the name for that symbol only, if any." | |
| 1049 (let ((types (symset:get type-category 'symbols)) | |
| 1050 (sym-name (and sym (symbol-name sym)))) | |
| 1051 (if sym-name | |
| 1052 ;; Strip category from sym-name before looking for a match. | |
| 1053 (progn (if (string-match "::" sym-name) | |
| 1054 (setq sym (intern (substring sym-name (match-end 0))))) | |
| 1055 (if (memq sym types) (symbol-name sym))) | |
| 1056 (mapcar 'symbol-name types)))) | |
| 1057 | |
| 1058 ;;; ------------------------------------------------------------------------ | |
| 1059 | |
| 1060 (defun htype:symbol (type type-category) | |
| 1061 "Return Hyperbole type symbol composed from TYPE and TYPE-CATEGORY (both symbols)." | |
| 1062 (intern (concat (symbol-name type-category) "::" | |
| 1063 (symbol-name type)))) | |
| 1064 | |
| 1065 ;;; ======================================================================== | |
| 1066 ;;; ibut class - Implicit Hyperbole Buttons | |
| 1067 ;;; ======================================================================== | |
| 1068 | |
| 1069 (defun ibut:at-p (&optional key-only) | |
| 1070 "Returns symbol for implicit button at point, else nil. | |
| 1071 With optional KEY-ONLY, returns only the label key for button." | |
| 1072 (let ((types (htype:category 'ibtypes)) | |
| 1073 ;; Global var used in (hact) function, don't delete. | |
| 1074 (hrule:action 'actype:identity) | |
| 1075 (itype) | |
| 1076 (args) | |
| 1077 (is-type)) | |
| 1078 (or key-only (hattr:clear 'hbut:current)) | |
| 1079 (while (and (not is-type) types) | |
| 1080 (setq itype (car types)) | |
| 1081 (if (setq args (funcall itype)) | |
| 1082 (setq is-type itype) | |
| 1083 (setq types (cdr types)))) | |
| 1084 (if is-type | |
| 1085 (if key-only | |
| 1086 (hattr:get 'hbut:current 'lbl-key) | |
| 1087 (hattr:set 'hbut:current 'loc (save-excursion | |
| 1088 (hbut:key-src 'full))) | |
| 1089 (hattr:set 'hbut:current 'categ is-type) | |
| 1090 (or (hattr:get 'hbut:current 'args) | |
| 1091 (not (listp args)) | |
| 1092 (progn | |
| 1093 (hattr:set 'hbut:current 'actype | |
| 1094 (or | |
| 1095 ;; Hyperbole action type | |
| 1096 (intern-soft (concat "actypes::" | |
| 1097 (symbol-name (car args)))) | |
| 1098 ;; Regular Emacs Lisp function symbol | |
| 1099 (car args) | |
| 1100 )) | |
| 1101 (hattr:set 'hbut:current 'args (cdr args)))) | |
| 1102 'hbut:current)))) | |
| 1103 | |
| 1104 (defun ibut:is-p (object) | |
| 1105 "Returns non-nil if object denotes an implicit Hyperbole button." | |
| 1106 (if (symbolp object) | |
| 1107 (let ((categ (hattr:get object 'categ))) | |
| 1108 (and categ (string-match "^ibtypes::" (symbol-name categ)))))) | |
| 1109 | |
| 1110 (defun ibut:label-p () | |
| 1111 "Returns key for Hyperbole implicit button label that point is on or nil." | |
| 1112 (ibut:at-p 'key-only)) | |
| 1113 | |
| 1114 (defun ibut:label-set (label &optional start end) | |
| 1115 "Sets current implicit button attributes from LABEL and START, END position. | |
| 1116 START and END are optional. When given, they specify the region in the buffer | |
| 1117 to flash when this implicit button is activated or queried for its attributes. | |
| 1118 If LABEL is a list, it is assumed to contain all arguments." | |
| 1119 (cond ((stringp label) | |
| 1120 (hattr:set 'hbut:current 'lbl-key (hbut:label-to-key label)) | |
| 1121 (and start (hattr:set 'hbut:current 'lbl-start start)) | |
| 1122 (and end (hattr:set 'hbut:current 'lbl-end end))) | |
| 1123 ((and label (listp label)) | |
| 1124 (hattr:set 'hbut:current 'lbl-key (hbut:label-to-key (car label))) | |
| 1125 (hattr:set 'hbut:current 'lbl-start (nth 1 label)) | |
| 1126 (hattr:set 'hbut:current 'lbl-end (nth 2 label))) | |
| 1127 (t (error "(ibut:label-set): Invalid label arg: '%s'" label))) | |
| 1128 t) | |
| 1129 | |
| 1130 ;;; ======================================================================== | |
| 1131 ;;; ibtype class - Implicit button types | |
| 1132 ;;; ======================================================================== | |
| 1133 | |
| 1134 (fset 'defib 'ibtype:create) | |
| 1135 (put 'ibtype:create 'lisp-indent-function 'defun) | |
| 1136 (defmacro ibtype:create (type params doc at-p &optional to-p style) | |
| 1137 "Creates implicit button TYPE (unquoted sym) with PARAMS, described by DOC. | |
| 1138 PARAMS are presently ignored. | |
| 1139 | |
| 1140 AT-P is a boolean form of no arguments which determines whether or not point | |
| 1141 is within a button of this type. | |
| 1142 Optional TO-P is a boolean form which moves point immediately after the next | |
| 1143 button of this type within the current buffer and returns a list of (button- | |
| 1144 label start-pos end-pos), or nil when none is found. | |
| 1145 Optional STYLE is a display style specification to use when highlighting | |
| 1146 buttons of this type; most useful when TO-P is also given. | |
| 1147 | |
| 1148 Returns symbol created when successful, else nil. Nil indicates that action | |
| 1149 type for ibtype is presently undefined." | |
| 1150 (if type | |
| 1151 (let ((to-func (if to-p (action:create nil (list to-p)))) | |
| 1152 (at-func (list at-p))) | |
| 1153 (` (htype:create (, type) ibtypes (, doc) nil (, at-func) | |
| 1154 (list 'to-p (, to-func) 'style (, style))))))) | |
| 1155 | |
| 1156 (defun ibtype:delete (type) | |
| 1157 "Deletes an implicit button TYPE (a symbol). | |
| 1158 Returns TYPE's symbol if it existed, else nil." | |
| 1159 (htype:delete type 'ibtypes)) | |
| 1160 | |
| 1161 ;;; ======================================================================== | |
| 1162 ;;; symset class - Hyperbole internal symbol set maintenance | |
| 1163 ;;; ======================================================================== | |
| 1164 | |
| 1165 (require 'set) | |
| 1166 | |
| 1167 (defun symset:add (elt symbol prop) | |
| 1168 "Adds ELT to SYMBOL's PROP set. | |
| 1169 Returns nil iff ELT is already in SET. Uses 'eq' for comparison." | |
| 1170 (let* ((set (get symbol prop)) | |
| 1171 (set:equal-op 'eq) | |
| 1172 (new-set (set:add elt set))) | |
| 1173 (and new-set (put symbol prop new-set)))) | |
| 1174 | |
| 1175 (fset 'symset:delete 'symset:remove) | |
| 1176 | |
| 1177 (defun symset:get (symbol prop) | |
| 1178 "Returns SYMBOL's PROP set." | |
| 1179 (get symbol prop)) | |
| 1180 | |
| 1181 (defun symset:remove (elt symbol prop) | |
| 1182 "Removes ELT from SYMBOL's PROP set and returns the new set. | |
| 1183 Assumes PROP is a valid set. Uses 'eq' for comparison." | |
| 1184 (let ((set (get symbol prop)) | |
| 1185 (set:equal-op 'eq)) | |
| 1186 (put symbol prop (set:remove elt set)))) | |
| 1187 | |
| 1188 | |
| 1189 (provide 'hbut) |