408 lines
12 KiB
Scheme
408 lines
12 KiB
Scheme
;;; 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 (geesh environment)
|
||
#:use-module (ice-9 hash-table)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-26)
|
||
#:export (get-status
|
||
set-status!
|
||
get-root-pid
|
||
getvar
|
||
setvar!
|
||
unsetvar!
|
||
exported?
|
||
set-exported!
|
||
read-only?
|
||
set-read-only!
|
||
with-variables
|
||
get-environ
|
||
with-environ
|
||
getfun
|
||
defun!
|
||
unsetfun!
|
||
with-arguments
|
||
getopt
|
||
setopt!
|
||
*option-names*
|
||
*option-letters*
|
||
call-with-continue
|
||
sh:continue
|
||
call-with-break
|
||
sh:break
|
||
call-with-return
|
||
sh:return
|
||
set-atexit!
|
||
sh:exit
|
||
*fd-count*
|
||
fd->current-port))
|
||
|
||
;;; Commentary:
|
||
;;;
|
||
;;; This module contains functions to inspect and manipulate the
|
||
;;; environment of the Shell language.
|
||
;;;
|
||
;;; Code:
|
||
|
||
|
||
;;; Status and PID.
|
||
|
||
(define *status* 0)
|
||
|
||
(define (get-status)
|
||
"Return the current status."
|
||
*status*)
|
||
|
||
(define (set-status! n)
|
||
"Set the current status."
|
||
(set! *status* n))
|
||
|
||
(define *root-pid* (getpid))
|
||
|
||
(define (get-root-pid)
|
||
*root-pid*)
|
||
|
||
|
||
;;; Variables.
|
||
|
||
(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 <> #\=) env))
|
||
|
||
(define (initial-pwd env)
|
||
(let* ((pwd (assoc-ref env "PWD"))
|
||
(pwd-p (false-if-exception (canonicalize-path pwd))))
|
||
(if (and pwd
|
||
(string-prefix? "/" pwd)
|
||
pwd-p
|
||
(string=? pwd-p (getcwd))
|
||
(not (any (lambda (component)
|
||
(member component '("." "..")))
|
||
(string-split pwd #\/))))
|
||
pwd
|
||
(getcwd))))
|
||
|
||
(define (initial-variables)
|
||
(let ((env (environ->alist (environ))))
|
||
(alist->hash-table
|
||
(map (match-lambda
|
||
((name . value) `(,name . ,(vector value #t #f))))
|
||
(append `(("PWD" . ,(initial-pwd env)))
|
||
env)))))
|
||
|
||
(define *variables* (initial-variables))
|
||
|
||
(define (exported? name)
|
||
"Check if the variable @var{name} has been exported."
|
||
(match (hash-ref *variables* name)
|
||
(#(_ exported? _) exported?)
|
||
(_ #f)))
|
||
|
||
(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 (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 _ _) (or value dflt))
|
||
(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! outside-variables *variables*)
|
||
(set! *variables* inside-variables))
|
||
thunk
|
||
(lambda ()
|
||
(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)))))
|
||
|
||
|
||
;;; Options.
|
||
|
||
(define *options*
|
||
(map (cut cons <> #f)
|
||
'(allexport
|
||
errexit
|
||
ignoreeof
|
||
monitor
|
||
noclobber
|
||
noglob
|
||
noexec
|
||
nolog
|
||
notify
|
||
nounset
|
||
verbose
|
||
vi
|
||
xtrace)))
|
||
|
||
(define (getopt name)
|
||
"Get the value of the option named @var{name}."
|
||
(match (assq name *options*)
|
||
((_ . value) value)))
|
||
|
||
(define (setopt! name value)
|
||
"Set the value of the option named @var{name} to @var{value}."
|
||
(match (assq name *options*)
|
||
((? pair? p) (set-cdr! p value))))
|
||
|
||
(define *option-names*
|
||
(map car *options*))
|
||
|
||
(define *option-letters*
|
||
'((#\a . allexport)
|
||
(#\e . errexit)
|
||
(#\m . monitor)
|
||
(#\C . noclobber)
|
||
(#\f . noglob)
|
||
(#\n . noexec)
|
||
(#\b . notify)
|
||
(#\u . nounset)
|
||
(#\v . verbose)
|
||
(#\x . xtrace)))
|
||
|
||
|
||
;;; 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* (sh: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* (sh: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))
|
||
|
||
(define *return-tag* (make-prompt-tag))
|
||
|
||
(define (call-with-return thunk)
|
||
"Call @var{thunk} in such a way that a call to @code{return} will
|
||
exit the dynamic extent of @var{thunk}."
|
||
(call-with-prompt *return-tag*
|
||
thunk
|
||
(lambda (cont status)
|
||
(set-status! status))))
|
||
|
||
(define* (sh:return #:optional (status (get-status)))
|
||
"Exit to the closest invocation of @code{call-with-return} setting
|
||
status to @var{status}. If @var{status} is not set, keep the current
|
||
status."
|
||
(abort-to-prompt *return-tag* status))
|
||
|
||
(define *atexit* #f)
|
||
(define *exiting?* #f)
|
||
|
||
(define (set-atexit! handler)
|
||
(set! *atexit* handler))
|
||
|
||
(define* (sh:exit #:optional status)
|
||
(if (and (not *exiting?*) (thunk? *atexit*))
|
||
(begin
|
||
(set! *exiting?* #t)
|
||
(*atexit*)
|
||
(exit (or status (get-status))))
|
||
(exit (or status (get-status)))))
|
||
|
||
|
||
;;; 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))))
|