Mercurial > hg > xemacs-beta
comparison lisp/hyperbole/hui.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: hui.el | |
| 4 ;; SUMMARY: GNU Emacs User Interface to Hyperbole | |
| 5 ;; USAGE: GNU Emacs Lisp Library | |
| 6 ;; KEYWORDS: hypermedia | |
| 7 ;; | |
| 8 ;; AUTHOR: Bob Weiner | |
| 9 ;; ORG: Brown U. | |
| 10 ;; | |
| 11 ;; ORIG-DATE: 19-Sep-91 at 21:42:03 | |
| 12 ;; LAST-MOD: 25-Aug-95 at 02:26:56 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 'hargs) (require 'set) (require 'hmail) | |
| 28 | |
| 29 ;;; ************************************************************************ | |
| 30 ;;; Public variables | |
| 31 ;;; ************************************************************************ | |
| 32 | |
| 33 (defvar hui:ebut-delete-confirm-p t | |
| 34 "*Non-nil means prompt before interactively deleting explicit buttons.") | |
| 35 | |
| 36 ;;; ************************************************************************ | |
| 37 ;;; Public functions | |
| 38 ;;; ************************************************************************ | |
| 39 | |
| 40 (defun hui:ebut-create (&optional start end) | |
| 41 "Creates an explicit but starting from label between optional START and END. | |
| 42 Indicates by delimiting and adding any necessary instance number of the button | |
| 43 label." | |
| 44 (interactive (list (and (marker-position (hypb:mark-marker t)) | |
| 45 (region-beginning)) | |
| 46 (and (marker-position (hypb:mark-marker t)) | |
| 47 (region-end)))) | |
| 48 (let ((default-lbl) lbl but-buf actype) | |
| 49 (save-excursion | |
| 50 (setq default-lbl | |
| 51 (hui:hbut-label-default start end (not (interactive-p))) | |
| 52 lbl (hui:hbut-label default-lbl "ebut-create")) | |
| 53 (if (not (equal lbl default-lbl)) (setq default-lbl nil)) | |
| 54 | |
| 55 (setq but-buf (if default-lbl (current-buffer) (hui:ebut-buf))) | |
| 56 (hui:buf-writable-err but-buf "ebut-create") | |
| 57 | |
| 58 (hattr:set 'hbut:current 'loc (hui:key-src but-buf)) | |
| 59 (hattr:set 'hbut:current 'dir (hui:key-dir but-buf)) | |
| 60 (setq actype (hui:actype)) | |
| 61 (hattr:set 'hbut:current 'actype actype) | |
| 62 (hattr:set 'hbut:current 'args (hargs:actype-get actype)) | |
| 63 (hattr:set 'hbut:current 'action | |
| 64 (and (boundp 'hui:ebut-prompt-for-action) | |
| 65 hui:ebut-prompt-for-action (hui:action actype))) | |
| 66 ) | |
| 67 (ebut:operate lbl nil))) | |
| 68 | |
| 69 (defun hui:ebut-delete (but-key &optional key-src) | |
| 70 "Deletes explicit Hyperbole button given by BUT-KEY in optional KEY-SRC. | |
| 71 KEY-SRC may be a buffer or a pathname, when nil the current buffer is used. | |
| 72 Returns t if button is deleted, nil if user chooses not to delete or signals | |
| 73 an error otherwise. If called interactively, prompts user whether to delete | |
| 74 and derives BUT-KEY from the button that point is within. | |
| 75 Signals an error if point is not within a button." | |
| 76 (interactive (list (if (ebut:at-p) | |
| 77 (hattr:get 'hbut:current 'lbl-key) | |
| 78 nil))) | |
| 79 (cond ((null but-key) | |
| 80 (hypb:error | |
| 81 "(ebut-delete): Point is not over the label of an existing button.")) | |
| 82 ((not (stringp but-key)) | |
| 83 (hypb:error | |
| 84 "(ebut-delete): Invalid label key argument: '%s'." but-key))) | |
| 85 (let ((interactive (interactive-p))) | |
| 86 (if (and hui:ebut-delete-confirm-p interactive) | |
| 87 (if (y-or-n-p (format "Delete button %s%s%s? " | |
| 88 ebut:start | |
| 89 (hbut:key-to-label but-key) ebut:end)) | |
| 90 (hui:ebut-delete-op interactive but-key key-src) | |
| 91 (message "")) | |
| 92 (hui:ebut-delete-op interactive but-key key-src)))) | |
| 93 | |
| 94 (defun hui:ebut-edit () | |
| 95 "Creates or modifies an explicit Hyperbole button when conditions are met. | |
| 96 A region must have been delimited with the action-key and point must now be | |
| 97 within it before this function is called or it will do nothing. The region | |
| 98 must be no larger than the size given by 'ebut:max-len'. It must be entirely | |
| 99 within or entirely outside of an existing explicit button. When region is | |
| 100 within the button, the button is interactively modified. Otherwise, a new | |
| 101 button is created interactively with the region as the default label." | |
| 102 (interactive) | |
| 103 (let ((m (marker-position (hypb:mark-marker t))) | |
| 104 (op action-key-depress-prev-point) (p (point)) (lbl-key)) | |
| 105 (if (and m (eq (marker-buffer m) (marker-buffer op)) | |
| 106 (< op m) (<= (- m op) ebut:max-len) | |
| 107 (<= p m) (<= op p)) | |
| 108 (progn | |
| 109 (if (setq lbl-key (ebut:label-p)) | |
| 110 (hui:ebut-modify lbl-key) | |
| 111 (hui:ebut-create op m)) | |
| 112 t)))) | |
| 113 | |
| 114 (defun hui:ebut-modify (lbl-key) | |
| 115 "Modifies an explicit Hyperbole button given by LBL-KEY. | |
| 116 Signals an error when no such button is found in the current buffer." | |
| 117 (interactive (list (save-excursion | |
| 118 (hui:buf-writable-err (current-buffer) "ebut-modify") | |
| 119 (or (ebut:label-p) | |
| 120 (ebut:label-to-key | |
| 121 (hargs:read-match "Button to modify: " | |
| 122 (ebut:alist) nil t | |
| 123 nil 'ebut)))))) | |
| 124 (let ((lbl (ebut:key-to-label lbl-key)) | |
| 125 (but-buf (current-buffer)) | |
| 126 actype but new-lbl) | |
| 127 (save-excursion | |
| 128 (or (interactive-p) | |
| 129 (hui:buf-writable-err but-buf "ebut-modify")) | |
| 130 | |
| 131 (or (setq but (ebut:get lbl-key but-buf)) | |
| 132 (progn (pop-to-buffer but-buf) | |
| 133 (hypb:error "(ebut-modify): Invalid button, no data for '%s'." lbl))) | |
| 134 | |
| 135 (setq new-lbl | |
| 136 (hargs:read | |
| 137 "Change button label to: " | |
| 138 (function | |
| 139 (lambda (lbl) | |
| 140 (and (not (string= lbl "")) (<= (length lbl) ebut:max-len)))) | |
| 141 lbl | |
| 142 (format "(ebut-modify): Enter a string of at most %s chars." | |
| 143 ebut:max-len) | |
| 144 'string)) | |
| 145 | |
| 146 (hattr:set 'hbut:current 'loc (hui:key-src but-buf)) | |
| 147 (hattr:set 'hbut:current 'dir (hui:key-dir but-buf)) | |
| 148 (setq actype (hui:actype (hattr:get but 'actype))) | |
| 149 (hattr:set 'hbut:current 'actype actype) | |
| 150 (hattr:set 'hbut:current 'args (hargs:actype-get actype 'modifying)) | |
| 151 (hattr:set 'hbut:current 'action | |
| 152 (and (boundp 'hui:ebut-prompt-for-action) | |
| 153 hui:ebut-prompt-for-action (hui:action actype))) | |
| 154 ) | |
| 155 (ebut:operate lbl new-lbl))) | |
| 156 | |
| 157 (defun hui:ebut-rename (curr-label new-label) | |
| 158 "Renames explicit Hyperbole button given by CURR-LABEL to NEW-LABEL. | |
| 159 If called interactively when point is not within an explicit button: | |
| 160 prompts for old and new button label values and performs rename. | |
| 161 If called interactively when point is within an explicit button: | |
| 162 saves button label and tells user to edit label, then call again. | |
| 163 second call changes the button's name from the stored value to the | |
| 164 edited value. | |
| 165 Signals an error if any problem occurs." | |
| 166 (interactive | |
| 167 (save-excursion | |
| 168 (let (curr-label new-label) | |
| 169 (hui:buf-writable-err (current-buffer) "ebut-rename") | |
| 170 (if hui:ebut-label-prev | |
| 171 (setq curr-label hui:ebut-label-prev | |
| 172 new-label (ebut:label-p 'as-label)) | |
| 173 (setq new-label nil | |
| 174 curr-label | |
| 175 (or (ebut:label-p 'as-label) | |
| 176 (let ((buts (ebut:alist))) | |
| 177 (if (null buts) | |
| 178 (hypb:error "(ebut-rename): No explicit buttons in buffer.") | |
| 179 (prog1 (hargs:read-match | |
| 180 "Button label to rename: " | |
| 181 buts nil t nil 'ebut) | |
| 182 (setq new-label | |
| 183 (hargs:read | |
| 184 "Rename button label to: " | |
| 185 (function | |
| 186 (lambda (lbl) | |
| 187 (and (not (string= lbl "")) | |
| 188 (<= (length lbl) ebut:max-len)))) | |
| 189 curr-label | |
| 190 (format | |
| 191 "(ebut-rename): Use a quoted string of at most %s chars." | |
| 192 ebut:max-len) | |
| 193 'string)))))))) | |
| 194 (list curr-label new-label)))) | |
| 195 | |
| 196 (save-excursion | |
| 197 (if (interactive-p) | |
| 198 nil | |
| 199 (hui:buf-writable-err (current-buffer) "ebut-rename") | |
| 200 (if (or (not (stringp curr-label)) (string= curr-label "")) | |
| 201 (hypb:error "(ebut-rename): 'curr-label' must be a non-empty string: %s" | |
| 202 curr-label)) | |
| 203 (and (stringp new-label) (string= new-label "") | |
| 204 (hypb:error "(ebut-rename): 'new-label' must be a non-empty string: %s" | |
| 205 new-label))) | |
| 206 (or (ebut:get (ebut:label-to-key curr-label)) | |
| 207 (hypb:error "(ebut-rename): Can't rename %s since no button data." | |
| 208 curr-label)) | |
| 209 ) | |
| 210 (cond (new-label | |
| 211 (ebut:operate curr-label new-label) | |
| 212 (setq hui:ebut-label-prev nil) | |
| 213 (message "Renamed from '%s' to '%s'." curr-label new-label)) | |
| 214 (curr-label | |
| 215 (setq hui:ebut-label-prev curr-label) | |
| 216 (message "Edit button label and use same command to finish rename.")) | |
| 217 (t (hypb:error "(ebut-rename): Move point to within a button label.")))) | |
| 218 | |
| 219 (defun hui:ebut-search (string &optional match-part) | |
| 220 "Shows lines of files/buffers containing an explicit but match for STRING. | |
| 221 Returns number of buttons matched and displayed. | |
| 222 By default, only matches for whole button labels are found, optional MATCH-PART | |
| 223 enables partial matches. The match lines are shown in a buffer which serves as | |
| 224 a menu to find any of the occurrences." | |
| 225 (interactive (list (read-string "Search for button string: ") | |
| 226 (y-or-n-p "Enable partial matches? "))) | |
| 227 (if (not (stringp string)) | |
| 228 (hypb:error "(ebut-search): String to search for is required.")) | |
| 229 (let* ((prefix (if (> (length string) 14) | |
| 230 (substring string 0 13) string)) | |
| 231 (out-buf (get-buffer-create (concat "*" prefix " Hypb Search*"))) | |
| 232 (total (ebut:search string out-buf match-part))) | |
| 233 (if (> total 0) | |
| 234 (progn | |
| 235 (set-buffer out-buf) | |
| 236 (moccur-mode) | |
| 237 (if (fboundp 'outline-minor-mode) | |
| 238 (and (progn (goto-char 1) | |
| 239 (search-forward "\C-m" nil t)) | |
| 240 (outline-minor-mode 1))) | |
| 241 (if (fboundp 'hproperty:but-create) | |
| 242 (hproperty:but-create nil nil (regexp-quote | |
| 243 (if match-part string | |
| 244 (concat ebut:start string ebut:end))))) | |
| 245 (goto-char (point-min)) | |
| 246 (pop-to-buffer out-buf) | |
| 247 (if (interactive-p) (message "%d match%s." total | |
| 248 (if (> total 1) "es" "")) | |
| 249 total)) | |
| 250 (if (interactive-p) (message "No matches.") | |
| 251 total)))) | |
| 252 | |
| 253 (defun hui:error (&rest args) | |
| 254 (hypb:error "(hui:error): Obsolete, use hypb:error instead.")) | |
| 255 | |
| 256 (defun hui:gbut-create (lbl) | |
| 257 "Creates Hyperbole global button with LBL." | |
| 258 (interactive "sCreate global button labeled: ") | |
| 259 (let (but-buf actype) | |
| 260 (save-excursion | |
| 261 (setq actype (hui:actype)) | |
| 262 (setq but-buf (set-buffer (find-file-noselect gbut:file))) | |
| 263 (hui:buf-writable-err but-buf "ebut-create") | |
| 264 ;; This prevents movement of point which might be useful to user. | |
| 265 (save-excursion | |
| 266 (goto-char (point-max)) | |
| 267 (hattr:set 'hbut:current 'loc (hui:key-src but-buf)) | |
| 268 (hattr:set 'hbut:current 'dir (hui:key-dir but-buf)) | |
| 269 (hattr:set 'hbut:current 'actype actype) | |
| 270 (hattr:set 'hbut:current 'args (hargs:actype-get actype)) | |
| 271 (hattr:set 'hbut:current 'action | |
| 272 (and (boundp 'hui:ebut-prompt-for-action) | |
| 273 hui:ebut-prompt-for-action (hui:action actype))) | |
| 274 (setq lbl (concat lbl (ebut:operate lbl nil))) | |
| 275 (goto-char (point-max)) | |
| 276 (insert "\n") | |
| 277 (save-buffer) | |
| 278 ) | |
| 279 (message "%s created." lbl) | |
| 280 ))) | |
| 281 | |
| 282 (defun hui:gbut-modify (lbl-key) | |
| 283 "Modifies a global Hyperbole button given by LBL-KEY. | |
| 284 Signals an error when no such button is found." | |
| 285 (interactive (list (save-excursion | |
| 286 (hui:buf-writable-err | |
| 287 (find-file-noselect gbut:file) "gbut-modify") | |
| 288 (hbut:label-to-key | |
| 289 (hargs:read-match "Global button to modify: " | |
| 290 (mapcar 'list (gbut:lbl-list)) | |
| 291 nil t nil 'ebut))))) | |
| 292 (let ((lbl (hbut:key-to-label lbl-key)) | |
| 293 (but-buf (find-file-noselect gbut:file)) | |
| 294 actype but new-lbl) | |
| 295 (save-excursion | |
| 296 (or (interactive-p) | |
| 297 (hui:buf-writable-err but-buf "gbut-modify")) | |
| 298 | |
| 299 (or (setq but (ebut:get lbl-key but-buf)) | |
| 300 (progn (pop-to-buffer but-buf) | |
| 301 (hypb:error | |
| 302 "(gbut-modify): Invalid button, no data for '%s'." lbl))) | |
| 303 | |
| 304 (setq new-lbl | |
| 305 (hargs:read | |
| 306 "Change global button label to: " | |
| 307 (function | |
| 308 (lambda (lbl) | |
| 309 (and (not (string= lbl "")) (<= (length lbl) ebut:max-len)))) | |
| 310 lbl | |
| 311 (format "(gbut-modify): Enter a string of at most %s chars." | |
| 312 ebut:max-len) | |
| 313 'string)) | |
| 314 | |
| 315 (hattr:set 'hbut:current 'loc (hui:key-src but-buf)) | |
| 316 (hattr:set 'hbut:current 'dir (hui:key-dir but-buf)) | |
| 317 (setq actype (hui:actype (hattr:get but 'actype))) | |
| 318 (hattr:set 'hbut:current 'actype actype) | |
| 319 (hattr:set 'hbut:current 'args (hargs:actype-get actype 'modifying)) | |
| 320 (hattr:set 'hbut:current 'action | |
| 321 (and (boundp 'hui:ebut-prompt-for-action) | |
| 322 hui:ebut-prompt-for-action (hui:action actype))) | |
| 323 (set-buffer but-buf) | |
| 324 (ebut:operate lbl new-lbl)))) | |
| 325 | |
| 326 (defun hui:hbut-act (&optional but) | |
| 327 "Executes action for optional Hyperbole button symbol BUT in current buffer. | |
| 328 Default is the current button." | |
| 329 (interactive | |
| 330 (let ((but (hbut:at-p)) (lst)) | |
| 331 (list | |
| 332 (cond (but) | |
| 333 ((setq lst (ebut:alist)) | |
| 334 (ebut:get (ebut:label-to-key | |
| 335 (hargs:read-match "Button to execute: " lst nil t | |
| 336 (ebut:label-p 'as-label) 'ebut)))) | |
| 337 (t (hypb:error "(hbut-act): No explicit buttons in buffer.")))))) | |
| 338 (cond ((and (interactive-p) (null but)) | |
| 339 (hypb:error "(hbut-act): No current button to activate.")) | |
| 340 ((not (hbut:is-p but)) | |
| 341 (hypb:error "(hbut-act): Button is invalid; it has no attributes.")) | |
| 342 (t (or but (setq but 'hbut:current)) | |
| 343 (hui:but-flash) (hyperb:act but)))) | |
| 344 | |
| 345 (defun hui:hbut-help (&optional but) | |
| 346 "Checks for and explains an optional button given by symbol, BUT. | |
| 347 BUT defaults to the button whose label point is within." | |
| 348 (interactive) | |
| 349 (setq but (or but (hbut:at-p) | |
| 350 (ebut:get (ebut:label-to-key | |
| 351 (hargs:read-match "Help for button: " | |
| 352 (ebut:alist) nil t nil 'ebut))))) | |
| 353 (or but | |
| 354 (hypb:error "(hbut-help): Move point to a valid Hyperbole button.")) | |
| 355 (if (not (hbut:is-p but)) | |
| 356 (cond (but (hypb:error "(hbut-help): Invalid button.")) | |
| 357 (t (hypb:error | |
| 358 "(hbut-help): Not on an implicit button and no buffer explicit buttons.")))) | |
| 359 (let ((type-help-func (intern-soft | |
| 360 (concat | |
| 361 (htype:names 'ibtypes (hattr:get but 'categ)) | |
| 362 ":help")))) | |
| 363 (or (equal (hypb:indirect-function 'hui:but-flash) | |
| 364 (function (lambda nil))) | |
| 365 ;; Only flash button if point is on it. | |
| 366 (let ((lbl-key (hattr:get but 'lbl-key))) | |
| 367 (and lbl-key | |
| 368 (or (equal lbl-key (ebut:label-p)) | |
| 369 (equal lbl-key (ibut:label-p))) | |
| 370 (hui:but-flash)))) | |
| 371 (if type-help-func | |
| 372 (funcall type-help-func but) | |
| 373 (let ((total (hbut:report but))) | |
| 374 (if total (hui:help-ebut-highlight)))))) | |
| 375 | |
| 376 (defun hui:hbut-label (default-label func-name) | |
| 377 "Reads button label from user using DEFAULT-LABEL and caller's FUNC-NAME." | |
| 378 (hargs:read "Button label: " | |
| 379 (function | |
| 380 (lambda (lbl) | |
| 381 (and (not (string= lbl "")) (<= (length lbl) ebut:max-len)))) | |
| 382 default-label | |
| 383 (format "(%s): Enter a string of at most %s chars." | |
| 384 func-name ebut:max-len) | |
| 385 'string)) | |
| 386 | |
| 387 (defun hui:hbut-label-default (start end &optional skip-len-test) | |
| 388 "Returns default label based on START and END region markers or points. | |
| 389 Optional SKIP-LEN-TEST means don't limit label to 'ebut:max-len' length. | |
| 390 Returns nil if START or END are invalid or if region fails length test. | |
| 391 | |
| 392 Also has side effect of moving point to start of default label, if any." | |
| 393 (if (markerp start) (setq start (marker-position start))) | |
| 394 (if (markerp end) (setq end (marker-position end))) | |
| 395 ;; Test whether to use region as default button label. | |
| 396 (if (and (integerp start) (integerp end) | |
| 397 (or skip-len-test | |
| 398 (<= (max (- end start) (- start end)) ebut:max-len))) | |
| 399 (progn (goto-char start) | |
| 400 (buffer-substring start end)))) | |
| 401 | |
| 402 (defun hui:hbut-report (&optional arg) | |
| 403 "Pretty prints attributes of current button, using optional prefix ARG. | |
| 404 See 'hbut:report'." | |
| 405 (interactive "P") | |
| 406 (if (and arg (symbolp arg)) | |
| 407 (hui:hbut-help arg) | |
| 408 (let ((total (hbut:report arg))) | |
| 409 (if total | |
| 410 (progn (hui:help-ebut-highlight) | |
| 411 (message "%d button%s." total (if (/= total 1) "s" ""))))))) | |
| 412 | |
| 413 (fset 'hui:hbut-summarize 'hui:hbut-report) | |
| 414 | |
| 415 (defun hui:link-directly () | |
| 416 "Creates a Hyperbole link button at depress point, linked to release point. | |
| 417 See also documentation for 'hui:link-possible-types'." | |
| 418 (let* ((link-types (hui:link-possible-types)) | |
| 419 (but-window action-key-depress-window) | |
| 420 (num-types (length link-types)) | |
| 421 (release-window (selected-window)) | |
| 422 (but-modify nil) | |
| 423 type-and-args lbl-key but-loc but-dir) | |
| 424 (select-window action-key-depress-window) | |
| 425 (hui:buf-writable-err (current-buffer) "link-directly") | |
| 426 (if (ebut:at-p) | |
| 427 (progn | |
| 428 (setq but-modify t | |
| 429 but-loc (hattr:get 'hbut:current 'loc) | |
| 430 but-dir (hattr:get 'hbut:current 'dir) | |
| 431 lbl-key (hattr:get 'hbut:current 'lbl-key))) | |
| 432 (setq but-loc (hui:key-src (current-buffer)) | |
| 433 but-dir (hui:key-dir (current-buffer)) | |
| 434 lbl-key (hbut:label-to-key | |
| 435 (hui:hbut-label | |
| 436 (if (marker-position (hypb:mark-marker t)) | |
| 437 (hui:hbut-label-default | |
| 438 (region-beginning) (region-end))) | |
| 439 "link-directly")))) | |
| 440 (select-window release-window) | |
| 441 | |
| 442 (cond ((= num-types 0) | |
| 443 (error "(link-directly): No possible link type to create.")) | |
| 444 ((= num-types 1) | |
| 445 (hui:link-create but-modify | |
| 446 but-window lbl-key but-loc but-dir | |
| 447 (setq type-and-args (car link-types)))) | |
| 448 (t;; more than 1 | |
| 449 (let ((item) | |
| 450 type) | |
| 451 (hui:link-create | |
| 452 but-modify but-window | |
| 453 lbl-key but-loc but-dir | |
| 454 (setq type-and-args | |
| 455 (hui:menu-select | |
| 456 (cons '("Link to>") | |
| 457 (mapcar | |
| 458 (function | |
| 459 (lambda (type-and-args) | |
| 460 (setq type (car type-and-args)) | |
| 461 (list | |
| 462 (capitalize | |
| 463 (if (string-match | |
| 464 "^\\(link-to\\|eval\\)-" | |
| 465 (setq item (symbol-name type))) | |
| 466 (setq item (substring | |
| 467 item (match-end 0))) | |
| 468 item)) | |
| 469 type-and-args | |
| 470 (documentation | |
| 471 (intern (concat "actypes::" | |
| 472 (symbol-name type))))))) | |
| 473 link-types)))))))) | |
| 474 (message "`%s' button %s type `%s'." | |
| 475 (hbut:key-to-label lbl-key) | |
| 476 (if but-modify "set to" "created with") | |
| 477 (car type-and-args)))) | |
| 478 | |
| 479 ;;; ************************************************************************ | |
| 480 ;;; Private functions | |
| 481 ;;; ************************************************************************ | |
| 482 | |
| 483 (defun hui:action (actype &optional prompt) | |
| 484 "Prompts for and returns an action to override action from ACTYPE." | |
| 485 (and actype | |
| 486 (let* ((act) (act-str) | |
| 487 (params (actype:params actype)) | |
| 488 (params-str (and params (concat " " (prin1-to-string params)))) | |
| 489 ) | |
| 490 (while (progn | |
| 491 (while (and (setq act-str | |
| 492 (hargs:read | |
| 493 (or prompt (concat "Action" params-str | |
| 494 ": ")) nil nil | |
| 495 nil 'string)) | |
| 496 (not (string= act-str "")) | |
| 497 (condition-case () | |
| 498 (progn (setq act (read act-str)) nil) | |
| 499 (error | |
| 500 (beep) (message "Invalid action syntax.") | |
| 501 (sit-for 3) t)))) | |
| 502 (and (not (symbolp act)) | |
| 503 params | |
| 504 ;; Use the weak condition that action must | |
| 505 ;; involve at least one of actype's parameters | |
| 506 ;; or else we assume the action is invalid, tell | |
| 507 ;; the user and provide another chance for entry. | |
| 508 (not (memq t | |
| 509 (mapcar | |
| 510 (function | |
| 511 (lambda (param) | |
| 512 (setq param (symbol-name param)) | |
| 513 (and (string-match | |
| 514 (concat "[\( \t\n,']" | |
| 515 (regexp-quote param) | |
| 516 "[\(\) \t\n\"]") | |
| 517 act-str) | |
| 518 t))) | |
| 519 params))) | |
| 520 )) | |
| 521 (beep) (message "Action must use at least one parameter.") | |
| 522 (sit-for 3)) | |
| 523 (let (head) | |
| 524 (while (cond ((listp act) | |
| 525 (and act (setq head (car act)) | |
| 526 (not (or (eq head 'lambda) | |
| 527 (eq head 'defun) | |
| 528 (eq head 'defmacro))) | |
| 529 (setq act (list 'lambda params act)) | |
| 530 nil ;; terminate loop | |
| 531 )) | |
| 532 ((symbolp act) | |
| 533 (setq act (cons act params))) | |
| 534 ((stringp act) | |
| 535 (setq act (action:kbd-macro act 1))) | |
| 536 ;; Unrecognized form | |
| 537 (t (setq act nil)) | |
| 538 ))) | |
| 539 act))) | |
| 540 | |
| 541 (defun hui:actype (&optional default-actype prompt) | |
| 542 "Using optional DEFAULT-ACTYPE, PROMPTs for a button action type. | |
| 543 DEFAULT-ACTYPE may be a valid symbol or symbol-name." | |
| 544 (and default-actype (symbolp default-actype) | |
| 545 (progn | |
| 546 (setq default-actype (symbol-name default-actype)) | |
| 547 (if (string-match "actypes::" default-actype) | |
| 548 (setq default-actype (substring default-actype (match-end 0)))))) | |
| 549 (if (or (null default-actype) (stringp default-actype)) | |
| 550 (intern-soft | |
| 551 (concat "actypes::" | |
| 552 (hargs:read-match (or prompt "Button's action type: ") | |
| 553 (mapcar 'list (htype:names 'actypes)) | |
| 554 nil t default-actype 'actype))) | |
| 555 (hypb:error "(actype): Invalid default action type received.") | |
| 556 )) | |
| 557 | |
| 558 (defun hui:buf-writable-err (but-buf func-name) | |
| 559 "If BUT-BUF is read-only or is unwritable, signal an error from FUNC-NAME." | |
| 560 (let ((obuf (prog1 (current-buffer) (set-buffer but-buf))) | |
| 561 ;; (unwritable (and buffer-file-name | |
| 562 ;; (not (file-writable-p buffer-file-name)))) | |
| 563 (err)) | |
| 564 ;; (if unwritable | |
| 565 ;; Commented error out since some people want to be able to create | |
| 566 ;; buttons within files which they have purposely marked read-only. | |
| 567 ;; (setq err | |
| 568 ;; (format "(ebut-modify): You are not allowed to modify '%s'." | |
| 569 ;; (file-name-nondirectory buffer-file-name)))) | |
| 570 (if buffer-read-only | |
| 571 (setq err | |
| 572 (format | |
| 573 "Button buffer '%s' is read-only. Use %s to change it." | |
| 574 (buffer-name but-buf) | |
| 575 (hypb:cmd-key-string | |
| 576 (if (where-is-internal 'vc-toggle-read-only) | |
| 577 'vc-toggle-read-only 'toggle-read-only)) | |
| 578 ))) | |
| 579 (set-buffer obuf) | |
| 580 (if err (progn (pop-to-buffer but-buf) (hypb:error err))))) | |
| 581 | |
| 582 (defun hui:ebut-buf (&optional prompt) | |
| 583 "Prompt for and return a buffer in which to place a button." | |
| 584 (let ((buf-name)) | |
| 585 (while | |
| 586 (progn | |
| 587 (setq buf-name | |
| 588 (hargs:read-match | |
| 589 (or prompt "Button's buffer: ") | |
| 590 (delq nil | |
| 591 (mapcar | |
| 592 (function | |
| 593 (lambda (buf) | |
| 594 (let ((b (buffer-name buf))) | |
| 595 (if (and (not (string-match "mail\\*" b)) | |
| 596 (not (string-match "\\*post-news\\*" b)) | |
| 597 (string-match "\\`[* ]" b)) | |
| 598 nil | |
| 599 (cons b nil))))) | |
| 600 (buffer-list))) | |
| 601 nil t (buffer-name) 'buffer)) | |
| 602 (or (null buf-name) (equal buf-name ""))) | |
| 603 (beep)) | |
| 604 (get-buffer buf-name))) | |
| 605 | |
| 606 (defun hui:ebut-delete-op (interactive but-key key-src) | |
| 607 "INTERACTIVEly or not deletes explicit Hyperbole button given by BUT-KEY in KEY-SRC. | |
| 608 KEY-SRC may be a buffer or a pathname, when nil the current buffer is used. | |
| 609 Returns t if button is deleted, signals error otherwise. If called | |
| 610 with INTERACTIVE non-nil, derives BUT-KEY from the button that point is | |
| 611 within." | |
| 612 (let ((buf (current-buffer)) (ebut)) | |
| 613 (if (if interactive | |
| 614 (ebut:delete) | |
| 615 (cond ((or (null key-src) (and (bufferp key-src) (setq buf key-src))) | |
| 616 (setq ebut (ebut:get but-key key-src))) | |
| 617 ((and (stringp key-src) | |
| 618 (setq buf (find-file-noselect key-src))) | |
| 619 (setq ebut (ebut:get but-key buf))) | |
| 620 (t (hypb:error "(ebut-delete): Invalid key-src: '%s'." key-src))) | |
| 621 (if ebut | |
| 622 (ebut:delete ebut) | |
| 623 (hypb:error "(ebut-delete): No valid %s button in %s." | |
| 624 (ebut:key-to-label but-key) buf)) | |
| 625 ) | |
| 626 (progn (set-buffer buf) | |
| 627 (if interactive | |
| 628 (progn | |
| 629 (call-interactively 'hui:ebut-unmark) | |
| 630 (message "Button deleted.")) | |
| 631 (hui:ebut-unmark but-key key-src)) | |
| 632 (if (hmail:reader-p) (hmail:msg-narrow)) | |
| 633 ) | |
| 634 (hypb:error "(ebut-delete): You may not delete buttons from this buffer.")))) | |
| 635 | |
| 636 (defun hui:ebut-delimit (start end instance-str) | |
| 637 (hypb:error "(hui:ebut-delimit): Obsolete, use ebut:delimit instead.")) | |
| 638 | |
| 639 (defun hui:ebut-operate (curr-label new-label) | |
| 640 (hypb:error "(hui:ebut-operate): Obsolete, use ebut:operate instead.")) | |
| 641 | |
| 642 (defun hui:ebut-unmark (&optional but-key key-src directory) | |
| 643 "Remove delimiters from button given by BUT-KEY in KEY-SRC of DIRECTORY. | |
| 644 All args are optional, the current button and buffer file are the defaults." | |
| 645 (interactive) | |
| 646 (let ((form (function | |
| 647 (lambda () | |
| 648 (let ((buffer-read-only) start end) | |
| 649 (setq start (match-beginning 0) | |
| 650 end (match-end 0)) | |
| 651 (and (fboundp 'hproperty:but-delete) | |
| 652 (hproperty:but-delete start)) | |
| 653 (skip-chars-backward " \t\n") | |
| 654 (skip-chars-backward "0-9") | |
| 655 (if (= (preceding-char) (string-to-char ebut:instance-sep)) | |
| 656 (setq start (1- (point)))) | |
| 657 (if (search-backward ebut:start (- (point) ebut:max-len) t) | |
| 658 (if current-prefix-arg | |
| 659 ;; Remove button label, delimiters and preceding | |
| 660 ;; space, if any. | |
| 661 (delete-region (max (point-min) | |
| 662 (1- (match-beginning 0))) | |
| 663 end) | |
| 664 ;; | |
| 665 ;; Remove button delimiters only. | |
| 666 ;; | |
| 667 ;; Remove button ending delimiter | |
| 668 (delete-region start end) | |
| 669 ;; Remove button starting delimiter | |
| 670 (delete-region (match-beginning 0) | |
| 671 (match-end 0))))))))) | |
| 672 (if (interactive-p) | |
| 673 (save-excursion | |
| 674 (if (search-forward ebut:end nil t) (funcall form))) | |
| 675 ;; Non-interactive invocation. | |
| 676 (let ((cur-p)) | |
| 677 (if (and (or (null key-src) (eq key-src buffer-file-name)) | |
| 678 (or (null directory) (eq directory default-directory))) | |
| 679 (setq cur-p t) | |
| 680 (set-buffer (find-file-noselect | |
| 681 (expand-file-name key-src directory)))) | |
| 682 (save-excursion | |
| 683 (goto-char (point-min)) | |
| 684 (if (re-search-forward (ebut:label-regexp but-key) nil t) | |
| 685 (progn (funcall form) | |
| 686 ;; If modified a buffer other than the current one, | |
| 687 ;; save it. | |
| 688 (or cur-p (save-buffer))))))))) | |
| 689 | |
| 690 (defun hui:file-find (file-name) | |
| 691 "If FILE-NAME is readable, finds it, else signals an error." | |
| 692 (if (and (stringp file-name) (file-readable-p file-name)) | |
| 693 (find-file file-name) | |
| 694 (hypb:error "(file-find): \"%s\" does not exist or is not readable." | |
| 695 file-name))) | |
| 696 | |
| 697 (defun hui:hbut-term-highlight (start end) | |
| 698 "For terminals only: Emphasize a button spanning from START to END." | |
| 699 (save-restriction | |
| 700 (save-excursion | |
| 701 (goto-char start) | |
| 702 (narrow-to-region (point-min) start) | |
| 703 (sit-for 0) | |
| 704 (setq inverse-video t) | |
| 705 (goto-char (point-min)) | |
| 706 (widen) | |
| 707 (narrow-to-region (point) end) | |
| 708 (sit-for 0) | |
| 709 (setq inverse-video nil) | |
| 710 ))) | |
| 711 | |
| 712 (defun hui:hbut-term-unhighlight (start end) | |
| 713 "For terminals only: Remove any emphasis from hyper-button at START to END." | |
| 714 (save-restriction | |
| 715 (save-excursion | |
| 716 (goto-char start) | |
| 717 (narrow-to-region (point-min) start) | |
| 718 (sit-for 0) | |
| 719 (setq inverse-video nil)))) | |
| 720 | |
| 721 (defun hui:help-ebut-highlight () | |
| 722 "Highlight any explicit buttons in help buffer associated with current buffer." | |
| 723 (if (fboundp 'hproperty:but-create) | |
| 724 (save-excursion | |
| 725 (set-buffer | |
| 726 (get-buffer (hypb:help-buf-name))) | |
| 727 (hproperty:but-create)))) | |
| 728 | |
| 729 (defun hui:htype-delete (htype-sym) | |
| 730 "Deletes HTYPE-SYM from use in current Hyperbole session. | |
| 731 HTYPE-SYM must be redefined for use again." | |
| 732 (and htype-sym (symbolp htype-sym) | |
| 733 (let ((type | |
| 734 (intern (hargs:read-match | |
| 735 (concat "Delete from " (symbol-name htype-sym) ": ") | |
| 736 (mapcar 'list (htype:names htype-sym)) | |
| 737 nil t nil htype-sym)))) | |
| 738 (htype:delete type htype-sym)))) | |
| 739 | |
| 740 (defun hui:htype-help (htype-sym &optional no-sort) | |
| 741 "Displays documentation for types from HTYPE-SYM which match to a regexp. | |
| 742 Optional NO-SORT means display in decreasing priority order (natural order)." | |
| 743 (and htype-sym (symbolp htype-sym) | |
| 744 (let* ((tstr (symbol-name htype-sym)) | |
| 745 (tprefix (concat tstr "::")) | |
| 746 (buf-name (hypb:help-buf-name (capitalize tstr))) | |
| 747 (temp-buffer-show-hook | |
| 748 (function | |
| 749 (lambda (buf) | |
| 750 (set-buffer buf) (goto-char (point-min)) | |
| 751 (replace-regexp "^" " ") (goto-char (point-min)) | |
| 752 (replace-string (concat " " tprefix) "") | |
| 753 (goto-char (point-min)) (set-buffer-modified-p nil) | |
| 754 (display-buffer buf nil)))) | |
| 755 (temp-buffer-show-function temp-buffer-show-hook) | |
| 756 (names (htype:names htype-sym)) | |
| 757 (term (hargs:read-match | |
| 758 (concat (capitalize tstr) | |
| 759 " to describe (RTN for all): ") | |
| 760 (mapcar 'list (cons "" names)) | |
| 761 nil t nil htype-sym)) | |
| 762 nm-list | |
| 763 doc-list) | |
| 764 (setq nm-list | |
| 765 (if (string= term "") | |
| 766 (let ((type-names | |
| 767 (mapcar (function (lambda (nm) (concat tprefix nm))) | |
| 768 names))) | |
| 769 (if no-sort type-names | |
| 770 (sort type-names 'string<))) | |
| 771 (cons (concat tprefix term) nil)) | |
| 772 doc-list (delq nil (mapcar | |
| 773 (function | |
| 774 (lambda (name) | |
| 775 (let ((doc (documentation | |
| 776 (intern-soft name)))) | |
| 777 (if doc (cons name doc))))) | |
| 778 nm-list))) | |
| 779 (with-output-to-temp-buffer buf-name | |
| 780 (mapcar (function (lambda (nm-doc-cons) | |
| 781 (princ (car nm-doc-cons)) (terpri) | |
| 782 (princ (cdr nm-doc-cons)) (terpri))) | |
| 783 doc-list))))) | |
| 784 | |
| 785 (defun hui:key-dir (but-buf) | |
| 786 "Returns button key src directory based on BUT-BUF, a buffer." | |
| 787 (if (bufferp but-buf) | |
| 788 (let ((file (buffer-file-name but-buf))) | |
| 789 (if file | |
| 790 (file-name-directory (hpath:symlink-referent file)) | |
| 791 (cdr (assq 'default-directory (buffer-local-variables but-buf))))) | |
| 792 (hypb:error "(hui:key-dir): '%s' is not a valid buffer."))) | |
| 793 | |
| 794 (defun hui:key-src (but-buf) | |
| 795 "Returns button key src location based on BUT-BUF, a buffer. | |
| 796 This is BUT-BUF when button data is stored in the buffer and the | |
| 797 button's source file name when the button data is stored externally." | |
| 798 (save-excursion | |
| 799 (set-buffer but-buf) | |
| 800 (cond ((hmail:mode-is-p) but-buf) | |
| 801 ((hpath:symlink-referent (buffer-file-name but-buf))) | |
| 802 (t but-buf)))) | |
| 803 | |
| 804 (defun hui:link-create (modify but-window lbl-key but-loc but-dir type-and-args) | |
| 805 "Creates or modifies a new Hyperbole button. | |
| 806 If MODIFY is non-nil, modifies button at point in BUT-WINDOW, | |
| 807 otherwise, prompts for button label and creates a button. | |
| 808 LBL-KEY is internal form of button label. BUT-LOC is file or buffer | |
| 809 in which to create button. BUT-DIR is directory of BUT-LOC. | |
| 810 TYPE-AND-ARGS is the action type for the button followed by any arguments it requires." | |
| 811 (hattr:set 'hbut:current 'loc but-loc) | |
| 812 (hattr:set 'hbut:current 'dir but-dir) | |
| 813 (hattr:set 'hbut:current 'actype (intern-soft | |
| 814 (concat "actypes::" | |
| 815 (symbol-name | |
| 816 (car type-and-args))))) | |
| 817 (hattr:set 'hbut:current 'args (cdr type-and-args)) | |
| 818 | |
| 819 (select-window but-window) | |
| 820 (let ((label (ebut:key-to-label lbl-key))) | |
| 821 (ebut:operate label (if modify label))) | |
| 822 ) | |
| 823 | |
| 824 (defun hui:link-possible-types () | |
| 825 "Returns list of possible link types for a Hyperbole button link to point. | |
| 826 Each list element is a list of the link type and any arguments it requires. | |
| 827 | |
| 828 The link types considered are fixed. Defining new link types will not alter | |
| 829 the possible types. The code must be changed to do that. | |
| 830 | |
| 831 Referent Context Possible Link Type Returned | |
| 832 ---------------------------------------------------- | |
| 833 Explicit Button link-to-ebut | |
| 834 or | |
| 835 Info Node link-to-Info-node | |
| 836 or | |
| 837 Mail Reader Msg link-to-mail | |
| 838 | |
| 839 Outline Regexp Prefix link-to-string-match | |
| 840 or | |
| 841 Directory Name link-to-directory | |
| 842 or | |
| 843 File Name link-to-file | |
| 844 or | |
| 845 Koutline Cell link-to-kcell | |
| 846 or | |
| 847 Buffer attached to File link-to-file | |
| 848 or | |
| 849 Buffer without File link-to-buffer-tmp | |
| 850 | |
| 851 Elisp Buffer at Start | |
| 852 or End of Sexpression eval-elisp | |
| 853 " | |
| 854 (let (val) | |
| 855 (delq nil | |
| 856 (list (if (ebut:at-p) | |
| 857 (list 'link-to-ebut buffer-file-name (ebut:label-p))) | |
| 858 (cond ((eq major-mode 'Info-mode) | |
| 859 (let ((hargs:reading-p 'Info-node)) | |
| 860 (list 'link-to-Info-node (hargs:at-p)))) | |
| 861 ((hmail:reader-p) | |
| 862 (list 'link-to-mail | |
| 863 (list (rmail:msg-id-get) buffer-file-name))) | |
| 864 ) | |
| 865 (cond | |
| 866 ;; If link is within an outline-regexp prefix, use | |
| 867 ;; a link-to-string-match. | |
| 868 ((and (boundp 'outline-regexp) | |
| 869 (stringp outline-regexp) | |
| 870 (save-excursion | |
| 871 (<= (point) | |
| 872 (progn | |
| 873 (beginning-of-line) | |
| 874 (if (looking-at outline-regexp) | |
| 875 (match-end 0) | |
| 876 0))))) | |
| 877 (save-excursion | |
| 878 (end-of-line) | |
| 879 (let ((heading (buffer-substring | |
| 880 (point) | |
| 881 (progn (beginning-of-line) (point)))) | |
| 882 (occur 1)) | |
| 883 (while (search-backward heading nil t) | |
| 884 (setq occur (1+ occur))) | |
| 885 (list 'link-to-string-match | |
| 886 heading occur buffer-file-name)))) | |
| 887 ((let ((hargs:reading-p 'directory)) | |
| 888 (setq val (hargs:at-p t))) | |
| 889 (list 'link-to-directory val)) | |
| 890 ((let ((hargs:reading-p 'file)) | |
| 891 (setq val (hargs:at-p t))) | |
| 892 (list 'link-to-file val (point))) | |
| 893 ((eq major-mode 'kotl-mode) | |
| 894 (list 'link-to-kcell buffer-file-name (kcell-view:idstamp))) | |
| 895 (buffer-file-name | |
| 896 (list 'link-to-file buffer-file-name (point))) | |
| 897 (t (list 'link-to-buffer-tmp (buffer-name))) | |
| 898 ) | |
| 899 (and (fboundp 'smart-emacs-lisp-mode-p) | |
| 900 (smart-emacs-lisp-mode-p) | |
| 901 (or (= (char-syntax (following-char)) ?\() | |
| 902 (= (char-syntax (preceding-char)) ?\))) | |
| 903 (setq val (hargs:sexpression-p)) | |
| 904 (list 'eval-elisp val)) | |
| 905 )))) | |
| 906 | |
| 907 | |
| 908 ;;; ************************************************************************ | |
| 909 ;;; Private variables | |
| 910 ;;; ************************************************************************ | |
| 911 | |
| 912 | |
| 913 (defvar hui:ebut-label-prev nil | |
| 914 "String value of previous button name during an explicit button rename. | |
| 915 At other times, values must be nil.") | |
| 916 | |
| 917 (provide 'hui) |