Download
(eval-when-compile (require 'cl))
(unless (and (intern-soft "*IS-MON-OBARRAY*")
(bound-and-true-p *IS-MON-OBARRAY*))
(setq *IS-MON-OBARRAY* (make-vector 17 nil)))
(defgroup mon-base nil
"Top level group from which other mon related packages and groups inherit.\n
:SEE-ALSO .\n►►►"
:prefix "mon-"
:prefix "*mon-"
:link '(url-link
:tag ":EMACSWIKI-FILE (URL `http://www.emacswiki.org/emacs/mon-utils.el')"
"http://www.emacswiki.org/emacs/mon-utils.el")
:link '(emacs-library-link
:tag ":FILE mon-utils.el"
"mon-utils.el")
:group 'local)
(defgroup mon-xrefs nil
"Customization group for xrefing variables `*mon-.*-xrefs*'.\n
An xrefing variable holds a list of symbol names provided by a `mon-*.el' feature.\n
The intent in maintaining these xrefing lists is to allow eventual aggregation
of of per symbol graphs of related/associated symbol names for use in a context
oriented extension to the Emacs *Help* facility.\n
:NOTE While it is relatively straight forward to locate these symbols with `features',
`featurep', `load-history', etc. the respective return values of these functions
are not necessarily easy to parse/disambiguate esp. w/re to docstrings and
relative to the symbol-type.\n
Likewise, Emacs doesn't effectively provide a centralized/canonical per feature
location where one can store aggregate metadata regarding the \"auxillary\" data
about the symbols provided by a given feature. Such a feature, (were it to
exist) would likely benefit from the use of plists esp. where these data
structures are a natural lisp extension and are pre-established with a
privileged state as a symbol cell and can be easily extended by attaching
hash-tables as values for plist properties. However, effective utilization of
such plists demands that we establish a global symbol specially dedicated to
hold this data. Note too that there is no immediate utility in store this data
directly in hash-tableas the Elisp API does not expose the ability to
attach/access hash-tables on a symbol cell e.g. there is not a `symbol-plist'
equivalent named `symbol-hash-table' and we must still establish a global
special value to hold the hash-table.
Note also that we do not consider either `defcustom' or is the package feature
of Emacs 24+ \(at least in their current configurations\) applicable to these
needs.\n
:SEE-ALSO `*mon-xrefs-xrefs*', `*mon-regexp-symbols-xrefs*',
`*mon-default-loads-xrefs*', `*mon-default-start-loads-xrefs*',
`*mon-dir-locals-alist-xrefs*', `*mon-testme-utils-xrefs*',
`*mon-button-utils-xrefs*', `*naf-mode-xref-of-xrefs*'.\n►►►"
:link '(emacs-library-link :tag ":FILE mon-utils.el" "mon-utils.el")
:group 'mon-base)
(require 'edebug)
(require 'easymenu)
(require 'bytecomp)
(require 'macroexp)
(defvar *mon-utils-post-load-requires* nil
"*List of features loaded by feature mon-utils.el\n
:CALLED BY `mon-utils-require-features-at-loadtime'\n
:SEE-ALSO `mon-after-mon-utils-loadtime'.\n►►►")
(unless (and (intern-soft "*mon-utils-post-load-requires*" obarray)
(bound-and-true-p *mon-utils-post-load-requires*))
(setq *mon-utils-post-load-requires*
'(mon-macs
mon-type-utils-vars
mon-type-utils
mon-error-utils
mon-plist-utils
mon-text-property-utils
mon-seq-utils
mon-buffer-utils
mon-window-utils
mon-randomize-utils
mon-event-utils
mon-line-utils
mon-region-utils
mon-string-utils
mon-env-proc-utils
mon-rectangle-utils
mon-word-syntax-utils
mon-testme-utils
mon-alphabet-list-utils
mon-regexp-symbols
mon-time-utils
mon-replacement-utils
mon-dir-locals-alist
mon-dir-utils
mon-dir-utils-local
mon-button-utils
mon-cifs-utils
mon-insertion-utils
naf-mode-insertion-utils
mon-wget-utils
mon-url-utils
mon-hash-utils
mon-doc-help-utils
mon-doc-help-CL
mon-tramp-utils
naf-skeletons
naf-mode
ebay-template-mode
mon-empty-registers
mon-iptables-vars
mon-iptables-regexps
mon-get-freenode-lisp-logs
mon-mysql-utils
)))
(defcustom *mon-xrefs-xrefs*
'(*mon-regexp-symbols-xrefs* *mon-default-loads-xrefs*
*mon-default-start-loads-xrefs* *mon-dir-locals-alist-xrefs*
*mon-error-utils-xrefs* *mon-testme-utils-xrefs* *mon-buffer-utils-xrefs*
*mon-button-utils-xrefs* *mon-bzr-utils-xrefs* *mon-keybindings-xrefs*
*mon-line-utils-xrefs* *mon-macs-xrefs* *mon-post-load-hooks-xrefs*
*mon-plist-utils-xrefs* *mon-seq-utils-xrefs* *mon-slime-xrefs*
*mon-string-utils-xrefs* *mon-type-utils-xrefs* *mon-window-utils-xrefs*
*naf-mode-xref-of-xrefs* *naf-mode-faces-xrefs* *naf-mode-date-xrefs*
*mon-ulan-utils-xrefs* *mon-xrefs-xrefs*)
"Meta list of mon-xrefing variables, e.g. those named `*mon-.*-xrefs*'.\n
:SEE-ALSO `*mon-regexp-symbols-xrefs*', `*mon-default-loads-xrefs*',
`*mon-default-start-loads-xrefs*', `*mon-dir-locals-alist-xrefs*',
`*mon-testme-utils-xrefs*', `*mon-button-utils-xrefs*',
`*naf-mode-xref-of-xrefs*', `*mon-xrefs-xrefs*'.\n►►►"
:type '(repeat symbol)
:group 'mon-xrefs)
(defcustom *mon-default-comment-start* ";;; "
"Comment prefix for `mon-comment-divider-w-len'.\n
This is a cheap work around so we don't have to deal with `comment-start' with
`mon-comment-*' functions which might rely on or calculate a string/substring
inidex per the value of this var.\n
Its value is a string consisting of one or more identical graphic prefix chars
followed by a single space \(char 32\). Default is \";;; \"\n
When an alternate value is supplied it should have the following format:\n
\"<PREFIX-CHARS>+<SPC>\"\n
Such that evaluation of the following two forms returns non-nil:\n
\(= \(mon-list-last \(append *mon-default-comment-start* nil\)\) 32\)\n
\(let* \(\(*mon-default-comment-start* \";;[ \"\)
\(sub-cmnt-start \(nreverse \(cdr \(reverse \(append *mon-default-comment-start* nil\)\)\)\)\)\)
\(catch 'prefix-not-same
\(equal *mon-default-comment-start*
\(concat
\(mapc #'\(lambda \(x\)
\(unless \(= x \(car sub-cmnt-start\)\)
\(throw 'prefix-not-same
\(format \"prefix chars not identical, failed-at: %c\" x\)\)\)\)
sub-cmnt-start\)
\" \"\)\)\)\)\n
:EXAMPLE\n\n(symbol-value '*mon-default-comment-start*)\n
\(let \(\(*mon-default-comment-start* \"%% \"\)\)
*mon-default-comment-start*\)\n
\(mon-comment-divider-w-len 36\)\n
:NOTE This variable is dynamically let-bound by `mon-*' functions.\n
:SEE-ALSO `*mon-default-comment-divider*', `mon-set-buffer-local-comment-start',
`mon-set-buffer-local-comment-start-init', `mon-comment-divider-to-col',
`mon-comment-divider-to-col-four', `mon-comment-divider-w-len',
`mon-comment-lisp-to-col'.\n►►►"
:type 'string
:group 'mon-base)
(defcustom *mon-default-comment-divider* (mon-comment-divider-w-len 30)
"Preferred mon-comment-divider for lisp source sectioning.\n
The first four chars should have the same form as `*mon-default-comment-start*'
such that (substring
Default is the return value of following form:\n
\(mon-comment-divider-w-len 30\)\n
:CALLED-BY `mon-comment-divider', `mon-comment-divider-to-col'\n
:SEE-ALSO `mon-comment-divider-w-len', `mon-comment-divider-to-col'\n►►►"
:type 'string
:group 'mon-base)
(defcustom *mon-timestamp-cond* nil
"A list of filenames which get alternative timestamp name strings.\n
car is a filename and must be a string without whitespace, delimiters or punctuation.\n
cadr is a username to insert when timestamping in a file matching car.\n
These values are used to inform calling functions according to some heuristic.\n
:NOTE Used for file based conditional timestamps and obfuscating files/source.
:SEE-ALSO `mon-timestamp', `mon-accessed-time-stamp', `mon-accessed-stamp',
`naf-mode-timestamp-flag'.\n►►►"
:type '(repeat (list string string))
:group 'mon-base)
(defvar *mon-recover-nil-t-default-plist* nil
"Bound at loadtime to the default plists of `nil' and `t'.\n
Recover plists with `mon-recover-nil-t-default-plist' if they become corrupted.\n
:EXAMPLE\n\n*mon-recover-nil-t-default-plist*\n
\(memq :nil-default-plist *mon-recover-nil-t-default-plist*\)\n
\(memq :t-default-plist *mon-recover-nil-t-default-plist*\)\n
:SEE-ALSO `setplist', `symbol-plist', `mon-after-mon-utils-loadtime',
`mon-run-post-load-hooks'.\n►►►")
(defun mon-recover-nil-t-default-plist (&optional intrp)
"Recover the default loadtime plists value of `nil' and `t'.\n
When called at loadtime and `*mon-recover-nil-t-default-plist*' is void bind it.\n
Called in a post-loadtime environement restores the plist values stored in
`*mon-recover-nil-t-default-plist*' keys :nil-default-plist :t-default-plist.\n
:EXAMPLE\n\n\(mon-recover-nil-t-default-plist t\)\n
:SEE-ALSO `setplist', `symbol-plist', `mon-after-mon-utils-loadtime',
`mon-run-post-load-hooks'.\n►►►"
(interactive "p")
(if (and (intern-soft "*mon-recover-nil-t-default-plist*" obarray)
(bound-and-true-p *mon-recover-nil-t-default-plist*))
(let ((nval (cadr (memq :nil-default-plist *mon-recover-nil-t-default-plist*)))
(tval (cadr (memq :t-default-plist *mon-recover-nil-t-default-plist*))))
(if intrp
(when (y-or-n-p (format
(concat
":FUNCTION `mon-recover-nil-t-default-plist' --\n"
"Current plist for `nil' is:\n %S\n"
"Loadtime plist for `nil' was:\n %S\n"
"Current plist for `t' is:\n %S\n"
"Loadtime plist for `t' was:\n %S\n"
"Rebind plists of `t' and `nil' to default loadtime values?: ")
(symbol-plist nil) nval (symbol-plist t) tval))
(setplist nil nval)
(setplist t tval)
(minibuffer-message (concat
":FUNCTION `mon-recover-nil-t-default-plist' "
"-- rebound plists of `t' and `nil' to default loadtime values")))
(and (setplist nil nval)
(setplist t tval)
t)))
(progn
(setq *mon-recover-nil-t-default-plist*
`(:nil-default-plist ,(symbol-plist nil) :t-default-plist ,(symbol-plist t)))
(mon-message :msg-spec '(":FUNCTION `mon-recover-nil-t-default-plist' "
"-- :VARIALBE `*mon-recover-nil-t-default-plist*' bound at loadtime")))))
(defmacro mon-check-feature-for-loadtime (feature-as-symbol &optional req-w-filname)
"Test if library FEATURE-AS-SYMBOL is in load path. If so, require feature.\n
The arg FEATURE-AS-SYMBOL is a quoted symbol.\n
When optional arg REQ-W-FILNAME is non-nil second arg to `require' will given as
the filename of feature FEATURE-AS-SYMBOL when it is in loadpath.\n
:EXAMPLE\n\n\(pp-macroexpand-expression
'\(mon-check-feature-for-loadtime 'mon-test-feature-fl\)\)\n
:SEE-ALSO `mon-run-post-load-hooks', `mon-purge-cl-symbol-buffers-on-load',
`mon-after-mon-utils-loadtime', `mon-unbind-command', `mon-unbind-symbol',
`mon-unbind-function', `mon-unbind-variable', `mon-unbind-defun',
`mon-compile-when-needed' `mon-load-or-alert', `mon-byte-compile-and-load',
`mon-dump-object-to-file', `mon-nuke-and-eval'.\n►►►"
(declare (indent 2) (debug t))
(let ((mcffl-lcl (make-symbol "mcffl-lcl"))
(mcffl-chk (make-symbol "mcffl-chk")))
`(let (,mcffl-lcl ,mcffl-chk)
(setq ,mcffl-lcl (locate-library (format "%s" ,feature-as-symbol)))
(if ,mcffl-lcl
(unless (featurep ,feature-as-symbol)
(if ,req-w-filname
(require ,feature-as-symbol ,mcffl-lcl t)
(require ,feature-as-symbol nil t)))
(error
(concat ":MACRO `mon-check-feature-for-loadtime' "
"-- arg FEATURE-AS-SYMBOL does not find a feature or file, got: %s")
,feature-as-symbol)))))
(defun mon-utils-require-features-at-loadtime ()
"Evaluated as the last form in mon-utils.el\n
Evaluates macro `mon-check-feature-for-loadtime' for each feature listed in
varaible `*mon-utils-post-load-requires*'\n
:SEE-ALSO `mon-after-mon-utils-loadtime', `mon-run-post-load-hooks'.\n►►►"
(let (murfal-did-rqr)
(dolist (murfal-D-1 *mon-utils-post-load-requires*)
(let ((murfal-D-1-lcl-rqrd (mon-check-feature-for-loadtime murfal-D-1)))
(when murfal-D-1-lcl-rqrd
(push (symbol-name murfal-D-1-lcl-rqrd) murfal-did-rqr))))
(when (consp murfal-did-rqr)
(mapc #'(lambda (murfal-L-1)
(message
(concat ":FUNCTION `mon-utils-require-features-at-loadtime' "
"-- :FEATURE mon-utils :REQUIRED :FEATURE " murfal-L-1 " on load")))
murfal-did-rqr)))
(when (and (intern-soft "IS-MON-SYSTEM-P" obarray)
(bound-and-true-p IS-MON-SYSTEM-P))
(require 'naf-mode-sql-skeletons nil t)
(require 'mon-dbc-xml-utils)))
(defun mon-after-mon-utils-loadtime ()
"List of packages and functions to load or eval.\n
These are brought into the current environment after mon-utils.el is loaded.\n
Called with \(eval-after-load \"mon-utils\" '\(mon-after-mon-utils-loadtime\)\)\n
Evaluated in :FILE mon-post-load-hooks.el\n
Evaluates the following functions per feature:\n
`mon-alphabet-as-doc-loadtime' <- mon-alphabet-list-utils
`mon-bind-nefs-photos-at-loadtime' <- mon-dir-utils-local
`mon-bind-cifs-vars-at-loadtime' <- mon-cifs-utils
`mon-tramp-utils-loadtime' <- mon-tramp-utils
`mon-set-register-tags-loadtime' <- mon-empty-registers
`mon-cntl-char-registers-loadtime' <- mon-empty-registers
`mon-help-utils-loadtime' <- mon-doc-help-utils
`mon-help-utils-CL-loadtime' <- mon-doc-help-CL
`mon-bind-mon-help-CL-pkgs-loadtime' <- mon-doc-help-CL
`mon-CL-cln-colon-swap' <- mon-cl-compat-regexps
`mon-bind-mysql-help-table-loadtime' <- mon-mysql-utils
`mon-bind-iptables-vars-at-loadtime' <- mon-iptables-regexps
`mon-bind-doc-help-proprietery-vars-at-loadtime' <- mon-doc-help-proprietary
`mon-css-complete-loadtime' <- mon-css-complete\n
Adds feature requirements:\n
mon-get-mon-packages <- :AFTER mon-wget-utils
mon-boxcutter
google-define-redux
mon-bzr-utils
mon-eight-bit-raw-utils\n
Peforms loadtime evaluation of functions defined in mon-utils.el:\n
`mon-recover-nil-t-default-plist'
`mon-get-bit-table'\n
:SEE-ALSO `after-load-alist', `mon-check-feature-for-loadtime',
`mon-unbind-command', `mon-unbind-symbol', `mon-unbind-function',
`mon-unbind-variable', `mon-run-post-load-hooks',
`mon-purge-cl-symbol-buffers-on-load', `mon-unbind-defun',
`mon-after-mon-utils-loadtime', `mon-compile-when-needed' `mon-load-or-alert',
`mon-byte-compile-and-load', `mon-dump-object-to-file', `mon-nuke-and-eval',
`mon-cl-compat-loadtime'.\n►►►"
(progn
(mon-recover-nil-t-default-plist)
(mon-get-bit-table)
(mon-alphabet-as-doc-loadtime
(mon-alphabet-as-map-bc *mon-alphabet-as-type-generate*))
(when (and (intern-soft "mon-get-mon-emacsd-paths" obarray)
(fboundp (intern-soft "mon-get-mon-emacsd-paths" obarray)))
(fset 'mon-get-emacsd-paths
(byte-compile
(indirect-function 'mon-get-mon-emacsd-paths)))
(message (concat ":FUNCTION `mon-after-mon-utils-loadtime'"
"`byte-compile'd `mon-get-mon-emacsd-paths' at loadtime")))
(eval-after-load "naf-mode-faces" '(mon-bind-naf-face-vars-loadtime t))
(eval-after-load "mon-dir-utils-local" '(mon-bind-nefs-photos-at-loadtime))
(eval-after-load "mon-replacement-utils" '(mon-make-iso-latin-1-approximation-loadtime))
(eval-after-load "mon-doc-help-utils" '(mon-help-utils-loadtime t))
(eval-after-load "mon-doc-help-CL" '(mon-bind-mon-help-CL-pkgs-loadtime t))
(eval-after-load "mon-cifs-utils" '(mon-bind-cifs-vars-at-loadtime))
(eval-after-load "mon-cl-compat-regexps" '(mon-CL-cln-colon-swap t))
(eval-after-load "mon-empty-registers" '(progn (mon-set-register-tags-loadtime t)
(mon-cntl-char-registers-loadtime)))
(eval-after-load "mon-tramp-utils" '(mon-tramp-utils-loadtime))
(eval-after-load "mon-iptables-regexps" '(mon-bind-iptables-vars-at-loadtime t))
(eval-after-load "mon-doc-help-proprietary"
'(progn
(unless (bound-and-true-p *mon-help-w32-CMD-commands-TEMP*)
(load-library "mon-doc-help-proprietary"))
(mon-bind-doc-help-proprietery-vars-at-loadtime *mon-help-w32-CMD-commands-TEMP*)))
(eval-after-load "mon-wget-utils"
'(mon-check-feature-for-loadtime 'mon-get-mon-packages))
(eval-after-load "mon-css-complete" '(mon-css-complete-loadtime t))
(eval-after-load "mon-mysql-utils" '(mon-bind-mysql-help-table-loadtime t))
(mon-check-feature-for-loadtime 'google-define-redux)
(mon-check-feature-for-loadtime 'mon-bzr-utils)
(mon-check-feature-for-loadtime 'mon-eight-bit-raw-utils)
(mon-check-feature-for-loadtime 'mon-drive-transfer-utils)
(mon-check-feature-for-loadtime 'mon-jg-directory-creator)
(mon-check-feature-for-loadtime 'mon-color-utils)
(eval-after-load "mon-boxcutter" '(boxcutter-mkdir-loadtime))
(mon-check-feature-for-loadtime 'mon-boxcutter)
(mon-check-feature-for-loadtime 'thumbs)
(mon-check-feature-for-loadtime 'mon-aliases)))
(defun mon-match-at-point (match-regexp)
"Return the buffer substring around point matching MATCH-REGEXP.\n
Look for a match starting at or before point.\n
Move back a character at a time while still looking at a match ending at the
same point.\n
If no match is found at or before point, return the first match after point, or
nil if there is no match in the buffer.\n
:SEE-ALSO `looking-at', `looking-at-p'.\n►►►"
(let (mmap-bkup mmap-beg mmap-end)
(save-excursion
(setq mmap-bkup
(or (save-match-data (looking-at match-regexp))
(and (search-forward-regexp match-regexp nil 'limit)
(setq mmap-end t)
(goto-char (match-beginning 0))
nil)
(search-backward-regexp match-regexp nil t)))
(when (or mmap-bkup mmap-end)
(setq mmap-beg (match-beginning 0))
(setq mmap-end (match-end 0)))
(if mmap-bkup
(while (and (not (bobp))
(progn (backward-char) t)
(save-match-data (looking-at match-regexp))
(= (match-end 0) mmap-end))
(setq mmap-beg (point)))
(or (bobp) (search-forward-regexp match-regexp nil t))))
(and mmap-beg
(progn
(goto-char mmap-end)
t)
(mon-buffer-sub-no-prop mmap-beg mmap-end))))
(defun mon-looking-back-p (regexp &optional limit greedy)
"Like `looking-back' but doesn't modify the match data.\n
:EXAMPLE\n\n\(let \(\(mb4-aftr \(list :old-match-data \(match-data t\)\)\)\)
\(save-excursion
\(end-of-line 3\)
\(when \(mon-looking-back-p \"^OMG theres a bubba back there!\"\)
\(unless \(equal \(match-data t\) mb4-aftr\)
\(setq mb4-aftr
\(nconc '\(:buba-change-match-data nil\) mb4-aftr\)\)\)
\(setq mb4-aftr \(nconc '\(:found-bubba t\) mb4-aftr\)\)\)\)
mb4-aftr\)\n\nOMG theres a bubba back there!\n
:SEE-ALSO `looking-at-p', `inhibit-changing-match-data'.\n►►►"
(let ((mlbp-beg (point))
(mlbp-psn
(let ((inhibit-changing-match-data t))
(save-excursion
(and (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)
(point))))))
(if (and greedy mlbp-psn)
(save-restriction
(narrow-to-region (mon-g2be -1 t) mlbp-beg)
(while (and (> mlbp-psn (point-min))
(save-excursion
(goto-char mlbp-psn)
(backward-char 1)
(looking-at-p (concat "\\(?:" regexp "\\)\\'"))))
(setq mlbp-psn (1- mlbp-psn)))
(save-excursion
(goto-char mlbp-psn)
(looking-at-p (concat "\\(?:" regexp "\\)\\'")))))
(not (null mlbp-psn))))
(defun mon-string-read-match-string (&optional match-subexp)
"Make `match-string' return more than just the last string matched.\n
Strip the # char from the side-effect value returned by match-string.
When MATCH-SUBEXP is non-nil return match-string of nth subexp.
The function match-string carries more data than just the string it returns.
These datum include:
from-idx to-idx of subexp match location;
if match string is fontified and the face used @ from-sub-idx to-sub-idx;
if match string carries text properties and if so the stickiness
of these props @ from-sub-idx to-sub-idx;
However, this data is not accessible to read because match-string returns as an
unreadable object with the '#' prefix so we strip it.\n
:EXAMPLE
:NOTE Evaluate following in *scratch* (or equiv) with `emacs-lisp-mode' t.
> \(search-forward-regexp \"\\\\\(\\\\\(\\=[\\\\\)\\\\\([0-9\\=]\\\\\\={8,10\\\\}\\\\\)\\\\\(]\\\\\)\\\\\)\" nil t\)
\"[500006383]\"
> (match-string 0)\n; => #\(\"[500006383]\" 0 11 \(fontified t face font-lock-string-face\)\)
> \(search-forward-regexp \"\\\\\(\\\\\(\\=[\\\\\)\\\\\([0-9\\=]\\\\\\={8,10\\\\}\\\\\)\\\\\(]\\\\\)\\\\\)\" nil t\)
\"[500006383]\"
> (mon-string-read-match-string)
; => \(\"[500006383]\" 0 11 \(fontified t face font-lock-string-face\)\)\n
:SEE-ALSO `mon-string-replace-char', `mon-looking-back-p'.\n►►►"
(let ((msrms-mtch (if (and (= (match-beginning 0) 1)(> (point) (mon-g2be -1 t) ))
nil
(car (read-from-string
(substring (format "%S" (match-string (if match-subexp match-subexp 0))) 1))))))
msrms-mtch))
(defun mon-view-help-source ()
"
:SEE-ALSO `mon-get-text-properties-category', `mon-line-test-content'.\n►►►"
(interactive)
(eval-when-compile (require 'ffap))
(unwind-protect
(let (mvhs-get-bfr)
(if (or (equal (buffer-name)(help-buffer))
(string= "*Help*" (buffer-name)))
(save-window-excursion
(mon-g2be -1)
(while (not (eobp))
(let ((mvhs-next-chng
(or (next-property-change (point) (current-buffer))
(point-max)))
mvhs-this-chng)
(progn
(goto-char mvhs-next-chng)
(setq mvhs-this-chng (mon-get-text-properties-category))
(when (and (and (string= mvhs-this-chng 'help-function-def-button))
(and (ffap-file-at-point)))
(let* ((mvhs-ffap-fl (ffap-file-at-point)))
(view-file-other-window (ffap-file-at-point))
(setq mvhs-get-bfr (find-buffer-visiting mvhs-ffap-fl)))
mvhs-get-bfr)))))))))
(defun mon-map-obarray-symbol-plist-props (w-prop-sym &optional display-in-buffer intrp)
"Map atoms in obarray looking for the plist property W-PROP-SYM.\n
Return the list of symbols with plist property W-PROP-SYM.\n
When called-interactively or optional arg DISPLAY-IN-BUFFER is non-nil return
values to buffer named \"*OBARRY-W-PROP-SYM-MATCHES*\".\n
If DISPLAY-IN-BUFFER is a string or buffer object that satisfies `buffer-live-p'
return results in that buffer creating one if it doesn't exist.\n
:EXAMPLE\n\n\(mon-map-obarray-symbol-plist-props 'permanent-local\)\n
\(mon-map-obarray-symbol-plist-props 'permanent-local t\)\n
\(mon-map-obarray-symbol-plist-props 'side-effect-free \(get-buffer-create \"*SIDE-EFFECT-FREE*\"\)\)\n
\(mon-map-obarray-symbol-plist-props 'side-effect-free \"*SIDE-EFFECT-FREE*\"\)\n
:SEE-ALSO `mon-plist-remove!', `mon-map-obarray-symbol-plist-props',
`mon-plist-remove-if', `mon-plist-remove-consing', `remf', `remprop',
`mon-plist-keys', `mon-help-plist-functions', `mon-help-plist-properties'.\n►►►"
(interactive "SSearch obarray for plist property: \npp")
(let* ((mmospp-clbrp 'mmospp-clbrp)
(mmospp-bfr (when display-in-buffer
(cond ((buffer-live-p display-in-buffer)
(setplist mmospp-clbrp '(no-clobber t))
display-in-buffer)
((stringp display-in-buffer)
(when (buffer-live-p (get-buffer display-in-buffer))
(setplist mmospp-clbrp '(no-clobber t))
(get-buffer-create display-in-buffer)))
((or intrp t)
(setplist mmospp-clbrp '(no-clobber nil))
(get-buffer-create "*OBARRY-W-PROP-SYM-MATCHES*"))))))
(when (and mmospp-bfr (not (get mmospp-clbrp 'no-clobber)))
(with-current-buffer mmospp-bfr (erase-buffer)))
(mapatoms #'(lambda (mmospp-L-1)
(when (plist-get (symbol-plist mmospp-L-1) w-prop-sym)
(if display-in-buffer
(progn
(princ (format "%s\n" (identity mmospp-L-1))
(get-buffer mmospp-bfr)))
(push mmospp-L-1 mmospp-bfr)))))
(if display-in-buffer
(with-current-buffer mmospp-bfr
(if (eq (mon-g2be -1 t)(mon-g2be 1 t))
(unwind-protect
(message (concat ":FUNCTION `mon-map-obarray-symbol-plist-props' "
"-- search in obarray for symbols with property `%S' "
"did not return displayable results") w-prop-sym)
(when (eq (current-buffer)
(get-buffer "*OBARRY-W-PROP-SYM-MATCHES*"))
(kill-buffer)))
(progn
(sort-lines nil (mon-g2be -1 t)(mon-g2be 1 t))
(mon-line-strings-bq-qt-sym-bol (mon-g2be -1 t)(1- (mon-g2be 1 t)) t)
(let ((comment-start ";;")
(comment-style 'indent))
(comment-region (mon-g2be -1 t)(mon-g2be 1 t)))
(emacs-lisp-mode)
(mon-g2be -1)
(insert (format ";; (mon-map-obarray-symbol-plist-props '%S)" w-prop-sym))
(display-buffer mmospp-bfr t)))))
mmospp-bfr))
(defun mon-escape-lisp-string-region (start end)
"Escape special characters in the region as if a lisp string.
Insert backslashes in front of special characters (namely `\' backslash,
`\"' double quote, `(' `)' parens in the region, according to the docstring escape
requirements.\n
Region should only contain the characters actually comprising the string
supplied without the surrounding quotes.\n
:NOTE Don't evaluate on docstrings containing regexps and expect sensible
return values.\n
:ALIASED-BY `mon-string-escape-lisp-region'
:ALIASED-BY `mon-lisp-escape-region'\n
:SEE-ALSO `mon-unescape-lisp-string-region', `mon-escape-string-for-cmd',
`mon-exchange-slash-and-backslash', `mon-quote-sexp'.\n►►►"
(interactive "*r")
(save-excursion
(save-restriction
(narrow-to-region start end)
(goto-char start)
(while (search-forward "\\" nil t)
(replace-match "\\\\" nil t))
(goto-char start)
(while (search-forward "\"" nil t)
(replace-match "\\\"" nil t))
(goto-char start)
(while (search-forward "(" nil t)
(replace-match "\\\(" nil t))
(goto-char start)
(while (search-forward ")" nil t)
(replace-match "\\\)" nil t)))))
(defun mon-unescape-lisp-string-region (start end)
"Unescape special characters inregion from START to END.\n
This amounts to removing preceeding backslashes from characters they escape.\n
:NOTE region should only contain the characters actually comprising the string
without the surrounding quotes.\n
:ALIASED-BY `mon-string-unescape-lisp-region'
:ALIASED-BY `mon-lisp-unescape-region'\n
:SEE-ALSO `mon-escape-lisp-string-region', `mon-quote-sexp',
`mon-escape-string-for-cmd', `mon-exchange-slash-and-backslash'.\n►►►"
(interactive "*r")
(save-excursion
(save-restriction
(narrow-to-region start end)
(goto-char start)
(while (search-forward "\\" nil t)
(replace-match "" nil t)
(forward-char)))))
(defun mon-quote-sexp (sexp)
"Quote SEXP as if by `quote' if it is not self quoting.\n
:EXAMPLE\n\n(mon-quote-sexp '(a list))\n
\(mon-quote-sexp #'\(lambda \(x\)\(x\)\)\)\n
\(mon-quote-sexp '\(lambda \(x\)\(x\)\)\)\n
\(mon-quote-sexp '\(a . b\)\)\n
\(mon-quote-sexp :test)\n
\(mon-quote-sexp #:is-not\)\n
:SEE-ALSO `mon-escape-lisp-string-region', `mon-unescape-lisp-string-region'.\n►►►"
(if (or (memq sexp '(t nil))
(keywordp (intern-soft (format "%S" sexp) obarray))
(and (listp sexp) (eq (car sexp) '(lambda)))
(stringp sexp)
(numberp sexp)
(vectorp sexp)
)
sexp
(list 'quote sexp)))
(defun mon-toggle-eval-length (&optional new-depth intrp)
"Toggle or set a new value for `eval-expression-print-length' variable.\n
Return value of `eval-expression-print-length'.\n
When `eval-expression-print-length' is nil and NEW-DEPTH is non-nil or
called-interactively with prefix arg use length, else set length to 12 - the
default.\n
When `eval-expression-print-length' is non-nil set length to nil.
When `eval-expression-print-length' and NEW-DEPTH are non-nil set length.\n
:EXAMPLE\n\n\(mon-toggle-eval-length\)\n\n\(mon-toggle-eval-length 16\)\n
\(mon-toggle-eval-length nil t\)\n\n\(mon-toggle-eval-length 1 t\)\n
\(mon-toggle-eval-length\)\n
:SEE-ALSO `mon-toggle-truncate-line', `mon-naf-mode-toggle-restore-llm',
`print-length'.\n►►►"
(interactive "P\np")
(let (mtel-nd)
(if (and new-depth intrp)
(setq mtel-nd
(read-number (concat ":FUNCTION `mon-toggle-eval-length' "
" -- new length for eval-expression-print-length: ")))
(setq mtel-nd new-depth))
(cond ((not eval-expression-print-length)
(if mtel-nd
(setq eval-expression-print-length mtel-nd)
(setq eval-expression-print-length 12)))
(eval-expression-print-length
(if mtel-nd
(setq eval-expression-print-length mtel-nd)
(setq eval-expression-print-length nil))))
eval-expression-print-length))
(defun mon-pretty-print-sexp-at-point (start end &optional CL->downcase)
"Pretty print the region in buffer. Do not move point.\n
When CL->DOWNCASE is non-nil it is used to clean CL that is `UPCASE'd.\n
:NOTE This function is meant for interactive use only.\n
:SEE-ALSO `mon-princ-cb', `mon-eval-sexp-at-point', `mon-eval-expression',
`mon-eval-print-last-sexp', `mon-toggle-eval-length'.\n►►►"
(interactive "r\nP")
(let ((fw (if CL->downcase
"(save-excursion (newline) (princ (downcase (pp '("
"(save-excursion (newline) (princ (pp '("))
(bw (if CL->downcase
"))) (current-buffer)))"
")) (current-buffer)))"))
(mk1 (make-marker))
(mk2 (make-marker))
(mk3 (make-marker))
(mk4 (make-marker)))
(unwind-protect
(save-restriction
(narrow-to-region start end)
(goto-char start)
(set-marker mk3 start)
(set-marker mk4 end)
(mon-wrap-with (concat fw "\n") (concat "\n" bw) t)
(search-forward-regexp (concat "\n" bw))
(set-marker mk2 (point))
(eval (preceding-sexp))
(search-backward-regexp (concat "\n" bw) nil t)
(set-marker mk1 (point))
(delete-region mk1 mk2)
(search-backward-regexp (concat fw "\n") nil t)
(set-marker mk1 (point))
(search-forward-regexp (concat fw "\n") nil t)
(set-marker mk2 (point))
(delete-region mk1 mk2)
(delete-region mk3 mk4)
(forward-sexp)
(set-marker mk2 (point))
(backward-sexp)
(set-marker mk1 (point))
(delete-region mk1 (1+ mk1))
(delete-region mk2 (1- mk2))
(backward-delete-char 1))
(mapc #'(lambda (mrk)
(set-marker mrk nil))
(list mk1 mk2 mk3 mk4)))))
(defun mon-princ-cb (&optional insrtp intrp)
"Wrap region in a princ->current-buffer to eval and print newline\\result
after point.\n
:SEE-ALSO `mon-eval-sexp-at-point', `mon-pretty-print-sexp-at-point', `mon-eval-expression',
`mon-eval-print-last-sexp'.\n►►►"
(interactive "i\np")
(save-excursion
(mon-wrap-text "(progn (newline) (princ '\n" "\n(current-buffer)))" insrtp intrp)))
(defun mon-eval-sexp-at-point ()
"Evaluate S-expression at point print commented result on newline.\n
Return point after commented result. Best on trivial expressions.\n
:EXAMPLE\n\(+ 1 3)\n;;;=> 4\n^point^\n
:SEE-ALSO `mon-princ-cb', `mon-pretty-print-sexp-at-point', `mon-eval-expression',
`mon-eval-print-last-sexp', `mon-eval-sexp-at-point', `mon-toggle-eval-length'.
►►►"
(interactive)
(let* ((mesap-wrap (sexp-at-point))
(mesap-val (eval mesap-wrap))
(mesap-comnt "\n;;;=> ")
(mesap-comn-sxp (format "%S%s%S" mesap-wrap mesap-comnt mesap-val))
(mesap-bnds))
(save-excursion
(if (not (eobp))
(forward-line)
(newline))
(insert mesap-comn-sxp))
(setq mesap-bnds (bounds-of-thing-at-point 'sexp))
(setq mesap-wrap (delete-and-extract-region (car mesap-bnds) (cdr mesap-bnds)))
(when (mon-line-bol-is-eol)
(delete-char 1))
(search-forward-regexp (format "^;;;=> %S" mesap-val) nil t)
mesap-val))
(defun mon-eval-print-last-sexp ()
"Like `eval-print-last-sexp' but does not move point.\n
:SEE-ALSO `mon-eval-expression', `mon-eval-sexp-at-point',
`mon-pretty-print-sexp-at-point', `mon-princ-cb', `mon-toggle-eval-length',
`pp-eval-last-sexp'.\n►►►"
(interactive)
(save-excursion
(eval-print-last-sexp)))
(defun mon-eval-expression (eval-expression-arg &optional eval-expression-insert-value)
"This is `eval-expression' with EVAL-EXPRESSION-INSERT-VALUE defaulted to t.\n
Gets us eval-expression automatically inserted into current-buffer.\n
:SEE-ALSO `mon-eval-print-last-sexp', `mon-eval-sexp-at-point',
`mon-pretty-print-sexp-at-point', `mon-princ-cb', `mon-toggle-eval-length'.\n►►►"
(interactive
(list (let ((minibuffer-completing-symbol t))
(read-from-minibuffer "Eval: "
nil read-expression-map t
'read-expression-history))
t))
(if (null eval-expression-debug-on-error)
(setq values (cons (eval eval-expression-arg) values))
(let ((old-value (make-symbol "t")) new-value)
(let ((debug-on-error old-value))
(setq values (cons (eval eval-expression-arg) values))
(setq new-value debug-on-error))
(unless (eq old-value new-value)
(setq debug-on-error new-value))))
(let ((print-length eval-expression-print-length)
(print-level eval-expression-print-level))
(if eval-expression-insert-value
(with-no-warnings
(let ((standard-output (current-buffer)))
(prin1 (car values))))
(prog1
(prin1 (car values) t)
(let ((str (eval-expression-print-format (car values))))
(if str (princ str t)))))))
(defun mon-extend-selection (arg &optional incremental)
"Mark symbol surrounding point.\n
Subsequent calls mark higher levels of sexps.\n
:SEE-ALSO `mon-semnav-up'.\n►►►"
(interactive
(list (prefix-numeric-value current-prefix-arg)
(or (and transient-mark-mode mark-active)
(eq last-command this-command))))
(if incremental
(progn
(mon-semnav-up (- arg))
(forward-sexp)
(mark-sexp -1))
(if (> arg 1)
(mon-extend-selection (1- arg) t)
(if (looking-at "\\=\\(\\s_\\|\\sw\\)*\\_>")
(goto-char (match-end 0))
(unless (memq (char-before) '(?\) ?\"))
(forward-sexp)))
(mark-sexp -1))))
;;; ==============================
;;; :COURTESY Nikolaj Schumacher :VERSION 2008-10-20
;;; :SEE (URL `http://xahlee.org/emacs/syntax_tree_walk.html')
;;; :CREATED <Timestamp: Sunday January 18, 2009 - by MON KEY>
(defun mon-semnav-up (arg)
"
:SEE-ALSO `mon-extend-selection'.\n►►►"
(interactive "p")
(when (nth 3 (syntax-ppss))
(if (> arg 0)
(progn
(skip-syntax-forward "^\"")
(goto-char (1+ (point)))
(decf arg))
(skip-syntax-backward "^\"")
(goto-char (1- (point)))
(incf arg)))
(up-list arg))
(defun mon-show-columns ()
"Show a numbered column display above the current line.\n
With ARG, begin column display at current column, not at left margin.\n
:SEE-ALSO `mon-indent-lines-from-to-col', `mon-line-strings-pipe-to-col',
`mon-string-fill-to-col', `mon-comment-lisp-to-col',
`mon-mysql-cln-pipes-map-col-field', `mon-mysql-csv-map-col-field',
`mon-mysql-get-field-col', `mon-rectangle-columns',
`mon-rectangle-sum-column', `show-point-mode'.\n►►►"
(interactive)
(let* ((msc-lead-blnks
(if (null current-prefix-arg) 0 (current-column)))
(msc-col-dsply (concat (make-string msc-lead-blnks ?\ )
"123456789.123456789.123456789."
"123456789.123456789.123456789."
"123456789.123456789.123456789."
"123456789.123456789.123456789."
"123456789.123456789.123456789."
"123456789.123456789.123456789."
"123456789.123456789.123456789."
"123456789.123456789.123456789.")))
(save-excursion
(forward-line -1)
(momentary-string-display
(substring msc-col-dsply
0 (min (1- (window-width)) (length msc-col-dsply)))
(point)))))
(defun mon-nuke-and-eval ()
"Attempt to cleanly re-evaluate a buffer of elisp code.\n
:SEE-ALSO `mon-unbind-command', `mon-unbind-symbol', `mon-unbind-function',
`mon-unbind-variable', `mon-compile-when-needed' `mon-load-or-alert',
`mon-byte-compile-and-load', `mon-dump-object-to-file',
`mon-after-mon-utils-loadtime'.\n►►►"
(interactive)
(save-excursion
(setf (point) (point-min))
(loop for form = (condition-case nil
(read (current-buffer))
(error nil))
while form
do (let ((mnae-typ (car form))
(mnae-nm (cadr form)))
(cond
((memq mnae-typ '(defun defun* defsubst defalias defmacro))
(fmakunbound mnae-nm))
((memq mnae-typ '(defvar defparameter defconst defcustom))
(makunbound mnae-nm))))))
(eval-buffer))
(defun mon-unbind-defun ()
"Unbind the `defun' near `point' in `current-buffer'.\n
:SEE-ALSO `mon-unbind-command', `mon-unbind-symbol', `mon-unbind-function',
`mon-unbind-variable', `mon-compile-when-needed' `mon-load-or-alert',
`mon-byte-compile-and-load', `mon-dump-object-to-file', `mon-nuke-and-eval',
`mon-after-mon-utils-loadtime'.\n►►►"
(interactive)
(save-excursion
(if (and (beginning-of-defun) (looking-at "(defun"))
(fmakunbound (cadr (read (current-buffer))))
(error ":FUNCTION `mon-unbind-defun' -- no defun found near point"))))
(defun mon-unbind-symbol (symbol)
"Totally unbind SYMBOL.\n
Includes unbinding function binding, variable binding, and property list.\n
:SEE-ALSO `mon-unbind-command', `mon-unbind-symbol', `mon-unbind-function',
`mon-unbind-variable', `mon-unbind-defun', `mon-compile-when-needed',
`mon-load-or-alert', `mon-byte-compile-and-load', `mon-dump-object-to-file',
`mon-nuke-and-eval', `mon-after-mon-utils-loadtime'.\n►►►"
(interactive "S:FUNCTION `mon-unbind-symbol' -- unbind symbol: ")
(fmakunbound symbol)
(makunbound symbol)
(setf (symbol-plist symbol) nil))
(defun mon-unbind-function (fncn-symbol)
"Remove the function binding of FNCN-SYMBOL.\n
:SEE-ALSO `mon-unbind-command', `mon-unbind-symbol', `mon-unbind-function',
`mon-unbind-variable', `mon-unbind-defun', `mon-compile-when-needed',
`mon-load-or-alert', `mon-byte-compile-and-load', `mon-dump-object-to-file',
`mon-nuke-and-eval', `mon-after-mon-utils-loadtime'.\n►►►"
(interactive "aFunction: ")
(fmakunbound fncn-symbol))
(defun mon-unbind-command (cmd-symbol)
"Remove the command binding of CMD-SYMBOL.\n
:SEE-ALSO `mon-unbind-command', `mon-unbind-symbol', `mon-unbind-function',
`mon-unbind-variable', `mon-unbind-defun', `mon-compile-when-needed',
`mon-load-or-alert', `mon-byte-compile-and-load', `mon-dump-object-to-file',
`mon-nuke-and-eval', `mon-after-mon-utils-loadtime'.\n►►►"
(interactive "CCommand: ")
(fmakunbound cmd-symbol))
(defun mon-unbind-variable (var-symbol)
"Remove the variable binding of VAR-SYMBOL.\n
:SEE-ALSO `mon-unbind-command', `mon-unbind-symbol', `mon-unbind-function',
`mon-unbind-variable', `mon-unbind-defun', `mon-compile-when-needed',
`mon-load-or-alert', `mon-byte-compile-and-load', `mon-dump-object-to-file',
`mon-nuke-and-eval', `mon-after-mon-utils-loadtime'.\n►►►"
(interactive (list
(completing-read "Variable: "
(loop for s being the symbols
when (boundp s) collect (list (symbol-name s))))))
(makunbound (if (stringp var-symbol) (intern var-symbol) var-symbol)))
(defun mon-dump-object-to-file (obj file)
"Save symbol object OBJ to the byte compiled version of FILE.\n
OBJ can be any lisp object, list, hash-table, etc.
FILE is an elisp file with ext *.el.
Loading the *.elc file will re-institute object.\n
:NOTE This function utilizes an documented feature of `eval-when-compile'. It
can be interesting way to save a persistent elisp object. Using `setf' combined
with `eval-when-compile' is a convenient way to save lisp objects like
hash-table.
:SEE-ALSO `mon-unbind-command', `mon-unbind-symbol', `mon-unbind-function',
`mon-unbind-variable', `mon-unbind-defun', `mon-compile-when-needed',
`mon-load-or-alert', `mon-byte-compile-and-load', `mon-dump-object-to-file',
`mon-nuke-and-eval', `mon-after-mon-utils-loadtime'.\n►►►"
(if (file-exists-p file)
(error (concat ":FUNCTION `mon-dump-object-to-file' "
"-- already existent FILE: %s") file)
(with-temp-file file
(erase-buffer)
(let* ((str-obj (symbol-name obj))
(fmt-obj (format "(setq %s (eval-when-compile %s))" str-obj str-obj)))
(insert fmt-obj)))
(byte-compile-file file)
(delete-file file)
(message (concat ":FUNCTION `mon-dump-object-to-file' "
"-- OBJ `%s' dumped to FILE: %sc")
obj file)))
(defun mon-byte-compile-and-load ()
"Byte compile and load the current .el file.\n
The function `byte-compile-file' was only easily accesible from the menu.\n
:SEE-ALSO `mon-unbind-command', `mon-unbind-symbol', `mon-unbind-function',
`mon-unbind-variable', `mon-unbind-defun', `mon-compile-when-needed',
`mon-load-or-alert', `mon-byte-compile-and-load', `mon-dump-object-to-file',
`mon-nuke-and-eval', `mon-after-mon-utils-loadtime'.\n►►►"
(interactive)
(byte-compile-file buffer-file-name t))
(defun mon-compile-when-needed (comp-fname)
"Compile the given file with COMP-FNAME only if needed.\n
Add .el if required, and use `load-path' to find it.\n
:SEE-ALSO `mon-unbind-command', `mon-unbind-symbol', `mon-unbind-function',
`mon-unbind-variable', `mon-unbind-defun', `mon-compile-when-needed',
`mon-load-or-alert', `mon-byte-compile-and-load', `mon-dump-object-to-file',
`mon-nuke-and-eval', `mon-after-mon-utils-loadtime'.\n►►►"
(if (not (string-match "\.el$" comp-fname))
(mon-compile-when-needed (concat comp-fname ".el"))
(mapc #'(lambda (dir)
(let* ((mcwn-src (concat dir "/" comp-fname)))
(when (file-newer-than-file-p mcwn-src (concat mcwn-src "c"))
(message (concat ":FUNCTION `mon-compile-when-needed' "
(if (let ((byte-compile-verbose nil))
(condition-case nil
(byte-compile-file mcwn-src)
(error nil)))
"-- compiled: %s"
"-- failed compilation of: %s"))
mcwn-src))))
load-path)))
(defun mon-load-or-alert (lib-name &optional compile-when-needed)
"Try to load the specified file LIB-NAME.\n
When optional arg COMPILE-WHEN-NEEDED `mon-compile-when-needed' the file
LIB-NAME first. Insert a warning message in a load-warning buffer in case of
failure.\n
:SEE-ALSO `mon-unbind-command', `mon-unbind-symbol', `mon-unbind-function',
`mon-unbind-variable', `mon-unbind-defun', `mon-compile-when-needed',
`mon-load-or-alert', `mon-byte-compile-and-load', `mon-dump-object-to-file',
`mon-nuke-and-eval', `mon-after-mon-utils-loadtime'.\n►►►"
(when compile-when-needed (mon-compile-when-needed lib-name))
(if (load lib-name t nil)
t
(let ((mloa-bfr (get-buffer-create "*MON-LOADING-WARNINGS*")))
(display-buffer mloa-bfr)
(set-buffer mloa-bfr)
(insert
(propertize "Warning: :FUNCTION `mon-load-or-alert' -- "
'face 'font-lock-warning-face 'fontified t)
" could not load '" lib-name "'\n")
(fit-window-to-buffer (get-buffer-window mloa-bfr))
(set-buffer-modified-p nil))
nil))
(provide 'mon-utils)
(eval-after-load "mon-utils" '(mon-utils-require-features-at-loadtime))