scsh-0.6/scsh/top.scm

;;; The scsh argv switch parser.
;;; Copyright (c) 1995 by Olin Shivers. See file COPYING.

;;; Imports:
;;;	COMMAND-PROCESSOR: set-batch-mode?! command-loop
;;; 	ENSURES-LOADED: really-ensure-loaded
;;;     ENVIRONMENTS: set-interaction-environment! environment-ref
;;;		environment-define!
;;;	ERROR-PACKAGE: error
;;; 	EVALUATION: eval
;;; 	EXTENDED-PORTS: make-string-input-port
;;;	INTERFACES: make-simple-interface
;;;     INTERRUPTS: interrupt-before-heap-overflow!
;;; 	PACKAGE-COMMANDS-INTERNAL: user-environment config-package 
;;;		get-reflective-tower
;;; 	PACKAGE-MUTATION: package-open!
;;;	PACKAGES: structure-package structure? make-structure 
;;;		make-simple-package
;;;	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.

(define (get-struct config-pack struct-name)
  (let ((s (environment-ref config-pack struct-name)))
    (cond ((structure? s) s)
	  (else (error "not a structure" s struct-name)))))

;;; 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))))

(define (really-ensure-loaded noise . structs)
  (let-fluid $current-noise-port (make-null-output-port)
	     (lambda ()
	       (apply ensure-loaded structs))))
		      
;;; The switches:
;;; 	-o <struct>		Open the structure in current package.
;;; 	-n <package>		Create new package, make it current package.
;;; 	-m <struct>		<struct>'s package becomes current package.
;;; 	
;;; 	-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.
;;; 	-dm			Load terminating script into config package.
;;; 	
;;; 	-e <entry>		Call (<entry>) to start program.
;;; 	
;;;				Terminating switches:
;;; 	-c <exp>		Eval <exp>, then exit.
;;; 	-s <script>		Specify <script> to be loaded by a -ds or -dm.
;;;	-sfd <num>		Script is on file descriptor <num>.
;;; 	--  			Interactive scsh.


;;; 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.
;;; - 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, 
;;;   the input port for -sfd, otw #f.
;;; - top-entry is the <entry> arg to a -e; #f if none.
;;; - command-line args are what's left over after picking off the scsh
;;;   switches.

(define (parse-scsh-args args)
  (let lp ((args (meta-arg-process-arglist args))
	   (switches '())	; A list of handler thunks
	   (top-entry #f)	; -t <entry>
	   (need-script? #f))	; Found a -ds or -dm?
;    (display args    (current-output-port))
    (if (pair? args)
	(let ((arg  (car args))
	      (args (cdr args)))

	  (cond ((string=? arg "-c")
		 (if (or need-script? top-entry (not (pair? args)))
		     (bad-arg)
		     (values (reverse switches) 'c (car args)
			     top-entry (cdr args))))

		((string=? arg "-s")
		 (if (not (pair? args))
		     (bad-arg "-s switch requires argument")
		     (values (reverse switches) 's (car args)
			     top-entry (cdr args))))

		;; -sfd <num>
		((string=? arg "-sfd")
		 (if (not (pair? args))
		     (bad-arg "-sfd switch requires argument")
		     (let* ((fd (string->number (car args)))
			    (p (fdes->inport fd)))
		       (release-port-handle p)	; Unreveal the port.
		       (values (reverse switches) 's p
			       top-entry (cdr args)))))

		((string=? arg "--")
		 (if need-script?
		     (bad-arg "-ds or -dm switch requires -s <script>")
		     (values (reverse switches) #f #f top-entry args)))

		((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)
			 (cons (cons arg (car args)) switches)
			 top-entry
			 need-script?)
		     (bad-arg "Switch requires argument" arg)))

		((or (string=? arg "-o")
		     (string=? arg "-n")
		     (string=? arg "-m"))
		 (if (pair? args)
		     (let* ((s (car args))
			    (name (if (and (string=? arg "-n")
					   (string=? s "#f"))
				      #f ; -n #f  treated specially.
				      (string->symbol s))))
		       (lp (cdr args)
			   (cons (cons arg name) switches)
			   top-entry
			   need-script?))
		     (bad-arg "Switch requires argument" arg)))

		((string=? arg "-e")
		 (lp (cdr args)                  switches
		     (string->symbol (car args)) need-script?))

	    (else (bad-arg "Unknown switch" arg))))

	(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)
	   (script-loaded? #f))
    (if (pair? switches)
	(let ((switch (car switches))
	      (switches (cdr switches)))
;	  (format #t "Doing switch ~a~%" switch)
	  (cond

	    ((equal? switch "-ds")
	     (load-quietly script-file (interaction-environment))
;	     (format #t "loaded script ~s~%" script-file)
	     (lp switches #t))

	    ((equal? switch "-dm")
	     (load-quietly script-file (config-package))
;	     (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))
	     (lp switches script-loaded?))

	    ((string=? (car switch) "-lm")
;	     (format #t "loading module file ~s~%" (cdr switch))
	     (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)))
	       ;; Should not be necessary to do this ensure-loaded, but it is.
	       (really-ensure-loaded #f (get-struct cp struct-name))
	       (package-open! (interaction-environment)
			      (lambda () (get-struct cp struct-name)))
;	       (format #t "Opened ~s~%" struct-name)
	       (lp switches script-loaded?)))

	    ((string=? (car switch) "-n")
	     (let* ((name (cdr switch))
		    (pack (new-empty-package name)))	; Contains nothing
	       (if name					; & exports nothing.
		   (let* ((iface  (make-simple-interface #f '()))
			  (struct (make-structure pack iface)))
		     (environment-define! (config-package) name struct)))
	       (set-interaction-environment! pack)
	       (lp switches script-loaded?)))

	    ((string=? (car switch) "-m")
;	     (format #t "struct-name ~s~%" (cdr switch))
	     (let ((struct (get-struct (config-package) (cdr switch))))
;	       (format #t "struct-name ~s, struct ~s~%" (cdr switch) struct)
	       (let ((pack (structure-package struct)))
;		 (format #t "package ~s~%" pack)
		 (set-interaction-environment! pack)
		 (really-ensure-loaded #f struct)
;		 (format #t "Switched to ~s~%" pack)
		 (lp switches script-loaded?))))

	    (else (error "Impossible error in do-switches. Report to developers."))))
	script-loaded?)))
	    

;;; (user-environment) probably isn't right. What is this g-r-t stuff?
;;; Check w/jar.

(define (new-empty-package name)
  (make-simple-package '() #t
		       (get-reflective-tower (user-environment)) ; ???
		       name))

(define (with-scsh-initialized interactive? context args thunk)
  (with-scsh-sighandlers
   interactive?
   (lambda ()
     (with-autoreaping
      (lambda ()
	;; environment,umask and cwd are already installed by resumers
	;; c.f. {env,umask,env}-reinitializer in scsh.scm
	(init-scsh-vars interactive?)
	(start-new-session context    
			   (current-input-port)
			   (current-output-port)
			   (current-error-port)
			   args
			   (not interactive?))
	(with-interaction-environment     
	 (user-environment)
	 thunk))))))

(define (parse-switches-and-execute all-args context)
  (receive (switches term-switch term-val top-entry args)
      (parse-scsh-args (cdr all-args))
    (with-handler 
     (lambda (cond more)
       (if (warning? cond)
	   (more)
	   (with-handler
	    (lambda (c m)
	      (scheme-exit-now 1))
	    (lambda ()
	      (call-exit-hooks-and-narrow (lambda () #t))
	      (more)))))
     (lambda ()
       (with-scsh-initialized
	(not term-switch) context args
	(lambda ()
	  ;; Have to do these before calling DO-SWITCHES, because actions
	  ;; performed while processing the switches may use these guys.
	  (set-command-line-args!
	   (cons (if (eq? term-switch 's)
		     (if (string? term-val)
			 term-val	; Script file.
			 "file-descriptor-script") ; -sfd <num>
		     (car all-args))
		 args))
	 
	  (let* ((script-loaded?  (do-switches switches term-val)))
	    (if (and (not script-loaded?) ; There wasn't a -ds or -dm,
		     (eq? term-switch 's)) ; but there is a script,
		(load-quietly term-val	; so load it now.
			      (interaction-environment)))
	   
	    (cond ((not term-switch)	; -- interactive
		   (scsh-exit-now       ;; TODO: ,exit will bypass this
		    (restart-command-processor 
		     args 
		     context 
		     (lambda ()
		       (display (string-append 
				 "Welcome to scsh "
				 scsh-version-string
				 " (" scsh-release-name ")")
				(current-output-port))
		       (newline (current-output-port))
		       (display "Type ,? for help."
				(current-output-port))
		       (newline (current-output-port))
		       (in-package (user-environment) '())))))

		  ((eq? term-switch 'c)
		   (let ((result (eval (read-exactly-one-sexp-from-string term-val)
				       (interaction-environment))))
		     (scsh-exit-now 0)))
		 
		  (top-entry		; There was a -e <entry>.
		   ((eval top-entry (interaction-environment))
		    (command-line))
		   (scsh-exit-now 0))
		 
		  ;; Otherwise, the script executed as it loaded,
		  ;; so we're done.
		  (else (scsh-exit-now 0))))))))))


(define (read-exactly-one-sexp-from-string s)
  (with-current-input-port (make-string-input-port s)
    (let ((val (read)))
      (if (eof-object? (read)) val
	  (error "More than one value read from string" s)))))

(define (scsh-exit-now status)
  (call-exit-hooks-and-narrow
   (lambda ()
     (scheme-exit-now status))))

(add-narrowed-exit-hook! flush-all-ports-no-threads)

(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)
    (newline)
    (display "Usage: scsh [meta-arg] [switch ..] [end-option arg ...]

meta-arg: \\ <script-file-name>

switch:	-e <entry-point>	Specify top-level entry point.
	-o <structure>		Open structure in current package.
	-m <package>		Switch to package.
	-n <new-package>	Switch to new package.


	-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.

end-option:	-s <script>	Specify script.
		-sfd <num>	Script is on file descriptor <num>.
		-c <exp>	Evaluate expression.
		--		Interactive session.
" (current-error-port)))
  (exit -1))