diff --git a/scsh/scsh-package.scm b/scsh/scsh-package.scm index 9268afe..878bdeb 100644 --- a/scsh/scsh-package.scm +++ b/scsh/scsh-package.scm @@ -317,6 +317,7 @@ ; with-current-output-port exit scsh-level-0-internals ; set-command-line-args! init-scsh-vars threads + list-lib ; any root-scheduler ; scheme-exit-now scheme) (files top meta-arg)) diff --git a/scsh/top.scm b/scsh/top.scm index 10c19d2..2383ec3 100644 --- a/scsh/top.scm +++ b/scsh/top.scm @@ -20,6 +20,12 @@ ;;; 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. @@ -31,6 +37,8 @@ ;;; 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)))) @@ -46,6 +54,16 @@ ;;; ;;; -l Load into current package. ;;; -lm Load into config package. +;;; -ll As in -lm, but search the library path list. +;;; +;;; +lp Add onto start of library path list. +;;; lp+ Add onto end of library path list. +;;; +lpe As in +lp, but expand env vars & ~user. +;;; lpe+ 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. @@ -111,11 +129,20 @@ (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) @@ -146,10 +173,22 @@ (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) + ;; 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)) @@ -169,6 +208,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)) @@ -179,6 +234,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))) @@ -305,6 +380,83 @@ (define (call-exit-hooks) (flush-all-ports)) +(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) @@ -322,6 +474,16 @@ switch: -e Specify top-level entry point. -lm Load module into config package. -l Load file into current package. + -ll As in -lm, but search the library path list. + +lp Add to front of library path list. + lp+ Add to end of library path list. + +lpe +lp, with env var and ~user expansion. + lpe+ 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.