532 lines
18 KiB
Scheme
532 lines
18 KiB
Scheme
;;; The scsh argv switch parser.
|
|
;;; Copyright (c) 1995 by Olin Shivers. See file COPYING.
|
|
|
|
;;; Imports:
|
|
;;; COMMAND-PROCESSOR: set-batch-mode?! command-loop
|
|
;;; ENSURES-LOADED: really-ensure-loaded
|
|
;;; ENVIRONMENTS: set-interaction-environment! environment-ref
|
|
;;; environment-define!
|
|
;;; ERROR-PACKAGE: error
|
|
;;; EVALUATION: eval
|
|
;;; EXTENDED-PORTS: make-string-input-port
|
|
;;; INTERFACES: make-simple-interface
|
|
;;; INTERRUPTS: interrupt-before-heap-overflow!
|
|
;;; PACKAGE-COMMANDS-INTERNAL: user-environment config-package
|
|
;;; get-reflective-tower
|
|
;;; PACKAGE-MUTATION: package-open!
|
|
;;; PACKAGES: structure-package structure? make-structure
|
|
;;; make-simple-package
|
|
;;; RECEIVING: mv return stuff
|
|
;;; SCSH-LEVEL-0-INTERNALS: set-command-line-args!
|
|
;;; SCSH-VERSION: scsh-version-string
|
|
;;;
|
|
;;; More imports for the new library-search facility:
|
|
;;; HANDLE: with-handler
|
|
;;; LIST-LIB: any
|
|
;;; SCSH-LEVEL-0: directory-files open-input-file file-directory? getenv
|
|
;;; SCSH-LEVEL-0: getenv
|
|
;;; SCSH-LEVEL-0: the file-name procs
|
|
|
|
;;; This should be defined by the package code, but it isn't.
|
|
|
|
(define (get-struct config-pack struct-name)
|
|
(let ((s (environment-ref config-pack struct-name)))
|
|
(cond ((structure? s) s)
|
|
(else (error "not a structure" s struct-name)))))
|
|
|
|
;;; ensure-loaded and load-into now write to noise-port anyway
|
|
|
|
(define (load-quietly filename p)
|
|
(if (not (string? filename))
|
|
(error "not a string in load-quietly" filename))
|
|
(let-fluid $current-noise-port (make-null-output-port)
|
|
(lambda () (load-into filename p))))
|
|
|
|
(define (load-port-quietly port p)
|
|
(let-fluid $current-noise-port (make-null-output-port)
|
|
(lambda () (load-port port p))))
|
|
|
|
(define (really-ensure-loaded noise . structs)
|
|
(let-fluid $current-noise-port (make-null-output-port)
|
|
(lambda ()
|
|
(apply ensure-loaded structs))))
|
|
|
|
;;; The switches:
|
|
;;; -o <struct> Open the structure in current package.
|
|
;;; -n <package> Create new package, make it current package.
|
|
;;; -m <struct> <struct>'s package becomes current package.
|
|
;;;
|
|
;;; -l <file> Load <file> into current package.
|
|
;;; -lm <file> Load <file> into config package.
|
|
;;; -le <file> Load <file> into exec package.
|
|
;;; -ll <file> As in -lm, but search the library path list.
|
|
;;;
|
|
;;; +lp <dir> Add <dir> onto start of library path list.
|
|
;;; lp+ <dir> Add <dir> onto end of library path list.
|
|
;;; +lpe <dir> As in +lp, but expand env vars & ~user.
|
|
;;; lpe+ <dir> As in lp+, but expand env vars & ~user.
|
|
;;; +lpsd Add the script-file's directory to front of path list
|
|
;;; lpsd+ Add the script-file's directory to end of path list
|
|
;;; -lp-clear Clear library path list to ().
|
|
;;; -lp-default Reset library path list to system default.
|
|
;;;
|
|
;;; These two require a terminating -s or -sfd arg:
|
|
;;; -ds Load terminating script into current package.
|
|
;;; -dm Load terminating script into config package.
|
|
;;; -de Load terminating script into exec package.
|
|
;;;
|
|
;;; -e <entry> Call (<entry>) to start program.
|
|
;;;
|
|
;;; Terminating switches:
|
|
;;; -c <exp> Eval <exp>, then exit.
|
|
;;; -s <script> Specify <script> to be loaded by a -ds, -dm, or -de.
|
|
;;; -sfd <num> Script is on file descriptor <num>.
|
|
;;; -- Interactive scsh.
|
|
|
|
|
|
;;; Return switch list, terminating switch, with arg, top-entry,
|
|
;;; and command-line args.
|
|
;;; - We first expand out any initial \ <filename> meta-arg.
|
|
;;; - A switch-list elt is either "-ds", "-dm", "-de", or a (switch . arg) pair
|
|
;;; for a -o, -n, -m, -l, or -lm switch.
|
|
;;; - Terminating switch is one of {s, c, #f} for -s or -sfd, -c,
|
|
;;; and -- respectively.
|
|
;;; - Terminating arg is the <exp> arg to -c, the <script> arg to -s,
|
|
;;; the input port for -sfd, otw #f.
|
|
;;; - top-entry is the <entry> arg to a -e; #f if none.
|
|
;;; - command-line args are what's left over after picking off the scsh
|
|
;;; switches.
|
|
|
|
(define (parse-scsh-args args)
|
|
(let lp ((args (meta-arg-process-arglist args))
|
|
(switches '()) ; A list of handler thunks
|
|
(top-entry #f) ; -t <entry>
|
|
(need-script? #f)) ; Found a -ds, -dm, or -de?
|
|
; (display args (current-output-port))
|
|
(if (pair? args)
|
|
(let ((arg (car args))
|
|
(args (cdr args)))
|
|
|
|
(cond ((string=? arg "-c")
|
|
(if (or need-script? top-entry (not (pair? args)))
|
|
(bad-arg)
|
|
(values (reverse switches) 'c (car args)
|
|
top-entry (cdr args))))
|
|
|
|
((string=? arg "-s")
|
|
(if (not (pair? args))
|
|
(bad-arg "-s switch requires argument")
|
|
(values (reverse switches) 's (car args)
|
|
top-entry (cdr args))))
|
|
|
|
;; -sfd <num>
|
|
((string=? arg "-sfd")
|
|
(if (not (pair? args))
|
|
(bad-arg "-sfd switch requires argument")
|
|
(let* ((fd (string->number (car args)))
|
|
(p (fdes->inport fd)))
|
|
(release-port-handle p) ; Unreveal the port.
|
|
(values (reverse switches) 'sfd p
|
|
top-entry (cdr args)))))
|
|
|
|
((string=? arg "--")
|
|
(if need-script?
|
|
(bad-arg "-ds, -dm, or -de switch requires -s <script>")
|
|
(values (reverse switches) #f #f top-entry args)))
|
|
|
|
((or (string=? arg "-ds")
|
|
(string=? arg "-dm")
|
|
(string=? arg "-de")
|
|
(string=? arg "+lpsd")
|
|
(string=? arg "lpsd+")
|
|
(string=? arg "-lp-default")
|
|
(string=? arg "-lp-clear"))
|
|
(lp args (cons arg switches) top-entry #t))
|
|
|
|
((or (string=? arg "-l")
|
|
(string=? arg "-lm")
|
|
(string=? arg "-le")
|
|
(string=? arg "-ll")
|
|
(string=? arg "lp+")
|
|
(string=? arg "+lp")
|
|
(string=? arg "lpe+")
|
|
(string=? arg "+lpe"))
|
|
(if (pair? args)
|
|
(lp (cdr args)
|
|
(cons (cons arg (car args)) switches)
|
|
top-entry
|
|
need-script?)
|
|
(bad-arg "Switch requires argument" arg)))
|
|
|
|
((or (string=? arg "-o")
|
|
(string=? arg "-n")
|
|
(string=? arg "-m"))
|
|
(if (pair? args)
|
|
(let* ((s (car args))
|
|
(name (if (and (string=? arg "-n")
|
|
(string=? s "#f"))
|
|
#f ; -n #f treated specially.
|
|
(string->symbol s))))
|
|
(lp (cdr args)
|
|
(cons (cons arg name) switches)
|
|
top-entry
|
|
need-script?))
|
|
(bad-arg "Switch requires argument" arg)))
|
|
|
|
((string=? arg "-e")
|
|
(lp (cdr args) switches
|
|
(string->symbol (car args)) need-script?))
|
|
|
|
(else (bad-arg "Unknown switch" arg))))
|
|
|
|
(values (reverse switches) #f #f top-entry '()))))
|
|
|
|
(define default-lib-dirs '("/usr/local/lib/scsh/modules/"))
|
|
|
|
;;; Do each -ds, -dm, -de, -o, -n, -m, -l/lm/ll, +lp/+lpe/lp+/lpe+, or
|
|
;;; -lp-clear/lp-default switch, and return the final result package and a
|
|
;;; flag saying if the script was loaded by a -ds, -dm, or -de.
|
|
|
|
(define (do-switches switches script-file)
|
|
;; We don't want to try to parse $SCSH_LIB_DIRS until we actually
|
|
;; need the value -- if the user is using the -lp-default switch,
|
|
;; for example, a parse error shouldn't effect the startup.
|
|
(define %mod-dirs #f)
|
|
(define (mod-dirs)
|
|
(if (not %mod-dirs) (set! %mod-dirs (parse-lib-dirs-env-var)))
|
|
%mod-dirs)
|
|
(define (set-mod-dirs! val) (set! %mod-dirs val))
|
|
|
|
; (format #t "Switches = ~a~%" switches)
|
|
(let lp ((switches switches)
|
|
(script-loaded? #f))
|
|
(if (pair? switches)
|
|
(let ((switch (car switches))
|
|
(switches (cdr switches)))
|
|
; (format #t "Doing switch ~a~%" switch)
|
|
(cond
|
|
|
|
((equal? switch "-ds")
|
|
(load-quietly script-file (interaction-environment))
|
|
; (format #t "loaded script ~s~%" script-file)
|
|
(lp switches #t))
|
|
|
|
((equal? switch "-dm")
|
|
(load-quietly script-file (config-package))
|
|
; (format #t "loaded module ~s~%" script-file)
|
|
(lp switches #t))
|
|
|
|
((equal? switch "-de")
|
|
(load-quietly script-file (user-command-environment))
|
|
; (format #t "loaded exec ~s~%" script-file)
|
|
(lp switches #t))
|
|
|
|
((equal? switch "-lp-clear")
|
|
(set-mod-dirs! '())
|
|
(lp switches script-loaded?))
|
|
|
|
((equal? switch "-lp-default")
|
|
(set-mod-dirs! default-lib-dirs)
|
|
(lp switches script-loaded?))
|
|
|
|
((equal? switch "+lpsd")
|
|
(set-mod-dirs! (cons 'script-dir (mod-dirs)))
|
|
(lp switches script-loaded?))
|
|
|
|
((equal? switch "lpsd+")
|
|
(set-mod-dirs! (append (mod-dirs) '(script-dir)))
|
|
(lp switches script-loaded?))
|
|
|
|
((string=? (car switch) "-l")
|
|
; (format #t "loading file ~s~%" (cdr switch))
|
|
(load-quietly (cdr switch) (interaction-environment))
|
|
(lp switches script-loaded?))
|
|
|
|
((string=? (car switch) "-lm")
|
|
; (format #t "loading module file ~s~%" (cdr switch))
|
|
(load-quietly (cdr switch) (config-package))
|
|
(lp switches script-loaded?))
|
|
|
|
((string=? (car switch) "-le")
|
|
; (format #t "loading exec file ~s~%" (cdr switch))
|
|
(load-quietly (cdr switch) (user-command-environment))
|
|
(lp switches script-loaded?))
|
|
|
|
((string=? (car switch) "-ll")
|
|
(load-library-file (cdr switch) (mod-dirs) script-file)
|
|
(lp switches script-loaded?))
|
|
|
|
((string=? (car switch) "+lp")
|
|
(set-mod-dirs! (cons (cdr switch) (mod-dirs)))
|
|
(lp switches script-loaded?))
|
|
((string=? (car switch) "lp+")
|
|
(set-mod-dirs! (append (mod-dirs) (list (cdr switch))))
|
|
(lp switches script-loaded?))
|
|
|
|
((string=? (car switch) "+lpe")
|
|
(set-mod-dirs! (cons (expand-lib-dir (cdr switch)) (mod-dirs)))
|
|
(lp switches script-loaded?))
|
|
|
|
((string=? (car switch) "lpe+")
|
|
(set-mod-dirs! (append (mod-dirs)
|
|
(list (expand-lib-dir (cdr switch)))))
|
|
(lp switches script-loaded?))
|
|
|
|
((string=? (car switch) "-o")
|
|
(let ((struct-name (cdr switch))
|
|
(cp (config-package)))
|
|
;; Should not be necessary to do this ensure-loaded, but it is.
|
|
(really-ensure-loaded #f (get-struct cp struct-name))
|
|
(package-open! (interaction-environment)
|
|
(lambda () (get-struct cp struct-name)))
|
|
; (format #t "Opened ~s~%" struct-name)
|
|
(lp switches script-loaded?)))
|
|
|
|
((string=? (car switch) "-n")
|
|
(let* ((name (cdr switch))
|
|
(pack (new-empty-package name))) ; Contains nothing
|
|
(if name ; & exports nothing.
|
|
(let* ((iface (make-simple-interface #f '()))
|
|
(struct (make-structure pack iface)))
|
|
(environment-define! (config-package) name struct)))
|
|
(set-interaction-environment! pack)
|
|
(lp switches script-loaded?)))
|
|
|
|
((string=? (car switch) "-m")
|
|
; (format #t "struct-name ~s~%" (cdr switch))
|
|
(let ((struct (get-struct (config-package) (cdr switch))))
|
|
; (format #t "struct-name ~s, struct ~s~%" (cdr switch) struct)
|
|
(let ((pack (structure-package struct)))
|
|
; (format #t "package ~s~%" pack)
|
|
(set-interaction-environment! pack)
|
|
(really-ensure-loaded #f struct)
|
|
; (format #t "Switched to ~s~%" pack)
|
|
(lp switches script-loaded?))))
|
|
|
|
(else (error "Impossible error in do-switches. Report to developers."))))
|
|
script-loaded?)))
|
|
|
|
|
|
;;; (user-environment) probably isn't right. What is this g-r-t stuff?
|
|
;;; Check w/jar.
|
|
|
|
(define (new-empty-package name)
|
|
(make-simple-package '() #t
|
|
(get-reflective-tower (user-environment)) ; ???
|
|
name))
|
|
|
|
(define (with-scsh-initialized interactive? context args thunk)
|
|
(with-scsh-sighandlers
|
|
interactive?
|
|
(lambda ()
|
|
(with-autoreaping
|
|
(lambda ()
|
|
;; environment,umask and cwd are already installed by resumers
|
|
;; c.f. {env,umask,env}-reinitializer in scsh.scm
|
|
(init-scsh-vars interactive?)
|
|
(start-new-session context
|
|
(current-input-port)
|
|
(current-output-port)
|
|
(current-error-port)
|
|
args
|
|
(not interactive?))
|
|
(with-interaction-environment
|
|
(user-environment)
|
|
thunk))))))
|
|
|
|
(define (parse-switches-and-execute all-args context)
|
|
(receive (switches term-switch term-val top-entry args)
|
|
(parse-scsh-args (cdr all-args))
|
|
(with-handler
|
|
(lambda (cond more)
|
|
(if (warning? cond)
|
|
(more)
|
|
(with-handler
|
|
(lambda (c m)
|
|
(scheme-exit-now 1))
|
|
(lambda ()
|
|
(call-exit-hooks-and-narrow (lambda () #t))
|
|
(more)))))
|
|
(lambda ()
|
|
(with-scsh-initialized
|
|
(not term-switch) context args
|
|
(lambda ()
|
|
;; Have to do these before calling DO-SWITCHES, because actions
|
|
;; performed while processing the switches may use these guys.
|
|
(set-command-line-args!
|
|
(cons (if (eq? term-switch 's)
|
|
term-val ; Script file.
|
|
(if (eq? term-val 'sfd)
|
|
"file-descriptor-script" ; -sfd <num>
|
|
(car all-args)))
|
|
args))
|
|
|
|
(let* ((script-loaded? (do-switches switches term-val)))
|
|
(if (not script-loaded?) ; There wasn't a -ds, -dm, or -de,
|
|
(if (eq? term-switch 's) ; but there is a script,
|
|
(load-quietly term-val; so load it now.
|
|
(interaction-environment))
|
|
(if (eq? term-switch 'sfd)
|
|
(load-port-quietly term-val (interaction-environment)))))
|
|
|
|
(cond ((not term-switch) ; -- interactive
|
|
(scsh-exit-now ;; TODO: ,exit will bypass this
|
|
(restart-command-processor
|
|
args
|
|
context
|
|
(lambda ()
|
|
(display (string-append
|
|
"Welcome to scsh "
|
|
scsh-version-string
|
|
" (" scsh-release-name ")")
|
|
(current-output-port))
|
|
(newline (current-output-port))
|
|
(display "Type ,? for help."
|
|
(current-output-port))
|
|
(newline (current-output-port))
|
|
(in-package (user-environment) '())))))
|
|
|
|
((eq? term-switch 'c)
|
|
(let ((result (eval (read-exactly-one-sexp-from-string term-val)
|
|
(interaction-environment))))
|
|
(scsh-exit-now 0)))
|
|
|
|
(top-entry ; There was a -e <entry>.
|
|
((eval top-entry (interaction-environment))
|
|
(command-line))
|
|
(scsh-exit-now 0))
|
|
|
|
;; Otherwise, the script executed as it loaded,
|
|
;; so we're done.
|
|
(else (scsh-exit-now 0))))))))))
|
|
|
|
|
|
(define (read-exactly-one-sexp-from-string s)
|
|
(with-current-input-port (make-string-input-port s)
|
|
(let ((val (read)))
|
|
(if (eof-object? (read)) val
|
|
(error "More than one value read from string" s)))))
|
|
|
|
(define (scsh-exit-now status)
|
|
(call-exit-hooks-and-narrow
|
|
(lambda ()
|
|
(scheme-exit-now status))))
|
|
|
|
(add-narrowed-exit-hook! flush-all-ports-no-threads)
|
|
|
|
(define (load-library-file file lib-dirs script-file)
|
|
; (format (error-output-port) "Load-library-file: ~a ~s\n" file lib-dirs)
|
|
(cond ((file-name-absolute? file)
|
|
(load-quietly file (config-package)))
|
|
|
|
;; Search library dirs for FILE.
|
|
((find-library-file file lib-dirs script-file) =>
|
|
(lambda (iport)
|
|
(load-quietly iport (config-package)))) ; Load it.
|
|
|
|
(else (error "Couldn't find library module file" file lib-dirs))))
|
|
|
|
;;; Search library dirs for FILE.
|
|
(define (find-library-file file lib-dirs script-file)
|
|
(letrec ((recur (lambda (dir)
|
|
; (format (error-output-port) "flf -- entering ~a\n" dir)
|
|
(let* ((f (string-append dir file))) ; Resolve it.
|
|
(or (check-file-for-open f) ; Found it.
|
|
(any (lambda (f) ; Search subdirs.
|
|
(let ((dir (string-append dir f "/")))
|
|
(and (file-directory?/safe dir) (recur dir))))
|
|
(directory-files/safe dir)))))))
|
|
(any (lambda (dir)
|
|
(cond ((eq? dir 'script-dir)
|
|
(let* ((script-dir (file-name-directory script-file))
|
|
(fname (string-append script-dir file)))
|
|
(check-file-for-open fname)))
|
|
|
|
;; Ends in / means recursive search.
|
|
((file-name-directory? dir)
|
|
(recur dir))
|
|
|
|
(else (check-file-for-open (absolute-file-name file dir)))))
|
|
lib-dirs)))
|
|
|
|
|
|
;;; (in-any-event abort-exp body ...)
|
|
;;; If *anything* goes wrong, bag the BODY forms, and eval ABORT-EXP instead.
|
|
|
|
(define-syntax in-any-event
|
|
(syntax-rules ()
|
|
((in-any-event abort-exp body ...)
|
|
(call-with-current-continuation
|
|
(lambda (ret)
|
|
(with-handler (lambda (condition more) (ret abort-exp))
|
|
(lambda () body ...)))))))
|
|
|
|
(define (check-file-for-open f)
|
|
(in-any-event #f (let ((iport (open-input-file f)))
|
|
(close-input-port iport)
|
|
f))) ; Any error, say false.
|
|
|
|
(define (directory-files/safe dir)
|
|
(in-any-event '() (directory-files dir))) ; Any error, say ().
|
|
|
|
(define (file-directory?/safe f)
|
|
(in-any-event #f (file-directory? f))) ; Any error, say false.
|
|
|
|
|
|
;;; Expand out env vars & ~user home dir prefixes.
|
|
(define (expand-lib-dir dir)
|
|
(substitute-env-vars (resolve-file-name dir)))
|
|
|
|
;;; Parse up the $SCSH_LIB_DIRS path list.
|
|
(define (parse-lib-dirs-env-var)
|
|
(let ((s (getenv "SCSH_LIB_DIRS")))
|
|
(if (not s) default-lib-dirs
|
|
|
|
(with-current-input-port (make-string-input-port s)
|
|
(let recur ()
|
|
(let ((val (read)))
|
|
(cond ((eof-object? val) '())
|
|
((string? val) (cons val (recur)))
|
|
((not val) (append default-lib-dirs (recur)))
|
|
(else (error "Illegal path element in $SCSH_LIB_DIRS"
|
|
s val)))))))))
|
|
|
|
(define (bad-arg . msg)
|
|
(with-current-output-port (current-error-port)
|
|
(for-each (lambda (x) (display x) (write-char #\space)) msg)
|
|
(newline)
|
|
(display "Usage: scsh [meta-arg] [switch ..] [end-option arg ...]
|
|
|
|
meta-arg: \\ <script-file-name>
|
|
|
|
switch: -e <entry-point> Specify top-level entry point.
|
|
-o <structure> Open structure in current package.
|
|
-m <package> Switch to package.
|
|
-n <new-package> Switch to new package.
|
|
|
|
|
|
-lm <module-file-name> Load module into config package.
|
|
-le <exec-file-name> Load file into exec package.
|
|
-l <file-name> Load file into current package.
|
|
|
|
-ll <module-file-name> As in -lm, but search the library path list.
|
|
+lp <dir> Add <dir> to front of library path list.
|
|
lp+ <dir> Add <dir> to end of library path list.
|
|
+lpe <dir> +lp, with env var and ~user expansion.
|
|
lpe+ <dir> lp+, with env var and ~user expansion.
|
|
+lpsd Add script-file's dir to front of path list.
|
|
lpsd+ Add script-file's dir to end of path list.
|
|
-lp-clear Clear library path list to ().
|
|
-lp-default Reset library path list to system default.
|
|
|
|
-ds Do script.
|
|
-dm Do script module.
|
|
-de Do script exec.
|
|
|
|
end-option: -s <script> Specify script.
|
|
-sfd <num> Script is on file descriptor <num>.
|
|
-c <exp> Evaluate expression.
|
|
-- Interactive session.
|
|
" (current-error-port)))
|
|
(exit -1))
|