[foo-cvs] foo/elkfoo/scm cmdline.scm,NONE,1.1 initialize.foo,NONE,1.1 Makefile.am,1.5,1.6 toplevel.foo.in,1.7,1.8

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/elkfoo/scm
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv21309

Modified Files:
	Makefile.am toplevel.foo.in 
Added Files:
	cmdline.scm initialize.foo 
Log Message:
refined startup code.  added cmdline: tools for parsing cmdlines e. g. with scripting.  added foo options like --load --unload for packaging support.

Index: Makefile.am
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/scm/Makefile.am,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** Makefile.am	30 Aug 2004 13:45:51 -0000	1.5
--- Makefile.am	3 Feb 2005 15:28:39 -0000	1.6
***************
*** 13,17 ****
--- 13,19 ----
  
  FOO_FILES = \
+ 	initialize.foo \
  	next-compat.foo \
+ 	cmdline.scm \
  	foops.scm \
  	$(NULL)

--- NEW FILE: cmdline.scm ---
;;; -*-Scheme-*-
;;;

;; cmdline.foo
;; command line parsing

;; helper function "multi-assoc" find list entry in associative array
;; while allowing multiple keys (list of keys)
;; uses (equal?) like assoc
(define (cmdline:multi-assoc key array)
  (cond
   ((null? array) #f)
   ((equal? (caar array) key) (car array))
   ((and (list? (caar array)) (member key (caar array))) (car array))
   (else (cmdline:multi-assoc key (cdr array)))))


;; validate cmdline string against optstring
(define (cmdline:cmdline-valid? cmdline opts notify)
  (letrec ((given-valid? ; validate given options
	    (lambda (cmd)
	      (cond
	       ((null? cmd) #t)
	       ((string=? "--" (car cmd)) #t) ; stop on "--"
	       ((and (char=? #\- (string-ref (car cmd) 0)) ; treat "-" as arg
		     (not (string=? "-" (car cmd))))
		(let ((opt (cmdline:multi-assoc (car cmd) opts))) ; option
		  (cond
		   ((not opt) ; option not in optstring
		    (begin
		      (if notify
			  (format #t "(cmdline:validate) unknown option: ~a\n" (car cmd)))
		      #f))
		   ((caddr opt) ; option with param?
		    (if (null? (cdr cmd))
			(begin
			  (if notify
			      (format #t "(cmdline:validate) missing parameter for option: ~a\n" (car opt)))
			  #f) ; opt w/ missing param
			(given-valid? (cddr cmd)))) ; opt w/ param
		   (else (given-valid? (cdr cmd)))))) ; opt w/o param
	       (else
		;; argument
		(given-valid? (cdr cmd))))))

	   ;; build list of non-optional "options"
	   (non-opts
	    (let loop ((opt opts))
	      (cond
	       ((null? opt) '())
	       ((cadar opt) (cons (if (list? (caar opt))
				      (caar opt)
				      (list (caar opt)))
				  (loop (cdr opt))))
	       (else (loop (cdr opt))))))

	    ;; check for presence of non-options
	   (non-opts-present?
	    (lambda (non-opt)
	      (cond
	       ((null? non-opt) #t) ; no more non-opts
	       ((cmdline:option-given? cmdline opts (caar non-opt))
		(non-opts-present? (cdr non-opt)))
	       (else
		(if notify
		    (format #t "(cmdline:validate) mandatory option missing: ~a\n" (caar non-opt)))
		#f)))))

    ;; main
    (if (given-valid? cmdline)
	(non-opts-present? non-opts)
	#f)))


;; get arguments in commandline (exclude options and params)
(define (cmdline:get-arguments cmdline opts)
  (cond
   ((null? cmdline)
    '())
   ((string=? "--" (car cmdline))
    (cdr cmdline))
   ((and (char=? #\- (string-ref (car cmdline) 0))
	     (not (string=? "-" (car cmdline))))
    ;; option
    (let ((opt (cmdline:multi-assoc (car cmdline) opts)))
      (cond
       ((not opt) ; ignore option not being in opts
	(cmdline:get-arguments (cdr cmdline) opts))
       ((caddr opt) ; opt with param
	(if (null? (cdr cmdline))
	    '() ; missing param
	    (cmdline:get-arguments (cddr cmdline) opts))) ; w/ param
       (else (cmdline:get-arguments (cdr cmdline) opts))))) ; w/o param
   (else
    ;; argument
    (cons (car cmdline)
	  (cmdline:get-arguments (cdr cmdline) opts)))))


;; determine whether a specific option was given
(define (cmdline:option-given? cmdline opts option)
  (let loop ((cmd cmdline)
	     (opt (cmdline:multi-assoc option opts))) ; check for alt options
    (cond
     ((null? cmd) #f)			; parse end
     ((string=? "--" (car cmd)) #f)	; -- : options end, arg start
     ((not opt) #f)			; option not in optstring
     ((string=? option (car cmd)) #t)	; direct match
     ((and (list? (car opt)) (member (car cmd) (car opt))) #t) ; alt arg
     (else (loop (cdr cmd) opt)))))


;; get parameter(s) for specific option
(define (cmdline:get-option-param cmdline opts option)
  (let ((tokenize
	 ;; we are using a modified version of (string-tokenize)
	 ;; from parse.scm here (added delim parameter)
	 (lambda (s delim)
	   (let ((i 0) (j)
		 (n (string-length s)))
	     (let loop ((args '()))
	       (while (and (< i n)
			   (char=? delim (string-ref s i)))
		      (set! i (1+ i)))
	       (if (>= i n)
		   (reverse! args)
		   (set! j i)
		   (while (and (< i n)
			       (not (char=? delim (string-ref s i))))
			  (set! i (1+ i)))
		   (loop (cons (substring s j i) args)))))))
	(alt-opts (let ((entry (cmdline:multi-assoc option opts)))
		    (cond
		     ((not entry) '())
		     ((list? (car entry)) (car entry))
		     (else (list (car entry)))))))

    (let loop ((cmd cmdline))
      (cond
       ((null? cmd) '())		; end of cmdline
       ((string=? "--" (car cmd)) '())	; end of options
       ((not (member (car cmd) alt-opts)) (loop (cdr cmd))) ; try next opt
       ((null? (cdr cmd)) '())		; param expected, but EOL
       (else (append (tokenize (cadr cmd) #\,) ; param found
		     (loop (cddr cmd))))))))
	       

;; split command line: return list of 2 lists, the first containing
;; all cmdline contents until the first occurence of arg (excluding
;; arg), the latter the rest of the cmdline (including arg)
(define (cmdline:split cmdline arg)
  (let loop ((rest cmdline)
	     (first '()))
    (cond
     ((null? rest)
      (list (reverse! first) '()))
     ((string=? arg (car rest))
      (list (reverse! first) rest))
     (else
      (loop (cdr rest)
	    (cons (car rest) first))))))


;; format help message from optlist
(define (cmdline:help-message opts)
  (let loop ((opt opts))
    (if (null? opt) ;; recursion done
	"multiple <args>: --opt <arg1> --opt <arg2> or --opt <arg1,arg2,...>\n"
	(let ((cadddar (lambda (l) (car (cdddar l))))
	      (option (string-append
		       "   "
		       (if (list? (caar opt)) ; multiple alt options
			   (string-append
			    (caaar opt)
			    (let loop ((o (cdaar opt)))
			      (if (not (null? o))
				  (string-append
				   ", "
				   (car o)
				   (loop (cdr o)))
				  "")))
			   (caar opt)) ; single option
		       (if (caddar opt)
			   " <args>"
			   ""))))
	  (string-append
	   option
	   (cond
	    ((< (string-length option) 8) "\t\t\t\t")
	    ((< (string-length option) 16) "\t\t\t")
	    ((< (string-length option) 24) "\t\t")
	    (else "\t"))
	   (cadddar opt)
	   "\n"
	   (loop (cdr opt)))))))


(provide 'cmdline)

Index: toplevel.foo.in
===================================================================
RCS file: /cvsroot/foo/foo/elkfoo/scm/toplevel.foo.in,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -d -r1.7 -r1.8
*** toplevel.foo.in	30 Aug 2004 13:44:58 -0000	1.7
--- toplevel.foo.in	3 Feb 2005 15:28:39 -0000	1.8
***************
*** 4,26 ****
  ;; @edited_input@
  
! ;; set load path according to installation
! (begin
!   (define foo-scm-path "@datadir@")
!   (define foo-lib-path "@ELKFOO_LIB_DIR@")
  
!   (define (add-to-load-path path)
!     ;; don't add if not expanded by autoconf
!     (if (> (string-length path) 1)
! 	;; if ./ at the beginning of load-path, keep it there
! 	(if (string=? (car load-path) ".")
! 	    (set! load-path
! 		  (cons (car load-path)
! 			(cons path
! 			      (cdr load-path))))
! 	    (set! load-path
! 		  (cons path load-path)))))
  
!   (add-to-load-path foo-lib-path)
!   (add-to-load-path foo-scm-path))
  
  ;;; requirements
--- 4,32 ----
  ;; @edited_input@
  
! ;; add path to load-path
! (define (foo:add-to-load-path! path)
!   ;; don't add if empty string
!   (if (> (string-length path) 0)
!       ;; if ./ at the beginning of load-path, keep it there
!       (if (or (string=? "." (car load-path))
! 	      (string=? "./" (car load-path)))
! 	  (set! load-path (cons (car load-path)
! 				(cons path (cdr load-path))))
! 	  (set! load-path (cons path load-path)))))
  
! ;; remove path from load-path
! (define (foo:remove-from-load-path! path)
!   (set! load-path (let loop ((path-rest load-path))
! 		    (cond
! 		     ((null? path-rest)
! 		      '())
! 		     ((equal? path (car path-rest))
! 		      (cdr path-rest))
! 		     (else
! 		      (cons (car path-rest) (loop (cdr path-rest))))))))
  
! ;; set load path according to installation
! (foo:add-to-load-path! "@datadir@")
! (foo:add-to-load-path! "@ELKFOO_LIB_DIR@")
  
  ;;; requirements
***************
*** 29,33 ****
  (require 'struct)
  
! (require 'elkfoo) ;; load the foo library
  
  (autoload 'pp 'pp.scm)
--- 35,40 ----
  (require 'struct)
  
! (require 'cmdline) ; load command line tools
! (require 'elkfoo) ; load the foo library
  
  (autoload 'pp 'pp.scm)
***************
*** 39,53 ****
  (autoload 'inspect 'debug.scm)
  
! ;; readline support (depending on environment var)
! (if (string? (getenv "ELK_READLINE"))
!     (if (> (string-length (getenv "ELK_READLINE")) 1)
!         (require 'readline.la)))
  
! (if (feature? 'readline.la)
!     (define foo-prompt-base "foo> "))
  
! ;; foo scripting
! (define foo-script-file "") 
! (define load-foo-script-file #f) 
  
  ;;; Read-eval-print loop and error handler (readline extension support)
--- 46,115 ----
  (autoload 'inspect 'debug.scm)
  
! ;; arg vector for foo main
! (define foo:main-args)
! ;; options uderstood by foo main
! (define foo:main-option-list)
! ;; foo main help screen
! (define foo:main-help)
! ;; arg vector for foo script
! (define foo:script-args)
  
! (let*
!     ;; options understood by foo main startup
!     ((main-option-list '((("--help" "-h") #f #f "this help screen")
! 			 ("--load" #f #t "load package(s) at startup")
! 			 ("--unload" #f #t "do not load package(s) at startup")
! 			 (("--readline" "--rl") #f #f "enable readline extension")
! 			 (("--no-readline" "--no-rl") #f #f "disable readline extension")))
!      (main-args '())
!      (script-args '())
!      (main-help (lambda ()
! 		  (format #t "Usage: foo [foo/elk-options] -- [foo-options] [script-file [script-options]]\nfoo-options understood:\n")
! 		  (format #t "~a\n" (cmdline:help-message main-option-list))
! 		  (exit))))
  
!   (set! foo:main-args (lambda () main-args))
!   (set! foo:main-option-list (lambda () main-option-list))
!   (set! foo:main-help main-help)
!   (set! foo:script-args (lambda () script-args))
! 
!   (set! main-args
! 	(if (null? (command-line-args))
! 	    '()
! 	    (cmdline:split
! 	     (command-line-args)
! 	     (let ((args (cmdline:get-arguments
! 			  (command-line-args) main-option-list)))
! 	       (if (null? args)
! 		   ""
! 		   (car args))))))
!   (if (not (null? main-args))
!       (begin
! 	(set! script-args (cadr main-args))
! 	(set! main-args (car main-args)))))
! 
! (if (not (cmdline:cmdline-valid? (foo:main-args) (foo:main-option-list) #t))
!     (foo:main-help))
! 
! ;; help needed?
! (if (cmdline:option-given? (foo:main-args) (foo:main-option-list) "--help")
!     (foo:main-help))
! 
! ;; readline support?
! (if (cond
!      ((cmdline:option-given?
!        (foo:main-args) (foo:main-option-list) "--no-readline") #f)
!      ((cmdline:option-given?
!        (foo:main-args) (foo:main-option-list) "--readline") #t)
!      ((if (string? (getenv "ELK_READLINE"))
! 	  (cond ((string-ci=? "no" (getenv "ELK_READLINE")) #f)
! 		((string-ci=? "yes" (getenv "ELK_READLINE")) #t)
! 		(else #t))
! 	  #t))
!      (else #t))
!     (require 'readline.la))
! 
! ;; input port for initialization
! (define foo-init-port)
  
  ;;; Read-eval-print loop and error handler (readline extension support)
***************
*** 71,103 ****
  	(display-flush-output dpy))
  
!     (if (feature? 'readline.la)
! 	(if (> rep-level 0)
! 	    (readline-set-prompt (string-append
! 				  (format #f "~a-" rep-level)
! 				  foo-prompt-base))
! 	    (readline-set-prompt foo-prompt-base))
! 	(begin
  	  (if (> rep-level 0)
! 	      (format #t "~a-" rep-level))
! 	  (display "foo> ")))
  
!     (if load-foo-script-file
! 	(begin
! 	  (set! load-foo-script-file #f)
! 	  (load foo-script-file))
! 	(begin
! 	  (if (feature? 'readline.la)
! 	      (set! input (readline-read))
! 	      (set! input (read)))
! 	  (set! & input)
! 	  (if (not (eof-object? input))
! 	      (begin
! 		(set! value (eval input env))
! 		(set! !!! !!)
! 		(set! !! !)
! 		(set! ! value)
! 		(write value)
! 		(newline)
! 		(loop)))))))
  
  (define rep-frames)
--- 133,169 ----
  	(display-flush-output dpy))
  
!     (begin
!       (cond
!        ((input-port? foo-init-port)	; not yet initialized
! 	(set! input (read foo-init-port))) ; read from port
!        ((feature? 'readline.la)		; readline support
! 	(let ((prompt-base "foo> "))
  	  (if (> rep-level 0)
! 	      (readline-set-prompt (string-append
! 				    (format #f "~a-" rep-level)
! 				    prompt-base))
! 	      (readline-set-prompt prompt-base)))
! 	(set! input (readline-read)))
!        (else				; standard reader
! 	(if (> rep-level 0)
! 	    (format #t "~a-" rep-level))
! 	(display "foo> ")
! 	(set! input (read))))
  
!       (set! & input)
!       (if (not (eof-object? input))
! 	  (begin
! 	    (set! value (eval input env))
! 	    (set! !!! !!)
! 	    (set! !! !)
! 	    (set! ! value)
! 	    (if (input-port? foo-init-port)
! 		(begin ; restore normal state and avoid newline
! 		  (close-input-port foo-init-port)
! 		  (set! foo-init-port #f))
! 		(begin
! 		  (write value)
! 		  (newline)))
! 	    (loop))))))
  
  (define rep-frames)
***************
*** 165,182 ****
    (newline)
    (if (feature? 'foo)
!       (if (> (string-length foo-script-file) 0)
! 	  (begin
! 	    (if (bound? 'foo:cleanup)
! 		(foo:cleanup))
! 	    (exit))
! 	  (begin
! 	    (format #t "do you really want to exit foo? [ny] (n): ")
! 	    (if (equal? (read-char) #\y)
! 		(begin
! 		  (format #t "bye~%")
! 		  (if (bound? 'foo:cleanup)
! 		      (foo:cleanup))
! 		  (exit))
! 		(the-top-level))))
        (exit)))
  
--- 231,243 ----
    (newline)
    (if (feature? 'foo)
!       (begin
! 	(format #t "do you really want to exit foo? [ny] (n): ")
! 	(if (equal? (read-char) #\y)
! 	    (begin
! 	      (format #t "bye~%")
! 	      (if (bound? 'foo:cleanup)
! 		  (foo:cleanup))
! 	      (exit))
! 	    (the-top-level)))
        (exit)))
  
***************
*** 189,251 ****
  (define (global-load file)
    (if global-load-notify?
!     (begin
! 	  (display "[Globloading ")
! 	  (display file)
! 	  (display "]")
! 	  (newline)
! 		))
    (load file (global-environment)))
  
! ;; scripting
! (if (not (null? (command-line-args)))
!     (if (file-exists? (car (command-line-args)))
! 	(begin
! 	  (set! foo-script-file (car (command-line-args)))
! 	  (set! load-foo-script-file #t))
! 	(begin
! 	  (format #t "couldn't load foo script ~s\n" (car (command-line-args)))
! 	  (if (bound? 'foo:cleanup)
! 	      (foo:cleanup))
! 	  (exit)))
!     ;; load history (ignore errors)
!     (if (and (feature? 'readline.la) (bound? 'readline-read-history))
! 	(readline-read-history (tilde-expand "~/.foo/foo_history"))))
! 
! ;; std list of initialization files
! (define foo-init-files
!   (list "control/init-tools.foo"
! 	"control/init-control.foo"))
! 
! ;; load init files
! (map load foo-init-files)
! 
! ;; load customization files
! (if (feature? 'elkfoo)
!     (begin
! 
!       ;; system wide defaults
!       (if (file-exists? "/etc/foo/init.foo")
! 	  (load "/etc/foo/init.foo"))
! 
!       ;; user defaults (backwards compat)
!       (if (file-exists? (tilde-expand "~/.initfoo"))
! 	  (load "~/.initfoo"))
!       ;; wd defaults (backwards compat)
!       (if (and (not (string=? (getenv "HOME") (getwd)))
!  	       (file-exists? ".initfoo"))
! 	  (load ".initfoo"))
! 
!       ;; user defaults
!       (if (file-exists? (tilde-expand "~/.foo/init.foo"))
! 	  (load "~/.foo/init.foo"))
!       ;; wd defaults
!       (if (file-exists? ".init.foo")
! 	  (load ".init.foo"))))
! 
! ;;; load init files
! ;(map load foo-init-files)
  
  (provide 'foo)
  
  (the-top-level)
  
--- 250,270 ----
  (define (global-load file)
    (if global-load-notify?
!       (begin
! 	(display "[Globloading ")
! 	(display file)
! 	(display "]")
! 	(newline)
! 	))
    (load file (global-environment)))
  
! ;; load history (ignore errors)
! (if (and (feature? 'readline.la) (bound? 'readline-read-history))
!     (readline-read-history (tilde-expand "~/.foo/foo_history")))
  
  (provide 'foo)
  
+ ;; trigger initialization
+ (set! foo-init-port (open-input-string "(load \"initialize.foo\")"))
+ 
  (the-top-level)
  

--- NEW FILE: initialize.foo ---
;;; -*-Scheme-*-
;;;

;; initialization

(require 'elkfoo)
(require 'cmdline)

(define foo:pre-init-files)
(define foo:set-pre-init-files!) ; this is pointless, when could this be done?
(define foo:load-packages)
(define foo:add-to-load-packages!)
(define foo:remove-from-load-packages!)
(define foo:init-files)
(define foo:set-init-files!)

(let
      ;; defaults (in order of evaluation)
    ((pre-init-files
      (list "/etc/foo/pre-init.foo"	; system wide
	    "~/.foo/pre-init.foo"	; user home
	    "./.pre-init.foo"))		; working dir

     (load-packages
      (list "control"))		; oh happy day...

     (init-files
      (list "/etc/foo/init.foo"	; system wide defaults
	    "~/.foo/init.foo"	; user home defaults
	    "./.init.foo"	; working dir defaults
	    "~/.initfoo"	; user home defaults (backwards compat)
	    "./.initfoo")))	; working dir defaults (backwards compat)

  ;; get pre-init files
  (set! foo:pre-init-files
	(lambda () pre-init-files))

  ;; set pre-init files
  (set! foo:set-pre-init-files!
	(lambda (files)
	  (set! pre-init-files files)))

  ;; get init files
  (set! foo:init-files
	(lambda () init-files))

  ;; set init files
  (set! foo:set-init-files!
	(lambda (files)
	  (set! init-files files)))

  ;; get load-packages
  (set! foo:load-packages
	(lambda () load-packages))

  ;; add package name to set load-packages, if not already there
  (set! foo:add-to-load-packages!
	(lambda (pack)
	  (set! load-packages
		(if (not (member pack load-packages))
		    (cons pack load-packages)
		    load-packages))))

  ;; remove all occurences of package name from set load-packages
  (set! foo:remove-from-load-packages!
	(lambda (pack)
	  (set! load-packages
		(let loop ((pack-rest load-packages))
		  (cond
		   ((null? pack-rest)
		    '())
		   ((equal? pack (car pack-rest))
		    (loop (cdr pack-rest)))
		   (else
		    (cons (car pack-rest) (loop (cdr pack-rest))))))))))


;; load file with existence check
;; not yet optimal, uses (tilde-expand) only
(define (foo:load-file file . notify)
  (if (file-exists? (tilde-expand file))
      (load file)
      (if (and (not (null? notify)) (car notify))
	  (format #t "(foo:load-file ~a) not found\n" file))))

;; load package
(define (foo:load-package pack)
  (let ((file (format #f "~a/init-~a.foo" pack pack)))
    ;; look for file in path
    (if (let loop ((path load-path))
	  (cond ((null? path) #f)
		((file-exists? (string-append (car path) "/" file)) #t)
		(else (loop (cdr path)))))
	(load file)
	(format #t "(foo:load-package ~a) ~a not found\n" pack file))))


;; und ab die post

;; load pre-init files
(map foo:load-file (foo:pre-init-files))

;; prepare load packages
(map foo:add-to-load-packages!
     (cmdline:get-option-param (foo:main-args)
			       (foo:main-option-list)
			       "--load"))
(map foo:remove-from-load-packages!
     (cmdline:get-option-param (foo:main-args)
			       (foo:main-option-list)
			       "--unload"))
;; do it
(map foo:load-package (foo:load-packages))

;; load init files
(map foo:load-file (foo:init-files))

;; what about scripting?
(if (not (null? (foo:script-args)))
    (foo:load-file (car (foo:script-args)) #t))

;; EOF