From 16e0fd55359044eec81cdd2354e7fbf07291a102 Mon Sep 17 00:00:00 2001
From: shivers <shivers>
Date: Sun, 7 Nov 1999 03:11:43 +0000
Subject: [PATCH] Added library directory path search command-line switches.

---
 scsh/top.scm | 177 +++++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 170 insertions(+), 7 deletions(-)

diff --git a/scsh/top.scm b/scsh/top.scm
index 45ada39..14f0d0c 100644
--- a/scsh/top.scm
+++ b/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.