diff --git a/.dir-locals.el b/.dir-locals.el index 2f08f9a..0f65bac 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -7,4 +7,5 @@ (eval . (put ' 'scheme-indent-function 1)) (eval . (put ' 'scheme-indent-function 1)) (eval . (put ' 'scheme-indent-function 1)) - (eval . (put 'call-with-backquoted-input-port 'scheme-indent-function 1))))) + (eval . (put 'call-with-backquoted-input-port 'scheme-indent-function 1)) + (eval . (put 'make-script 'scheme-indent-function 1))))) diff --git a/.gitignore b/.gitignore index b412523..5e43614 100644 --- a/.gitignore +++ b/.gitignore @@ -14,4 +14,5 @@ lcov.info pre-inst-env scripts/geesh tests/*.trs +tests/config.scm tools/coverage diff --git a/Makefile.am b/Makefile.am index 70c8e4d..83be488 100644 --- a/Makefile.am +++ b/Makefile.am @@ -41,6 +41,7 @@ MODULES = \ geesh/lexer.scm \ geesh/parser.scm \ geesh/repl.scm \ + geesh/shell.scm \ geesh/word.scm bin_SCRIPTS = \ @@ -51,6 +52,7 @@ TESTS = \ tests/lexer.scm \ tests/parser.scm \ tests/repl.scm \ + tests/shell.scm \ tests/word.scm CLEANFILES = \ diff --git a/configure.ac b/configure.ac index 93387c0..77c3da2 100644 --- a/configure.ac +++ b/configure.ac @@ -13,6 +13,7 @@ AM_CONDITIONAL([HAVE_GENHTML], [test -n $GENHTML]) AC_CONFIG_FILES([Makefile]) AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env]) AC_CONFIG_FILES([scripts/geesh], [chmod +x scripts/geesh]) +AC_CONFIG_FILES([tests/config.scm]) AC_CONFIG_FILES([tools/coverage], [chmod +x tools/coverage]) AC_OUTPUT diff --git a/geesh/shell.scm b/geesh/shell.scm new file mode 100644 index 0000000..355c084 --- /dev/null +++ b/geesh/shell.scm @@ -0,0 +1,33 @@ +(define-module (geesh shell) + #:use-module (geesh environment) + #:use-module (ice-9 match) + #:export (sh:exec-let + sh:exec)) + +;;; Commentary: +;;; +;;; This module provides functions for executing Shell language +;;; constructs. +;;; +;;; Code: + +(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))) + (match (primitive-fork) + (0 (apply execle path utility-env name args)) + (pid (match-let (((pid . status) (waitpid pid))) + (set-var! env "?" (number->string (status:exit-val status)))))))) + +(define (sh:exec-let env bindings name . args) + "Execute @var{name} with arguments @var{args}, environment +@var{env}, and extra environment variable bindings @var{bindings}." + (exec-utility env bindings name name args)) + +(define (sh:exec env name . args) + "Execute @var{name} with arguments @var{args} and environment +@var{env}." + (apply sh:exec-let env '() name args)) diff --git a/tests/config.scm.in b/tests/config.scm.in new file mode 100644 index 0000000..ed7115b --- /dev/null +++ b/tests/config.scm.in @@ -0,0 +1,4 @@ +(define-module (tests config) + #:export (*guile-path*)) + +(define *guile-path* "@GUILE@") diff --git a/tests/shell.scm b/tests/shell.scm new file mode 100644 index 0000000..81ee1e1 --- /dev/null +++ b/tests/shell.scm @@ -0,0 +1,97 @@ +;;; The Geesh Shell Interpreter +;;; Copyright 2018 Timothy Sample +;;; +;;; 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 . + +(define-module (test-shell) + #:use-module (geesh environment) + #:use-module (geesh shell) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (ice-9 textual-ports) + #:use-module (srfi srfi-64) + #:use-module (tests automake) + #:use-module (tests config)) + +;;; Commentary: +;;; +;;; Tests for the shell module. +;;; +;;; Code: + +(define (make-temporary-directory) + (let loop ((name (tmpnam))) + (catch 'system-error + (lambda () + (mkdir name #o700) + name) + (lambda args + (unless (= (system-error-errno args) EEXIST) + (apply throw args)) + (loop (tmpnam)))))) + +(define (delete-recursively path) + (define enter? (const #t)) + (define (leaf path stat acc) (delete-file path) #f) + (define down (const #f)) + (define (up path stat acc) (rmdir path) #f) + (define skip (const #f)) + (define (error path stat errno result) + (scm-error 'system-error + "delete-recursively" + "~A" `(,strerror errno) + `(,errno))) + (file-system-fold enter? leaf down up skip error #f path)) + +(define (call-with-temporary-directory proc) + (let* ((directory (make-temporary-directory)) + (result (with-continuation-barrier + (lambda () + (proc directory))))) + (delete-recursively directory) + result)) + +(define (%make-script object . forms) + (define (write-script port) + (chmod port #o755) + (format port "#!~a --no-auto-compile~%!#~%~%" *guile-path*) + (for-each (lambda (form) + (write form port) + (newline port)) + forms)) + (match object + ((? port?) (write-script object)) + ((? string?) (call-with-output-file object write-script)))) + +(define-syntax-rule (make-script path form form1 ...) + (%make-script path `form `form1 ...)) + +(test-begin "shell") + +(test-assert "Executes a utility by absolute path" + (call-with-temporary-directory + (lambda (directory) + (let ((utility (string-append directory "/utility")) + (sentinal (string-append directory "/sentinal.txt")) + (env (make-environment '()))) + (make-script utility + (with-output-to-file ,sentinal + (lambda () + (display "x")))) + (sh:exec env utility) + (file-exists? sentinal))))) + +(test-end)