diff --git a/scsh/lib-dirs.scm b/scsh/lib-dirs.scm new file mode 100644 index 0000000..f28cc6e --- /dev/null +++ b/scsh/lib-dirs.scm @@ -0,0 +1,112 @@ +;;; More imports for the new library-search facility: +;;; HANDLE: with-handler +;;; LIST-LIB: any +;;; SCSH-LEVEL-0: directory-files open-input-file file-directory? +;;; SCSH-LEVEL-0: getenv +;;; SCSH-LEVEL-0: the file-name procs + +(define default-lib-dirs '("/usr/local/lib/scsh/modules/")) + +(define (set-default-lib-dirs! path-list) + (set! default-lib-dirs path-list)) + +;;; 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. + +(define (resolve-dir-name dir) + (if (file-name-directory? dir) + (file-name-as-directory (resolve-file-name dir)) + (resolve-file-name dir))) + +;;; Expand out env vars & ~user home dir prefixes. +(define (expand-lib-dir dir) + (substitute-env-vars (resolve-dir-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))))))))) + +;; 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 %lib-dirs #f) +(define reinit-lib-dirs + (make-reinitializer (lambda () (set! %lib-dirs #f)))) + +(define (lib-dirs) + (if (not %lib-dirs) (set! %lib-dirs (parse-lib-dirs-env-var))) + %lib-dirs) + +;; Don't export -- direct modification of %lib-dirs +(define (set-lib-dirs! val) (set! %lib-dirs val)) + +(define (lib-dirs-append-script-dir!) + (set-lib-dirs! (append (lib-dirs) '(script-dir)))) + +(define (lib-dirs-prepend-script-dir!) + (set-lib-dirs! (cons 'script-dir (lib-dirs)))) + +(define (reset-lib-dirs!) + (set-lib-dirs! default-lib-dirs)) + +(define (clear-lib-dirs!) + (set-lib-dirs! '())) + +(define (lib-dirs-prepend! dir) + (set-lib-dirs! (cons dir (lib-dirs)))) + +(define (lib-dirs-append! dir) + (set-lib-dirs! (append (lib-dirs) (list dir)))) diff --git a/scsh/scsh-interfaces.scm b/scsh/scsh-interfaces.scm index 315f49c..509f545 100644 --- a/scsh/scsh-interfaces.scm +++ b/scsh/scsh-interfaces.scm @@ -1206,4 +1206,18 @@ cppflags ldflags linker-flags - compiler-flags)) \ No newline at end of file + compiler-flags)) + +(define-interface lib-dirs-interface + (export lib-dirs + find-library-file + + lib-dirs-append-script-dir! + lib-dirs-prepend-script-dir! + reset-lib-dirs! + clear-lib-dirs! + lib-dirs-prepend! + lib-dirs-append!)) + +(define-interface lib-dirs-internal-interface + (export expand-lib-dir)) diff --git a/scsh/scsh-package.scm b/scsh/scsh-package.scm index bc76fc7..2eeb7b6 100644 --- a/scsh/scsh-package.scm +++ b/scsh/scsh-package.scm @@ -356,7 +356,8 @@ ; with-current-output-port exit scsh-level-0-internals ; set-command-line-args! init-scsh-vars threads - (subset srfi-1 (any)) + lib-dirs + lib-dirs-internal (subset srfi-14 (char-set char-set-complement! char-set-contains? @@ -458,6 +459,7 @@ dot-locking-interface md5-interface configure-interface + lib-dirs-interface ) (open structure-refs @@ -474,6 +476,7 @@ dot-locking md5 configure + lib-dirs scheme) (access scsh-top-package) @@ -591,4 +594,13 @@ (open scheme re-level-0 rx-syntax (subset srfi-13 (string-join))) - (files configure)) \ No newline at end of file + (files configure)) + +(define-structures ((lib-dirs lib-dirs-interface) + (lib-dirs-internal lib-dirs-internal-interface)) + (open scsh-level-0 + scheme + handle + scsh-utilities + (subset srfi-1 (any))) + (files lib-dirs)) \ No newline at end of file diff --git a/scsh/top.scm b/scsh/top.scm index 1e430a1..4ae6c7b 100644 --- a/scsh/top.scm +++ b/scsh/top.scm @@ -19,13 +19,7 @@ ;;; 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. @@ -50,7 +44,19 @@ (let-fluid $current-noise-port (make-null-output-port) (lambda () (apply ensure-loaded structs)))) - + +(define (load-library-file file lib-dirs script-file package) +; (format (error-output-port) "Load-library-file: ~a ~s\n" file lib-dirs) + (cond ((file-name-absolute? file) + (load-quietly file package)) + + ;; Search library dirs for FILE. + ((find-library-file file lib-dirs script-file) => + (lambda (file) + (load-quietly file package))) ; Load it. + + (else (error "Couldn't find library file" file lib-dirs)))) + ;;; The switches: ;;; -o Open the structure in current package. ;;; -n Create new package, make it current package. @@ -183,24 +189,11 @@ (values (reverse switches) #f #f top-entry '())))) -(define default-lib-dirs '("/usr/local/lib/scsh/modules/")) - -(define (set-default-lib-dirs! path-list) - (set! default-lib-dirs path-list)) - ;;; 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) @@ -227,19 +220,19 @@ (lp switches #t)) ((equal? switch "-lp-clear") - (set-mod-dirs! '()) + (clear-lib-dirs!) (lp switches script-loaded?)) ((equal? switch "-lp-default") - (set-mod-dirs! default-lib-dirs) + (reset-lib-dirs!) (lp switches script-loaded?)) ((equal? switch "+lpsd") - (set-mod-dirs! (cons 'script-dir (mod-dirs))) + (lib-dirs-prepend-script-dir!) (lp switches script-loaded?)) ((equal? switch "lpsd+") - (set-mod-dirs! (append (mod-dirs) '(script-dir))) + (lib-dirs-append-script-dir!) (lp switches script-loaded?)) ((string=? (car switch) "-l") @@ -258,29 +251,29 @@ (lp switches script-loaded?)) ((string=? (car switch) "-ll") - (load-library-file (cdr switch) (mod-dirs) script-file + (load-library-file (cdr switch) (lib-dirs) script-file (config-package)) (lp switches script-loaded?)) ((string=? (car switch) "-lel") - (load-library-file (cdr switch) (mod-dirs) script-file + (load-library-file (cdr switch) (lib-dirs) script-file (user-command-environment)) (lp switches script-loaded?)) ((string=? (car switch) "+lp") - (set-mod-dirs! (cons (cdr switch) (mod-dirs))) + (lib-dirs-prepend! (cdr switch)) (lp switches script-loaded?)) + ((string=? (car switch) "lp+") - (set-mod-dirs! (append (mod-dirs) (list (cdr switch)))) + (lib-dirs-append! (cdr switch)) (lp switches script-loaded?)) ((string=? (car switch) "+lpe") - (set-mod-dirs! (cons (expand-lib-dir (cdr switch)) (mod-dirs))) + (lib-dirs-prepend! (expand-lib-dir (cdr switch))) (lp switches script-loaded?)) ((string=? (car switch) "lpe+") - (set-mod-dirs! (append (mod-dirs) - (list (expand-lib-dir (cdr switch))))) + (lib-dirs-append! (expand-lib-dir (cdr switch))) (lp switches script-loaded?)) ((string=? (car switch) "-o") @@ -425,83 +418,6 @@ (add-narrowed-exit-hook! flush-all-ports-no-threads) -(define (load-library-file file lib-dirs script-file package) -; (format (error-output-port) "Load-library-file: ~a ~s\n" file lib-dirs) - (cond ((file-name-absolute? file) - (load-quietly file package)) - - ;; Search library dirs for FILE. - ((find-library-file file lib-dirs script-file) => - (lambda (file) - (load-quietly file package))) ; Load it. - - (else (error "Couldn't find library 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)