Update of /cvsroot/scsh/scsh-0.6/scsh
In directory usw-pr-cvs1:/tmp/cvs-serv16156
Modified Files:
scsh-package.scm top.scm
Log Message:
Added library directory path search command-line switches.
Unlike 0.5.3 I don't allow symbols in SCSH_LIB_DIRS (See bug #489901).
Index: scsh-package.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/scsh-package.scm,v
retrieving revision 1.30
retrieving revision 1.31
diff -C2 -r1.30 -r1.31
*** scsh-package.scm 2001/12/03 15:21:46 1.30
--- scsh-package.scm 2001/12/07 11:24:30 1.31
***************
*** 318,321 ****
--- 318,322 ----
scsh-level-0-internals ; set-command-line-args! init-scsh-vars
threads
+ list-lib ; any
root-scheduler ; scheme-exit-now
scheme)
Index: top.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/top.scm,v
retrieving revision 1.18
retrieving revision 1.19
diff -C2 -r1.18 -r1.19
*** top.scm 2001/11/27 17:10:07 1.18
--- top.scm 2001/12/07 11:24:30 1.19
***************
*** 21,24 ****
--- 21,30 ----
;;; 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.
***************
*** 32,35 ****
--- 38,43 ----
(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))))
***************
*** 47,51 ****
--- 55,69 ----
;;; -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.
***************
*** 112,120 ****
((or (string=? arg "-ds")
! (string=? arg "-dm"))
(lp args (cons arg switches) top-entry #t))
((or (string=? arg "-l")
! (string=? arg "-lm"))
(if (pair? args)
(lp (cdr args)
--- 130,147 ----
((or (string=? arg "-ds")
! (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 "-ll")
! (string=? arg "lp+")
! (string=? arg "+lp")
! (string=? arg "lpe+")
! (string=? arg "+lpe"))
(if (pair? args)
(lp (cdr args)
***************
*** 146,154 ****
(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 (do-switches switches script-file)
; (format #t "Switches = ~a~%" switches)
(let lp ((switches switches)
--- 173,193 ----
(values (reverse switches) #f #f top-entry '()))))
+
+ (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)
***************
*** 170,173 ****
--- 209,228 ----
(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))
***************
*** 180,183 ****
--- 235,258 ----
(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))
***************
*** 306,309 ****
--- 381,461 ----
(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)
***************
*** 322,325 ****
--- 474,487 ----
-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.
|