commit/fsf-compat: jamesjer: Add button.el from Emacs.

1 new commit in fsf-compat: https://bitbucket.org/xemacs/fsf-compat/commits/a7f07ad493ca/ Changeset: a7f07ad493ca User: jamesjer Date: 2014-05-07 21:26:30 Summary: Add button.el from Emacs. See <CAHCOHQ=LEV_eFzV_ZZA9G=d3JqRQDD7a0wP8dVLVH_PL7PRGzw(a)mail.gmail.com&gt; in xemacs-patches. Affected #: 3 files diff -r 0998c837f4f326480a8d4ea8cff61b1ff3306728 -r a7f07ad493caeb6a8b93ecb66840f40012603cd6 ChangeLog --- a/ChangeLog +++ b/ChangeLog ＠＠ -1,17 +1,6 ＠＠ -2014-04-02 Michael Sperber <mike(a)xemacs.org&gt; +2014-05-06 Jerry James <james(a)xemacs.org&gt; - * subr-fsf.el (wholenump, declare-function): Two trivial functions - from GNU Emacs. - -2013-12-03 Michael Sperber <mike(a)xemacs.org&gt; - - * timer.el (timer-activate-when-idle): Only call `activate-timer' - on non-active-timers. - -2013-02-20 Michael Sperber <mike(a)xemacs.org&gt; - - * overlay.el (copy-overlay, remove-overlays): Add functions from - GNU Emacs. + * button.el: New. From Emacs 24.3. 2009-08-14 Norbert Koch <viteno(a)xemacs.org&gt; diff -r 0998c837f4f326480a8d4ea8cff61b1ff3306728 -r a7f07ad493caeb6a8b93ecb66840f40012603cd6 Makefile --- a/Makefile +++ b/Makefile ＠＠ -29,6 +29,7 ＠＠ EXTRA_SOURCES = README -ELCS = overlay.elc thingatpt.elc timer.elc x-popup-menu.elc goto-addr.elc subr-fsf.elc +ELCS = button.elc goto-addr.elc overlay.elc thingatpt.elc timer.elc \ + x-popup-menu.elc include ../../XEmacs.rules diff -r 0998c837f4f326480a8d4ea8cff61b1ff3306728 -r a7f07ad493caeb6a8b93ecb66840f40012603cd6 button.el --- /dev/null +++ b/button.el ＠＠ -0,0 +1,520 ＠＠ +;;; button.el --- clickable buttons +;; +;; Copyright (C) 2001-2014 Free Software Foundation, Inc. +;; +;; Author: Miles Bader <miles(a)gnu.org&gt; +;; Keywords: extensions +;; Package: emacs +;; +;; This file is part of XEmacs. +;; +;; XEmacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; XEmacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>;. + +;;; Commentary: +;; +;; This package defines functions for inserting and manipulating +;; clickable buttons in Emacs buffers, such as might be used for help +;; hyperlinks, etc. +;; +;; In some ways it duplicates functionality also offered by the +;; `widget' package, but the button package has the advantage that it +;; is (1) much faster, (2) much smaller, and (3) much, much, simpler +;; (the code, that is, not the interface). +;; +;; Buttons can either use extents, in which case the button is +;; represented by the extent itself, or text-properties, in which case +;; the button is represented by a marker or buffer-position pointing +;; somewhere in the button. In the latter case, no markers into the +;; buffer are retained, which is important for speed if there are are +;; extremely large numbers of buttons. Note however that if there is +;; an existing face text-property at the site of the button, the +;; button face may not be visible. Using extents avoids this. +;; +;; Using `define-button-type' to define default properties for buttons +;; is not necessary, but it is encouraged, since doing so makes the +;; resulting code clearer and more efficient. +;; + +;;; Code: + + +;; Globals + +(defface button '((t (:underline t))) + "Default face used for buttons." +:group 'faces) + +(defvar button-map + (let ((map (make-sparse-keymap 'button-map))) + ;; The following definition needs to avoid using escape sequences that + ;; might get converted to ^M when building loaddefs.el + (define-key map [(control ?m)] 'push-button) + (define-key map [button2] 'push-button) + map) + "Keymap used by buttons.") + +(defvar button-buffer-map + (let ((map (make-sparse-keymap 'button-buffer-map))) + (define-key map [?\t] 'forward-button) + (define-key map "\e\t" 'backward-button) + (define-key map [backtab] 'backward-button) + map) + "Keymap useful for buffers containing buttons. +Mode-specific keymaps may want to use this as their parent keymap.") + +;; Default properties for buttons +(put 'default-button 'face 'button) +(put 'default-button 'mouse-face 'highlight) +(put 'default-button 'keymap button-map) +(put 'default-button 'type 'button) +;; action may be either a function to call, or a marker to go to +(put 'default-button 'action 'ignore) +(put 'default-button 'help-echo "mouse-2, RET: Push this button") +;; Make extent buttons go away if their underlying text is deleted. +(put 'default-button 'detachable t) +;; Prevent insertions adjacent to the text-property buttons from +;; inheriting its properties. +(put 'default-button 'rear-nonsticky t) + +;; A `category-symbol' property for the default button type +(put 'button 'button-category-symbol 'default-button) + + +;; Button types (which can be used to hold default properties for buttons) + +;; Because button-type properties are inherited by buttons using the +;; special `category' property (implemented by both extents and +;; text-properties), we need to store them on a symbol to which the +;; `category' properties can point. Instead of using the symbol that's +;; the name of each button-type, however, we use a separate symbol (with +;; `-button' appended, and uninterned) to store the properties. This is +;; to avoid name clashes. + +;; [this is an internal function] +(defsubst button-category-symbol (type) + "Return the symbol used by button-type TYPE to store properties. +Buttons inherit them by setting their `category' property to that symbol." + (or (get type 'button-category-symbol) + (error "Unknown button type `%s'" type))) + +;;;###autoload +(defun define-button-type (name &rest properties) + "Define a `button type' called NAME (a symbol). +The remaining arguments form a sequence of PROPERTY VALUE pairs, +specifying properties to use as defaults for buttons with this type +\(a button's type may be set by giving it a `type' property when +creating the button, using the :type keyword argument). + +In addition, the keyword argument :supertype may be used to specify a +button-type from which NAME inherits its default property values +\(however, the inheritance happens only when NAME is defined; subsequent +changes to a supertype are not reflected in its subtypes)." + (let ((catsym (make-symbol (concat (symbol-name name) "-button"))) + (super-catsym + (button-category-symbol + (or (plist-get properties 'supertype) + (plist-get properties :supertype) + 'button)))) + ;; Provide a link so that it's easy to find the real symbol. + (put name 'button-category-symbol catsym) + ;; Initialize NAME's properties using the global defaults. + (let ((default-props (symbol-plist super-catsym))) + (while default-props + (put catsym (pop default-props) (pop default-props)))) + ;; Add NAME as the `type' property, which will then be returned as + ;; the type property of individual buttons. + (put catsym 'type name) + ;; Add the properties in PROPERTIES to the real symbol. + (while properties + (let ((prop (pop properties))) + (when (eq prop :supertype) + (setq prop 'supertype)) + (put catsym prop (pop properties)))) + ;; Make sure there's a `supertype' property + (unless (get catsym 'supertype) + (put catsym 'supertype 'button)) + name)) + +(defun button-type-put (type prop val) + "Set the button-type TYPE's PROP property to VAL." + (put (button-category-symbol type) prop val)) + +(defun button-type-get (type prop) + "Get the property of button-type TYPE named PROP." + (get (button-category-symbol type) prop)) + +(defun button-type-subtype-p (type supertype) + "Return t if button-type TYPE is a subtype of SUPERTYPE." + (or (eq type supertype) + (and type + (button-type-subtype-p (button-type-get type 'supertype) + supertype)))) + + +;; Button properties and other attributes + +(defun button-start (button) + "Return the position at which BUTTON starts." + (if (extentp button) + (extent-start-position button) + ;; Must be a text-property button. + (or (previous-single-property-change (1+ button) 'button) + (point-min)))) + +(defun button-end (button) + "Return the position at which BUTTON ends." + (if (extentp button) + (extent-end-position button) + ;; Must be a text-property button. + (or (next-single-property-change button 'button) + (point-max)))) + +(defun button-get (button prop) + "Get the property of button BUTTON named PROP." + (cond ((extentp button) + (or (extent-property button prop) + (let ((category (extent-property button 'category))) + (when category + (get category prop))))) + ((button--area-button-p button) + (get-text-property (cdr button) + prop (button--area-button-string button))) + (t ; Must be a text-property button. + (get-text-property button prop)))) + +(defun button-put (button prop val) + "Set BUTTON's PROP property to VAL." + ;; Treat some properties specially. + (cond ((memq prop '(type :type)) + ;; We translate a `type' property a `category' property, since + ;; that's what's actually used by extents/text-properties for + ;; inheriting properties. + (setq prop 'category) + (setq val (button-category-symbol val))) + ((eq prop 'category) + ;; Disallow updating the `category' property directly. + (error "Button `category' property may not be set directly"))) + ;; Add the property. + (cond ((extentp button) + (set-extent-property button prop val)) + ((button--area-button-p button) + (setq button (button--area-button-string button)) + (put-text-property 0 (length button) prop val button)) + (t ; Must be a text-property button. + (put-text-property + (or (previous-single-property-change (1+ button) 'button) + (point-min)) + (or (next-single-property-change button 'button) + (point-max)) + prop val)))) + +;;;###autoload +(defun button-activate (button &optional use-mouse-action) + "Call BUTTON's action property. +If USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action +instead of its normal action; if the button has no mouse-action, +the normal action is used instead. + +The action can either be a marker or a function. If it's a +marker then goto it. Otherwise if it is a function then it is +called with BUTTON as only argument. BUTTON is either an +extent, a buffer position, or (for buttons in the mode-line or +header-line) a string." + (let ((action (or (and use-mouse-action (button-get button 'mouse-action)) + (button-get button 'action)))) + (if (markerp action) + (save-selected-window + (select-window (display-buffer (marker-buffer action))) + (goto-char action) + (recenter 0)) + (funcall action button)))) + +(defun button-label (button) + "Return BUTTON's text label." + (if (button--area-button-p button) + (substring-no-properties (button--area-button-string button)) + (buffer-substring-no-properties (button-start button) + (button-end button)))) + +(defsubst button-type (button) + "Return BUTTON's button-type." + (button-get button 'type)) + +(defun button-has-type-p (button type) + "Return t if BUTTON has button-type TYPE, or one of TYPE's subtypes." + (button-type-subtype-p (button-get button 'type) type)) + +(defun button--area-button-p (b) + "Return non-nil if BUTTON is an area button. +Such area buttons are used for buttons in the mode-line and header-line." + (stringp (car-safe b))) + +(defalias 'button--area-button-string #'car) + +;; Creating extent buttons + +;;;###autoload +(defun make-button (beg end &rest properties) + "Make a button from BEG to END in the current buffer. +The remaining arguments form a sequence of PROPERTY VALUE pairs, +specifying properties to add to the button. +In addition, the keyword argument :type may be used to specify a +button-type from which to inherit other properties; see +`define-button-type'. + +Also see `make-text-button', `insert-button'." + (when (> beg end) + (setq beg (prog1 end (setq end beg)))) + (let ((extent (make-extent beg end))) + (set-extent-property extent 'start-open t) + (while properties + (button-put extent (pop properties) (pop properties))) + ;; Put a pointer to the button in the extent, so it's easy to get + ;; when we don't actually have a reference to the extent. + (set-extent-property extent 'button extent) + ;; If the user didn't specify a type, use the default. + (unless (extent-property extent 'category) + (set-extent-property extent 'category 'default-button)) + ;; EXTENT is the button, so return it + extent)) + +;;;###autoload +(defun insert-button (label &rest properties) + "Insert a button with the label LABEL. +The remaining arguments form a sequence of PROPERTY VALUE pairs, +specifying properties to add to the button. +In addition, the keyword argument :type may be used to specify a +button-type from which to inherit other properties; see +`define-button-type'. + +Also see `insert-text-button', `make-button'." + (apply #'make-button + (prog1 (point) (insert label)) + (point) + properties)) + + +;; Creating text-property buttons + +;;;###autoload +(defun make-text-button (beg end &rest properties) + "Make a button from BEG to END in the current buffer. +The remaining arguments form a sequence of PROPERTY VALUE pairs, +specifying properties to add to the button. +In addition, the keyword argument :type may be used to specify a +button-type from which to inherit other properties; see +`define-button-type'. + +This function is like `make-button', except that the button is actually +part of the text instead of being a property of the buffer. That is, +this function uses text properties, the other uses extents. +Creating large numbers of buttons can also be somewhat faster +using `make-text-button'. Note, however, that if there is an existing +face property at the site of the button, the button face may not be visible. +You may want to use `make-button' in that case. + +BEG can also be a string, in which case it is made into a button. + +Also see `insert-text-button'." + (let ((object nil) + (type-entry + (or (plist-member properties 'type) + (plist-member properties :type)))) + (when (stringp beg) + (setq object beg beg 0 end (length object))) + ;; Disallow setting the `category' property directly. + (when (plist-get properties 'category) + (error "Button `category' property may not be set directly")) + (if (null type-entry) + ;; The user didn't specify a `type' property, use the default. + (setq properties (cons 'category (cons 'default-button properties))) + ;; The user did specify a `type' property. Translate it into a + ;; `category' property, which is what's actually used by + ;; text-properties for inheritance. + (setcar type-entry 'category) + (setcar (cdr type-entry) + (button-category-symbol (car (cdr type-entry))))) + ;; Now add all the text properties at once + (add-text-properties beg end + ;; Each button should have a non-eq `button' + ;; property so that next-single-property-change can + ;; detect boundaries reliably. + (cons 'button (cons (list t) properties)) + object) + ;; Return something that can be used to get at the button. + (or object beg))) + +(defun insert-text-button (label &rest properties) + "Insert a button with the label LABEL. +The remaining arguments form a sequence of PROPERTY VALUE pairs, +specifying properties to add to the button. +In addition, the keyword argument :type may be used to specify a +button-type from which to inherit other properties; see +`define-button-type'. + +This function is like `insert-button', except that the button is +actually part of the text instead of being a property of the buffer. +Creating large numbers of buttons can also be somewhat faster using +`insert-text-button'. + +Also see `make-text-button'." + (apply #'make-text-button + (prog1 (point) (insert label)) + (point) + properties)) + + +;; Finding buttons in a buffer + +;;;###autoload +(defun button-at (pos) + "Return the button at position POS in the current buffer, or nil. +If the button at POS is a text property button, the return value +is a marker pointing to POS." + (let ((button (get-char-property pos 'button))) + (if (or (extentp button) (null button)) + button + ;; Must be a text-property button; return a marker pointing to it. + (copy-marker pos t)))) + +;;;###autoload +(defun next-button (pos &optional count-current) + "Return the next button after position POS in the current buffer. +If COUNT-CURRENT is non-nil, count any button at POS in the search, +instead of starting at the next button." + (unless count-current + ;; Search for the next button boundary. + (setq pos (next-single-char-property-change pos 'button))) + (and (< pos (point-max)) + (or (button-at pos) + ;; We must have originally been on a button, and are now in + ;; the inter-button space. Recurse to find a button. + (next-button pos)))) + +;;;###autoload +(defun previous-button (pos &optional count-current) + "Return the previous button before position POS in the current buffer. +If COUNT-CURRENT is non-nil, count any button at POS in the search, +instead of starting at the next button." + (let ((button (button-at pos))) + (if button + (if count-current + button + ;; We started out on a button, so move to its start and look + ;; for the previous button boundary. + (setq pos (previous-single-char-property-change + (button-start button) 'button)) + (let ((new-button (button-at pos))) + (if new-button + ;; We are in a button again; this can happen if there + ;; are adjacent buttons (or at bob). + (unless (= pos (button-start button)) new-button) + ;; We are now in the space between buttons. + (previous-button pos)))) + ;; We started out in the space between buttons. + (setq pos (previous-single-char-property-change pos 'button)) + (or (button-at pos) + (and (> pos (point-min)) + (button-at (1- pos))))))) + + +;; User commands + +;;;###autoload +(defun push-button (&optional pos use-mouse-action) + "Perform the action specified by a button at location POS. +POS may be either a buffer position or a mouse-event. If +USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action +instead of its normal action; if the button has no mouse-action, +the normal action is used instead. The action may be either a +function to call or a marker to display and is invoked using +`button-activate' (which see). + +POS defaults to point, except when `push-button' is invoked +interactively as the result of a mouse-event, in which case, the +mouse event is used. +If there's no button at POS, do nothing and return nil, otherwise +return t." + (interactive + (list (if (mouse-event-p last-command-event) last-command-event (point)))) + (if (and (not (integerp pos)) (eventp pos)) + ;; POS is a mouse event; switch to the proper window/buffer + (with-current-buffer (event-buffer pos) + (if (event-over-text-area-p pos) + (push-button (event-point pos) t) + (button-activate (event-point pos) t))) + ;; POS is just normal position + (let ((button (button-at (or pos (point))))) + (when button + (button-activate button use-mouse-action) + t)))) + +;;;###autoload +(defun forward-button (n &optional wrap display-message) + "Move to the Nth next button, or Nth previous button if N is negative. +If N is 0, move to the start of any button at point. +If WRAP is non-nil, moving past either end of the buffer continues from the +other end. +If DISPLAY-MESSAGE is non-nil, the button's help-echo string is displayed. +Any button with a non-nil `skip' property is skipped over. +Returns the button found." + (interactive "p\nd\nd") + (let (button) + (if (zerop n) + ;; Move to start of current button + (if (setq button (button-at (point))) + (goto-char (button-start button))) + ;; Move to Nth next button + (let ((iterator (if (> n 0) #'next-button #'previous-button)) + (wrap-start (if (> n 0) (point-min) (point-max))) + opoint fail) + (setq n (abs n)) + (setq button t) ; just to start the loop + (while (and (null fail) (> n 0) button) + (setq button (funcall iterator (point))) + (when (and (not button) wrap) + (setq button (funcall iterator wrap-start t))) + (when button + (goto-char (button-start button)) + ;; Avoid looping forever (e.g., if all the buttons have + ;; the `skip' property). + (cond ((null opoint) + (setq opoint (point))) + ((= opoint (point)) + (setq fail t))) + (unless (button-get button 'skip) + (setq n (1- n))))))) + (if (null button) + (error (if wrap "No buttons!" "No more buttons")) + (let ((msg (and display-message (button-get button 'help-echo)))) + (when msg + (message "%s" msg))) + button))) + +;;;###autoload +(defun backward-button (n &optional wrap display-message) + "Move to the Nth previous button, or Nth next button if N is negative. +If N is 0, move to the start of any button at point. +If WRAP is non-nil, moving past either end of the buffer continues from the +other end. +If DISPLAY-MESSAGE is non-nil, the button's help-echo string is displayed. +Any button with a non-nil `skip' property is skipped over. +Returns the button found." + (interactive "p\nd\nd") + (forward-button (- n) wrap display-message)) + + +(provide 'button) + +;;; button.el ends here Repository URL: https://bitbucket.org/xemacs/fsf-compat/ -- This is a commit notification from bitbucket.org. You are receiving this because you have the service enabled, addressing the recipient of this email. _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches