Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/hbut.el @ 70:131b0175ea99 r20-0b30

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