361 lines
10 KiB
Scheme
361 lines
10 KiB
Scheme
;;; 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:
|