Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/hbut.el @ 24:4103f0995bd7 r19-15b95

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b95
author cvs
date Mon, 13 Aug 2007 08:51:03 +0200
parents 376386a54a3c
children 131b0175ea99
comparison
equal deleted inserted replaced
23:0edd3412f124 24:4103f0995bd7
4 ;; SUMMARY: Hyperbole button constructs. 4 ;; SUMMARY: Hyperbole button constructs.
5 ;; USAGE: GNU Emacs Lisp Library 5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: extensions, hypermedia 6 ;; KEYWORDS: extensions, hypermedia
7 ;; 7 ;;
8 ;; AUTHOR: Bob Weiner 8 ;; AUTHOR: Bob Weiner
9 ;; ORG: Brown U. 9 ;; ORG: InfoDock Associates
10 ;; 10 ;;
11 ;; ORIG-DATE: 18-Sep-91 at 02:57:09 11 ;; ORIG-DATE: 18-Sep-91 at 02:57:09
12 ;; LAST-MOD: 25-Oct-95 at 04:12:59 by Bob Weiner 12 ;; LAST-MOD: 17-Feb-97 at 15:31:03 by Bob Weiner
13 ;; 13 ;;
14 ;; This file is part of Hyperbole. 14 ;; This file is part of Hyperbole.
15 ;; Available for use and distribution under the same terms as GNU Emacs. 15 ;; Available for use and distribution under the same terms as GNU Emacs.
16 ;; 16 ;;
17 ;; Copyright (C) 1991-1995, Free Software Foundation, Inc. 17 ;; Copyright (C) 1991-1996, Free Software Foundation, Inc.
18 ;; Developed with support from Motorola Inc. 18 ;; Developed with support from Motorola Inc.
19 ;; 19 ;;
20 ;; DESCRIPTION: 20 ;; DESCRIPTION:
21 ;; DESCRIP-END. 21 ;; DESCRIP-END.
22 22
43 Nil disables saving.") 43 Nil disables saving.")
44 44
45 (defconst ebut:max-len 100 45 (defconst ebut:max-len 100
46 "Maximum length of a hyper-button label.") 46 "Maximum length of a hyper-button label.")
47 47
48
49 (defun ebut:act (label)
50 "Activates Hyperbole explicit button with LABEL from the current buffer."
51 (interactive (list (hargs:read-match "Activate explicit button labeled: "
52 (ebut:alist)
53 nil t nil 'ebut)))
54 (let* ((lbl-key (hbut:label-to-key label))
55 (but (ebut:get lbl-key)))
56 (if but
57 (hbut:act but)
58 (error "(ebut:act): No explicit button labeled: %s" label))))
48 59
49 (defun ebut:alist (&optional file) 60 (defun ebut:alist (&optional file)
50 "Returns alist with each element a list containing a button label. 61 "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 62 For use as a completion table. Gets labels from optional FILE or current
52 buffer." 63 buffer."
335 (function 346 (function
336 (lambda (lbl start end) 347 (lambda (lbl start end)
337 ;; Normalize label spacing 348 ;; Normalize label spacing
338 (ebut:key-to-label 349 (ebut:key-to-label
339 (ebut:label-to-key lbl)))))))) 350 (ebut:label-to-key lbl))))))))
340 (if loc-p buts (nreverse (set:create buts))))))) 351 (if loc-p buts (if buts (nreverse (set:create buts))))))))
341 352
342 (fset 'map-ebut 'ebut:map) 353 (fset 'map-ebut 'ebut:map)
343 (defun ebut:map (but-func &optional start-delim end-delim 354 (defun ebut:map (but-func &optional start-delim end-delim
344 regexp-match include-delims) 355 regexp-match include-delims)
345 "Applies BUT-FUNC to buttons delimited by optional START-DELIM and END-DELIM. 356 "Applies BUT-FUNC to buttons delimited by optional START-DELIM and END-DELIM.
610 "File that stores Hyperbole buttons accessible by name, global buttons.") 621 "File that stores Hyperbole buttons accessible by name, global buttons.")
611 622
612 (defun gbut:act (label) 623 (defun gbut:act (label)
613 "Activates Hyperbole global button with LABEL." 624 "Activates Hyperbole global button with LABEL."
614 (interactive (list (hargs:read-match "Activate global button labeled: " 625 (interactive (list (hargs:read-match "Activate global button labeled: "
615 (mapcar 'list (gbut:lbl-list)) 626 (mapcar 'list (gbut:label-list))
616 nil t nil 'ebut))) 627 nil t nil 'ebut)))
617 (let* ((lbl-key (hbut:label-to-key label)) 628 (let* ((lbl-key (hbut:label-to-key label))
618 (but (ebut:get lbl-key nil gbut:file))) 629 (but (ebut:get lbl-key nil gbut:file)))
619 (if but 630 (if but
620 (hbut:act but) 631 (hbut:act but)
621 (error "(gbut:act): No global button labeled: %s" label)))) 632 (error "(gbut:act): No global button labeled: %s" label))))
622 633
623 (defun gbut:help (label) 634 (defun gbut:help (label)
624 "Displays help for Hyperbole global button with LABEL." 635 "Displays help for Hyperbole global button with LABEL."
625 (interactive (list (hargs:read-match "Report on global button labeled: " 636 (interactive (list (hargs:read-match "Report on global button labeled: "
626 (mapcar 'list (gbut:lbl-list)) 637 (mapcar 'list (gbut:label-list))
627 nil t nil 'ebut))) 638 nil t nil 'ebut)))
628 (let* ((lbl-key (hbut:label-to-key label)) 639 (let* ((lbl-key (hbut:label-to-key label))
629 (but (ebut:get lbl-key nil gbut:file))) 640 (but (ebut:get lbl-key nil gbut:file)))
630 (if but 641 (if but
631 (hbut:report but) 642 (hbut:report but)
632 (error "(gbut:help): No global button labeled: %s" label)))) 643 (error "(gbut:help): No global button labeled: %s" label))))
644
645 (defun gbut:label-list ()
646 "Returns list of global button labels."
647 (mapcar 'hbut:key-to-label (gbut:key-list)))
633 648
634 ;;; ------------------------------------------------------------------------ 649 ;;; ------------------------------------------------------------------------
635 (defun gbut:key-list () 650 (defun gbut:key-list ()
636 "Returns list of global button label keys." 651 "Returns list of global button label keys."
637 (save-excursion 652 (save-excursion
643 (goto-char (point-min)) 658 (goto-char (point-min))
644 (condition-case () 659 (condition-case ()
645 (while (setq gbuts (cons (car (read (current-buffer))) gbuts))) 660 (while (setq gbuts (cons (car (read (current-buffer))) gbuts)))
646 (error nil)) 661 (error nil))
647 gbuts))))) 662 gbuts)))))
648
649 (defun gbut:lbl-list ()
650 "Returns list of global button labels."
651 (mapcar 'hbut:key-to-label (gbut:key-list)))
652 663
653 ;;; ======================================================================== 664 ;;; ========================================================================
654 ;;; hattr class 665 ;;; hattr class
655 ;;; ======================================================================== 666 ;;; ========================================================================
656 667
773 (put obj-symbol attr-symbol attr-value)) 784 (put obj-symbol attr-symbol attr-value))
774 785
775 (fset 'hattr:summarize 'hattr:report) 786 (fset 'hattr:summarize 'hattr:report)
776 787
777 (defvar hattr:filename 788 (defvar hattr:filename
778 (if (memq system-type '(ms-windows windows-nt ms-dos)) "_hypb" ".hypb") 789 (if hyperb:microcruft-os-p "_hypb" ".hypb")
779 "Per directory file name in which explicit button attributes are stored. 790 "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 791 If you change its value, you will be unable to use buttons created by
781 others who use a different value!") 792 others who use a different value!")
782 793
783 ;;; ======================================================================== 794 ;;; ========================================================================
784 ;;; hbut class - abstract 795 ;;; hbut class - abstract
785 ;;; ======================================================================== 796 ;;; ========================================================================
786 797
787 (defun hbut:act (hbut) 798 (defun hbut:act (hbut)
788 "Performs action for explicit or implicit Hyperbole button symbol HBUT." 799 "Performs action for explicit or implicit Hyperbole button symbol HBUT."
789 (and hbut (apply 'actype:act (hattr:get hbut 'actype) 800 (if hbut (apply 'actype:act (hattr:get hbut 'actype)
790 (hattr:get hbut 'args)))) 801 (hattr:get hbut 'args))))
791 802
792 (defun hbut:action (hbut) 803 (defun hbut:action (hbut)
793 "Returns appropriate action for Hyperbole button symbol HBUT." 804 "Returns appropriate action for Hyperbole button symbol HBUT."
794 (let ((categ (hattr:get hbut 'categ)) (atype) (action)) 805 (let ((categ (hattr:get hbut 'categ)) (atype) (action))
795 (if (eq categ 'explicit) 806 (if (eq categ 'explicit)
963 974
964 (defun hbut:source (&optional full) 975 (defun hbut:source (&optional full)
965 "Returns Hyperbole source buffer or file given at point. 976 "Returns Hyperbole source buffer or file given at point.
966 If a file, always returns a full path if optional FULL is non-nil." 977 If a file, always returns a full path if optional FULL is non-nil."
967 (goto-char (match-end 0)) 978 (goto-char (match-end 0))
968 (cond ((looking-at "#<buffer \\([^ \n]+\\)>") 979 (cond ((looking-at "#<buffer \"?\\([^ \n\"]+\\)\"?>")
969 (get-buffer (buffer-substring (match-beginning 1) 980 (get-buffer (buffer-substring (match-beginning 1)
970 (match-end 1)))) 981 (match-end 1))))
971 ((looking-at "\".+\"") 982 ((looking-at "\".+\"")
972 (let* ((file (buffer-substring (1+ (match-beginning 0)) 983 (let* ((file (buffer-substring (1+ (match-beginning 0))
973 (1- (match-end 0)))) 984 (1- (match-end 0))))
1111 "Returns key for Hyperbole implicit button label that point is on or nil." 1122 "Returns key for Hyperbole implicit button label that point is on or nil."
1112 (ibut:at-p 'key-only)) 1123 (ibut:at-p 'key-only))
1113 1124
1114 (defun ibut:label-set (label &optional start end) 1125 (defun ibut:label-set (label &optional start end)
1115 "Sets current implicit button attributes from LABEL and START, END position. 1126 "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 1127 Returns label. START and END are optional. When given, they specify the
1117 to flash when this implicit button is activated or queried for its attributes. 1128 region in the buffer to flash when this implicit button is activated or
1118 If LABEL is a list, it is assumed to contain all arguments." 1129 queried for its attributes. If LABEL is a list, it is assumed to contain all
1130 arguments."
1119 (cond ((stringp label) 1131 (cond ((stringp label)
1120 (hattr:set 'hbut:current 'lbl-key (hbut:label-to-key label)) 1132 (hattr:set 'hbut:current 'lbl-key (hbut:label-to-key label))
1121 (and start (hattr:set 'hbut:current 'lbl-start start)) 1133 (and start (hattr:set 'hbut:current 'lbl-start start))
1122 (and end (hattr:set 'hbut:current 'lbl-end end))) 1134 (and end (hattr:set 'hbut:current 'lbl-end end)))
1123 ((and label (listp label)) 1135 ((and label (listp label))
1124 (hattr:set 'hbut:current 'lbl-key (hbut:label-to-key (car label))) 1136 (hattr:set 'hbut:current 'lbl-key (hbut:label-to-key (car label)))
1125 (hattr:set 'hbut:current 'lbl-start (nth 1 label)) 1137 (hattr:set 'hbut:current 'lbl-start (nth 1 label))
1126 (hattr:set 'hbut:current 'lbl-end (nth 2 label))) 1138 (hattr:set 'hbut:current 'lbl-end (nth 2 label)))
1127 (t (error "(ibut:label-set): Invalid label arg: '%s'" label))) 1139 (t (error "(ibut:label-set): Invalid label arg: '%s'" label)))
1128 t) 1140 label)
1129 1141
1130 ;;; ======================================================================== 1142 ;;; ========================================================================
1131 ;;; ibtype class - Implicit button types 1143 ;;; ibtype class - Implicit button types
1132 ;;; ======================================================================== 1144 ;;; ========================================================================
1133 1145