andrius
/
gash
mirror of https://git.savannah.gnu.org/git/gash.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Globalize the environment module 

Instead of passing around references to the environment, just treat it
as a global.  The old way was just the remains of an idea to make the
environment immutable and keep the interpreter from manipulating any
global state.  By making everything global and mutable, we will have
less impedance mismatch with POSIX going forward.

The following changelog is only a sketch, since nearly every function
has changed.

* geesh/environment.scm: Replace this module with one that treats the
environment as a global resource.
* tests/environment.scm: Delete file.
* Makefile.am: Remove it from the list of tests.
* geesh/shell.scm, geesh/eval.scm, geesh/repl.scm, geesh/word.scm,
geesh/built-ins/break.scm, geesh/built-ins/continue.scm,
geesh/built-ins/echo.scm, geesh/built-ins/export.scm,
geesh/built-ins/false.scm, geesh/built-ins/read.scm,
geesh/built-ins/readonly.scm, geesh/built-ins/set.scm,
geesh/built-ins/true.scm, geesh/built-ins/unset.scm: Remove 'env'
parameters and use the new environment module.
* .dir-locals.el: Update indentation of functions that no longer take
an 'env' parameter and add with-arguments, with-environ, and
with-variables from the new environment module.
* tests/shell.scm, tests/word.scm: Update environment creation and
manipulation in tests.
This commit is contained in:
Timothy Sample 2018-11-25 00:47:09 -05:00
parent dd64f22361
commit 4ef6907851
20 changed files with 719 additions and 766 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
.dir-locals.el
View File

@ -9,8 +9,12 @@
(eval . (put '<sh-with-redirects> 'scheme-indent-function 1))
(eval . (put 'call-with-backquoted-input-port 'scheme-indent-function 1))
(eval . (put 'make-script 'scheme-indent-function 1))
(eval . (put 'sh:for 'scheme-indent-function 2))
(eval . (put 'sh:subshell 'scheme-indent-function 1))
(eval . (put 'sh:substitute-command 'scheme-indent-function 1))
(eval . (put 'sh:with-redirects 'scheme-indent-function 2))
(eval . (put 'with-environment-arguments 'scheme-indent-function 2)))))
(eval . (put 'sh:for 'scheme-indent-function 1))
(eval . (put 'sh:subshell 'scheme-indent-function 0))
(eval . (put 'sh:substitute-command 'scheme-indent-function 0))
(eval . (put 'sh:with-redirects 'scheme-indent-function 1))
(eval . (put 'call-with-break 'scheme-indent-function 0))
(eval . (put 'call-with-continue 'scheme-indent-function 0))
(eval . (put 'with-arguments 'scheme-indent-function 1))
(eval . (put 'with-environ 'scheme-indent-function 1))
(eval . (put 'with-variables 'scheme-indent-function 1)))))

1
Makefile.am
View File

@ -66,7 +66,6 @@ bin_SCRIPTS = \
scripts/geesh
TESTS = \
tests/environment.scm \
tests/lexer.scm \
tests/parser.scm \
tests/pattern.scm \

8
geesh/built-ins/break.scm
View File

@ -25,12 +25,12 @@
;;;
;;; Code:
(define (main env . args)
(define (main . args)
(let* ((arg (and (pair? args) (car args)))
(n (string->number (or arg "1"))))
(if (and arg (or (not n) (not (exact-integer? n)) (< n 1)))
1
(let ((break-prompt (environment-break-prompt env)))
(begin
;; Since we do not return, we have to set the status here.
(set-environment-status! env 0)
(abort-to-prompt break-prompt (1- n))))))
(set-status! 0)
(break (1- n))))))

8
geesh/built-ins/continue.scm
View File

@ -25,12 +25,12 @@
;;;
;;; Code:
(define (main env . args)
(define (main . args)
(let* ((arg (and (pair? args) (car args)))
(n (string->number (or arg "1"))))
(if (and arg (or (not n) (not (exact-integer? n)) (< n 1)))
1
(let ((continue-prompt (environment-continue-prompt env)))
(begin
;; Since we do not return, we have to set the status here.
(set-environment-status! env 0)
(abort-to-prompt continue-prompt (1- n))))))
(set-status! 0)
(continue (1- n))))))

2
geesh/built-ins/echo.scm
View File

@ -25,7 +25,7 @@
;;;
;;; Code:
(define (echo env . args)
(define (echo . args)
(let* ((n? (and (pair? args) (string=? (car args) "-n")))
(args (if n? (cdr args) args)))
(display (string-join args " "))

4
geesh/built-ins/export.scm
View File

@ -27,12 +27,12 @@
;;;
;;; Code:
(define (main env . args)
(define (main . args)
(match args
(("-p") (throw 'not-implemented "export -p"))
(_ (for-each (lambda (assignment)
(call-with-values (lambda () (split-assignment assignment))
(lambda (name value)
(set-var-export! env name value))))
(set-exported! name value))))
args)
0)))

2
geesh/built-ins/false.scm
View File

@ -24,5 +24,5 @@
;;;
;;; Code:
(define (main env . args)
(define (main . args)
1)

4
geesh/built-ins/read.scm
View File

@ -27,8 +27,8 @@
;;;
;;; Code:
(define (main env . args)
(define (main . args)
(match (read-line (current-input-port))
((? eof-object?) 1)
(str (set-var! env (car args) str)
(str (setvar! (car args) str)
0)))

4
geesh/built-ins/readonly.scm
View File

@ -27,12 +27,12 @@
;;;
;;; Code:
(define (main env . args)
(define (main . args)
(match args
(("-p") (throw 'not-implemented "readonly -p"))
(_ (for-each (lambda (assignment)
(call-with-values (lambda () (split-assignment assignment))
(lambda (name value)
(set-var-read-only! env name value))))
(set-read-only! name value))))
args)
0)))

5
geesh/built-ins/set.scm
View File

@ -27,7 +27,8 @@
;;; Code:
(define (main env . args)
(define (main . args)
(match args
(("--" . args) (set-environment-arguments! env args))
(("--" . args)
(set-program-arguments (cons (car (program-arguments)) args)))
(_ (throw 'not-implemented (string-join (cons "set" args))))))

2
geesh/built-ins/true.scm
View File

@ -24,5 +24,5 @@
;;;
;;; Code:
(define (main env . args)
(define (main . args)
0)

6
geesh/built-ins/unset.scm
View File

@ -26,12 +26,12 @@
;;;
;;; Code:
(define (main env . args)
(define (main . args)
(match args
(("-f" . names)
(delete-environment-functions! env names)
(for-each unsetfun! names)
0)
((or ("-v" . names)
names)
(delete-environment-vars! env names)
(for-each unsetvar! names)
0)))

402
geesh/environment.scm
View File

@ -17,176 +17,286 @@
;;; along with Geesh. If not, see <http://www.gnu.org/licenses/>.
(define-module (geesh environment)
#:use-module (ice-9 hash-table)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:export (<environment>
make-environment
environment?
var-ref
var-ref*
set-var!
set-var-export!
set-var-read-only!
delete-environment-vars!
environment->environ
environ->alist
environment-status
set-environment-status!
environment-function-ref
define-environment-function!
delete-environment-functions!
environment-arguments
set-environment-arguments!
with-environment-arguments
environment-break-prompt
environment-continue-prompt))
#:export (get-status
set-status!
getvar
setvar!
unsetvar!
exported?
set-exported!
read-only?
set-read-only!
with-variables
get-environ
with-environ
getfun
defun!
unsetfun!
with-arguments
call-with-continue
continue
call-with-break
break
*fd-count*
fd->current-port))
;;; Commentary:
;;;
;;; This module contains data structures and functions for the
;;; This module contains functions to inspect and manipulate the
;;; environment of the Shell language.
;;;
;;; Code:
(define-record-type <variable>
(make-variable value export? read-only?)
variable?
(value variable-value)
(export? variable-exported?)
(read-only? variable-read-only?))
;;; Status.
(define-record-type <environment>
(%make-environment vars functions arguments status
break-prompt continue-prompt)
environment?
(vars environment-vars set-environment-vars!)
(functions environment-functions set-environment-functions!)
(arguments environment-arguments set-environment-arguments!)
(status environment-status set-environment-status!)
(break-prompt environment-break-prompt)
(continue-prompt environment-continue-prompt))
(define *status* 0)
(define* (make-environment vars #:optional (arguments '()))
;; In order to insure that each pair in the 'vars' alist is mutable,
;; we copy each one into a new list.
(%make-environment (map (match-lambda
((key . val)
(cons key (make-variable val #t #f))))
vars)
'()
arguments
0
(make-prompt-tag)
(make-prompt-tag)))
(define (get-status)
"Return the current status."
*status*)
(define (var-ref env name)
"Get the value of the variable @var{name} in @var{env}. If
@var{name} is unset, return @code{#f}."
(and=> (assoc-ref (environment-vars env) name)
(match-lambda
(($ <variable> value _ _) value))))
(define (set-status! n)
"Set the current status."
(set! *status* n))
(define (var-ref* env name)
"Get the value of the variable @var{name} in @var{env}. If
@var{name} is unset return @code{\"\"}."
(or (var-ref env name) ""))
;;; Variables.
(define (set-var! env name val)
"Set the variable @var{name} to @var{val} in @var{env}."
(match (assoc-ref (environment-vars env) name)
(#f (set-environment-vars!
env (acons name (make-variable val #f #f)
(environment-vars env))))
(($ <variable> _ export? read-only?)
(when read-only? (throw 'variable-assignment-error))
(set-environment-vars!
env (acons name (make-variable val export? #f)
(environment-vars env))))))
(define* (set-var-export! env name #:optional val)
"Set the export attribute for variable @var{name} in @var{env}. If
@var{val} is specified, update the variable's value as well."
(match (assoc-ref (environment-vars env) name)
(#f (set-environment-vars! env (acons name (make-variable val #t #f)
(environment-vars env))))
(($ <variable> value export? read-only?)
(when (and read-only? val) (throw 'variable-assignment-error))
(set-environment-vars!
env (acons name (make-variable (or val value) #t read-only?)
(environment-vars env))))))
(define* (set-var-read-only! env name #:optional val)
"Set the read-only attribute for variable @var{name} in @var{env}.
If @var{val} is specified, update the variable's value as well."
(match (assoc-ref (environment-vars env) name)
(#f (set-environment-vars! env (acons name (make-variable val #f #t)
(environment-vars env))))
(($ <variable> value export? read-only?)
(when (and read-only? val) (throw 'variable-assignment-error))
(set-environment-vars!
env (acons name (make-variable (or val value) export? #t)
(environment-vars env))))))
(define (delete-environment-vars! env names)
(set-environment-vars! env (remove (match-lambda
((key . _) (member key names)))
(environment-vars env))))
(define* (environment->environ env #:optional (bindings '()))
"Convert the environment variables from @var{env} into a list of
@code{\"name=value\"} strings (an @dfn{environ}). If @var{bindings}
is set to a list of pairs of strings, those name-value pairs take
precedence over the ones in @var{env}."
(let ((exported (filter-map (match-lambda
((name . ($ <variable> val export? _))
(and export? val `(,name . ,val))))
(environment-vars env))))
(let loop ((env-vars (append bindings exported))
(acc '())
(seen '()))
(match env-vars
(((name . value) . rest)
(if (member name seen)
(loop rest acc seen)
(loop rest
(cons (string-append name "=" value) acc)
(cons name seen))))
(() acc)))))
(define (environ->alist environ)
(define (environ->alist env)
"Convert @var{environ} (a value of the type returned by
@code{environ}) to an alist."
(define (string-split-1 str char_pred)
(and=> (string-index str char_pred)
(lambda (index)
`(,(substring str 0 index) . ,(substring str (1+ index))))))
(filter-map (cut string-split-1 <> #\=) environ))
(filter-map (cut string-split-1 <> #\=) env))
(define (environment-function-ref env name)
"Get the function named @var{name} in @var{env}. If there is no
such function, return @code{#f}."
(assoc-ref (environment-functions env) name))
(define *variables*
(alist->hash-table
(map (match-lambda
((name . value) `(,name . ,(vector value #t #f))))
(environ->alist (environ)))))
(define (define-environment-function! env name proc)
"Make @var{name} refer to @var{proc} in @var{env}."
(set-environment-functions! env (acons name proc
(environment-functions env))))
(define (exported? name)
"Check if the variable @var{name} has been exported."
(match (hash-ref *variables* name)
(#(_ exported? _) exported?)
(_ #f)))
(define (delete-environment-functions! env . names)
(set-environment-functions! env (remove (match-lambda
((key . _) (member key names)))
(environment-functions env))))
(define* (set-exported! name #:optional value)
"Export the variable @var{name}. If the optional parameter
@var{value} is provided, update the variable's value as well."
(match (hash-ref *variables* name)
((? vector? vec)
(vector-set! vec 1 #t)
(when value
(vector-set! vec 0 value)))
(v (hash-set! *variables* name (vector (or value v) #t #f)))))
(define (with-environment-arguments env arguments thunk)
"Call @var{thunk} with the arguments in @var{env} set to
@var{arguments}."
(let ((saved-arguments #f))
(define (read-only? name)
"Check if the variable @var{name} has been marked read-only."
(match (hash-ref *variables* name)
(#(_ _ read-only?) read-only?)
(_ #f)))
(define* (set-read-only! name #:optional value)
"Mark the variable @var{name} as read-only. If the optional
parameter @var{value} is provided, update the variable's value as
well."
(match (hash-ref *variables* name)
((? vector? vec)
(vector-set! vec 2 #t)
(when value
(vector-set! vec 0 value)))
(v (hash-set! *variables* name (vector (or value v) #f #t)))))
(define* (getvar name #:optional dflt)
"Return the value of the variable @var{name}. If it does not exist
and @var{dflt} is provided, return @var{dflt}. Otherwise, return
@code{#f}."
(match (hash-ref *variables* name dflt)
(#(value _ _) value)
(value value)))
(define (setvar! name value)
"Set the variable @var{name} to @var{value}. If @var{value} is
@code{#f}, the variable will be removed from the set of current
variables. If @var{name} has been marked read-only, an exception will
be thrown."
(match (hash-ref *variables* name)
((? vector? vec)
(when (vector-ref vec 2)
(scm-error
'shell-error "setvar!"
"Attempted to assign the read-only only variable \"~A\"."
`(,name)
'(variable-assignment-error)))
(if value
(vector-set! vec 0 value)
(hash-remove! *variables* name)))
(_ (if value
(hash-set! *variables* name value)
(hash-remove! *variables* name)))))
(define (unsetvar! name)
"Remove the variable @var{name} from the set of current variables."
(setvar! name #f))
(define (with-variables variables thunk)
"Call @var{thunk} in a dynamic extent in which the set of current
variables contains only @var{variables}. The previous set of current
variables is unaffected by any changes made from within the dynamic
extent of @var{thunk}."
(let ((outside-variables #f)
(inside-variables (alist->hash-table variables)))
(dynamic-wind
(lambda ()
(set! saved-arguments (environment-arguments env))
(set-environment-arguments! env arguments))
(set! outside-variables *variables*)
(set! *variables* inside-variables))
thunk
(lambda ()
(let ((tmp saved-arguments))
(set! saved-arguments (environment-arguments env))
(set-environment-arguments! env tmp))))))
(set! inside-variables *variables*)
(set! outside-variables *variables*)))))
(define* (get-environ #:optional (bindings '()))
"Return a value that represents the set of current variables is
suitable for passing to @code{environ}. If @var{bindings} is set,
consider them as part of the set of current variables."
(let ((exported (hash-fold (lambda (name v acc)
(match v
(#(value #t _)
(cons `(,name . ,value) acc))
(_ acc)))
'()
*variables*)))
(map (match-lambda
((name . value) (string-append name "=" value)))
(delete-duplicates!
(append bindings exported)
(lambda (x y)
(string=? (car x) (car y)))))))
(define (with-environ env thunk)
"Call @var{thunk} in a dynamic extent in which the environment (the
regular @code{getenv}/@code{setenv} one -- not the Geesh one) has been
set to @var{env} (a value suitable for passing to @code{environ}."
(let ((outside-env #f)
(inside-env env))
(dynamic-wind
(lambda ()
(set! outside-env (environ))
(environ inside-env))
thunk
(lambda ()
(set! inside-env (environ))
(environ outside-env)))))
;;; Functions.
(define *functions* (make-hash-table))
(define (getfun name)
"Return the function @var{name}. If it does not exist, return
@code{#f}."
(hash-ref *functions* name))
(define (defun! name proc)
"Define the function @var{name} to be @var{proc} (a procedure that
takes a variable number of arguments)."
(hash-set! *functions* name proc))
(define (unsetfun! name)
"Remove the function @var{name} from the set of current functions."
(hash-remove! *functions* name))
;;; Arguments.
(define (with-arguments args thunk)
"Call @var{thunk} in a dynamic extent in which the current arguments
list (as obtained by calling @code{program-arguments}) is set to
@var{args}. The previous arguments list is unaffected by any changes
made from within the dynamic extent of @var{thunk}."
(let ((outside-args #f)
(inside-args args))
(dynamic-wind
(lambda ()
(set! outside-args (program-arguments))
(set-program-arguments inside-args))
thunk
(lambda ()
(set! inside-args (program-arguments))
(set-program-arguments outside-args)))))
;;; Prompts
(define *continue-tag* (make-prompt-tag))
(define (call-with-continue thunk)
"Call @var{thunk} in such a way that a call to @code{continue} will
exit the dynamic extent of @var{thunk}."
(call-with-prompt *continue-tag*
thunk
(lambda (cont n)
(when (> n 0)
(false-if-exception
(abort-to-prompt *continue-tag* (1- n)))))))
(define* (continue #:optional (n 0))
"Exit to the closest invocation of @code{call-with-continue}. If
@var{n} is set, exit to the @math{n + 1}th closest invocation."
(abort-to-prompt *continue-tag* n))
(define *break-tag* (make-prompt-tag))
(define (call-with-break thunk)
"Call @var{thunk} in such a way that a call to @code{break} will
exit the dynamic extent of @var{thunk}."
(call-with-prompt *break-tag*
thunk
(lambda (cont n)
(when (> n 0)
(false-if-exception
(abort-to-prompt *break-tag* (1- n)))))))
(define* (break #:optional (n 0))
"Exit to the closest invocation of @code{call-with-break}. If
@var{n} is set, exit to the @math{n + 1}th closest invocation."
(abort-to-prompt *break-tag* n))
;;; Files.
(define *fd-count* 10)
(define current-3-port (make-parameter #f))
(define current-4-port (make-parameter #f))
(define current-5-port (make-parameter #f))
(define current-6-port (make-parameter #f))
(define current-7-port (make-parameter #f))
(define current-8-port (make-parameter #f))
(define current-9-port (make-parameter #f))
(define fd->current-port
(let ((cps (vector current-input-port
current-output-port
current-error-port
current-3-port
current-4-port
current-5-port
current-6-port
current-7-port
current-8-port
current-9-port)))
(lambda (fd)
"Return the current port (e.g. @code{current-input-port})
corresponding to the the Shell file descriptor @var{fd}. The value of
@var{fd} must be a nonnegative integer less than @code{*fd-count*}."
(vector-ref cps fd))))

124
geesh/eval.scm
View File

@ -31,17 +31,17 @@
;;;
;;; Code:
(define* (eval-word env word #:key (output 'fields) (rhs-tildes? #f))
(define* (eval-word word #:key (output 'fields) (rhs-tildes? #f))
(parameterize ((eval-cmd-sub (lambda (exps)
(sh:substitute-command env
(sh:substitute-command
(lambda ()
(for-each (cut eval-sh env <>) exps))))))
(expand-word env word #:output output #:rhs-tildes? rhs-tildes?)))
(for-each eval-sh exps))))))
(expand-word word #:output output #:rhs-tildes? rhs-tildes?)))
(define (eval-redir env redir)
"Evaluate the redirect @var{redir} in environment @var{env}."
(define (eval-redir redir)
"Evaluate the redirect @var{redir}."
(match-let* (((op fd word) redir)
(field (eval-word env word #:output 'string)))
(field (eval-word word #:output 'string)))
(match op
((or '>& '<&)
(let ((n (string->number field)))
@ -51,127 +51,123 @@
(else (throw 'bad-dup)))))
(_ `(,op ,fd ,field)))))
(define (exp->thunk env exp)
(lambda () (eval-sh env exp)))
(define (exp->thunk exp)
(lambda () (eval-sh exp)))
(define (exps->thunk env exps)
(lambda () (eval-sh env `(<sh-begin> ,@exps))))
(define (exps->thunk exps)
(lambda () (eval-sh `(<sh-begin> ,@exps))))
(define (eval-sh env exp)
"Evaluate the Shell expression @var{exp} in the context of the Shell
environment @var{env}."
(define (eval-sh exp)
"Evaluate the Shell expression @var{exp}."
(match exp
(('<sh-and> exp1 exp2)
(sh:and env (exp->thunk env exp1) (exp->thunk env exp2)))
(sh:and (exp->thunk exp1) (exp->thunk exp2)))
(('<sh-begin> . sub-exps)
(for-each (cut eval-sh env <>) sub-exps))
(for-each eval-sh sub-exps))
(('<sh-case> word (pattern-lists . sub-exp-lists) ...)
(let ((value (eval-word env word #:output 'string)))
(apply sh:case env value
(let ((value (eval-word word #:output 'string)))
(apply sh:case value
(map (lambda (patterns sub-exps)
`(,(map (cut eval-word env <> #:output 'pattern)
`(,(map (cut eval-word <> #:output 'pattern)
patterns)
,(exps->thunk env sub-exps)))
,(exps->thunk sub-exps)))
pattern-lists
sub-exp-lists))))
(('<sh-cond> (test-exps . sub-exp-lists) ..1)
(apply sh:cond env
(apply sh:cond
(map (lambda (test-exp sub-exps)
`(,(match test-exp
('<sh-else> #t)
(exp (exp->thunk env exp)))
,(exps->thunk env sub-exps)))
(exp (exp->thunk exp)))
,(exps->thunk sub-exps)))
test-exps
sub-exp-lists)))
(('<sh-defun> name . sub-exps)
(let ((proc (lambda (env . args)
(eval-sh env `(<sh-begin> ,@sub-exps)))))
(define-environment-function! env name proc)))
(let ((proc (lambda args
(eval-sh `(<sh-begin> ,@sub-exps)))))
(defun! name proc)))
(('<sh-exec> words ..1)
(let ((args (append-map (cut eval-word env <>) words)))
(let ((args (append-map eval-word words)))
(match args
((name . args) (apply sh:exec env name args))
((name . args) (apply sh:exec name args))
(() #f))))
(('<sh-exec-let> ((names var-words) ..1) cmd-words ..1)
(let* ((args (append-map (cut eval-word env <>) cmd-words))
(let* ((args (append-map eval-word cmd-words))
(bindings (map (lambda (name word)
`(,name . ,(eval-word env word
`(,name . ,(eval-word word
#:output 'string
#:rhs-tildes? #t)))
names var-words)))
(match args
((name . args) (apply sh:exec-let env bindings name args))
((name . args) (apply sh:exec-let bindings name args))
(() (for-each (match-lambda
((name . value) (set-var! env name value)))
((name . value) (setvar! name value)))
bindings)))))
(('<sh-for> (name (words ...)) . sub-exps)
(sh:for env `(,name ,(append-map (cut eval-word env <>) words))
(exps->thunk env sub-exps)))
(sh:for `(,name ,(append-map eval-word words))
(exps->thunk sub-exps)))
(('<sh-not> exp)
(sh:not env (exp->thunk env exp)))
(sh:not (exp->thunk exp)))
(('<sh-or> exp1 exp2)
(sh:or env (exp->thunk env exp1) (exp->thunk env exp2)))
(sh:or (exp->thunk exp1) (exp->thunk exp2)))
(('<sh-pipeline> cmd*s ..1)
(apply sh:pipeline env (map (cut exp->thunk env <>) cmd*s)))
(apply sh:pipeline (map exp->thunk cmd*s)))
(('<sh-set!> (names words) ..1)
(for-each (lambda (name word)
(set-var! env name (eval-word env word
#:output 'string
#:rhs-tildes? #t)))
(setvar! name (eval-word word
#:output 'string
#:rhs-tildes? #t)))
names words))
(('<sh-subshell> . sub-exps)
(sh:subshell env (exps->thunk env sub-exps)))
(sh:subshell (exps->thunk sub-exps)))
(('<sh-while> test-exp sub-exps ..1)
(sh:while env (exp->thunk env test-exp) (exps->thunk env sub-exps)))
(sh:while (exp->thunk test-exp) (exps->thunk sub-exps)))
(('<sh-with-redirects> (redirs ..1) sub-exp)
(match sub-exp
;; For "simple commands" we have to observe a special order of
;; evaluation: first command words, then redirects, and finally
;; assignment words.
(('<sh-exec> words ..1)
(let ((args (append-map (cut eval-word env <>) words)))
(match (false-if-exception
(map (cut eval-redir env <>) redirs))
(#f (set-environment-status! env 1))
(let ((args (append-map eval-word words)))
(match (false-if-exception (map eval-redir redirs))
(#f (set-status! 1))
(redirs
(match args
;; This built-in, called with no arguments, is a very
;; special case. We need to treat the redirects
;; directly rather than pass them to
;; 'sh:with-redirects'.
(("exec") (sh:set-redirects env redirs))
(("exec") (sh:set-redirects redirs))
((name . args)
(sh:with-redirects env redirs
(sh:with-redirects redirs
(lambda ()
(apply sh:exec env name args))))
(apply sh:exec name args))))
(() #f))))))
(('<sh-exec-let> ((names var-words) ..1) cmd-words ..1)
(let ((args (append-map (cut eval-word env <>) cmd-words)))
(match (false-if-exception
(map (cut eval-redir env <>) redirs))
(#f (set-environment-status! env 1))
(let ((args (append-map eval-word cmd-words)))
(match (false-if-exception (map eval-redir redirs))
(#f (set-status! 1))
(redirs
(let ((bindings (map (lambda (name word)
`(,name . ,(eval-word env word
`(,name . ,(eval-word word
#:output 'string
#:rhs-tildes? #t)))
names var-words)))
(match args
;; See the '<sh-exec>' case for why this built-in is
;; treated specially.
(("exec") (sh:set-redirects env redirs))
(("exec") (sh:set-redirects redirs))
((name . args)
(sh:with-redirects env redirs
(sh:with-redirects redirs
(lambda ()
(apply sh:exec-let env bindings name args))))
(apply sh:exec-let bindings name args))))
(() (for-each (match-lambda
((name . value) (set-var! env name value)))
((name . value) (setvar! name value)))
bindings))))))))
(_ (match (false-if-exception
(map (cut eval-redir env <>) redirs))
(#f (set-environment-status! env 1))
(_ (match (false-if-exception (map eval-redir redirs))
(#f (set-status! 1))
(redirs
(sh:with-redirects env redirs
(exp->thunk env sub-exp)))))))
(sh:with-redirects redirs
(exp->thunk sub-exp)))))))
(('<sh-until> test-exp sub-exps ..1)
(sh:until env (exp->thunk env test-exp) (exps->thunk env sub-exps)))))
(sh:until (exp->thunk test-exp) (exps->thunk sub-exps)))))

9
geesh/repl.scm
View File

@ -30,10 +30,9 @@
;;; Code:
(define (run-repl)
(let loop ((env (make-environment (environ->alist (environ))))
(exp (read-sh (current-input-port))))
(let loop ((exp (read-sh (current-input-port))))
(if (eof-object? exp)
(environment-status env)
(get-status)
(begin
(eval-sh env exp)
(loop env (read-sh (current-input-port)))))))
(eval-sh exp)
(loop (read-sh (current-input-port)))))))

201
geesh/shell.scm
View File

@ -29,31 +29,6 @@
;;;
;;; Code:
(define *fd-count* 10)
(define current-3-port (make-parameter #f))
(define current-4-port (make-parameter #f))
(define current-5-port (make-parameter #f))
(define current-6-port (make-parameter #f))
(define current-7-port (make-parameter #f))
(define current-8-port (make-parameter #f))
(define current-9-port (make-parameter #f))
(define (fd->current-port fd)
"Return the current port (e.g. @code{current-input-port})
corresponding to the the Shell file descriptor @var{fd}."
(match fd
(0 current-input-port)
(1 current-output-port)
(2 current-error-port)
(3 current-3-port)
(4 current-4-port)
(5 current-5-port)
(6 current-6-port)
(7 current-7-port)
(8 current-8-port)
(9 current-9-port)))
(define (install-current-ports!)
"Install all current ports into their usual file descriptors. For
example, if @code{current-input-port} is a @code{file-port?}, make the
@ -73,12 +48,11 @@ to @file{/dev/null}."
(_ #t)))
(iota *fd-count*)))
(define (exec-utility env bindings path name args)
"Execute @var{path} as a subprocess with environment @var{env} and
extra environment variables @var{bindings}. The first argument given
to the new process will be @var{name}, and the rest of the arguments
will be @var{args}."
(let ((utility-env (environment->environ env bindings)))
(define (exec-utility bindings path name args)
"Execute @var{path} as a subprocess with extra environment variables
@var{bindings}. The first argument given to the new process will be
@var{name}, and the rest of the arguments will be @var{args}."
(let ((utility-env (get-environ bindings)))
;; We need to flush all ports here to ensure the proper sequence
;; of output. Without flushing, output that we have written could
;; stay in a buffer while the utility (which does not know about
@ -88,7 +62,7 @@ will be @var{args}."
(0 (install-current-ports!)
(apply execle path utility-env name args))
(pid (match-let (((pid . status) (waitpid pid)))
(set-environment-status! env (status:exit-val status)))))))
(set-status! (status:exit-val status)))))))
(define (slashless? s)
"Test if the string @var{s} does not contain any slashes ('/')."
@ -98,10 +72,11 @@ will be @var{args}."
"Split the search path string @var{s}."
(if (string-null? s) '() (string-split s #\:)))
(define (find-utility env name)
"Search for the path of the utility @var{name} using @var{env}. If
(define (find-utility name)
"Search for the path of the utility @var{name} using the current
search path as specified by the environment variable @code{$PATH}. If
it cannot be found, return @code{#f}."
(let loop ((prefixes (split-search-path (var-ref* env "PATH"))))
(let loop ((prefixes (split-search-path (getvar "PATH" ""))))
(and (pair? prefixes)
(let* ((prefix (car prefixes))
(path (if (string-suffix? "/" prefix)
@ -111,43 +86,42 @@ it cannot be found, return @code{#f}."
path
(loop (cdr prefixes)))))))
(define (sh:exec-let env bindings name . args)
"Find and execute @var{name} with arguments @var{args}, environment
@var{env}, and extra environment variable bindings @var{bindings}."
(define (sh:exec-let bindings name . args)
"Find and execute @var{name} with arguments @var{args} and extra
environment variable bindings @var{bindings}."
(if (slashless? name)
(or (and=> (search-special-built-ins name)
(lambda (proc)
(for-each (match-lambda
((name . value)
(set-var! env name value)))
(setvar! name value)))
bindings)
(let ((exit-val (apply proc env args)))
(set-environment-status! env exit-val))))
(and=> (environment-function-ref env name)
(let ((exit-val (apply proc args)))
(set-status! exit-val))))
(and=> (getfun name)
(lambda (proc)
(with-environment-arguments env args
(with-arguments (cons (car (program-arguments)) args)
(lambda ()
(apply proc env args)))))
(apply proc args)))))
(and=> (search-built-ins name)
(lambda (proc)
;; TODO: Use 'bindings' here.
(let ((exit-val (apply proc env args)))
(set-environment-status! env exit-val))))
(and=> (find-utility env name)
(let ((exit-val (apply proc args)))
(set-status! exit-val))))
(and=> (find-utility name)
(lambda (path)
(exec-utility env bindings path name args)))
(exec-utility bindings path name args)))
(error "Command not found."))
(exec-utility env bindings name name args)))
(exec-utility bindings name name args)))
(define (sh:exec env name . args)
"Find and execute @var{name} with arguments @var{args} and
environment @var{env}."
(apply sh:exec-let env '() name args))
(define (sh:exec name . args)
"Find and execute @var{name} with arguments @var{args}."
(apply sh:exec-let '() name args))
;;; Redirects.
(define (redir->parameter+port env redir)
(define (redir->parameter+port redir)
"Convert @var{redir} into a pair consisting of the current-port
parameter to be updated and the port that should be its new value (or
@code{#f} if it should be considered closed)."
@ -187,20 +161,20 @@ parameter to be updated and the port that should be its new value (or
(seek port 0 SEEK_SET)
(make-parameter+port fd port)))))
(define (sh:set-redirects env redirs)
(define (sh:set-redirects redirs)
"Put the redirects @var{redirs} into effect."
(let loop ((redirs redirs))
(match redirs
(() #t)
((redir . rest)
(match (false-if-exception
(redir->parameter+port env redir))
(#f (set-environment-status! env 1))
(redir->parameter+port redir))
(#f (set-status! 1))
((parameter . port)
(parameter port)
(loop rest)))))))
(define (sh:with-redirects env redirs thunk)
(define (sh:with-redirects redirs thunk)
"Call @var{thunk} with the redirects @var{redirs} in effect."
;; This may be too clever! We need to parameterize a variable
;; number of things in a particular order, and this seems to be the
@ -208,8 +182,8 @@ parameter to be updated and the port that should be its new value (or
((fold-right (lambda (redir thunk)
(lambda ()
(match (false-if-exception
(redir->parameter+port env redir))
(#f (set-environment-status! env 1))
(redir->parameter+port redir))
(#f (set-status! 1))
((parameter . port)
(parameterize ((parameter port))
(thunk))
@ -233,13 +207,13 @@ process."
(primitive-exit))
(pid pid)))
(define (sh:subshell env thunk)
(define (sh:subshell thunk)
"Run @var{thunk} in a subshell environment."
(match-let* ((pid (%subshell thunk))
((pid . status) (waitpid pid)))
(set-environment-status! env (status:exit-val status))))
(set-status! (status:exit-val status))))
(define (sh:substitute-command env thunk)
(define (sh:substitute-command thunk)
"Run @var{thunk} in a subshell environment and return its output as
a string."
(match-let* (((sink . source) (pipe))
@ -250,7 +224,7 @@ a string."
(close-port source)
(match-let ((result (string-trim-right (get-string-all sink) #\newline))
((pid . status) (waitpid pid)))
(set-environment-status! env (status:exit-val status))
(set-status! (status:exit-val status))
result)))
@ -280,7 +254,7 @@ for an input port and the last will have @code{#f} as an output port."
(_ (let ((pipes (map (lambda (x) (pipe)) (cdr xs))))
(map cons xs (swap-and-shift-pairs pipes))))))
(define (plumb env in out thunk)
(define (plumb in out thunk)
"Run @var{thunk} in a new process with @code{current-input-port} set
to @var{in} and @code{current-output-port} set to @var{out}. If
@var{in} or @var{out} is @code{#f}, the corresponding ``current'' port
@ -296,93 +270,76 @@ is left unchanged."
(when out (close-port out))
pid))
(define (sh:pipeline env . thunks)
(define (sh:pipeline . thunks)
"Run each thunk in @var{thunks} in its own process with the output
of each thunk sent to the input of the next thunk."
(let ((pids (map (match-lambda
((thunk . (source . sink))
(plumb env source sink thunk)))
(plumb source sink thunk)))
(make-pipes thunks))))
(unless (null? pids)
(match-let* ((pid (last pids))
((pid . status) (waitpid pid)))
(set-environment-status! env (status:exit-val status))))))
(set-status! (status:exit-val status))))))
;;; Boolean expressions.
(define (sh:and env thunk1 thunk2)
"Run @var{thunk1} then, if the @code{$?} variable is zero in @var{env},
run @var{thunk2}."
(define (sh:and thunk1 thunk2)
"Run @var{thunk1} and if it exits with status zero, run
@var{thunk2}."
(thunk1)
(when (= (environment-status env) 0)
(when (= (get-status) 0)
(thunk2)))
(define (sh:or env thunk1 thunk2)
"Run @var{thunk1} then, if the @code{$?} variable is nonzero in
@var{env}, run @var{thunk2}."
(define (sh:or thunk1 thunk2)
"Run @var{thunk1} and if it exits with a nonzero status, run
@var{thunk2}."
(thunk1)
(unless (= (environment-status env) 0)
(unless (= (get-status) 0)
(thunk2)))
(define (sh:not env thunk)
"Run @var{thunk} and then invert the @code{$?} variable in @var{env}."
(define (sh:not thunk)
"Run @var{thunk}, inverting its exit status."
(thunk)
(let ((inverted-status (if (= (environment-status env) 0) 1 0)))
(set-environment-status! env inverted-status)))
(let ((inverted-status (if (= (get-status) 0) 1 0)))
(set-status! inverted-status)))
;;; Loops.
(define (sh:for env bindings thunk)
(define (sh:for bindings thunk)
"Run @var{thunk} for each binding in @var{bindings}. The value of
@var{bindings} have the form @code{(@var{name} (@var{value} ...))}."
(set-environment-status! env 0)
(match-let ((break-prompt (environment-break-prompt env))
(continue-prompt (environment-continue-prompt env))
((name (values ...)) bindings))
(call-with-prompt break-prompt
(set-status! 0)
(match-let (((name (values ...)) bindings))
(call-with-break
(lambda ()
(for-each (lambda (value)
(set-var! env name value)
(call-with-prompt continue-prompt
thunk
(lambda (cont n)
(when (> n 0)
(false-if-exception
(abort-to-prompt continue-prompt (1- n)))))))
values))
(lambda (cont n)
(when (> n 0)
(false-if-exception
(abort-to-prompt break-prompt (1- n))))))))
(setvar! name value)
(call-with-continue thunk))
values)))))
(define (sh:while env test-thunk thunk)
(let ((break-prompt (environment-break-prompt env))
(continue-prompt (environment-continue-prompt env)))
(call-with-prompt break-prompt
(lambda ()
(let loop ((last-status 0))
(test-thunk)
(cond
((= (environment-status env) 0)
(thunk)
(loop (environment-status env)))
(else
(set-environment-status! env last-status)))))
(lambda (cont n)
(when (> n 0)
(false-if-exception
(abort-to-prompt break-prompt (1- n))))))))
(define (sh:while test-thunk thunk)
(call-with-break
(lambda ()
(let loop ((last-status 0))
(test-thunk)
(cond
((= (get-status) 0)
(thunk)
(loop (get-status)))
(else
(set-status! last-status)))))))
(define (sh:until env test-thunk thunk)
(sh:while env (lambda () (sh:not env test-thunk)) thunk))
(define (sh:until test-thunk thunk)
(sh:while (lambda () (sh:not test-thunk)) thunk))
;;; Conditionals.
(define (sh:case env value . cases)
(set-environment-status! env 0)
(define (sh:case value . cases)
(set-status! 0)
(let loop ((cases cases))
(match cases
(() #t)
@ -391,8 +348,8 @@ run @var{thunk2}."
(thunk)
(loop tail))))))
(define (sh:cond env . cases)
(set-environment-status! env 0)
(define (sh:cond . cases)
(set-status! 0)
(let loop ((cases cases))
(match cases
(() #t)
@ -400,6 +357,6 @@ run @var{thunk2}."
(thunk))
(((test-thunk thunk) . tail)
(test-thunk)
(if (= (environment-status env) 0)
(if (= (get-status) 0)
(thunk)
(loop tail))))))

73
geesh/word.scm
View File

@ -218,84 +218,77 @@ string, the separator is derived from @var{ifs} using
"Check if @var{str} is a non-null string."
(and (string? str) (not (string-null? str))))
(define (parameter-ref env name)
"Get the value of the variable or special parameter @var{name} in
@var{env}. If @var{name} is unset, return @code{#f}."
(define* (parameter-ref name #:optional dflt)
"Get the value of the variable or special parameter @var{name} from
the environment. If @var{name} is unset, return @code{#f}."
(match name
("@" `(<sh-at> ,(environment-arguments env)))
("*" (let* ((ifs (or (var-ref env "IFS")
("@" `(<sh-at> ,(cdr (program-arguments))))
("*" (let* ((ifs (or (getvar "IFS")
(string #\space #\tab #\newline)))
(sep (argument-separator ifs)))
(string-join (environment-arguments env) sep)))
("?" (number->string (environment-status env)))
(_ (var-ref env name))))
(string-join (cdr (program-arguments)) sep)))
("?" (number->string (get-status)))
(_ (getvar name dflt))))
(define (parameter-ref* env name)
"Get the value of the variable or special parameter @var{name} in
@var{env}. If @var{name} is unset, return @code{\"\"}."
(or (parameter-ref env name) ""))
(define (word->qword env word)
(define (word->qword word)
"Convert @var{word} into a qword by resolving all parameter, command,
and arithmetic substitions using the environment @var{env}."
and arithmetic substitions."
(match word
((? string?)
word)
(('<sh-quote> quoted-word)
`(<sh-quote> ,(word->qword env quoted-word)))
`(<sh-quote> ,(word->qword quoted-word)))
(('<sh-cmd-sub> . exps)
((eval-cmd-sub) exps))
(('<sh-ref> name)
(parameter-ref* env name))
(parameter-ref name ""))
(('<sh-ref-or> name default)
(or (parameter-ref env name)
(word->qword env (or default ""))))
(or (parameter-ref name)
(word->qword (or default ""))))
(('<sh-ref-or*> name default)
(let ((value (parameter-ref env name)))
(let ((value (parameter-ref name)))
(if (string-not-null? value)
value
(word->qword env (or default "")))))
(word->qword (or default "")))))
(('<sh-ref-or!> name default)
(or (parameter-ref env name)
(let ((new-value (expand-word env (or default "")
(or (parameter-ref name)
(let ((new-value (expand-word (or default "")
#:output 'string #:rhs-tildes? #t)))
(set-var! env name new-value)
(setvar! name new-value)
new-value)))
(('<sh-ref-or!*> name default)
(let ((value (parameter-ref env name)))
(let ((value (parameter-ref name)))
(if (string-not-null? value)
value
(let ((new-value (expand-word env (or default "")
(let ((new-value (expand-word (or default "")
#:output 'string #:rhs-tildes? #t)))
(set-var! env name new-value)
(setvar! name new-value)
new-value))))
(('<sh-ref-assert> name message) (error "Not implemented"))
(('<sh-ref-assert*> name message) (error "Not implemented"))
(('<sh-ref-and> name value)
(if (string-not-null? (parameter-ref env name))
(word->qword env (or value ""))
(if (string-not-null? (parameter-ref name))
(word->qword (or value ""))
""))
(('<sh-ref-and*> name value)
(or (and (parameter-ref env name)
(word->qword env (or value "")))
(or (and (parameter-ref name)
(word->qword (or value "")))
""))
(('<sh-ref-except-min> name pattern) (error "Not implemented"))
(('<sh-ref-except-max> name pattern) (error "Not implemented"))
(('<sh-ref-skip-min> name pattern) (error "Not implemented"))
(('<sh-ref-skip-max> name pattern) (error "Not implemented"))
(('<sh-ref-length> name)
(number->string (string-length (parameter-ref* env name))))
(_ (map (cut word->qword env <>) word))))
(number->string (string-length (parameter-ref name ""))))
(_ (map word->qword word))))
(define* (expand-word env word #:key (output 'fields) (rhs-tildes? #f))
"Expand @var{word} into a list of fields using the environment
@var{env}."
(define* (expand-word word #:key (output 'fields) (rhs-tildes? #f))
"Expand @var{word} into a list of fields."
;; The value of '$IFS' may depend on side-effects performed during
;; 'word->qword', so use 'let*' here.
(let* ((qword (word->qword env word))
(ifs (or (and env (var-ref env "IFS"))
(string #\space #\tab #\newline)))
(pwd (and env (var-ref env "PWD"))))
(let* ((qword (word->qword word))
(ifs (getvar "IFS" (string #\space #\tab #\newline)))
(pwd (getvar "PWD")))
(match output
('fields (if pwd
(append-map (cut expand-pathnames <> pwd ifs)

111
tests/environment.scm
View File

@ -1,111 +0,0 @@
;;; The Geesh Shell Interpreter
;;; Copyright 2018 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Geesh.
;;;
;;; Geesh 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.
;;;
;;; Geesh 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 Geesh. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-environment)
#:use-module (geesh environment)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-64)
#:use-module (tests automake))
;;; Commentary:
;;;
;;; Tests for the environment module.
;;;
;;; Code:
(test-begin "environment")
;;;
;;; Variables.
;;;
(test-equal "Stores existing variables"
"bar"
(let ((env (make-environment '(("FOO" . "bar")))))
(var-ref env "FOO")))
(test-equal "Stores new variables"
"bar"
(let ((env (make-environment '())))
(set-var! env "FOO" "bar")
(var-ref env "FOO")))
(test-equal "Updates variables"
"baz"
(let ((env (make-environment '(("FOO" . "bar")))))
(set-var! env "FOO" "baz")
(var-ref env "FOO")))
(test-equal "Returns '#f' for unset variables"
#f
(let ((env (make-environment '())))
(var-ref env "FOO")))
;;;
;;; Making and reading 'environs'.
;;;
(define (subset? lst1 lst2)
"Test if @var{lst1} is a subset of @var{lst2}."
(every (lambda (x) (member x lst2)) lst1))
(define (set=? lst1 lst2)
"Test if @var{lst1} is @code{equal?} to @var{lst2} without respect
to order."
(and (subset? lst1 lst2)
(subset? lst2 lst1)))
(test-equal "Creates environ from empty environment"
'()
(let ((env (make-environment '())))
(environment->environ env)))
(test-assert "Creates environ from environment"
(let* ((env (make-environment '(("FOO" . "abc")
("BAR" . "def"))))
(environ (environment->environ env)))
(set=? environ '("FOO=abc" "BAR=def"))))
(test-assert "Creates environ from empty environment and bindings"
(let* ((env (make-environment '()))
(bindings '(("FOO" . "abc")
("BAR" . "def")))
(environ (environment->environ env bindings)))
(set=? environ '("FOO=abc" "BAR=def"))))
(test-assert "Creates environ from environment and bindings"
(let* ((env (make-environment '(("FOO" . "abc")
("BAZ" . "ghi"))))
(bindings '(("BAR" . "def")
("QUUX" . "jkl")))
(environ (environment->environ env bindings)))
(set=? environ '("FOO=abc" "BAR=def" "BAZ=ghi" "QUUX=jkl"))))
(test-assert "Bindings override environment when creating an environ"
(let* ((env (make-environment '(("FOO" . "abc")
("BAR" . "def"))))
(bindings '(("FOO" . "ghi")))
(environ (environment->environ env bindings)))
(set=? environ '("FOO=ghi" "BAR=def"))))
(test-assert "Creates an alist from an environ"
(let* ((environ '("FOO=abc" "BAR=def"))
(alist (environ->alist environ)))
(set=? alist '(("FOO" . "abc") ("BAR" . "def")))))
(test-end)

221
tests/shell.scm
View File

@ -85,47 +85,46 @@
(call-with-temporary-directory
(lambda (directory)
(let ((utility (string-append directory "/utility"))
(sentinal (string-append directory "/sentinal.txt"))
(env (make-environment '())))
(sentinal (string-append directory "/sentinal.txt")))
(make-script utility
(with-output-to-file ,sentinal
(lambda ()
(display "x"))))
(sh:exec env utility)
(sh:exec utility)
(file-exists? sentinal)))))
(test-assert "Executes a utility by searching PATH"
(call-with-temporary-directory
(lambda (directory)
(let ((utility (string-append directory "/utility"))
(sentinal (string-append directory "/sentinal.txt"))
(env (make-environment `(("PATH" . ,directory)))))
(sentinal (string-append directory "/sentinal.txt")))
(make-script utility
(with-output-to-file ,sentinal
(lambda ()
(display "x"))))
(sh:exec env "utility")
(with-variables `(("PATH" . ,directory))
(lambda () (sh:exec "utility")))
(file-exists? sentinal)))))
(test-assert "Throws error if a utility cannot be found"
(call-with-temporary-directory
(lambda (directory)
(let ((env (make-environment `(("PATH" . ,directory)))))
(catch #t
(lambda ()
(sh:exec env "utility")
#f)
(lambda args
(match args
(('misc-error _ _ ("Command not found.") _) #t)
(_ #f))))))))
(with-variables `(("PATH" . ,directory))
(lambda ()
(catch #t
(lambda ()
(sh:exec "utility")
#f)
(lambda args
(match args
(('misc-error _ _ ("Command not found.") _) #t)
(_ #f)))))))))
(test-equal "Executes regular built-ins"
"foo bar\n"
(let ((env (make-environment '())))
(with-output-to-string
(lambda ()
(sh:exec env "echo" "foo" "bar")))))
(with-output-to-string
(lambda ()
(sh:exec "echo" "foo" "bar"))))
;;; Redirects.
@ -136,9 +135,8 @@
"foo\n"
(call-with-temporary-directory
(lambda (directory)
(let ((foo (string-append directory "/foo.txt"))
(env (make-environment '())))
(sh:with-redirects env `((> 1 ,foo))
(let ((foo (string-append directory "/foo.txt")))
(sh:with-redirects `((> 1 ,foo))
(lambda ()
(display "foo")
(newline)))
@ -148,9 +146,8 @@
"foo\n"
(call-with-temporary-directory
(lambda (directory)
(let ((foo (string-append directory "/foo.txt"))
(env (make-environment '())))
(sh:with-redirects env `((> 2 ,foo))
(let ((foo (string-append directory "/foo.txt")))
(sh:with-redirects `((> 2 ,foo))
(lambda ()
(display "foo" (current-error-port))
(newline (current-error-port))))
@ -161,14 +158,13 @@
(call-with-temporary-directory
(lambda (directory)
(let ((utility (string-append directory "/utility"))
(foo (string-append directory "/foo.txt"))
(env (make-environment '())))
(foo (string-append directory "/foo.txt")))
(make-script utility
(display "foo")
(newline))
(sh:with-redirects env `((> 1 ,foo))
(sh:with-redirects `((> 1 ,foo))
(lambda ()
(sh:exec env utility)))
(sh:exec utility)))
(call-with-input-file foo get-string-all)))))
(test-equal "Redirects external standard error to file"
@ -176,14 +172,13 @@
(call-with-temporary-directory
(lambda (directory)
(let ((utility (string-append directory "/utility"))
(foo (string-append directory "/foo.txt"))
(env (make-environment '())))
(foo (string-append directory "/foo.txt")))
(make-script utility
(display "foo" (current-error-port))
(newline (current-error-port)))
(sh:with-redirects env `((> 2 ,foo))
(sh:with-redirects `((> 2 ,foo))
(lambda ()
(sh:exec env utility)))
(sh:exec utility)))
(call-with-input-file foo get-string-all)))))
(test-equal "Redirects built-in standard input from file"
@ -191,13 +186,12 @@
(call-with-temporary-directory
(lambda (directory)
(let ((foo (string-append directory "/foo.txt"))
(output (string-append directory "/output.txt"))
(env (make-environment '())))
(output (string-append directory "/output.txt")))
(with-output-to-file foo
(lambda ()
(display "foo")
(newline)))
(sh:with-redirects env `((< 0 ,foo))
(sh:with-redirects `((< 0 ,foo))
(lambda ()
(with-output-to-file output
(lambda ()
@ -210,8 +204,7 @@
(lambda (directory)
(let ((utility (string-append directory "/utility"))
(foo (string-append directory "/foo.txt"))
(output (string-append directory "/output.txt"))
(env (make-environment '())))
(output (string-append directory "/output.txt")))
(with-output-to-file foo
(lambda ()
(display "foo")
@ -221,9 +214,9 @@
(with-output-to-file ,output
(lambda ()
(display (get-string-all (current-input-port))))))
(sh:with-redirects env `((< 0 ,foo))
(sh:with-redirects `((< 0 ,foo))
(lambda ()
(sh:exec env utility)))
(sh:exec utility)))
(call-with-input-file output get-string-all)))))
;; These next two tests are non-deterministic, so we need to allow
@ -234,9 +227,8 @@
(test-assert "Redirects built-in standard error to standard output"
(call-with-temporary-directory
(lambda (directory)
(let ((foo (string-append directory "/foo.txt"))
(env (make-environment '())))
(sh:with-redirects env `((> 1 ,foo) (>& 2 1))
(let ((foo (string-append directory "/foo.txt")))
(sh:with-redirects `((> 1 ,foo) (>& 2 1))
(lambda ()
(display "foo")
(newline)
@ -250,16 +242,15 @@
(call-with-temporary-directory
(lambda (directory)
(let ((utility (string-append directory "/utility"))
(foo (string-append directory "/foo.txt"))
(env (make-environment '())))
(foo (string-append directory "/foo.txt")))
(make-script utility
(display "foo")
(newline)
(display "bar" (current-error-port))
(newline (current-error-port)))
(sh:with-redirects env `((> 1 ,foo) (>& 2 1))
(sh:with-redirects `((> 1 ,foo) (>& 2 1))
(lambda ()
(sh:exec env utility)))
(sh:exec utility)))
(let ((result (call-with-input-file foo get-string-all)))
(or (string=? result "foo\nbar\n")
(string=? result "bar\nfoo\n")))))))
@ -268,13 +259,12 @@
"foo\nbar\n"
(call-with-temporary-directory
(lambda (directory)
(let ((foo (string-append directory "/foo.txt"))
(env (make-environment '())))
(let ((foo (string-append directory "/foo.txt")))
(with-output-to-file foo
(lambda ()
(display "foo")
(newline)))
(sh:with-redirects env `((>> 1 ,foo))
(sh:with-redirects `((>> 1 ,foo))
(lambda ()
(display "bar")
(newline)))
@ -282,31 +272,28 @@
(test-equal "Redirects here-document to standard input"
"foo\n"
(let ((env (make-environment '())))
(with-output-to-string
(lambda ()
(sh:with-redirects env '((<< 0 "foo\n"))
(lambda ()
(display (get-string-all (current-input-port)))))))))
(with-output-to-string
(lambda ()
(sh:with-redirects '((<< 0 "foo\n"))
(lambda ()
(display (get-string-all (current-input-port))))))))
(test-equal "Redirects work with string ports"
"foo\n"
(let ((env (make-environment '())))
(with-input-from-string "bar\n"
(lambda ()
(setvbuf (current-input-port) 'none)
(with-output-to-string
(lambda ()
(sh:with-redirects env '((<< 0 "foo\n"))
(lambda ()
(display (get-string-all (current-input-port)))))))))))
(with-input-from-string "bar\n"
(lambda ()
(setvbuf (current-input-port) 'none)
(with-output-to-string
(lambda ()
(sh:with-redirects '((<< 0 "foo\n"))
(lambda ()
(display (get-string-all (current-input-port))))))))))
(test-equal "Does not use buffered input from current-input-port"
"foo\n"
(call-with-temporary-directory
(lambda (directory)
(let ((bar-baz (string-append directory "/bar-baz.txt"))
(env (make-environment '())))
(let ((bar-baz (string-append directory "/bar-baz.txt")))
(with-output-to-file bar-baz
(lambda ()
(display "bar\nbaz\n")))
@ -316,7 +303,7 @@
(get-line (current-input-port))
(with-output-to-string
(lambda ()
(sh:with-redirects env '((<< 0 "foo\n"))
(sh:with-redirects '((<< 0 "foo\n"))
(lambda ()
(display (get-string-all (current-input-port)))))))))))))
@ -324,21 +311,19 @@
"foo\n"
(call-with-temporary-directory
(lambda (directory)
(let ((foo (string-append directory "/foo.txt"))
(env (make-environment '())))
(sh:with-redirects env `((> 1 ,foo) (<< 0 "foo\n"))
(let ((foo (string-append directory "/foo.txt")))
(sh:with-redirects `((> 1 ,foo) (<< 0 "foo\n"))
(lambda ()
(display (get-string-all (current-input-port)))))
(call-with-input-file foo get-string-all)))))
(test-equal "Uses last here-document specified"
"foo\n"
(let ((env (make-environment '())))
(with-output-to-string
(lambda ()
(sh:with-redirects env '((<< 0 "bar\n") (<< 0 "foo\n"))
(lambda ()
(display (get-string-all (current-input-port)))))))))
(with-output-to-string
(lambda ()
(sh:with-redirects '((<< 0 "bar\n") (<< 0 "foo\n"))
(lambda ()
(display (get-string-all (current-input-port))))))))
;; TODO: Read-write tests, closing tests, clobbering tests.
@ -347,11 +332,12 @@
(test-equal "Subshells cannot change variables"
"foo"
(let ((env (make-environment '(("x" . "foo")))))
(sh:subshell env
(lambda ()
(set-var! env "x" "bar")))
(var-ref env "x")))
(with-variables '(("x" . "foo"))
(lambda ()
(sh:subshell
(lambda ()
(setvar! "x" "bar")))
(getvar "x"))))
;; TODO: Test other means of manipulating the environment and exit
;; statuses.
@ -361,45 +347,40 @@
(test-equal "Substitutes output from built-in"
"foo"
(let ((env (make-environment '())))
(sh:substitute-command env
(lambda ()
(display "foo")))))
(sh:substitute-command
(lambda ()
(display "foo"))))
(test-equal "Substitutes output from external utilities"
"foo"
(call-with-temporary-directory
(lambda (directory)
(let ((utility (string-append directory "/utility"))
(env (make-environment '())))
(let ((utility (string-append directory "/utility")))
(make-script utility
(display "foo"))
(sh:substitute-command env
(sh:substitute-command
(lambda ()
(sh:exec env utility)))))))
(sh:exec utility)))))))
(test-equal "Trailing newlines are trimmed from substitutions"
"foo"
(let ((env (make-environment '())))
(sh:substitute-command env
(lambda ()
(display "foo")
(newline)))))
(sh:substitute-command
(lambda ()
(display "foo")
(newline))))
(test-equal "Non-trailing newlines are preserved in substitutions"
"\nfoo\nbar"
(let ((env (make-environment '())))
(sh:substitute-command env
(lambda ()
(newline)
(display "foo")
(newline)
(display "bar")))))
(sh:substitute-command
(lambda ()
(newline)
(display "foo")
(newline)
(display "bar"))))
(test-equal "Empty substitutions produce empty strings"
""
(let ((env (make-environment '())))
(sh:substitute-command env noop)))
(sh:substitute-command noop))
;; Pipelines.
@ -408,10 +389,8 @@
"foo"
(call-with-temporary-directory
(lambda (directory)
(let ((foo (string-append directory "/foo.txt"))
(env (make-environment '())))
(sh:pipeline env
(lambda ()
(let ((foo (string-append directory "/foo.txt")))
(sh:pipeline (lambda ()
(display "foo\n"))
(lambda ()
(with-output-to-file foo
@ -425,8 +404,7 @@
(lambda (directory)
(let ((utility1 (string-append directory "utility1"))
(utility2 (string-append directory "utility2"))
(foo (string-append directory "/foo.txt"))
(env (make-environment '())))
(foo (string-append directory "/foo.txt")))
(make-script utility1
(display "foo\n"))
(make-script utility2
@ -434,11 +412,10 @@
(with-output-to-file ,foo
(lambda ()
(display (get-line (current-input-port))))))
(sh:pipeline env
(sh:pipeline (lambda ()
(sh:exec utility1))
(lambda ()
(sh:exec env utility1))
(lambda ()
(sh:exec env utility2)))
(sh:exec utility2)))
(call-with-input-file foo get-string-all)))))
(test-equal "Externals and built-ins are connected by pipelines"
@ -446,13 +423,11 @@
(call-with-temporary-directory
(lambda (directory)
(let ((utility (string-append directory "/utility"))
(foo (string-append directory "/foo.txt"))
(env (make-environment '())))
(foo (string-append directory "/foo.txt")))
(make-script utility
(display "foo\n"))
(sh:pipeline env
(lambda ()
(sh:exec env utility))
(sh:pipeline (lambda ()
(sh:exec utility))
(lambda ()
(with-output-to-file foo
(lambda ()
@ -464,18 +439,16 @@
(call-with-temporary-directory
(lambda (directory)
(let ((utility (string-append directory "/utility"))
(foo (string-append directory "/foo.txt"))
(env (make-environment '())))
(foo (string-append directory "/foo.txt")))
(make-script utility
(use-modules (ice-9 textual-ports))
(with-output-to-file ,foo
(lambda ()
(display (get-line (current-input-port))))))
(sh:pipeline env
(lambda ()
(sh:pipeline (lambda ()
(display "foo\n"))
(lambda ()
(sh:exec env utility)))
(sh:exec utility)))
(call-with-input-file foo get-string-all)))))
(test-end)

284
tests/word.scm
View File

@ -28,17 +28,6 @@
;;;
;;; Code:
;; This function exists to add a layer of slippage between the
;; "environment" module and our tests. The "environment" module is
;; still under development, and it would be annoying to have to
;; rewrite all the tests.
(define* (make-test-env vars #:key (noglob? #f) (nounset? #f))
"Create a testing environment with the alist @var{vars} as the
current variables. If @var{noglob?} is set, enable the `noglob'
option. If @var{nounset?} is set, enable the `nounset' option. (See
the `set' built-in for details on these options.)"
(make-environment vars))
(test-begin "word")
@ -46,70 +35,70 @@ the `set' built-in for details on these options.)"
(test-equal "Converts a simple word (string) to a single field"
'("foo")
(expand-word #f "foo"))
(expand-word "foo"))
(test-equal "Converts a simple word (list) to a single field"
'("foo")
(expand-word #f '("foo")))
(expand-word '("foo")))
(test-equal "Concatenates contiguous parts into a single field"
'("foobar")
(expand-word #f '("foo" "bar")))
(expand-word '("foo" "bar")))
(test-equal "Splits a word along unquoted spaces"
'("foo" "bar")
(expand-word #f '("foo bar")))
(expand-word '("foo bar")))
(test-equal "Splits a word on leading space"
'("foo" "bar")
(expand-word #f '("foo" " bar")))
(expand-word '("foo" " bar")))
(test-equal "Splits a word on trailing space"
'("foo" "bar")
(expand-word #f '("foo " "bar")))
(expand-word '("foo " "bar")))
(test-equal "Ignores leading spaces"
'("foo")
(expand-word #f '(" foo")))
(expand-word '(" foo")))
(test-equal "Ignores trailing spaces"
'("foo")
(expand-word #f '("foo ")))
(expand-word '("foo ")))
(test-equal "Treats multiple spaces as a single space"
'("foo" "bar")
(expand-word #f '("foo bar")))
(expand-word '("foo bar")))
(test-equal "Handles multiple joins and splits"
'("hi_how" "are_you")
(expand-word #f '("hi_" "how are" "_you")))
(expand-word '("hi_" "how are" "_you")))
(test-equal "Handles nested lists"
'("foo")
(expand-word #f '("f" ("oo"))))
(expand-word '("f" ("oo"))))
;;; Quotes.
(test-equal "Ignores spaces in quotes"
'("foo bar")
(expand-word #f '(<sh-quote> "foo bar")))
(expand-word '(<sh-quote> "foo bar")))
(test-equal "Concatenates strings and quotes"
'("foo bar")
(expand-word #f '("foo" (<sh-quote> " bar"))))
(expand-word '("foo" (<sh-quote> " bar"))))
(test-equal "Concatenates quotes"
'("foo bar")
(expand-word #f '((<sh-quote> "foo") (<sh-quote> " bar"))))
(expand-word '((<sh-quote> "foo") (<sh-quote> " bar"))))
(test-equal "Handles nested quotes"
'("foo bar")
(expand-word #f '(<sh-quote> (<sh-quote> "foo bar"))))
(expand-word '(<sh-quote> (<sh-quote> "foo bar"))))
(test-equal "Splits and concatenates words and quotes"
'("foo" "bar")
(expand-word #f '((<sh-quote> "foo") " " (<sh-quote> "bar"))))
(expand-word '((<sh-quote> "foo") " " (<sh-quote> "bar"))))
;;; Tildes.
@ -123,43 +112,51 @@ the `set' built-in for details on these options.)"
(test-equal "Resolves parameters"
'("foo")
(expand-word (make-test-env '(("x" . "foo")))
'(<sh-ref> "x")))
(with-variables '(("x" . "foo"))
(lambda ()
(expand-word '(<sh-ref> "x")))))
(test-equal "Splits parameter results"
'("foo" "bar")
(expand-word (make-test-env '(("x" . "foo bar")))
'(<sh-ref> "x")))
(with-variables '(("x" . "foo bar"))
(lambda ()
(expand-word '(<sh-ref> "x")))))
(test-equal "Resolves quoted parameters"
'("foo")
(expand-word (make-test-env '(("x" . "foo")))
'(<sh-quote> (<sh-ref> "x"))))
(with-variables '(("x" . "foo"))
(lambda ()
(expand-word '(<sh-quote> (<sh-ref> "x"))))))
(test-equal "Ignores spaces in quoted parameters"
'("foo bar")
(expand-word (make-test-env '(("x" . "foo bar")))
'(<sh-quote> (<sh-ref> "x"))))
(with-variables '(("x" . "foo bar"))
(lambda ()
(expand-word '(<sh-quote> (<sh-ref> "x"))))))
(test-equal "Treats empty variables as nothing"
'()
(expand-word (make-test-env '(("x" . "")))
'(<sh-ref> "x")))
(with-variables '(("x" . ""))
(lambda ()
(expand-word '(<sh-ref> "x")))))
(test-equal "Treats unset variables as nothing"
'()
(expand-word (make-test-env '())
'(<sh-ref> "x")))
(with-variables '()
(lambda ()
(expand-word '(<sh-ref> "x")))))
(test-equal "Preserves empty variables when quoted"
'("")
(expand-word (make-test-env '(("x" . "")))
'(<sh-quote> (<sh-ref> "x"))))
(with-variables '(("x" . ""))
(lambda ()
(expand-word '(<sh-quote> (<sh-ref> "x"))))))
(test-equal "Preserves unset variables when quoted"
'("")
(expand-word (make-test-env '())
'(<sh-quote> (<sh-ref> "x"))))
(with-variables '()
(lambda ()
(expand-word '(<sh-quote> (<sh-ref> "x"))))))
;;; Parameter operations.
@ -168,103 +165,120 @@ the `set' built-in for details on these options.)"
(test-equal "Handles 'or' when parameter is set"
'("foo")
(expand-word (make-test-env '(("x" . "foo")))
'(<sh-ref-or> "x" "bar")))
(with-variables '(("x" . "foo"))
(lambda ()
(expand-word '(<sh-ref-or> "x" "bar")))))
(test-equal "Handles 'or' when parameter is set and empty"
'()
(expand-word (make-test-env '(("x" . "")))
'(<sh-ref-or> "x" "bar")))
(with-variables '(("x" . ""))
(lambda ()
(expand-word '(<sh-ref-or> "x" "bar")))))
(test-equal "Handles 'or' when parameter is unset"
'("bar")
(expand-word (make-test-env '())
'(<sh-ref-or> "x" "bar")))
(with-variables '()
(lambda ()
(expand-word '(<sh-ref-or> "x" "bar")))))
(test-equal "Handles 'or' fall-through without default"
'()
(expand-word (make-test-env '())
'(<sh-ref-or> "x" #f)))
(with-variables '()
(lambda ()
(expand-word '(<sh-ref-or> "x" #f)))))
;;; or*
(test-equal "Handles 'or*' when parameter is set"
'("foo")
(expand-word (make-test-env '(("x" . "foo")))
'(<sh-ref-or*> "x" "bar")))
(with-variables '(("x" . "foo"))
(lambda ()
(expand-word '(<sh-ref-or*> "x" "bar")))))
(test-equal "Handles 'or*' when parameter is set and empty"
'("bar")
(expand-word (make-test-env '(("x" . "")))
'(<sh-ref-or*> "x" "bar")))
(with-variables '(("x" . ""))
(lambda ()
(expand-word '(<sh-ref-or*> "x" "bar")))))
(test-equal "Handles 'or*' when parameter is unset"
'("bar")
(expand-word (make-test-env '())
'(<sh-ref-or*> "x" "bar")))
(with-variables '()
(lambda ()
(expand-word '(<sh-ref-or*> "x" "bar")))))
(test-equal "Handles 'or*' fall-through without default"
'()
(expand-word (make-test-env '())
'(<sh-ref-or*> "x" #f)))
(with-variables '()
(lambda ()
(expand-word '(<sh-ref-or*> "x" #f)))))
;;; or!
(test-equal "Handles 'or!' when parameter is set"
'(("foo") "foo")
(let ((env (make-test-env '(("x" . "foo")))))
(list (expand-word env '(<sh-ref-or!> "x" "bar"))
(var-ref env "x"))))
(with-variables '(("x" . "foo"))
(lambda ()
(list (expand-word '(<sh-ref-or!> "x" "bar"))
(getvar "x")))))
(test-equal "Handles 'or!' when parameter is set and empty"
'(() "")
(let ((env (make-test-env '(("x" . "")))))
(list (expand-word env '(<sh-ref-or!> "x" "bar"))
(var-ref env "x"))))
(with-variables '(("x" . ""))
(lambda ()
(list (expand-word '(<sh-ref-or!> "x" "bar"))
(getvar "x")))))
(test-equal "Handles 'or!' when parameter is unset"
'(("bar") "bar")
(let ((env (make-test-env '())))
(list (expand-word env '(<sh-ref-or!> "x" "bar"))
(var-ref env "x"))))
(with-variables '()
(lambda ()
(list (expand-word '(<sh-ref-or!> "x" "bar"))
(getvar "x")))))
(test-equal "Handles 'or!' fall-through without default"
'(() "")
(let ((env (make-test-env '())))
(list (expand-word env '(<sh-ref-or!> "x" #f))
(var-ref env "x"))))
(with-variables '()
(lambda ()
(list (expand-word '(<sh-ref-or!> "x" #f))
(getvar "x")))))
;;; or!*
(test-equal "Handles 'or!*' when parameter is set"
'(("foo") "foo")
(let ((env (make-test-env '(("x" . "foo")))))
(list (expand-word env '(<sh-ref-or!*> "x" "bar"))
(var-ref env "x"))))
(with-variables '(("x" . "foo"))
(lambda ()
(list (expand-word '(<sh-ref-or!*> "x" "bar"))
(getvar "x")))))
(test-equal "Handles 'or!*' when parameter is set and empty"
'(("bar") "bar")
(let ((env (make-test-env '(("x" . "")))))
(list (expand-word env '(<sh-ref-or!*> "x" "bar"))
(var-ref env "x"))))
(with-variables '(("x" . ""))
(lambda ()
(list (expand-word '(<sh-ref-or!*> "x" "bar"))
(getvar "x")))))
(test-equal "Handles 'or!*' when parameter is unset"
'(("bar") "bar")
(let ((env (make-test-env '())))
(list (expand-word env '(<sh-ref-or!*> "x" "bar"))
(var-ref env "x"))))
(with-variables '()
(lambda ()
(list (expand-word '(<sh-ref-or!*> "x" "bar"))
(getvar "x")))))
(test-equal "Handles 'or!*' fall-through without default"
'(() "")
(let ((env (make-test-env '())))
(list (expand-word env '(<sh-ref-or!*> "x" #f))
(var-ref env "x"))))
(with-variables '()
(lambda ()
(list (expand-word '(<sh-ref-or!*> "x" #f))
(getvar "x")))))
(test-equal "Does not split fields on assignment"
'(("foo" "bar") "foo bar")
(let ((env (make-test-env '(("y" . "foo bar")))))
(list (expand-word env '(<sh-ref-or!*> "x" (<sh-ref> "y")))
(var-ref env "x"))))
(with-variables '(("y" . "foo bar"))
(lambda ()
(list (expand-word '(<sh-ref-or!*> "x" (<sh-ref> "y")))
(getvar "x")))))
;;; FIXME: Test 'assert'.
@ -272,57 +286,67 @@ the `set' built-in for details on these options.)"
(test-equal "Handles 'and' when parameter is set"
'("bar")
(expand-word (make-test-env '(("x" . "foo")))
'(<sh-ref-and> "x" "bar")))
(with-variables '(("x" . "foo"))
(lambda ()
(expand-word '(<sh-ref-and> "x" "bar")))))
(test-equal "Handles 'and' when parameter is set and empty"
'()
(expand-word (make-test-env '(("x" . "")))
'(<sh-ref-and> "x" "bar")))
(with-variables '(("x" . ""))
(lambda ()
(expand-word '(<sh-ref-and> "x" "bar")))))
(test-equal "Handles 'and' when parameter is unset"
'()
(expand-word (make-test-env '())
'(<sh-ref-and> "x" "bar")))
(with-variables '()
(lambda ()
(expand-word '(<sh-ref-and> "x" "bar")))))
(test-equal "Handles 'and' fall-through without default"
'()
(expand-word (make-test-env '(("x" . "foo")))
'(<sh-ref-and> "x" #f)))
(with-variables '(("x" . "foo"))
(lambda ()
(expand-word '(<sh-ref-and> "x" #f)))))
;;; and*
(test-equal "Handles 'and*' when parameter is set"
'("bar")
(expand-word (make-test-env '(("x" . "foo")))
'(<sh-ref-and*> "x" "bar")))
(with-variables '(("x" . "foo"))
(lambda ()
(expand-word '(<sh-ref-and*> "x" "bar")))))
(test-equal "Handles 'and*' when parameter is set and empty"
'("bar")
(expand-word (make-test-env '(("x" . "")))
'(<sh-ref-and*> "x" "bar")))
(with-variables '(("x" . ""))
(lambda ()
(expand-word '(<sh-ref-and*> "x" "bar")))))
(test-equal "Handles 'and*' when parameter is unset"
'()
(expand-word (make-test-env '())
'(<sh-ref-and*> "x" "bar")))
(with-variables '()
(lambda ()
(expand-word '(<sh-ref-and*> "x" "bar")))))
(test-equal "Handles 'and*' fall-through without default"
'()
(expand-word (make-test-env '(("x" . "foo")))
'(<sh-ref-and*> "x" #f)))
(with-variables '(("x" . "foo"))
(lambda ()
(expand-word '(<sh-ref-and*> "x" #f)))))
;;; length
(test-equal "Handles 'length' when parameter is set"
'("3")
(expand-word (make-test-env '(("x" . "foo")))
'(<sh-ref-length> "x")))
(with-variables '(("x" . "foo"))
(lambda ()
(expand-word '(<sh-ref-length> "x")))))
(test-equal "Handles 'length' when parameter is unset"
'("0")
(expand-word (make-test-env '())
'(<sh-ref-length> "x")))
(with-variables '()
(lambda ()
(expand-word '(<sh-ref-length> "x")))))
;;; Command substition.
@ -330,22 +354,22 @@ the `set' built-in for details on these options.)"
(test-equal "Resolves commands"
'("foo")
(parameterize ((eval-cmd-sub identity))
(expand-word #f '(<sh-cmd-sub> "foo"))))
(expand-word '(<sh-cmd-sub> "foo"))))
(test-equal "Splits command results"
'("foo" "bar")
(parameterize ((eval-cmd-sub identity))
(expand-word #f '(<sh-cmd-sub> "foo bar"))))
(expand-word '(<sh-cmd-sub> "foo bar"))))
(test-equal "Resolves quoted commands"
'("foo")
(parameterize ((eval-cmd-sub identity))
(expand-word #f '(<sh-quote> (<sh-cmd-sub> "foo")))))
(expand-word '(<sh-quote> (<sh-cmd-sub> "foo")))))
(test-equal "Ignores spaces in quoted commands"
'("foo bar")
(parameterize ((eval-cmd-sub identity))
(expand-word #f '(<sh-quote> (<sh-cmd-sub> "foo bar")))))
(expand-word '(<sh-quote> (<sh-cmd-sub> "foo bar")))))
;;; Arithmetic expansion.
@ -362,42 +386,50 @@ the `set' built-in for details on these options.)"
(test-equal "Respects IFS value"
'("foo" "bar")
(let ((env (make-test-env '(("IFS" . "-")))))
(expand-word env '("foo-bar"))))
(with-variables '(("IFS" . "-"))
(lambda ()
(expand-word '("foo-bar")))))
(test-equal "Combines multiple whitespace separators"
'("foo" "bar")
(let ((env (make-test-env '(("IFS" . " ")))))
(expand-word env '("foo bar"))))
(with-variables '(("IFS" . " "))
(lambda ()
(expand-word '("foo bar")))))
(test-equal "Keeps multiple non-whitespace separators"
'("foo" "" "bar")
(let ((env (make-test-env '(("IFS" . "-")))))
(expand-word env '("foo--bar"))))
(with-variables '(("IFS" . "-"))
(lambda ()
(expand-word '("foo--bar")))))
(test-equal "Combines whitespace separators with a non-whitespace separator"
'("foo" "bar")
(let ((env (make-test-env '(("IFS" . "- ")))))
(expand-word env '("foo - bar"))))
(with-variables '(("IFS" . "- "))
(lambda ()
(expand-word '("foo - bar")))))
(test-equal "Keeps multiple non-whitespace separators with whitespace"
'("foo" "" "bar")
(let ((env (make-test-env '(("IFS" . "- ")))))
(expand-word env '("foo - - bar"))))
(with-variables '(("IFS" . "- "))
(lambda ()
(expand-word '("foo - - bar")))))
(test-equal "Splits on leading non-whitespace separator"
'("" "foo")
(let ((env (make-test-env '(("IFS" . "-")))))
(expand-word env '("-foo"))))
(with-variables '(("IFS" . "-"))
(lambda ()
(expand-word '("-foo")))))
(test-equal "Does not split on trailing non-whitespace separator"
'("foo")
(let ((env (make-test-env '(("IFS" . "-")))))
(expand-word env '("foo-"))))
(with-variables '(("IFS" . "-"))
(lambda ()
(expand-word '("foo-")))))
(test-equal "Makes one field for single non-whitespace separator"
'("")
(let ((env (make-test-env '(("IFS" . "-")))))
(expand-word env '("-"))))
(with-variables '(("IFS" . "-"))
(lambda ()
(expand-word '("-")))))
(test-end)