support indented heredocs, add new "Reader macros" manual section

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

5 files changed, 88 insertions, 75 deletions

diff --git a/src/property/apt.lisp b/src/property/apt.lisp
index f7a258e..11367d2 100644
--- a/src/property/apt.lisp
+++ b/src/property/apt.lisp
@@ -209,12 +209,12 @@ packages.  Does not do any automatic upgrades."
   (:desc "apt periodic updates")
   (:hostattrs (os:required 'os:debianlike))
   (:apply
-   (file:has-content "/etc/apt/apt.conf.d/02periodic"
-#>EOF>APT::Periodic::Enable "1";
-APT::Periodic::Update-Package-Lists "1";
-APT::Periodic::Download-Upgradeable-Packages "1";
-APT::Periodic::Verbose "1";
-EOF))
+   (file:has-content "/etc/apt/apt.conf.d/02periodic" #>>~EOF>>
+                     APT::Periodic::Enable "1";
+                     APT::Periodic::Update-Package-Lists "1";
+                     APT::Periodic::Download-Upgradeable-Packages "1";
+                     APT::Periodic::Verbose "1";
+                     EOF))
   (:unapply
    (file:does-not-exist "/etc/apt/apt.conf.d/02periodic")))
 
diff --git a/src/property/sbuild.lisp b/src/property/sbuild.lisp
index 297e836..9a0eca6 100644
--- a/src/property/sbuild.lisp
+++ b/src/property/sbuild.lisp
@@ -123,17 +123,17 @@ To take advantage of the piuparts and autopkgtest support, add to your
         (file:contains-lines "/etc/schroot/sbuild/fstab"
           "/var/cache/ccache-sbuild /var/cache/ccache-sbuild none rw,bind 0 0"))
        ;; Script from <https://wiki.debian.org/sbuild>.
-       (file:has-content "/var/cache/ccache-sbuild/sbuild-setup"
-#>EOF>#!/bin/sh
+       (file:has-content "/var/cache/ccache-sbuild/sbuild-setup" #>>~EOF>>
+                         #!/bin/sh
 
-export CCACHE_DIR=/var/cache/ccache-sbuild
-export CCACHE_UMASK=002
-export CCACHE_COMPRESS=1
-unset CCACHE_HARDLINK
-export PATH="/usr/lib/ccache:$PATH"
+                         export CCACHE_DIR=/var/cache/ccache-sbuild
+                         export CCACHE_UMASK=002
+                         export CCACHE_COMPRESS=1
+                         unset CCACHE_HARDLINK
+                         export PATH="/usr/lib/ccache:$PATH"
 
-exec "$@"
-EOF :mode #o755)
+                         exec "$@"
+                         EOF :mode #o755)
 
        ;; schroot
        (chroot:os-bootstrapped-for ,chroot-options ,chroot ,host)
diff --git a/src/property/schroot.lisp b/src/property/schroot.lisp
index e528f10..3601c45 100644
--- a/src/property/schroot.lisp
+++ b/src/property/schroot.lisp
@@ -44,22 +44,22 @@ Implicitly sets SCHROOT:USES-OVERLAYS.
 Shell script from <https://wiki.debian.org/sbuild>."
   (:desc "schroot overlays in tmpfs")
   (:hostattrs (push-hostattr 'uses-overlays t))
-  (:apply (file:has-content "/etc/schroot/setup.d/04tmpfs"
-#>EOF>#!/bin/sh
+  (:apply
+   (file:has-content "/etc/schroot/setup.d/04tmpfs" #>>~EOF>>
+                     #!/bin/sh
 
-set -e
+                     set -e
 
-. "$SETUP_DATA_DIR/common-data"
-. "$SETUP_DATA_DIR/common-functions"
-. "$SETUP_DATA_DIR/common-config"
+                     . "$SETUP_DATA_DIR/common-data"
+                     . "$SETUP_DATA_DIR/common-functions"
+                     . "$SETUP_DATA_DIR/common-config"
 
-
-if [ $STAGE = "setup-start" ]; then
-  mount -t tmpfs overlay /var/lib/schroot/union/overlay
-elif [ $STAGE = "setup-recover" ]; then
-  mount -t tmpfs overlay /var/lib/schroot/union/overlay
-elif [ $STAGE = "setup-stop" ]; then
-  umount -f /var/lib/schroot/union/overlay
-fi
-EOF :mode #o755))
+                     if [ $STAGE = "setup-start" ]; then
+                         mount -t tmpfs overlay /var/lib/schroot/union/overlay
+                     elif [ $STAGE = "setup-recover" ]; then
+                         mount -t tmpfs overlay /var/lib/schroot/union/overlay
+                     elif [ $STAGE = "setup-stop" ]; then
+                         umount -f /var/lib/schroot/union/overlay
+                     fi
+                     EOF :mode #o755))
   (:unapply (file:does-not-exist "/etc/schroot/setup.d/04tmpfs")))
diff --git a/src/reader.lisp b/src/reader.lisp
index e4f15b9..f744fa4 100644
--- a/src/reader.lisp
+++ b/src/reader.lisp
@@ -1,6 +1,6 @@
 ;;; Consfigurator -- Lisp declarative configuration management system
 
-;;; Copyright (C) 2021  Sean Whitton <spwhitton@spwhitton.name>
+;;; Copyright (C) 2021, 2023  Sean Whitton <spwhitton@spwhitton.name>
 
 ;;; This file is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -17,20 +17,64 @@
 
 (in-package :consfigurator)
 
+(defun lines (text &optional trimfun (trimchars '(#\Space #\Tab)))
+  (with-input-from-string (stream text)
+    (let (bolp buffer)
+      (flet ((trim (line)
+               (if trimfun (funcall trimfun trimchars line) line))
+             (reset ()
+               (setq bolp t
+                     buffer (make-array 0 :fill-pointer 0
+                                          :element-type 'character))))
+        ;; Split on either <CR>, <LF> or <CR><LF>; <LF><CR> would mean split
+        ;; with a blank line in between.  Drop a single trailing blank line.
+        (loop initially (reset)
+              for char = (read-char stream nil nil)
+              if char
+                if (member char '(#\Return #\Newline) :test #'char=)
+                  collect (trim buffer)
+                  and do (reset)
+                         (when (char= char #\Return)
+                           (when-let ((next (peek-char nil stream nil nil)))
+                             (when (char= next #\Newline)
+                               (read-char stream))))
+                else do (setq bolp nil)
+                        (vector-push-extend char buffer)
+                end
+              else
+                unless bolp collect (trim buffer) end
+                and do (loop-finish))))))
+
+(defun unlines (lines)
+  (format nil "~{~A~%~}" lines))
+
 (defun read-heredoc (stream char arg)
-  "Like CL-HEREDOC:READ-HEREDOC but treat #>EOF> and #>>EOF>> differently:
-#>>EOF>> skips over the remainder of the current line and its newline.
-For the sake of future extension, the remainder of the line after the #>>EOF>>
-should not contain anything other than a single-line comment."
-  (if (char= (peek-char nil stream t :eof t) char)
-      ;; #>>EOF>> -- ignore the rest of the line.
-      (progn (read-char stream t :eof t)
-             (let* ((delim (make-string 2 :initial-element char))
-                    (ender (cl-heredoc:read-until-match stream delim)))
-               (read-line stream t :eof t)
-               (cl-heredoc:read-until-match stream ender)))
-      ;; #>EOF> -- just use the normal READ-HEREDOC.
-      (cl-heredoc:read-heredoc stream char arg)))
+  "Like CL-HEREDOC:READ-HEREDOC, with some additional features.
+
+Treat #>EOF> and #>>EOF>> differently: #>>EOF>> skips over the remainder of
+the current line and its newline.  For the sake of future extension, the
+remainder of the line after the #>>EOF>> must not contain anything other than
+a single-line comment.
+
+Preceding the specification of the terminating string with a tilde means an
+indented heredoc; see perlop(1)."
+  (declare (ignore arg))
+  (let* ((>> (and (char= char (peek-char nil stream t :eof t))
+                  (read-char stream t :eof t)))
+         (indented (and (char= #\~ (peek-char nil stream t :eof t))
+                        (read-char stream t :eof t)))
+         (delim (if >> (make-string 2 :initial-element char) (string char)))
+         (ender (cl-heredoc:read-until-match stream delim)))
+    (when >>
+      (read-line stream t :eof t))
+    (let ((heredoc (cl-heredoc:read-until-match stream ender)))
+      (if indented
+          (loop with lines = (lines heredoc)
+                with indent = (length (lastcar lines))
+                for (line . rest) on lines while rest
+                collect (subseq line (min indent (length line))) into accum
+                finally (return (unlines accum)))
+          heredoc))))
 
 (named-readtables:defreadtable :consfigurator
   (:merge :standard)
diff --git a/src/util.lisp b/src/util.lisp
index 47ce5ac..20a3714 100644
--- a/src/util.lisp
+++ b/src/util.lisp
@@ -38,37 +38,6 @@
              for result in new and i upfrom 0 do
                (setf (aref results i) (nreconc result (aref results i))))))
 
-(defun lines (text &optional trimfun (trimchars '(#\Space #\Tab)))
-  (with-input-from-string (stream text)
-    (let (bolp buffer)
-      (flet ((trim (line)
-               (if trimfun (funcall trimfun trimchars line) line))
-             (reset ()
-               (setq bolp t
-                     buffer (make-array 0 :fill-pointer 0
-                                          :element-type 'character))))
-        ;; Split on either <CR>, <LF> or <CR><LF>; <LF><CR> would mean split
-        ;; with a blank line in between.  Drop a single trailing blank line.
-        (loop initially (reset)
-              for char = (read-char stream nil nil)
-              if char
-                if (member char '(#\Return #\Newline) :test #'char=)
-                  collect (trim buffer)
-                  and do (reset)
-                         (when (char= char #\Return)
-                           (when-let ((next (peek-char nil stream nil nil)))
-                             (when (char= next #\Newline)
-                               (read-char stream))))
-                else do (setq bolp nil)
-                        (vector-push-extend char buffer)
-                end
-              else
-                unless bolp collect (trim buffer) end
-                and do (loop-finish))))))
-
-(defun unlines (lines)
-  (format nil "~{~A~%~}" lines))
-
 (defun words (text)
   (delete "" (split-string text) :test #'string=))