gash/tests/unit/word.scm

;;; Gash -- Guile As SHell
;;; Copyright © 2018, 2019 Timothy Sample <samplet@ngyro.com>
;;;
;;; The 'mock' syntax was taken from the 'guix/tests.scm' file in GNU
;;; Guix, which has the following copyright notice:
;;;
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-word)
  #:use-module (gash environment)
  #:use-module (gash word)
  #:use-module (ice-9 i18n)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64)
  #:use-module (tests unit automake))

;;; Commentary:
;;;
;;; Tests for the word module.
;;;
;;; Code:

(define-syntax-rule (mock (module proc replacement) body ...)
  "Within @var{body}, replace the definition of @var{proc} from
@var{module} with the definition given by @var{replacement}."
  (let* ((m (resolve-module 'module))
         (original (module-ref m 'proc)))
    (dynamic-wind
      (lambda () (module-set! m 'proc replacement))
      (lambda () body ...)
      (lambda () (module-set! m 'proc original)))))

(define (make-pure-scandir files pwd)
  "Return a procedure that acts like @code{scandir} but instead of
using the real filesystem it resolves queries by looking at
@var{files}.  To scan relative paths, the procedure will use
@var{pwd}."
  (define (list-directory select? parents base path)
    (match path
      (()
       (match base
         ((base-name . children)
          (filter select?
                  (cons* "." ".."
                         (map (match-lambda
                                ((name . _) name)
                                (name name))
                              children))))
         (base-name #f)))
      (((or "" ".") . rest)
       (list-directory select? parents base rest))
      ((".." . rest)
       (match parents
         ((parent)
          (list-directory select? parents parent rest))
         ((parent . grandparents)
          (list-directory select? grandparents parent rest))))
      ((component . rest)
       (match base
         ((base-name . children)
          (let ((child (find (match-lambda
                               ((name . _) (string=? name component))
                               (name (string=? name component)))
                             children)))
            (and child
                 (list-directory select? (cons base parents) child rest))))
         (base-name #f)))))

  (lambda* (path #:optional (select? (const #t)) (entry<? string-locale<?))
    (if (string-null? path)
        #f
        (and=> (let* ((path* (if (string-prefix? "/" path)
                                 path
                                 (string-append pwd "/" path)))
                      (split-path (string-split path* #\/)))
                 (list-directory select? (list files) files split-path))
               (lambda (entries) (sort entries entry<?))))))

(define-syntax-rule (with-mocked-files files body ...)
  "Mock filesystem-accessing procedures used in pathname expansion so
that within @var{body}, the filesystem seems as though it contains
only @var{files}.  As a bonus, the value of the Gash environment
variable @var{PWD} will be restored when leaving the extent of
@var{body}."
  (let ((saved-pwd #f))
    (dynamic-wind
      (lambda () (set! saved-pwd (getvar "PWD")))
      (lambda ()
        (mock ((ice-9 ftw) scandir (make-pure-scandir files "/"))
          body ...))
      (lambda () (setvar! "PWD" saved-pwd)))))

(test-begin "word")


;;; Basic string handling.

(test-equal "Converts a simple word (string) to a single field"
  '("foo")
  (expand-qword "foo"))

(test-equal "Converts a simple word (list) to a single field"
  '("foo")
  (expand-qword '("foo")))

(test-equal "Concatenates contiguous parts into a single field"
  '("foobar")
  (expand-qword '("foo" "bar")))

(test-equal "Splits a word along unquoted spaces"
  '("foo" "bar")
  (expand-qword '("foo bar")))

(test-equal "Splits a word on leading space"
  '("foo" "bar")
  (expand-qword '("foo" " bar")))

(test-equal "Splits a word on trailing space"
  '("foo" "bar")
  (expand-qword '("foo " "bar")))

(test-equal "Ignores leading spaces"
  '("foo")
  (expand-qword '(" foo")))

(test-equal "Ignores trailing spaces"
  '("foo")
  (expand-qword '("foo ")))

(test-equal "Treats multiple spaces as a single space"
  '("foo" "bar")
  (expand-qword '("foo  bar")))

(test-equal "Handles multiple joins and splits"
  '("hi_how" "are_you")
  (expand-qword '("hi_" "how are" "_you")))

(test-equal "Handles nested lists"
  '("foo")
  (expand-qword '("f" ("oo"))))

(test-equal "Handles nested lists for string output"
  "foo"
  (expand-qword '("f" ("oo")) #:output 'string))


;;; Quotes.

(test-equal "Ignores spaces in quotes"
  '("foo bar")
  (expand-qword '(<sh-quote> "foo bar")))

(test-equal "Concatenates strings and quotes"
  '("foo bar")
  (expand-qword '("foo" (<sh-quote> " bar"))))

(test-equal "Concatenates quotes"
  '("foo bar")
  (expand-qword '((<sh-quote> "foo") (<sh-quote> " bar"))))

(test-equal "Handles nested quotes"
  '("foo bar")
  (expand-qword '(<sh-quote> (<sh-quote> "foo bar"))))

(test-equal "Splits and concatenates words and quotes"
  '("foo" "bar")
  (expand-qword '((<sh-quote> "foo") " " (<sh-quote> "bar"))))


;;; Tildes.
;;;
;;; Not yet implemented.


;;; Pathname expansion.

(test-equal "Expands pathnames"
  '("a" "b" "c")
  (with-mocked-files '("" ("foo" "a" "b" "c"))
    (setvar! "PWD" "/foo")
    (expand-qword "*")))

(test-equal "Sorts expanded pathnames"
  '("a" "b" "c")
  (with-mocked-files '("" ("foo" "c" "b" "a"))
    (setvar! "PWD" "/foo")
    (expand-qword "*")))

(test-equal "Expands absolute pathnamess"
  '("/foo/a" "/foo/b")
  (with-mocked-files '("" ("foo" "a" "b"))
    (setvar! "PWD" "/")
    (expand-qword "/foo/*")))

(test-equal "Paths with trailing slashes get expanded"
  '("foo/")
  (with-mocked-files '("" ("foo" "bar") "baz")
    (setvar! "PWD" "/")
    (expand-qword "*/")))

(test-equal "Expands patterns in the middle of a path"
  '("/bar/a" "/foo/a")
  (with-mocked-files '("" ("bar" "a") ("foo" "a"))
    (setvar! "PWD" "/")
    (expand-qword "/*/a")))

(test-equal "Does not expand quoted patterns"
  '("*")
  (with-mocked-files '("" ("foo" "a" "b" "c"))
    (setvar! "PWD" "/foo")
    (expand-qword '(<sh-quote> "*"))))

(test-equal "Pathname expansion works when slashes are quoted"
  '("foo/bar")
  (with-mocked-files '("" ("foo" "bar"))
    (setvar! "PWD" "/")
    (expand-qword '("foo" (<sh-quote> "/") "*"))))

(test-equal "Pathname expansion works when slashes are patterns"
  '("f[o/b]r")
  (with-mocked-files '("" ("f[o" "b]r"))
    (setvar! "PWD" "/")
    (expand-qword "f[o/b]*")))

(test-equal "Pathname expansion works when slashes are broken patterns"
  '("f[o/bar")
  (with-mocked-files '("" ("f[o" "bar"))
    (setvar! "PWD" "/")
    (expand-qword "f[o/*")))

(test-equal "Does not implicitly match dotted files"
  '("baz")
  (with-mocked-files '("" ("foo" ".bar" "baz"))
    (setvar! "PWD" "/foo")
    (expand-qword "*")))

(test-equal "Explicitly matches dotted files"
  '("." ".." ".bar")
  (with-mocked-files '("" ("foo" ".bar" "baz"))
    (setvar! "PWD" "/foo")
    (expand-qword ".*")))

;; This is left unspecified in POSIX, so we follow Bash.
(test-equal "Bracked dots are not explicit enough"
  '("[.]*")
  (with-mocked-files '("" ("foo" ".bar" "baz"))
    (setvar! "PWD" "/foo")
    (expand-qword "[.]*")))

(test-equal "Paths with duplicate slashes get expanded"
  '("foo///bar")
  (with-mocked-files '("" ("foo" "bar"))
    (setvar! "PWD" "/")
    (expand-qword "foo///*")))

(test-equal "Absolute paths with duplicate slashes get expanded"
  '("///foo/bar")
  (with-mocked-files '("" ("foo" "bar"))
    (setvar! "PWD" "/")
    (expand-qword "///foo/*")))

;; Bash does not preserve the duplicate slashes, but Dash does, and it
;; seems like the more consistent thing to do.
(test-equal "Paths with duplicate trailing slashes get expanded"
  '("foo///")
  (with-mocked-files '("" ("foo" "bar") "baz")
    (setvar! "PWD" "/")
    (expand-qword "*///")))

(test-equal "Paths with dot nodes get expanded"
  '("./foo/./bar")
  (with-mocked-files '("" ("foo" "bar"))
    (setvar! "PWD" "/")
    (expand-qword "./foo/./*")))

(test-equal "Paths with dot-dot nodes get expanded"
  '("../foo/../foo/bar")
  (with-mocked-files '("" ("foo" "bar"))
    (setvar! "PWD" "/foo")
    (expand-qword "../*/../*/*")))

(test-equal "Patterns matching dot-dot get expanded"
  '("../foo")
  (with-mocked-files '("" ("foo" "bar"))
    (setvar! "PWD" "/foo")
    (expand-qword ".*/f*")))


;;; Field splitting (IFS)

(test-equal "Respects IFS value"
  '("foo" "bar")
  (with-variables '(("IFS" . "-"))
    (lambda ()
      (expand-qword '("foo-bar")))))

(test-equal "Combines multiple whitespace separators"
  '("foo" "bar")
  (with-variables '(("IFS" . " "))
    (lambda ()
      (expand-qword '("foo  bar")))))

(test-equal "Keeps multiple non-whitespace separators"
  '("foo" "" "bar")
  (with-variables '(("IFS" . "-"))
    (lambda ()
      (expand-qword '("foo--bar")))))

(test-equal "Combines whitespace separators with a non-whitespace separator"
  '("foo" "bar")
  (with-variables '(("IFS" . "- "))
    (lambda ()
      (expand-qword '("foo - bar")))))

(test-equal "Keeps multiple non-whitespace separators with whitespace"
  '("foo" "" "bar")
  (with-variables '(("IFS" . "- "))
    (lambda ()
      (expand-qword '("foo - - bar")))))

(test-equal "Splits on leading non-whitespace separator"
  '("" "foo")
  (with-variables '(("IFS" . "-"))
    (lambda ()
      (expand-qword '("-foo")))))

(test-equal "Does not split on trailing non-whitespace separator"
  '("foo")
  (with-variables '(("IFS" . "-"))
    (lambda ()
      (expand-qword '("foo-")))))

(test-equal "Makes one field for single non-whitespace separator"
  '("")
  (with-variables '(("IFS" . "-"))
    (lambda ()
      (expand-qword '("-")))))

(test-end)

;; Local Variables:
;; eval: (put 'mock 'scheme-indent-function 1)
;; eval: (put 'with-mocked-files 'scheme-indent-function 1)
;; End: