Download
(eval-when-compile (require 'cl))
(defun mon-button-at-point-p (&optional putative-button-at)
"Return non-nil when ther is a `button` property on char at point.\n
Arg PUTATIVE-BUTTON-AT is a buffer-position to check.
:EXAMPLE\n\n\(progn
\(goto-char \(buffer-end 0\)\)
\(while \(not \(get-char-property \(point\) 'button\)\) \(forward-char\)\)
\(point\)\)\n
:SEE-ALSO `mon-button-get-plist', `mon-button-get-plist-props',
`mon-button-at-point-p', `mon-button-at-point-describe-button-plist'.\n►►►"
(let ((gcp-btn (get-char-property (or putative-button-at (point)) 'button))
hld-prps)
(when gcp-btn
(setplist hld-prps
(cond ((car-safe gcp-btn)
`(:BUTTON-CATEGORY-SYMBOL ,(get-char-property (or putative-button-at (point)) 'category)
:BUTTON-TXTPROP t :BUTTON-OVERLAY nil))
((overlayp gcp-btn)
`(:BUTTON-CATEGORY-SYMBOL ,(overlay-get gcp-btn 'category)
:BUTTON-OVERLAY t :BUTTON-IS-TEXT nil))))
(setq gcp-btn (symbol-plist (plist-get (symbol-plist hld-prps) :BUTTON-CATEGORY-SYMBOL)))
(plist-put (symbol-plist hld-prps) :BUTTON-PLIST gcp-btn)
(let ((btn-pl-prps (plist-get (symbol-plist hld-prps) :BUTTON-PLIST))
invrt-bpp)
(when (plist-get btn-pl-prps 'type)
(plist-put (symbol-plist hld-prps) :BUTTON-TYPE (plist-get btn-pl-prps 'type)))
(when (plist-get btn-pl-prps 'supertype)
(plist-put (symbol-plist hld-prps) :BUTTON-SUPER (plist-get btn-pl-prps 'supertype))))
(symbol-plist hld-prps))))
(defun mon-button-at-point-describe-button-plist (&optional button-at-psn)
"Return pp'd display of buttons current props as if by `apropos-describe-plist'.
:EXAMPLE\n\n
:SEE-ALSO `apropos-describe-plist' `mon-button-get-plist', `mon-button-get-plist-props',
`mon-button-at-point-p', `mon-button-at-point-describe-button-plist'.\n►►►"
(interactive)
(let ((mbapp (make-symbol "--temp-adp--")))
(setplist mbapp
(mon-button-at-point-p (or button-at-psn (point))))
(apropos-describe-plist mbapp)))
(defun mon-button-get-plist (type-button)
"Return a plist of enumerating properites for a button-type.\n
TYPE-BUTTON is a button constructed with `define-button-type'
Properties returned are those from the plist of symbol returned from
`button-category-symbol' with TYPE-BUTTON as arg.
:NOTE Directly accessing the button properties associated with the TYPE-BUTTON
symbol is not possible as that symbol does not actually hold the button
properties associated with it.\n
When `define-button-type' constructs a button it generates a separate uninterned
symbol having the form:\n
<SYMBOL>-button|n
As such, accessors of button properties are indirected through this separate
uninterned symbol via its `category` property. Because the `category` property
is implemented by both overlays and text-properties this indirection allows:
- flexible creation of buttons with `make-text-button', `make-button' or
directly with `make-overlay', `overlay-put', `add-text-properties', etc.;\n
- guarding against inadverdent name clashes;
- provision of a lightweight subertype <-> subtype inheritance hierarchy which
can be shared/extended/modified across the entire regime of Eacs
\"text-property\" frobbing facilites i.e. text-properties, overlays, widgets,
faces, char-properties, keymaps. etc.
:EXAMPLE\n\n
:SEE-ALSO `mon-button-get-plist', `mon-button-get-plist-props',
`mon-button-at-point-p', `mon-button-at-point-describe-button-plist'.\n►►►"
(let ((get-bcs (and (bound-and-true-p type-button)
(get type-button 'button-category-symbol))))
(unless (null get-bcs)
`(:BUTTON-TYPE ,type-button
:BUTTON-CATEGORY-SYMBOL ,get-bcs
:BUTTON-PLIST ,(symbol-plist get-bcs)))))
(defun mon-button-get-plist-props (type-of-button)
"Return a plist properties for TYPE-OF-BUTTON.\n
TYPE-OF-BUTTON is a button constructed with `define-button-type'.\n
:EXAMPLE\n\n\(mon-button-get-plist-props 'button\)\n
:ALIASED-BY `mon-get-button-plist-props'\nn
:SEE-ALSO `mon-button-get-plist', `mon-button-get-plist-props',
`mon-button-at-point-p', `mon-button-at-point-describe-button-plist'.\n►►►"
(let* ((cp-sypl (mon-button-get-plist type-of-button))
(cp-pl (unless (null cp-sypl)
(plist-get cp-sypl :BUTTON-PLIST)))
hds)
(unless (null cp-pl)
(while cp-pl
(push (car cp-pl) hds)
(setq cp-pl (cddr cp-pl)))
(nreverse hds))))
(defalias 'mon-get-button-plist-props 'mon-button-get-plist-props)
(provide 'mon-button-utils)