new reader macros for shell- and Perl-style matching & replacement

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

4 files changed, 129 insertions, 14 deletions

diff --git a/src/property/cron.lisp b/src/property/cron.lisp
index bba953f..e68b6ca 100644
--- a/src/property/cron.lisp
+++ b/src/property/cron.lisp
@@ -135,7 +135,7 @@ directory."
           (old (runlines :may-fail "crontab" "-l"))
           (new
             (mapcar
-             (lambda (line) (re:regex-replace-all #?/\$HOME/ line home))
+             #~s/\$HOME/${home}/g
              (nconc
               (list "# Automatically updated by Consfigurator; do not edit" "")
               (loop for (k v) on env by #'cddr
diff --git a/src/property/crypttab.lisp b/src/property/crypttab.lisp
index cc44f50..6538409 100644
--- a/src/property/crypttab.lisp
+++ b/src/property/crypttab.lisp
@@ -25,10 +25,9 @@
     (if (string= val "") nil val)))
 
 (defun get-device-parent (device)
-  (multiple-value-bind (match groups)
-      (re:scan-to-strings #?/^1\s+dependencies\s*:\s*\((\S+)\)$/
-                          (run "dmsetup" "deps" "-o" "blkdevname" device))
-    (and match (merge-pathnames (elt groups 0) #P"/dev/"))))
+  (aand (#1~/^1\s+dependencies\s*:\s*\((\S+)\)$/
+         (run "dmsetup" "deps" "-o" "blkdevname" device))
+        (merge-pathnames it #P"/dev/")))
 
 (defmethod ct-target ((volume opened-luks-container))
   (volume-label volume))
diff --git a/src/reader.lisp b/src/reader.lisp
index f744fa4..3d73046 100644
--- a/src/reader.lisp
+++ b/src/reader.lisp
@@ -76,10 +76,130 @@ indented heredoc; see perlop(1)."
                 finally (return (unlines accum)))
           heredoc))))
 
+;; Originally inspired by some ideas of Doug Hoyt in his *Let Over Lambda*.
+(defun perl-tilde-reader (stream char arg)
+  (flet ((readerr (&rest args)
+           (apply #'simple-reader-error stream args)))
+    (let ((negated (and (char= #\! char)
+                        (or (char= #\~ (read-char stream t :eof t))
+                            (readerr "Expected \"~~\" following \"!\"."))))
+          first-delim op)
+      (loop for next = (read-char stream t :eof t)
+            while (alpha-char-p next) collect next into accum
+            finally (setq first-delim next
+                          op (cond ((null accum) #\m)
+                                   ((= (length accum) 1) (car accum))
+                                   ((string= (coerce accum 'string) "tr") #\y)
+                                   (t (readerr "Unknown regexp operator ~S."
+                                               (coerce accum 'string))))))
+      (let* ((cl-interpol:*inner-delimiters*
+               (and (not (eql first-delim #\'))
+                    ;; This is the same as CL-INTERPOL's regexp mode, but we
+                    ;; don't turn that on for SECOND-ARG.
+                    '((#\{ . #\}))))
+             (first-arg
+               (cl-interpol:interpol-reader
+                (make-concatenated-stream
+                 (make-string-input-stream (format nil "r~A" first-delim))
+                 stream)
+                #\? nil))
+             (second-delim
+               (and (member op '(#\s #\y))
+                    (if (atom (find first-delim cl-interpol:*outer-delimiters*
+                                    :key #'ensure-car))
+                        first-delim
+                        (read-char stream t :eof t))))
+             (second-closer
+               (aand (find second-delim cl-interpol:*outer-delimiters*
+                           :key #'ensure-car)
+                     (consp it) (cdr it)))
+             (second-arg
+               ;; Here we have to do our own pass before calling
+               ;; CL-INTERPOL:INTERPOL-READER because we need to additionally
+               ;; preserve \`, \& and \', and its regexp mode doesn't do that.
+               ;; We do want to use CL-INTERPOL:INTERPOL-READER too, because
+               ;; interpolating into replacement strings is useful.
+               (and second-delim
+                    (loop
+                      with escaped and depth = 0
+                      and result = (make-array 1 :fill-pointer 1
+                                                 :element-type 'character
+                                                 ;; Use our own delimiter to
+                                                 ;; ensure no regexp mode.
+                                                 :initial-element #\#)
+                      for next = (read-char stream t :eof t)
+                      for extra-escape = (if escaped
+                                             (or (digit-char-p next)
+                                                 (member next '(#\` #\& #\')))
+                                             (eql next #\#))
+                      if escaped do (setq escaped nil)
+                        else do (switch (next)
+                                  (second-delim (if second-closer
+                                                    (incf depth)
+                                                    (loop-finish)))
+                                  (second-closer (if (zerop depth)
+                                                     (loop-finish)
+                                                     (decf depth)))
+                                  (#\\ (setq escaped t)))
+                      when extra-escape
+                        do (vector-push-extend #\\ result)
+                      do (vector-push-extend next result)
+                      finally (vector-push-extend #\# result)
+                              (return (cl-interpol:interpol-reader
+                                       (make-string-input-stream result)
+                                       #\? nil)))))
+             (modes (loop for next = (read-char stream t :eof t)
+                          while (alpha-char-p next) collect next
+                          finally (unread-char next stream)))
+             (scanner-args
+               (list first-arg
+                     :case-insensitive-mode (and (find #\i modes) t)
+                     :multi-line-mode (and (find #\m modes) t)
+                     :single-line-mode (and (find #\s modes) t)
+                     ;; We're choosing not to use CL-INTERPOL's own extended
+                     ;; mode because CL-PPCRE's is closer to Perl's.
+                     :extended-mode (and (find #\x modes) t)))
+             (scanner (if (constantp first-arg)
+                          `(load-time-value
+                            (re:create-scanner ,@scanner-args))
+                          `(re:create-scanner ,@scanner-args)))
+             (body
+               (ecase op
+                 (#\m
+                  (cond ((member #\g modes)
+                         `(re:all-matches-as-strings ,scanner target-string))
+                        ((not arg)
+                         ;; The number of capture groups is constant if
+                         ;; FIRST-ARG is constant, so could we self-replace
+                         ;; on first execution / otherwise memoise?
+                         `(multiple-value-bind (zeroth rest)
+                              (re:scan-to-strings ,scanner target-string)
+                            ;; We could (coerce rest 'list) for use with
+                            ;; DESTRUCTURING-BIND.  But there is already
+                            ;; CL-PPCRE:REGISTER-GROUPS-BIND.
+                            (if (zerop (length rest)) zeroth rest)))
+                        ((zerop arg)
+                         `(re:scan-to-strings ,scanner target-string))
+                        (t              ; ARG is a positive integer
+                         `(aand
+                           (nth-value 1 (re:scan-to-strings ,scanner
+                                                            target-string))
+                           (values (aref it ,(1- arg)) it)))))
+                 (#\s `(,(if (member #\g modes)
+                             're:regex-replace-all
+                             're:regex-replace)
+                        ,scanner target-string ,second-arg))
+                 (#\y (readerr "Transliteration unimplemented.")))))
+        `(lambda (target-string)
+           ,(if negated `(not ,body) body))))))
+
 (named-readtables:defreadtable :consfigurator
   (:merge :standard)
   (:dispatch-macro-char #\# #\? #'cl-interpol:interpol-reader)
-  (:dispatch-macro-char #\# #\> #'read-heredoc))
+  (:dispatch-macro-char #\# #\> #'read-heredoc)
+
+  (:dispatch-macro-char #\# #\~ #'perl-tilde-reader)
+  (:dispatch-macro-char #\# #\! #'perl-tilde-reader))
 
 (named-readtables:defreadtable :consfigurator.without-read-eval
   (:merge :consfigurator)
diff --git a/src/util.lisp b/src/util.lisp
index 20a3714..fea974d 100644
--- a/src/util.lisp
+++ b/src/util.lisp
@@ -249,9 +249,7 @@ simple collections of readably-printable values."
 
 (defun parse-username-from-id (output)
   "Where OUTPUT is the output of the id(1) command, extract the username."
-  (multiple-value-bind (match groups)
-      (re:scan-to-strings "^uid=[0-9]+\\(([^)]+)" output)
-    (and match (elt groups 0))))
+  (#1~/^uid=[0-9]+\(([^)]+)/ output))
 
 (defun abbreviate-consfigurator-package (name)
   (with-standard-io-syntax
@@ -421,11 +419,9 @@ on simple scripts embedded in source code, written with newlines for the sake
 of maintainability.  Converting those scripts to single lines before they are
 executed improves Consfigurator's debug output, and also makes process names
 visible to remote commands like ps(1) more readable."
-  (re:regex-replace-all
-   #?/\s+/ (re:regex-replace-all "(then|else|elif|fi|case|in|;;|do|done);"
-                                 (format nil "~{~A~^; ~}" (lines script))
-                                 "\\1")
-   " "))
+  (#~s/\s+/ /g
+   (#~s/(then|else|elif|fi|case|in|;;|do|done);/\1/g
+    (format nil "~{~A~^; ~}" (lines script)))))
 
 
 ;;;; Progress & debug printing