|
From: Martin R. <ru...@us...> - 2005-02-03 15:28:50
|
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 |