scratch/tzz/auth-source-reveal-mode 0f699c3: lisp/auth-source.el: rewrite authinfo-mode as minor auth-source-reveal-mode

[Teodor Zlatanov]

branch: scratch/tzz/auth-source-reveal-mode
commit 0f699c39081aa383f86050d1dc85d6771049cd6b
Author: Ted Zlatanov <tzz@lifelogs.com>
Commit: Ted Zlatanov <tzz@lifelogs.com>

    lisp/auth-source.el: rewrite authinfo-mode as minor auth-source-reveal-mode
---
 lisp/auth-source.el         | 102 ++++++++++++++++++++++++-----------
 lisp/progmodes/prog-mode.el | 128 ++++++++++++++++++++++++++++++++++++++++----
 2 files changed, 188 insertions(+), 42 deletions(-)

diff --git a/lisp/auth-source.el b/lisp/auth-source.el
index 7a0e09b..d3fc774 100644
--- a/lisp/auth-source.el
+++ b/lisp/auth-source.el
@@ -44,6 +44,7 @@
 
 (require 'cl-lib)
 (require 'eieio)
+(require 'prog-mode)
 
 (autoload 'secrets-create-item "secrets")
 (autoload 'secrets-delete-item "secrets")
@@ -2405,44 +2406,83 @@ MODE can be \"login\" or \"password\"."
       (setq password (funcall password)))
     (list user password auth-info)))
 
-;;; Tiny mode for editing .netrc/.authinfo modes (that basically just
-;;; hides passwords).
+;;; Tiny minor mode for editing .netrc/.authinfo modes (that basically
+;;; just hides passwords).
 
-(defcustom authinfo-hidden "password"
-  "Regexp matching elements in .authinfo/.netrc files that should be hidden."
+(defcustom auth-source-reveal-regex "password"
+  "Regexp matching tokens or JSON keys in .authinfo/.netrc/JSON files.
+The text following the tokens or under the JSON keys will be hidden."
   :type 'regexp
   :version "27.1")
 
-;;;###autoload
-(define-derived-mode authinfo-mode fundamental-mode "Authinfo"
-  "Mode for editing .authinfo/.netrc files.
+(defcustom auth-source-reveal-json-modes '(json-mode js-mode js2-mode 
rjsx-mode)
+  "List of symbols for modes that should use JSON parsing logic."
+  :type 'list
+  :version "27.1")
 
-This is just like `fundamental-mode', but hides passwords.  The
-passwords are revealed when point moved into the password.
+(defcustom auth-source-reveal-hider '(?* (base-right . base-left) ?© 
(base-right . base-left) ?© (base-right . base-left) ?*)
+  "A character or a composition list to hide passwords.
+In the composition list form, you can use the format
+(?h (base-right . base-left) ?i (base-right . base-left) ?d (base-right . 
base-left) ?e)
+to show the string \"hide\" (by aligning character left/right baselines).
 
-\\{authinfo-mode-map}"
-  (authinfo--hide-passwords (point-min) (point-max))
-  (reveal-mode))
+Other composition keywords you can use: top-left/tl,
+top-center/tc, top-right/tr, base-left/Bl, base-center/Bc,
+base-right/Br, bottom-left/bl, bottom-center/bc, bottom-right/br,
+center-left/cl, center-center/cc, center-right/cr."
+  :type '(choice
+          (const :tag "A single copyright sign" ?©)
+          (character :tag "Any character")
+          (sexp :tag "A composition list"))
+  :version "27.1")
 
-(defun authinfo--hide-passwords (start end)
-  (save-excursion
-    (save-restriction
-      (narrow-to-region start end)
-      (goto-char start)
-      (while (re-search-forward (format "\\(\\s-\\|^\\)\\(%s\\)\\s-+"
-                                        authinfo-hidden)
-                                nil t)
-        (when (auth-source-netrc-looking-at-token)
-          (let ((overlay (make-overlay (match-beginning 0) (match-end 0))))
-            (overlay-put overlay 'display (propertize "****"
-                                                      'face 'warning))
-            (overlay-put overlay 'reveal-toggle-invisible
-                         #'authinfo--toggle-display)))))))
-
-(defun authinfo--toggle-display (overlay hide)
-  (if hide
-      (overlay-put overlay 'display (propertize "****" 'face 'warning))
-    (overlay-put overlay 'display nil)))
+(defun auth-source-reveal-compose-p (start end _match)
+  "Return true iff the symbol MATCH should be composed.
+The symbol starts at position START and ends at position END.
+This overrides the default for `prettify-symbols-compose-predicate'."
+  ;; Check that the chars should really be composed into a symbol.
+  t)
+
+;;;###autoload
+(define-minor-mode auth-source-reveal-mode
+  "Toggle password hiding for auth-source files using `prettify-symbols-mode'.
+
+If called interactively, enable auth-source-reveal mode if ARG is
+positive, and disable it if ARG is zero or negative.  If called
+from Lisp, also enable the mode if ARG is omitted or nil, and
+toggle it if ARG is toggle; disable the mode otherwise.
+
+When auth-source-reveal mode is enabled, passwords will be
+hidden. To reveal them when point is inside them, see
+`prettify-symbols-unprettify-at-point'.
+
+See `auth-source-password-hide-regex' for the regex matching the
+tokens and keys associated with passwords."
+  ;; The initial value.
+  :init-value nil
+  ;; The indicator for the mode line.
+  :lighter " asr"
+  :group 'auth-source
+
+  (when auth-source-reveal-mode
+    (let ((prettify-augments
+           `(auth-source-reveal-mode-prettify-regexp ; identifier symbol
+             ,(if (apply #'derived-mode-p auth-source-reveal-json-modes)
+                  (format "\"?password\"?[:[:blank:]]+\"\\([^\t\r\n\"]+\\)\"" 
auth-source-reveal-regex)
+                (format "\\b%s\\b\\s-+\\([^ \t\r\n]+\\)" 
auth-source-reveal-regex))
+             ,auth-source-reveal-hider)))
+
+      (setq-local
+       prettify-symbols-compose-predicate #'auth-source-reveal-compose-p
+       prettify-symbols-alist (cl-adjoin prettify-augments
+                                         prettify-symbols-alist
+                                         :test #'equal)))
+    (unless prettify-symbols-unprettify-at-point
+      (auth-source-do-warn
+       "Please set `%s' to _see_ passwords at point"
+       'prettify-symbols-unprettify-at-point)))
+
+  (prettify-symbols-mode (if auth-source-reveal-mode 1 -1)))
 
 (provide 'auth-source)
 
diff --git a/lisp/progmodes/prog-mode.el b/lisp/progmodes/prog-mode.el
index d3d3dea..4aeccf8 100644
--- a/lisp/progmodes/prog-mode.el
+++ b/lisp/progmodes/prog-mode.el
@@ -30,6 +30,7 @@
 ;;; Code:
 
 (eval-when-compile (require 'cl-lib)
+                   (require 'seq)
                    (require 'subr-x))
 
 (defgroup prog-mode nil
@@ -91,10 +92,25 @@ instead."
   (or (car prog-indentation-context) 0))
 
 (defvar-local prettify-symbols-alist nil
-  "Alist of symbol prettifications.
-Each element looks like (SYMBOL . CHARACTER), where the symbol
-matching SYMBOL (a string, not a regexp) will be shown as
-CHARACTER instead.
+  "Alist of symbol string prettifications.
+Each element can look like (STRING . CHARACTER), where the
+STRING (a string, not a regexp) will be shown as CHARACTER
+instead.
+
+For example: \"->\" to the Unicode RIGHT ARROW →
+ (\"->\" . ?→)
+
+Elements can also look like (IDENTIFIER REGEXP CHARACTER) which
+will behave like the simpler (SYMBOL-STRING . CHARACTER) form
+except it will match regular expressions. The IDENTIFIER can be
+any symbol and should be unique to every package that augments
+`prettify-symbols-alist' (in order to remove prettifications
+easily with `prettify-symbols-remove-prettifications').
+
+For example: \"abc[123]\" matching \"abc1\", \"abc2\", or
+\"abc3\" could be mapped to the Unicode WORLD MAP. Note again the
+IDENTIFIER is an arbitrary Lisp symbol.
+ (my-worldmap \"abc[123]\" 128506)
 
 CHARACTER can be a character, or it can be a list or vector, in
 which case it will be used to compose the new symbol as per the
@@ -121,7 +137,41 @@ The matched symbol is the car of one entry in 
`prettify-symbols-alist'.
 The predicate receives the match's start and end positions as well
 as the match-string as arguments.")
 
-(defun prettify-symbols--compose-symbol (alist)
+;; (prettify-symbols-default-compose-replacer '(("xyz" 231) (prettify-regexp 
"aaa\\(bbb\\)" 169)) 568 574 "aaabbb")
+(defun prettify-symbols-default-compose-replacer (alist start end match 
&optional identifier)
+  "Return the compose-region prettification for MATCH from ALIST.
+START and END are passed back and may be modified (narrowed)."
+  (let ((quick-assoc (cdr (assoc match alist))))
+    (if quick-assoc
+        ;; Return the quick lookup if we can, else...
+        (list start end quick-assoc)
+      (cl-loop for ps in alist
+               ;; Did we get a valid regexp entry, and does it match
+               ;; the identifier (if packaged in the call) or the regexp?
+               if (and (symbolp (car-safe ps))
+                       ;; We must match the identifier symbol if we got it.
+                       (if identifier
+                           (eq identifier (car ps))
+                         t) ; But if there's no identifier, pass safely.
+
+                       ;; ...We need to always do a string-match for the 
bounds.
+                       (string-match (nth 1 ps) match))
+               ;; Now return the actual prettification start and end.
+               return (list (+ start (match-beginning 1))
+                            (+ start(match-end 1))
+                            (nth 2 ps))))))
+
+(defvar-local prettify-symbols-compose-replacer
+  #'prettify-symbols-default-compose-replacer
+  "A function to generate the replacement for a matched string.
+The function receives the current prettify-symbols-alist, the
+match's start and end positions, and the match-string as
+arguments.
+
+For regexp matches, the function will also receive the symbol
+that identifies the match, as per `prettify-symbols-alist'.")
+
+(defun prettify-symbols--compose-symbol (alist &optional identifier)
   "Compose a sequence of characters into a symbol.
 Regexp match data 0 specifies the characters to be composed."
   ;; Check that the chars should really be composed into a symbol.
@@ -132,10 +182,14 @@ Regexp match data 0 specifies the characters to be 
composed."
              (funcall prettify-symbols-compose-predicate start end match))
         ;; That's a symbol alright, so add the composition.
         (with-silent-modifications
-          (compose-region start end (cdr (assoc match alist)))
-          (add-text-properties
-           start end
-           `(prettify-symbols-start ,start prettify-symbols-end ,end)))
+          (let* ((replacement (funcall prettify-symbols-compose-replacer
+                                       alist start end match identifier))
+                 (start (nth 0 replacement))
+                 (end (nth 1 replacement)))
+            (apply #'compose-region replacement)
+            (add-text-properties
+             start end
+             `(prettify-symbols-start ,start prettify-symbols-end ,end))))
       ;; No composition for you.  Let's actually remove any
       ;; composition we may have added earlier and which is now
       ;; incorrect.
@@ -146,10 +200,30 @@ Regexp match data 0 specifies the characters to be 
composed."
   ;; Return nil because we're not adding any face property.
   nil)
 
+(defun prettify-symbols--make-fixed-matcher (alist)
+  "Make the fixed string matcher portion of the font-lock keywords from ALIST."
+  (regexp-opt (cl-loop for s in (mapcar 'car alist)
+                       if (stringp s)
+                       collect s)
+              t))
+
+(defun prettify-symbols--make-regexp-keywords (alist)
+  "Make the regexp string matcher portion of the font-lock keywords from 
ALIST."
+  ;; Collect the symbols to generate matchers keyed on them.
+  (cl-loop for ps in alist
+           if (symbolp (car-safe ps))
+           collect `(
+                     ,(nth 1 ps)          ; the regexp
+                     ;; the symbol composer called with the identifier
+                     (0 (prettify-symbols--compose-symbol
+                         ',prettify-symbols-alist
+                         ',(car ps))))))
+
 (defun prettify-symbols--make-keywords ()
   (if prettify-symbols-alist
-      `((,(regexp-opt (mapcar 'car prettify-symbols-alist) t)
-         (0 (prettify-symbols--compose-symbol ',prettify-symbols-alist))))
+      `((,(prettify-symbols--make-fixed-matcher prettify-symbols-alist)
+         (0 (prettify-symbols--compose-symbol ',prettify-symbols-alist)))
+        ,@(prettify-symbols--make-regexp-keywords prettify-symbols-alist))
     nil))
 
 (defvar-local prettify-symbols--keywords nil)
@@ -195,6 +269,38 @@ on the symbol."
        (setq prettify-symbols--current-symbol-bounds (list s e))
         (remove-text-properties s e '(composition nil))))))
 
+(defun prettify-symbols-add-prettification-entry (entry)
+  "Add ENTRY to `prettify-symbols-alist' for the current buffer.
+ENTRY is formatted as per `prettify-symbols-alist' (which see).
+Duplicates according to `equal' will not be added."
+  (setq-local prettify-symbols-alist (cl-adjoin entry
+                                                prettify-symbols-alist
+                                                :test #'equal)))
+
+(defun prettify-symbols-add-prettification-rx (identifier regexp replacement)
+  "Convenience wrapper of `prettify-symbols-add-prettification-entry' to 
prettify REGEXP with REPLACEMENT."
+  (prettify-symbols-add-prettification-entry
+   (list identifier regexp replacement)))
+
+(defun prettify-symbols-add-prettification-string (fixed-string replacement)
+  "Convenience wrapper of `prettify-symbols-add-prettification-entry' to 
prettify FIXED-STRING with REPLACEMENT."
+  (prettify-symbols-add-prettification-entry
+   (cons fixed-string replacement)))
+
+(defun prettify-symbols-remove-prettification (entry)
+  "Remove ENTRY to `prettify-symbols-alist' for the current buffer.
+ENTRY is found with an `equal' test."
+  (setq-local prettify-symbols-alist (cl-remove entry
+                                                prettify-symbols-alist
+                                                :test #'equal)))
+
+(defun prettify-symbols-remove-prettifications (identifier)
+  "Remove all IDENTIFIER entries from `prettify-symbols-alist' for the current 
buffer.
+IDENTIFIER is as per `prettify-symbols-alist' (which see)."
+  (setq-local prettify-symbols-alist (cl-remove identifier
+                                                prettify-symbols-alist
+                                                :test #'car)))
+
 ;;;###autoload
 (define-minor-mode prettify-symbols-mode
   "Toggle Prettify Symbols mode.