Moved the library directories facility to its own module.
This commit is contained in:
mainzelm
parent
eb9410cc44
commit
03ab628c93
|
|
@ -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))))
|
||||
|
|
@ -1207,3 +1207,17 @@
|
|||
ldflags
|
||||
linker-flags
|
||||
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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -592,3 +595,12 @@
|
|||
re-level-0 rx-syntax
|
||||
(subset srfi-13 (string-join)))
|
||||
(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))
|
||||
130
scsh/top.scm
130
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.
|
||||
|
||||
|
|
@ -51,6 +45,18 @@
|
|||
(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 <struct> Open the structure in current package.
|
||||
;;; -n <package> 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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue