Added library directory path search command-line switches.
This commit is contained in:
shivers
parent
f65a314430
commit
16e0fd5535
177
scsh/top.scm
177
scsh/top.scm
|
|
@ -20,6 +20,13 @@
|
|||
;;; 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.
|
||||
|
||||
|
|
@ -35,6 +42,16 @@
|
|||
;;;
|
||||
;;; -l <file> Load <file> into current package.
|
||||
;;; -lm <file> Load <file> into config 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.
|
||||
|
|
@ -52,8 +69,9 @@
|
|||
;;; 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", or a (switch . arg) pair
|
||||
;;; for a -o, -n, -m, -l, or -lm switch.
|
||||
;;; - A switch-list elt is either "-ds", "-dm", "-lp-clear", "-lp-default"
|
||||
;;; "+lpsd", "lpsd+" or a (switch . arg) pair for a -o, -n, -m, -l, -lm,
|
||||
;;; -ll, +lp, lp+, +lpe, or lpe+ 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,
|
||||
|
|
@ -99,11 +117,21 @@
|
|||
(values (reverse switches) #f #f top-entry args)))
|
||||
|
||||
((or (string=? arg "-ds")
|
||||
(string=? arg "-dm"))
|
||||
(string=? arg "-dm")
|
||||
(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 "-lm")
|
||||
(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)
|
||||
|
|
@ -134,11 +162,24 @@
|
|||
|
||||
(values (reverse switches) #f #f top-entry '()))))
|
||||
|
||||
;;; Do each -ds, -dm, -o, -n, -m, -l, and -lm switch, and return the final
|
||||
;;; result package and a flag saying if the script was loaded by a -ds or -dm.
|
||||
(define default-lib-dirs '("/usr/local/lib/scsh/modules/"))
|
||||
|
||||
;;; Do each -ds, -dm, -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 or -dm.
|
||||
|
||||
(define (do-switches switches script-file)
|
||||
; (format #t "Switches = ~a~%" switches)
|
||||
;; 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 = ~s~%" switches)
|
||||
|
||||
(let lp ((switches switches)
|
||||
(script-loaded? #f))
|
||||
(if (pair? switches)
|
||||
|
|
@ -157,6 +198,22 @@
|
|||
; (format #t "loaded module ~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))
|
||||
|
|
@ -167,6 +224,26 @@
|
|||
(load-quietly (cdr switch) (config-package))
|
||||
(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)))
|
||||
|
|
@ -276,6 +353,82 @@
|
|||
(error "More than one value read from string" s)))))
|
||||
|
||||
|
||||
(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 (open-input-file/safe 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)))
|
||||
(open-input-file/safe fname)))
|
||||
|
||||
;; Ends in / means recursive search.
|
||||
((file-name-directory? dir)
|
||||
(recur dir))
|
||||
|
||||
(else (open-input-file/safe (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 (open-input-file/safe f)
|
||||
(in-any-event #f (open-input-file 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) '())
|
||||
((or (string? val) (symbol? 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 (error-output-port)
|
||||
(for-each (lambda (x) (display x) (write-char #\space)) msg)
|
||||
|
|
@ -293,6 +446,16 @@ switch: -e <entry-point> Specify top-level entry point.
|
|||
-lm <module-file-name> Load module into config 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.
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue