diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..2befb38 --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +*.c +*.o +*.so +*.import.scm +tests/run2 +tests/run diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..beb0060 --- /dev/null +++ b/Makefile @@ -0,0 +1,6 @@ +test-configf: + cd tests && csc run_configf.scm && run_configf + +test-inifile: + cd tests && csc run.scm && ./run + diff --git a/configf/Makefile b/configf/Makefile new file mode 100644 index 0000000..69ea0fb --- /dev/null +++ b/configf/Makefile @@ -0,0 +1,23 @@ +CSCOPTS= + +SRCFILES = common.scm configf.scm run_configf.scm struct-indexer.scm + +OFILES = $(SRCFILES:%.scm=%.o) + +#csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg + +help: + @echo "Makefile targets" + @echo "================" + @echo "make test - run tests" + @echo "make clean - clean up .o's and binaries" + +test: $(OFILES) + csc $(CSCOPTS) $(OFILES) -o run_configf + ./run_configf + +%.o : %.scm + csc $(CSCOPTS) -c $< + +clean: + rm -f *.o test-configf diff --git a/configf/common.scm b/configf/common.scm new file mode 100644 index 0000000..ef500e2 --- /dev/null +++ b/configf/common.scm @@ -0,0 +1,1050 @@ +;;====================================================================== +;; Copyright 2006-2012, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 nanomsg sql-de-lite hostinfo) +(require-extension regex posix) + +(require-extension (srfi 18) extras tcp rpc) + +(import (prefix sqlite3 sqlite3:)) +(import (prefix base64 base64:)) + +(declare (unit common)) + +(include "common_records.scm") + +;; (require-library margs) +;; (include "margs.scm") + +;; (define old-exit exit) +;; +;; (define (exit . code) +;; (if (null? code) +;; (old-exit) +;; (old-exit code))) + +(define getenv get-environment-variable) +(define (safe-setenv key val) + (if (and (string? val)(string? key)) + (handle-exceptions + exn + (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val) + (setenv key val)) + (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val))) + +(define home (getenv "HOME")) +(define user (getenv "USER")) + +;; GLOBAL GLETCHES +(define *db-keys* #f) +(define *configinfo* #f) +(define *configdat* #f) +(define *toppath* #f) +(define *already-seen-runconfig-info* #f) +(define *waiting-queue* (make-hash-table)) +(define *test-meta-updated* (make-hash-table)) +(define *globalexitstatus* 0) ;; attempt to work around possible thread issues +(define *passnum* 0) ;; when running track calls to run-tests or similar +(define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0)) +(define *alt-log-file* #f) ;; used by -log +(define *common:denoise* (make-hash-table)) ;; for low noise printing + +;; DATABASE +(define *dbstruct-db* #f) +(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > +(define *db-stats-mutex* (make-mutex)) +(define *db-sync-mutex* (make-mutex)) +(define *db-multi-sync-mutex* (make-mutex)) +(define *db-local-sync* (make-hash-table)) ;; used to record last touch of db +(define *megatest-db* #f) +(define *last-db-access* (current-seconds)) ;; update when db is accessed via server +(define *db-write-access* #t) +(define *inmemdb* #f) +(define *task-db* #f) ;; (vector db path-to-db) +(define *db-access-allowed* #t) ;; flag to allow access +(define *db-access-mutex* (make-mutex)) + +;; SERVER +(define *my-client-signature* #f) +(define *transport-type* 'http) +(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg +(define *runremote* (make-hash-table)) ;; if set up for server communication this will hold +(define *max-cache-size* 0) +(define *logged-in-clients* (make-hash-table)) +(define *client-non-blocking-mode* #f) +(define *server-id* #f) +(define *server-info* #f) +(define *time-to-exit* #f) +(define *received-response* #f) +(define *default-numtries* 10) +(define *server-run* #t) +(define *run-id* #f) +(define *server-kind-run* (make-hash-table)) + +(define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN +(define *keys* (make-hash-table)) ;; cache the keys here +(define *keyvals* (make-hash-table)) +(define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here +(define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here +(define *test-ids* (make-hash-table)) ;; cache run-id, testname, and item-path => test-id +(define *test-info* (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db + +(define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget + +;; Awful. Please FIXME +(define *env-vars-by-run-id* (make-hash-table)) +(define *current-run-name* #f) + +;; Testconfig and runconfig caches. +(define *testconfigs* (make-hash-table)) ;; test-name => testconfig +(define *runconfigs* (make-hash-table)) ;; target => runconfig + +;; This is a cache of pre-reqs met, don't re-calc in cases where called with same params less than +;; five seconds ago +(define *pre-reqs-met-cache* (make-hash-table)) + +(define (common:clear-caches) + (set! *target* (make-hash-table)) + (set! *keys* (make-hash-table)) + (set! *keyvals* (make-hash-table)) + (set! *toptest-paths* (make-hash-table)) + (set! *test-paths* (make-hash-table)) + (set! *test-ids* (make-hash-table)) + (set! *test-info* (make-hash-table)) + (set! *run-info-cache* (make-hash-table)) + (set! *env-vars-by-run-id* (make-hash-table)) + (set! *test-id-cache* (make-hash-table))) + +;; Generic string database +(define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) +;; Generic path database +(define *fdb* #f) + +;;====================================================================== +;; L O C K E R S A N D B L O C K E R S +;;====================================================================== + +;; block further accesses to databases. Call this before shutting db down +(define (common:db-block-further-queries) + (mutex-lock! *db-access-mutex*) + (set! *db-access-allowed* #f) + (mutex-unlock! *db-access-mutex*)) + +(define (common:db-access-allowed?) + (let ((val (begin + (mutex-lock! *db-access-mutex*) + *db-access-allowed* + (mutex-unlock! *db-access-mutex*)))) + val)) + +;;====================================================================== +;; U S E F U L S T U F F +;;====================================================================== + +(define (common:low-noise-print waitval . keys) + (let* ((key (string-intersperse (map conc keys) "-" )) + (lasttime (hash-table-ref/default *common:denoise* key 0)) + (currtime (current-seconds))) + (if (> (- currtime lasttime) waitval) + (begin + (hash-table-set! *common:denoise* key currtime) + #t) + #f))) + +(define (common:get-megatest-exe) + (or (getenv "MT_MEGATEST") "megatest")) + +(define (common:read-encoded-string instr) + (handle-exceptions + exn + (handle-exceptions + exn + (begin + (debug:print 0 "ERROR: received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port)) + #f) + (read (open-input-string (base64:base64-decode instr)))) + (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) + +;; dot-locking egg seems not to work, using this for now +;; if lock is older than expire-time then remove it and try again +;; to get the lock +;; +(define (common:simple-file-lock fname #!key (expire-time 300)) + (if (file-exists? fname) + (if (> (- (current-seconds)(file-modification-time fname)) expire-time) + (begin + (delete-file* fname) + (common:simple-file-lock fname expire-time: expire-time)) + #f) + (let ((key-string (conc (get-host-name) "-" (current-process-id)))) + (with-output-to-file fname + (lambda () + (print key-string))) + (thread-sleep! 0.25) + (with-input-from-file fname + (lambda () + (equal? key-string (read-line))))))) + +(define (common:simple-file-release-lock fname) + (delete-file* fname)) + +;;====================================================================== +;; S T A T E S A N D S T A T U S E S +;;====================================================================== + +(define *common:std-states* + '((0 "COMPLETED") + (1 "NOT_STARTED") + (2 "RUNNING") + (3 "REMOTEHOSTSTART") + (4 "LAUNCHED") + (5 "KILLED") + (6 "KILLREQ") + (7 "STUCK") + (8 "ARCHIVED"))) + +(define *common:std-statuses* + '((0 "PASS") + (1 "WARN") + (2 "FAIL") + (3 "CHECK") + (4 "n/a") + (5 "WAIVED") + (6 "SKIP") + (7 "DELETED") + (8 "STUCK/DEAD") + (9 "ABORT"))) + +;; These are stopping conditions that prevent a test from being run +(define *common:cant-run-states-sym* + '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE ABORT ARCHIVED)) + +;;====================================================================== +;; D E B U G G I N G S T U F F +;;====================================================================== + +(define *verbosity* 1) +(define *logging* #f) + +(define (get-with-default val default) + (let ((val (args:get-arg val))) + (if val val default))) + +(define (assoc/default key lst . default) + (let ((res (assoc key lst))) + (if res (cadr res)(if (null? default) #f (car default))))) + +(define (common:get-testsuite-name) + (or (configf:lookup *configdat* "setup" "testsuite" ) + (pathname-file *toppath*))) + +;;====================================================================== +;; E X I T H A N D L I N G +;;====================================================================== + +(define (common:legacy-sync-recommended) + (or (args:get-arg "-runtests") + (args:get-arg "-server") + (args:get-arg "-set-run-status") + (args:get-arg "-remove-runs") + (args:get-arg "-get-run-status") + )) + +(define (common:legacy-sync-required) + (configf:lookup *configdat* "setup" "megatest-db")) + +(define (std-exit-procedure) + (let ((no-hurry (if *time-to-exit* ;; hurry up + #f + (begin + (set! *time-to-exit* #t) + #t)))) + (debug:print-info 4 "starting exit process, finalizing databases.") + (if (and no-hurry (debug:debug-mode 18)) + (rmt:print-db-stats)) + (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds + (let ((run-ids (hash-table-keys *db-local-sync*))) + (if (and (not (null? run-ids)) + (configf:lookup *configdat* "setup" "megatest-db")) + (if no-hurry (db:multi-db-sync run-ids 'new2old)))) + (if *dbstruct-db* (db:close-all *dbstruct-db*)) + (if *inmemdb* (db:close-all *inmemdb*)) + (if (and *megatest-db* + (sqlite3:database? *megatest-db*)) + (begin + (sqlite3:interrupt! *megatest-db*) + (sqlite3:finalize! *megatest-db* #t) + (set! *megatest-db* #f))) + (if *task-db* + (let ((db (cdr *task-db*))) + (if (sqlite3:database? db) + (begin + (sqlite3:interrupt! db) + (sqlite3:finalize! db #t) + (vector-set! *task-db* 0 #f)))))) "Cleanup db exit thread")) + (th2 (make-thread (lambda () + (debug:print 4 "Attempting clean exit. Please be patient and wait a few seconds...") + (if no-hurry + (thread-sleep! 5) ;; give the clean up few seconds to do it's stuff + (thread-sleep! 2)) + (debug:print 4 " ... done") + ) + "clean exit"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1)))) + +(define (std-signal-handler signum) + ;; (signal-mask! signum) + (set! *time-to-exit* #t) + (debug:print 0 "ERROR: Received signal " signum " exiting promptly") + ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway + (exit)) + +(set-signal-handler! signal/int std-signal-handler) ;; ^C +(set-signal-handler! signal/term std-signal-handler) +(set-signal-handler! signal/stop std-signal-handler) ;; ^Z + +;;====================================================================== +;; M I S C U T I L S +;;====================================================================== + +;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 +(define (common:hms-string->seconds tstr) + (let ((parts (string-split tstr)) + (time-secs 0) + ;; s=seconds, m=minutes, h=hours, d=days + (trx (regexp "(\\d+)([smhd])"))) + (for-each (lambda (part) + (let ((match (string-match trx part))) + (if match + (let ((val (string->number (cadr match))) + (unt (caddr match))) + (if val + (set! time-secs (+ time-secs (* val + (case (string->symbol unt) + ((s) 1) + ((m) 60) + ((h) (* 60 60)) + ((d) (* 24 60 60)) + (else 0)))))))))) + parts) + time-secs)) + +(define (common:version-signature) + (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) + +;; one-of args defined +(define (args-defined? . param) + (let ((res #f)) + (for-each + (lambda (arg) + (if (args:get-arg arg)(set! res #t))) + param) + res)) + +;; convert stuff to a number if possible +(define (any->number val) + (cond + ((number? val) val) + ((string? val) (string->number val)) + ((symbol? val) (any->number (symbol->string val))) + (else #f))) + +(define (any->number-if-possible val) + (let ((num (any->number val))) + (if num num val))) + +(define (patt-list-match item patts) + (debug:print-info 8 "patt-list-match item=" item " patts=" patts) + (if (and item patts) ;; here we are filtering for matches with item patterns + (let ((res #f)) ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is % + (for-each + (lambda (patt) + (let ((modpatt (string-substitute "%" ".*" patt #t))) + (debug:print-info 10 "patt " patt " modpatt " modpatt) + (if (string-match (regexp modpatt) item) + (set! res #t)))) + (string-split patts ",")) + res) + #t)) + +;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) +(define (common:get-runconfig-targets #!key (configf #f)) + (sort (map car (hash-table->alist + (or configf + (read-config "runconfigs.config" + #f #t)))) + string (length lista)(length listb)) + #f + (let loop ((heda (car lista)) + (tala (cdr lista)) + (hedb (car listb)) + (talb (cdr listb))) + (if (equal? heda hedb) + (if (null? tala) ;; we are done + talb + (loop (car tala) + (cdr tala) + (car talb) + (cdr talb))) + #f))))) + +;; Needed for long lists to be sorted where (apply max ... ) dies +;; +(define (common:max inlst) + (let loop ((max-val (car inlst)) + (hed (car inlst)) + (tal (cdr inlst))) + (if (not (null? tal)) + (loop (max hed max-val) + (car tal) + (cdr tal)) + (max hed max-val)))) + + +;;====================================================================== +;; Munge data into nice forms +;;====================================================================== + +;; Generate an index for a sparse list of key values +;; ( (rowname1 colname1 val1)(rowname2 colname2 val2) ) +;; +;; => +;; +;; ( (rowname1 0)(rowname2 1)) ;; rownames -> num +;; (colname1 0)(colname2 1)) ) ;; colnames -> num +;; +;; optional apply proc to rownum colnum value +(define (common:sparse-list-generate-index data #!key (proc #f)) + (if (null? data) + (list '() '()) + (let loop ((hed (car data)) + (tal (cdr data)) + (rownames '()) + (colnames '()) + (rownum 0) + (colnum 0)) + (let* ((rowkey (car hed)) + (colkey (cadr hed)) + (value (caddr hed)) + (existing-rowdat (assoc rowkey rownames)) + (existing-coldat (assoc colkey colnames)) + (curr-rownum (if existing-rowdat rownum (+ rownum 1))) + (curr-colnum (if existing-coldat colnum (+ colnum 1))) + (new-rownames (if existing-rowdat rownames (cons (list rowkey curr-rownum) rownames))) + (new-colnames (if existing-coldat colnames (cons (list colkey curr-colnum) colnames)))) + ;; (debug:print-info 0 "Processing record: " hed ) + (if proc (proc curr-rownum curr-colnum rowkey colkey value)) + (if (null? tal) + (list new-rownames new-colnames) + (loop (car tal) + (cdr tal) + new-rownames + new-colnames + (if (> curr-rownum rownum) curr-rownum rownum) + (if (> curr-colnum colnum) curr-colnum colnum) + )))))) + +;;====================================================================== +;; System stuff +;;====================================================================== + +;; return a nice clean pathname made absolute +(define (nice-path dir) + (normalize-pathname (if (absolute-pathname? dir) + dir + (conc (current-directory) "/" dir)))) + +(define (get-cpu-load) + (car (common:get-cpu-load))) +;; (let* ((load-res (cmd-run->list "uptime")) +;; (load-rx (regexp "load average:\\s+(\\d+)")) +;; (cpu-load #f)) +;; (for-each (lambda (l) +;; (let ((match (string-search load-rx l))) +;; (if match +;; (let ((newval (string->number (cadr match)))) +;; (if (number? newval) +;; (set! cpu-load newval)))))) +;; (car load-res)) +;; cpu-load)) + +;; get cpu load by reading from /proc/loadavg, return all three values +;; +(define (common:get-cpu-load) + (with-input-from-file "/proc/loadavg" + (lambda ()(list (read)(read)(read))))) + +(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000)) + (let* ((loadavg (common:get-cpu-load)) + (first (car loadavg)) + (next (cadr loadavg)) + (adjload (* maxload numcpus)) + (loadjmp (- first next))) + (cond + ((and (> first adjload) + (> count 0)) + (debug:print-info 0 "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload) + (thread-sleep! waitdelay) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))) + ((and (> loadjmp numcpus) + (> count 0)) + (debug:print-info 0 "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus) + (thread-sleep! waitdelay) + (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))))) + +(define (common:get-num-cpus) + (with-input-from-file "/proc/cpuinfo" + (lambda () + (let loop ((numcpu 0) + (inl (read-line))) + (if (eof-object? inl) + numcpu + (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl) + (+ numcpu 1) + numcpu) + (read-line))))))) + +(define (get-uname . params) + (let* ((uname-res (cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) + (uname #f)) + (if (null? (car uname-res)) + "unknown" + (caar uname-res)))) + +;; for reasons I don't understand multiple calls to real-path in parallel threads +;; must be protected by mutexes +;; +(define (common:real-path inpath) + ;; (cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params) + ;; (let-values + ;; (((inp oup pid) (process "readlink" (list "-f" inpath)))) + ;; (with-input-from-port inp + ;; (let loop ((inl (read-line)) + ;; (res #f)) + ;; (print "inl=" inl) + ;; (if (eof-object? inl) + ;; (begin + ;; (close-input-port inp) + ;; (close-output-port oup) + ;; ;; (process-wait pid) + ;; res) + ;; (loop (read-line) inl)))))) + (with-input-from-pipe (conc "readlink -f " inpath) read-line)) + +;;====================================================================== +;; D I S K S P A C E +;;====================================================================== + +(define (common:get-disk-space-used fpath) + (with-input-from-pipe (conc "/usr/bin/du -s " fpath) read)) + +(define (get-df path) + (let* ((df-results (cmd-run->list (conc "df " path))) + (space-rx (regexp "([0-9]+)\\s+([0-9]+)%")) + (freespc #f)) + ;; (write df-results) + (for-each (lambda (l) + (let ((match (string-search space-rx l))) + (if match + (let ((newval (string->number (cadr match)))) + (if (number? newval) + (set! freespc newval)))))) + (car df-results)) + freespc)) + +;; paths is list of lists ((name path) ... ) +;; +(define (common:get-disk-with-most-free-space disks minsize) + (let ((best #f) + (bestsize 0)) + (for-each + (lambda (disk-num) + (let* ((dirpath (cadr (assoc disk-num disks))) + (freespc (cond + ((not (directory? dirpath)) + (if (common:low-noise-print 50 "disks not a dir " disk-num) + (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a directory - ignoring it.")) + -1) + ((not (file-write-access? dirpath)) + (if (common:low-noise-print 50 "disks not writeable " disk-num) + (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not writeable - ignoring it.")) + -1) + ((not (eq? (string-ref dirpath 0) #\/)) + (if (common:low-noise-print 50 "disks not a proper path " disk-num) + (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a fully qualified path - ignoring it.")) + -1) + (else + (get-df dirpath))))) + (if (> freespc bestsize) + (begin + (set! best (cons disk-num dirpath)) + (set! bestsize freespc))))) + (map car disks)) + (if (and best (> bestsize minsize)) + best + #f))) ;; #f means no disk candidate found + +;;====================================================================== +;; E N V I R O N M E N T V A R S +;;====================================================================== + +(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES"))) + (let ((envvars (get-environment-variables)) + (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]"))) + (with-output-to-file (conc fname ".csh") + (lambda () + (for-each (lambda (keyval) + (let* ((key (car keyval)) + (val (cdr keyval)) + (delim (if (string-search whitesp val) + "\"" + ""))) + (print (if (member key ignorevars) + "# setenv " + "setenv ") + key " " delim val delim))) + envvars))) + (with-output-to-file (conc fname ".sh") + (lambda () + (for-each (lambda (keyval) + (let* ((key (car keyval)) + (val (cdr keyval)) + (delim (if (string-search whitesp val) + "\"" + ""))) + (print (if (member key ignorevars) + "# export " + "export ") + key "=" delim val delim))) + envvars))))) + +;; set some env vars from an alist, return an alist with original values +;; (("VAR" "value") ...) +(define (alist->env-vars lst) + (if (list? lst) + (let ((res '())) + (for-each (lambda (p) + (let* ((var (car p)) + (val (cadr p)) + (prv (get-environment-variable var))) + (set! res (cons (list var prv) res)) + (if val + (setenv var (->string val)) + (unsetenv var)))) + lst) + res) + '())) + +;; clear vars matching pattern, run proc, set vars back +;; if proc is a string run that string as a command with +;; system. +;; +(define (common:without-vars proc . var-patts) + (let ((vars (make-hash-table))) + (for-each + (lambda (vardat) ;; each env var + (for-each + (lambda (var-patt) + (if (string-match var-patt (car vardat)) + (let ((var (car vardat)) + (val (cdr vardat))) + (hash-table-set! vars var val) + (unsetenv var)))) + var-patts)) + (get-environment-variables)) + (cond + ((string? proc)(system proc)) + (proc (proc))) + (hash-table-for-each + vars + (lambda (var val) + (setenv var val))) + vars)) + +;;====================================================================== +;; time and date nice to have stuff +;;====================================================================== + +(define (seconds->hr-min-sec secs) + (let* ((hrs (quotient secs 3600)) + (min (quotient (- secs (* hrs 3600)) 60)) + (sec (- secs (* hrs 3600)(* min 60)))) + (conc (if (> hrs 0)(conc hrs "hr ") "") + (if (> min 0)(conc min "m ") "") + sec "s"))) + +(define (seconds->time-string sec) + (time->string + (seconds->local-time sec) "%H:%M:%S")) + +(define (seconds->work-week/day-time sec) + (time->string + (seconds->local-time sec) "ww%V.%u %H:%M")) + +(define (seconds->work-week/day sec) + (time->string + (seconds->local-time sec) "ww%V.%u")) + +(define (seconds->year-work-week/day sec) + (time->string + (seconds->local-time sec) "%yww%V.%w")) + +(define (seconds->year-work-week/day-time sec) + (time->string + (seconds->local-time sec) "%yww%V.%w %H:%M")) + +(define (seconds->quarter sec) + (case (string->number + (time->string + (seconds->local-time sec) + "%m")) + ((1 2 3) 1) + ((4 5 6) 2) + ((7 8 9) 3) + ((10 11 12) 4) + (else #f))) + +;;====================================================================== +;; Colors +;;====================================================================== + +(define (common:name->iup-color name) + (case (string->symbol (string-downcase name)) + ((red) "223 33 49") + ((grey) "192 192 192") + ((orange) "255 172 13") + ((purple) "This is unfinished ..."))) + +;; (define (common:get-color-for-state-status state status) +;; (case (string->symbol state) +;; ((COMPLETED) +;; (case (string->symbol status) +;; ((PASS) "70 249 73") +;; ((WARN WAIVED) "255 172 13") +;; ((SKIP) "230 230 0") +;; (else "223 33 49"))) +;; ((LAUNCHED) "101 123 142") +;; ((CHECK) "255 100 50") +;; ((REMOTEHOSTSTART) "50 130 195") +;; ((RUNNING) "9 131 232") +;; ((KILLREQ) "39 82 206") +;; ((KILLED) "234 101 17") +;; ((NOT_STARTED) "240 240 240") +;; (else "192 192 192"))) + +(define (common:get-color-from-status status) + (cond + ((equal? status "PASS") "green") + ((equal? status "FAIL") "red") + ((equal? status "WARN") "orange") + ((equal? status "KILLED") "orange") + ((equal? status "KILLREQ") "purple") + ((equal? status "RUNNING") "blue") + ((equal? status "ABORT") "brown") + (else "black"))) + +;;====================================================================== +;; N A N O M S G C L I E N T +;;====================================================================== + +(define (server:get-best-guess-address hostname) + (let ((res #f)) + (for-each + (lambda (adr) + (if (not (eq? (u8vector-ref adr 0) 127)) + (set! res adr))) + ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME + (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) + (string-intersperse + (map number->string + (u8vector->list + (if res res (hostname->ip hostname)))) "."))) + +(define (common:open-nm-req addr) + (let* ((req (nn-socket 'req)) + (res (nn-connect req addr))) + req)) + +;; (with-output-to-string (lambda ()(serialize obj))) +(define (common:nm-send-receive soc msg) + (nn-send soc msg) + (nn-recv soc)) + +(define (common:close-nm-req soc) + (nn-close soc)) + +(define (common:send-dboard-main-changed) + (let* ((dashboard-ips (mddb:get-dashboards))) + (for-each + (lambda (ipadr) + (let* ((soc (common:open-nm-req (conc "tcp://" ipadr))) + (msg (conc "main " *toppath*)) + (res (common:nm-send-receive-timeout soc msg))) + (if (not res) ;; couldn't reach that dashboard - remove it from db + (print "ERROR: couldn't reach dashboard " ipadr)) + res)) + dashboard-ips))) + +(define (common:nm-send-receive-timeout req msg) + (let* ((key "ping") + (success #f) + (keepwaiting #t) + (result #f) + (sendrec (make-thread + (lambda () + (nn-send req msg) + (set! result (nn-recv req)) + (set! success #t)) + "send-receive")) + (timeout (make-thread (lambda () + (let loop ((count 0)) + (thread-sleep! 1) + (print "still waiting after count seconds...") + (if (and keepwaiting (< count 10)) + (loop (+ count 1)))) + (if keepwaiting + (begin + (print "timeout waiting for reply") + (thread-terminate! sendrec)))) + "timeout"))) + (handle-exceptions + exn + (begin + (print-call-chain) + (print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn))) + (thread-start! timeout) + (thread-start! sendrec) + (thread-join! sendrec) + (if success (thread-terminate! timeout))) + result)) + +(define (common:ping-nm req) + ;; send a random number and check that we get it back + (let* ((key "ping") + (success #f) + (keepwaiting #t) + (ping (make-thread + (lambda () + (print "ping: sending string \"" key "\", expecting " (current-process-id)) + (nn-send req key) + (let ((result (nn-recv req))) + (if (equal? (conc (current-process-id)) result) + (begin + (print "ping, success: received \"" result "\"") + (set! success #t)) + (begin + (print "ping, failed: received key \"" result "\"") + (set! keepwaiting #f) + (set! success #f))))) + "ping")) + (timeout (make-thread (lambda () + (let loop ((count 0)) + (thread-sleep! 1) + (print "still waiting after count seconds...") + (if (and keepwaiting (< count 10)) + (loop (+ count 1)))) + (if keepwaiting + (begin + (print "timeout waiting for ping") + (thread-terminate! ping)))) + "timeout"))) + (handle-exceptions + exn + (begin + (print-call-chain) + (print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (print "exn=" (condition->list exn)) + (print "ping failed to connect to tcp://" hostport)) + (thread-start! timeout) + (thread-start! ping) + (thread-join! ping) + (if success (thread-terminate! timeout))) + (if return-socket + (if success req #f) + (begin + (nn-close req) + success)))) + +;;====================================================================== +;; D A S H B O A R D D B +;;====================================================================== + +(define (mddb:open-db) + (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db")))) + (set-busy-handler! db (busy-timeout 10000)) + (for-each + (lambda (qry) + (exec (sql db qry))) + (list + "CREATE TABLE IF NOT EXISTS vars (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));" + "CREATE TABLE IF NOT EXISTS dashboards ( + id INTEGER PRIMARY KEY, + pid INTEGER, + username TEXT, + hostname TEXT, + ipaddr TEXT, + portnum INTEGER, + start_time TIMESTAMP DEFAULT (strftime('%s','now')), + CONSTRAINT hostport UNIQUE (hostname,portnum) + );" + )) + db)) + +;; register a dashboard +;; +(define (mddb:register-dashboard port) + (let* ((pid (current-process-id)) + (hostname (get-host-name)) + (ipaddr (server:get-best-guess-address hostname)) + (username (current-user-name)) ;; (car userinfo))) + (db (mddb:open-db))) + (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username) + (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);") + pid username hostname ipaddr port) + (close-database db))) + +;; unregister a monitor +;; +(define (mddb:unregister-dashboard host port) + (let* ((db (mddb:open-db))) + (print "Register unregister monitor, host:port=" host ":" port) + (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port) + (close-database db))) + +;; get registered dashboards +;; +(define (mddb:get-dashboards) + (let ((db (mddb:open-db))) + (query fetch-column + (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;")))) + +;;====================================================================== +;; T E S T L A U N C H I N G P E R I T E M W I T H H O S T T Y P E S +;;====================================================================== +;; +;; [host-types] +;; general ssh #{getbgesthost general} +;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo +;; +;; [hosts] +;; general cubian xena +;; +;; [launchers] +;; envsetup general +;; xor/%/n 4C16G +;; % nbgeneral +;; +;; [jobtools] +;; launcher bsub +;; # if defined and not "no" flexi-launcher will bypass launcher unless there is no +;; # match. +;; flexi-launcher yes + +(define (common:get-launcher configdat testname itempath) + (let ((fallback-launcher (configf:lookup configdat "jobtools" "launcher"))) + (if (and (configf:lookup configdat "jobtools" "flexi-launcher") ;; overrides launcher + (not (equal? (configf:lookup configdat "jobtools" "flexi-launcher") "no"))) + (let* ((launchers (hash-table-ref/default configdat "launchers" '()))) + (if (null? launchers) + fallback-launcher + (let loop ((hed (car launchers)) + (tal (cdr launchers))) + (let ((patt (car hed)) + (host-type (cadr hed))) + (if (tests:match patt testname itempath) + (begin + (debug:print-info 0 "Have flexi-launcher match for " testname "/" itempath " = " host-type) + (let ((launcher (configf:lookup configdat "host-types" host-type))) + (if launcher + launcher + (begin + (debug:print-info 0 "WARNING: no launcher found for host-type " host-type) + (if (null? tal) + fallback-launcher + (loop (car tal)(cdr tal))))))) + ;; no match, try again + (if (null? tal) + fallback-launcher + (loop (car tal)(cdr tal)))))))) + fallback-launcher))) + diff --git a/configf/common_records.scm b/configf/common_records.scm new file mode 100644 index 0000000..cf0caa9 --- /dev/null +++ b/configf/common_records.scm @@ -0,0 +1,110 @@ +;;====================================================================== +;; Copyright 2006-2012, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +;; (use trace) + +;; Some of these routines use: +;; +;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html +;; +;; Syntax for defining macros in a simple style similar to function definiton, +;; when there is a single pattern for the argument list and there are no keywords. +;; +;; (define-simple-syntax (name arg ...) body ...) +;; + +(define-syntax define-simple-syntax + (syntax-rules () + ((_ (name arg ...) body ...) + (define-syntax name (syntax-rules () ((name arg ...) (begin body ...))))))) + +(define-syntax common:handle-exceptions + (syntax-rules () + ((_ exn-in errstmt ...)(handle-exceptions exn-in errstmt ...)))) + +(define (debug:calc-verbosity vstr) + (cond + ((number? vstr) vstr) + ((not (string? vstr)) 1) + ;; ((string-match "^\\s*$" vstr) 1) + (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) + (cond + ((> (length debugvals) 1) debugvals) + ((> (length debugvals) 0)(car debugvals)) + (else 1)))) + ((args:get-arg "-v") 2) + ((args:get-arg "-q") 0) + (else 1))) + +;; check verbosity, #t is ok +(define (debug:check-verbosity verbosity vstr) + (if (not (or (number? verbosity) + (list? verbosity))) + (begin + (print "ERROR: Invalid debug value \"" vstr "\"") + #f) + #t)) + +(define (debug:debug-mode n) + (cond + ((and (number? *verbosity*) ;; number number + (number? n)) + (<= n *verbosity*)) + ((and (list? *verbosity*) ;; list number + (number? n)) + (member n *verbosity*)) + ((and (list? *verbosity*) ;; list list + (list? n)) + (not (null? (lset-intersection! eq? *verbosity* n)))) + ((and (number? *verbosity*) + (list? n)) + (member *verbosity* n)))) + +(define (debug:setup) + (let ((debugstr (or (args:get-arg "-debug") + (getenv "MT_DEBUG_MODE")))) + (set! *verbosity* (debug:calc-verbosity debugstr)) + (debug:check-verbosity *verbosity* debugstr) + ;; if we were handed a bad verbosity rule then we will override it with 1 and continue + (if (not *verbosity*)(set! *verbosity* 1)) + (if (or (args:get-arg "-debug") + (not (getenv "MT_DEBUG_MODE"))) + (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) + (string-intersperse (map conc *verbosity*) ",") + (conc *verbosity*)))))) + + +(define (debug:print n . params) + (if (debug:debug-mode n) + (with-output-to-port (current-error-port) + (lambda () + (if *logging* + (db:log-event (apply conc params)) + ;; (apply print "pid:" (current-process-id) " " params) + (apply print params) + ))))) + +(define (debug:print-info n . params) + (if (debug:debug-mode n) + (with-output-to-port (current-error-port) + (lambda () + (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) + (if *logging* + (db:log-event res) + ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) + (apply print "INFO: (" n ") " params) ;; res) + )))))) + +;; if a value is printable (i.e. string or number) return the value +;; else return an empty string +(define-inline (printable val) + (if (or (number? val)(string? val)) val "")) + diff --git a/configf/configf.scm b/configf/configf.scm new file mode 100644 index 0000000..7bbfa43 --- /dev/null +++ b/configf/configf.scm @@ -0,0 +1,542 @@ +;;====================================================================== +;; Copyright 2006-2012, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +;;====================================================================== +;; Config file handling +;;====================================================================== + +(use regex regex-case directory-utils) +(declare (unit configf)) + + + + +(declare (uses common)) +;;(declare (uses process)) + +(include "common_records.scm") + +;; return list (path fullpath configname) +(define (find-config configname #!key (toppath #f)) + (if toppath + (let ((cfname (conc toppath "/" configname))) + (if (file-exists? cfname) + (list toppath cfname configname) + (list #f #f #f))) + (let* ((cwd (string-split (current-directory) "/"))) + (let loop ((dir cwd)) + (let* ((path (conc "/" (string-intersperse dir "/"))) + (fullpath (conc path "/" configname))) + (if (file-exists? fullpath) + (list path fullpath configname) + (let ((remcwd (take dir (- (length dir) 1)))) + (if (null? remcwd) + (list #f #f #f) ;; #f #f) + (loop remcwd))))))))) + +(define (config:assoc-safe-add alist key val) + (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) + (append newalist (list (list key val))))) + +(define (config:eval-string-in-environment str) + (let ((cmdres (cmd-run->list (conc "echo " str)))) + (if (null? cmdres) "" + (caar cmdres)))) + +;;====================================================================== +;; Make the regexp's needed globally available +;;====================================================================== + +(define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) +(define configf:section-rx (regexp "^\\[(.*)\\]\\s*$")) +(define configf:blank-l-rx (regexp "^\\s*$")) +(define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) +(define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$")) +(define configf:key-no-val (regexp "^(\\S+)(\\s*)$")) +(define configf:comment-rx (regexp "^\\s*#.*")) +(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")) +(define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$")) + +;; read a line and process any #{ ... } constructs + +(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget)\\s+([^\\}\\{]*)\\}(.*)")) +(define (configf:process-line l ht allow-system) + (let loop ((res l)) + (if (string? res) + (let ((matchdat (string-search configf:var-expand-regex res))) + (if matchdat + (let* ((prestr (list-ref matchdat 1)) + (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv + (cmd (list-ref matchdat 3)) + (poststr (list-ref matchdat 4)) + (result #f) + (fullcmd (case (string->symbol cmdtype) + ((scheme)(conc "(lambda (ht)" cmd ")")) + ((system)(conc "(lambda (ht)(system \"" cmd "\"))")) + ((shell) (conc "(lambda (ht)(shell \"" cmd "\"))")) + ((getenv)(conc "(lambda (ht)(get-environment-variable \"" cmd "\"))")) + ((get) + (let* ((parts (string-split cmd)) + (sect (car parts)) + (var (cadr parts))) + (conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))"))) + ((runconfigs-get) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) + ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) + (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) + ;; (print "fullcmd=" fullcmd) + (handle-exceptions + exn + (debug:print 0 "ERROR: failed to process config input \"" l "\"") + (if (or allow-system + (not (member cmdtype '("system" "shell")))) + (with-input-from-string fullcmd + (lambda () + (set! result ((eval (read)) ht)))) + (set! result (conc "#{(" cmdtype ") " cmd "}")))) + (loop (conc prestr result poststr))) + res)) + res))) + +;; Run a shell command and return the output as a string +(define (shell cmd) + (let* ((output (cmd-run->list cmd)) + (res (car output)) + (status (cadr output))) + (if (equal? status 0) + (let ((outres (string-intersperse + res + "\n"))) + (debug:print-info 4 "shell result:\n" outres) + outres) + (begin + (with-output-to-port (current-error-port) + (lambda () + (print "ERROR: " cmd " returned bad exit code " status))) + "")))) + +;; Lookup a value in runconfigs based on -reqtarg or -target +(define (runconfigs-get config var) + (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) + (if targ + (or (configf:lookup config targ var) + (configf:lookup config "default" var)) + (configf:lookup config "default" var)))) + +;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ... +;; +(define (configf:read-line p ht allow-processing settings) + (let loop ((inl (read-line p))) + (let ((cont-line (and (string? inl) + (not (string-null? inl)) + (equal? "\\" (string-take-right inl 1))))) + (if cont-line ;; last character is \ + (let ((nextl (read-line p))) + (if (not (eof-object? nextl)) + (loop (string-append (if cont-line + (string-take inl (- (string-length inl) 1)) + inl) + nextl)))) + (let ((res (case allow-processing ;; if (and allow-processing + ;; (not (eq? allow-processing 'return-string))) + ((#t #f) + (configf:process-line inl ht allow-processing)) + ((return-string) + inl) + (else + (configf:process-line inl ht allow-processing))))) + (if (and (string? res) + (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no"))) + (string-substitute "\\s+$" "" res) + res)))))) + +;; read a config file, returns hash table of alists + +;; read a config file, returns hash table of alists +;; adds to ht if given (must be #f otherwise) +;; envion-patt is a regex spec that identifies sections that will be eval'd +;; in the environment on the fly +;; sections: #f => get all, else list of sections to gather +(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)(settings (make-hash-table))) + (debug:print-info 5 "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory)) + (debug:print 9 "START: " path) + (if (not (file-exists? path)) + (begin + (debug:print-info 1 "read-config - file not found " path " current path: " (current-directory)) + ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read? + #f) ;; (if (not ht)(make-hash-table) ht)) + (let ((inp (open-input-file path)) + (res (if (not ht)(make-hash-table) ht))) + (let loop ((inl (configf:read-line inp res allow-system settings)) ;; (read-line inp)) + (curr-section-name (if curr-section curr-section "default")) + (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere + (lead #f)) + (debug:print-info 8 "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") + (if (eof-object? inl) + (begin + (close-input-port inp) + (hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht + (debug:print 9 "END: " path) + res) + (regex-case + inl + (configf:comment-rx _ (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)) + (configf:blank-l-rx _ (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)) + (configf:settings ( x setting val ) (begin + (hash-table-set! settings setting val) + (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))) + (configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path)) + (full-conf (if (absolute-pathname? include-file) + include-file + (nice-path + (conc (if curr-conf-dir + curr-conf-dir + ".") + "/" include-file))))) + (if (file-exists? full-conf) + (begin + ;; (push-directory conf-dir) + (debug:print 9 "Including: " full-conf) + (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings) + ;; (pop-directory) + (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)) + (begin + (debug:print '(2 9) "INFO: include file " include-file " not found (called from " path ")") + (debug:print 2 " " full-conf) + (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))))) + (configf:section-rx ( x section-name ) (loop (configf:read-line inp res allow-system settings) + ;; if we have the sections list then force all settings into "" and delete it later? + (if (or (not sections) + (member section-name sections)) + section-name "") ;; stick everything into "" + #f #f)) + (configf:key-sys-pr ( x key cmd ) (if allow-system + (let ((alist (hash-table-ref/default res curr-section-name '())) + (val-proc (lambda () + (let* ((cmdres (cmd-run->list cmd)) + (status (cadr cmdres)) + (res (car cmdres))) + (debug:print-info 4 "" inl "\n => " (string-intersperse res "\n")) + (if (not (eq? status 0)) + (begin + (debug:print 0 "ERROR: problem with " inl ", return code " status + " output: " cmdres) + (exit 1))) + (if (null? res) + "" + (string-intersperse res " ")))))) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist + key + (case allow-system + ((return-procs) val-proc) + ((return-string) cmd) + (else (val-proc))))) + (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)) + (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))) + (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '())) + (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) + (realval (if envar + (config:eval-string-in-environment val) + val))) + (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) + (if envar (safe-setenv key realval)) + (debug:print 10 " setting: [" curr-section-name "] " key " = " val) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key realval)) + (loop (configf:read-line inp res allow-system settings) curr-section-name key #f))) + (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '()))) + (debug:print 10 " setting: [" curr-section-name "] " key " = #t") + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key #t)) + (loop (configf:read-line inp res allow-system settings) curr-section-name key #f))) + ;; if a continued line + (configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) + (if var-flag ;; if set to a string then we have a continued var + (let ((newval (conc + (config-lookup res curr-section-name var-flag) "\n" + ;; trim lead from the incoming whsp to support some indenting. + (if lead + (string-substitute (regexp lead) "" whsp) + "") + val))) + ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist var-flag newval)) + (loop (configf:read-line inp res allow-system settings) curr-section-name var-flag (if lead lead whsp))) + (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)))) + (else (debug:print 0 "ERROR: problem parsing " path ",\n \"" inl "\"") + (set! var-flag #f) + (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)))))))) + +;; pathenvvar will set the named var to the path of the config +(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)) + (let* ((curr-dir (current-directory)) + (configinfo (find-config fname toppath: given-toppath)) + (toppath (car configinfo)) + (configfile (cadr configinfo))) + (if toppath (change-directory toppath)) + (if (and toppath pathenvvar)(setenv pathenvvar toppath)) + (let ((configdat (if configfile (read-config configfile #f #t environ-patt: environ-patt) #f))) ;; (make-hash-table)))) + (if toppath (change-directory curr-dir)) + (list configdat toppath configfile fname)))) + +(define (config-lookup cfgdat section var) + (if (hash-table? cfgdat) + (let ((sectdat (hash-table-ref/default cfgdat section '()))) + (if (null? sectdat) + #f + (let ((match (assoc var sectdat))) + (if match ;; (and match (list? match)(> (length match) 1)) + (cadr match) + #f)) + )) + #f)) + +(define configf:lookup config-lookup) +(define configf:read-file read-config) + +(define (configf:section-vars cfgdat section) + (let ((sectdat (hash-table-ref/default cfgdat section '()))) + (if (null? sectdat) + '() + (map car sectdat)))) + +(define (configf:get-section cfgdat section) + (hash-table-ref/default cfgdat section '())) + +;;(define (setup) +;; (let* ((configf (find-config)) +;; (config (if configf (read-config configf #f #t) #f))) +;; (if config +;; (setenv "RUN_AREA_HOME" (pathname-directory configf))) +;; config)) + +;;====================================================================== +;; Non destructive writing of config file +;;====================================================================== + +(define (configf:compress-multi-lines fdat) + ;; step 1.5 - compress any continued lines + (if (null? fdat) fdat + (let loop ((hed (car fdat)) + (tal (cdr fdat)) + (cur "") + (led #f) + (res '())) + ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!! + ;; 1. remove led whitespace + ;; 2. tack on to hed with "\n" + (let ((match (string-match configf:cont-ln-rx hed))) + (if match ;; blast! have to deal with a multiline + (let* ((lead (cadr match)) + (lval (caddr match)) + (newl (conc cur "\n" lval))) + (if (not led)(set! led lead)) + (if (null? tal) + (set! fdat (append fdat (list newl))) + (loop (car tal)(cdr tal) newl led res))) ;; NB// not tacking newl onto res + (let ((newres (if led + (append res (list cur hed)) + (append res (list hed))))) + ;; prev was a multiline + (if (null? tal) + newres + (loop (car tal)(cdr tal) "" #f newres)))))))) + +;; note: I'm cheating a little here. I merely replace "\n" with "\n " +(define (configf:expand-multi-lines fdat) + ;; step 1.5 - compress any continued lines + (if (null? fdat) fdat + (let loop ((hed (car fdat)) + (tal (cdr fdat)) + (res '())) + (let ((newres (append res (list (string-substitute (regexp "\n") "\n " hed #t))))) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres)))))) + +(define (configf:file->list fname) + (if (file-exists? fname) + (let ((inp (open-input-file fname))) + (let loop ((inl (read-line inp)) + (res '())) + (if (eof-object? inl) + (begin + (close-input-port inp) + (reverse res)) + (loop (read-line inp)(cons inl res))))) + '())) + +;;====================================================================== +;; Write a config +;; 0. Given a refererence data structure "indat" +;; 1. Open the output file and read it into a list +;; 2. Flatten any multiline entries +;; 3. Modify values per contents of "indat" and remove absent values +;; 4. Append new values to the section (immediately after last legit entry) +;; 5. Write out the new list +;;====================================================================== + +(define (configf:write-config indat fname #!key (required-sections '())) + (let* (;; step 1: Open the output file and read it into a list + (fdat (configf:file->list fname)) + (refdat (make-hash-table)) + (sechash (make-hash-table)) ;; current section hash, init with hash for "default" section + (new #f) ;; put the line to be used in new, if it is to be deleted the set new to #f + (secname #f)) + + ;; step 2: Flatten multiline entries + (if (not (null? fdat))(set! fdat (configf:compress-multi-line fdat))) + + ;; step 3: Modify values per contents of "indat" and remove absent values + (if (not (null? fdat)) + (let loop ((hed (car fdat)) + (tal (cadr fdat)) + (res '()) + (lnum 0)) + (regex-case + hed + (configf:comment-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f)) + (configf:blank-l-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f)) + (configf:section-rx ( x section-name ) (let ((section-hash (hash-table-ref/default refdat section-name #f))) + (if (not section-hash) + (let ((newhash (make-hash-table))) + (hash-table-set! refhash section-name newhash) + (set! sechash newhash)) + (set! sechash section-hash)) + (set! new hed) ;; will append this at the bottom of the loop + (set! secname section-name) + )) + ;; No need to process key cmd, let it fall though to key val + (configf:key-val-pr ( x key val ) + (let ((newval (config-lookup indat sec key))) + ;; can handle newval == #f here => that means key is removed + (cond + ((equal? newval val) + (set! res (append res (list hed)))) + ((not newval) ;; key has been removed + (set! new #f)) + ((not (equal? newval val)) + (hash-table-set! sechash key newval) + (set! new (conc key " " newval))) + (else + (debug:print 0 "ERROR: problem parsing line number " lnum "\"" hed "\""))))) + (else + (debug:print 0 "ERROR: Problem parsing line num " lnum " :\n " hed ))) + (if (not (null? tal)) + (loop (car tal)(cdr tal)(if new (append res (list new)) res)(+ lnum 1))) + ;; drop to here when done processing, res contains modified list of lines + (set! fdat res))) + + ;; step 4: Append new values to the section + (for-each + (lambda (section) + (let ((sdat '()) ;; append needed bits here + (svars (configf:section-vars indat section))) + (for-each + (lambda (var) + (let ((val (config-lookup refdat section var))) + (if (not val) ;; this one is new + (begin + (if (null? sdat)(set! sdat (list (conc "[" section "]")))) + (set! sdat (append sdat (list (conc var " " val)))))))) + svars) + (set! fdat (append fdat sdat)))) + (delete-duplicates (append require-sections (hash-table-keys indat)))) + + ;; step 5: Write out new file + (with-output-to-file fname + (lambda () + (for-each + (lambda (line) + (print line)) + (configf:expand-multi-lines fdat)))))) + +;;====================================================================== +;; refdb +;;====================================================================== + +;; reads a refdb into an assoc array of assoc arrays +;; returns (list dat msg) +(define (configf:read-refdb refdb-path) + (let ((sheets-file (conc refdb-path "/sheet-names.cfg"))) + (if (not (file-exists? sheets-file)) + (list #f (conc "ERROR: no refdb found at " refdb-path)) + (if (not (file-read-access? sheets-file)) + (list #f (conc "ERROR: refdb file not readable at " refdb-path)) + (let* ((sheets (with-input-from-file sheets-file + (lambda () + (let loop ((inl (read-line)) + (res '())) + (if (eof-object? inl) + (reverse res) + (loop (read-line)(cons inl res))))))) + (data '())) + (for-each + (lambda (sheet-name) + (let* ((dat-path (conc refdb-path "/" sheet-name ".dat")) + (ref-dat (configf:read-file dat-path #f #t)) + (ref-assoc (map (lambda (key) + (list key (hash-table-ref ref-dat key))) + (hash-table-keys ref-dat)))) + ;; (hash-table->alist ref-dat))) + ;; (set! data (append data (list (list sheet-name ref-assoc)))))) + (set! data (cons (list sheet-name ref-assoc) data)))) + sheets) + (list data "NO ERRORS")))))) + +;; map over all pairs in a three level hierarchial alist and apply a function to the keys/val +;; +(define (configf:map-all-hier-alist data proc #!key (initproc1 #f)(initproc2 #f)(initproc3 #f)) + (for-each + (lambda (sheetname) + (let* ((sheettmp (assoc sheetname data)) + (sheetdat (if sheettmp (cadr sheettmp) '()))) + (if initproc1 (initproc1 sheetname)) + (for-each + (lambda (sectionname) + (let* ((sectiontmp (assoc sectionname sheetdat)) + (sectiondat (if sectiontmp (cadr sectiontmp) '()))) + (if initproc2 (initproc2 sheetname sectionname)) + (for-each + (lambda (varname) + (let* ((valtmp (assoc varname sectiondat)) + (val (if valtmp (cadr valtmp) ""))) + (proc sheetname sectionname varname val))) + (map car sectiondat)))) + (map car sheetdat)))) + (map car data)) + data) + +;;====================================================================== +;; C O N F I G T O / F R O M A L I S T +;;====================================================================== + +(define (configf:config->alist cfgdat) + (hash-table->alist cfgdat)) + +(define (configf:alist->config adat) + (let ((ht (make-hash-table))) + (for-each + (lambda (section) + (hash-table-set! ht (car section)(cdr section))) + adat) + ht)) + +(define (configf:read-alist fname) + (configf:alist->config + (with-input-from-file fname read))) + +(define (configf:write-alist cdat fname) + (with-output-to-file fname + (lambda () + (pp (configf:config->alist cdat))))) + diff --git a/configf/configf_1.ini b/configf/configf_1.ini new file mode 100644 index 0000000..544780c --- /dev/null +++ b/configf/configf_1.ini @@ -0,0 +1,10 @@ +; last modified 1 April 2001 by John Doe +[owner] +name John Doe +organization Acme Widgets Inc. + +[database] +# use IP address in case network name resolution is not working +server 192.0.2.62 +port 143 +file payroll.dat diff --git a/configf/example.ini b/configf/example.ini new file mode 100644 index 0000000..2b50cc2 --- /dev/null +++ b/configf/example.ini @@ -0,0 +1,10 @@ +; last modified 1 April 2001 by John Doe +[owner] +name: John Doe +organization: Acme Widgets Inc. + +[database] +server: 192.0.2.62 +port: 143 +file: "payroll.dat" +date: #{system /bin/date} diff --git a/configf/ini-file_1.ini b/configf/ini-file_1.ini new file mode 100644 index 0000000..c595c2c --- /dev/null +++ b/configf/ini-file_1.ini @@ -0,0 +1,9 @@ +; last modified 1 April 2001 by John Doe +[owner] +name=John Doe +organization=Acme Widgets Inc. + +[database] +server=192.0.2.62 ; use IP address in case network name resolution is not working +port=143 +file = "payroll.dat" diff --git a/configf/run_configf b/configf/run_configf new file mode 100755 index 0000000..21bd2f6 Binary files /dev/null and b/configf/run_configf differ diff --git a/configf/run_configf.scm b/configf/run_configf.scm new file mode 100644 index 0000000..f5d04d9 --- /dev/null +++ b/configf/run_configf.scm @@ -0,0 +1,22 @@ +(declare (uses configf struct-indexer)) +(use test) +(use srfi-69) + + +(use ini-file) + +(let ((ini (read-ini "ini-file_1.ini"))) + (print "ini-file: lu database.file=[" + (lu ini "database.file")"]")) + +(let ((ini (read-config "configf_1.ini" #f #f))) + (print "configf: lu database.file=[" + (lu ini "database.file")"]")) + + +(exit 0) + + + + + diff --git a/configf/struct-indexer.scm b/configf/struct-indexer.scm new file mode 100644 index 0000000..181b83f --- /dev/null +++ b/configf/struct-indexer.scm @@ -0,0 +1,92 @@ +(declare (unit struct-indexer)) + +;;(use trace) +(use yaml) + +;; fix-alist: alist -> alist +;; * handle malformed alists where data is a list of one item instead of that item +(define (fix-alist alist) + (map + (lambda (x) + (if (and + (list? (cdr x)) + (= 1 (length (cdr x)))) + (cons (car x) (cadr x)) + x)) + alist)) + +;; wrapper around alist-ref to choose correct +;; equation founction and fix-alist +(define (my-alist-ref index alist) + (let ((eqfunc + (cond + ((string? index) equal?) + ((symbol? index) eq?) + (else equal?)))) + + (try-string-and-symbol + (lambda (item) + (alist-ref + item + (fix-alist alist) + eqfunc)) + index))) + +(define (my-hash-table-ref ht index) + (try-string-and-symbol + (lambda (item) + (hash-table-ref/default + ht + item + #f)) + index)) + +;; try a function with one argument using the item argument +;; both string and symbol. +;; returns whichever result is not #f +;; original type is checked first. +(define (try-string-and-symbol func item ) + (if (symbol? item) + (let ((symres (func item))) + (if symres + symres + (func (symbol->string item)))) + + (let ((strres (func item))) + (if strres + strres + (func (string->symbol item)))))) + +;; lookup +(define (lu struct key) + (define (descender key-list-left struct-left) + (cond + ((null? key-list-left) + struct-left) + + ((null? struct-left) + #f) + + ((not struct-left) + #f) + + ((type-checks#alist? struct-left) + + (descender + (cdr key-list-left) + (my-alist-ref + (car key-list-left) + struct-left))) + + ((hash-table? struct-left) + (descender + (cdr key-list-left) + (my-hash-table-ref + struct-left + (car key-list-left)))) + + (else + (print "descender: case else") + #f))) + + (descender (string-split key ".") struct)) diff --git a/configf_features.md b/configf_features.md new file mode 100644 index 0000000..da8ce89 --- /dev/null +++ b/configf_features.md @@ -0,0 +1,17 @@ +## configf features to integrate into ini-file + - [include ] template + - [system .. ] + - #{scheme} + - #{system} + - #{shell} + - #{getenv} + - #{get} + - #{runconfigs-get} + - #{rget} + +## new features to add to ini-file + - [system-multiline] template + * allows executing a file, pulls in all lines from stdout + +## other nice to have things + - config file for ini-file to use megatest configf config file syntax diff --git a/ini-file.scm b/ini-file.scm index 0998514..3930d1f 100644 --- a/ini-file.scm +++ b/ini-file.scm @@ -67,59 +67,120 @@ (begin body ...)) ((_ str) (void)))) + +;; system and other macros produce lines to be used. These do not come +;; from the input port. the stuffed-lines parameter keeps a list +;; of lines that have been stuffed in to preempt the input port when +;; getting the next line of input +(define stuffed-lines (make-parameter (list))) + + +;; Discard comments and +;; whitespace from the string. +(define (chomp-str line) + (string-substitute* + line + '( ("[;#].*" . "") ("\\s+$" . "") ) )) + +;; process line, search for macros, then hand off line +;; if macro generates new lines, add them to stuffed-lines parameter +(define (preprocess-line rawline) + (let ((line (chomp-str rawline))) + (match-string + line + ;; include) + (("\\s*\\[\\s*include\\s+([^\\]]+?)\\s*\\]" include-file) + (let* ((all-lines (read-lines include-file)) + (first-line (if (null? all-lines) "" (car all-lines))) + (rest-lines (if (null? all-lines) '() (cdr all-lines))) + (prev-stuffed-lines (stuffed-lines)) + ) + (stuffed-lines (append rest-lines prev-stuffed-lines)) + (preprocess-line first-line))) + + ;; no macros; pass it along unmolested + (else line)))) + + + ;; get next line and preprocess it; + ;; 1) check stuffed-lines parameter to preempt input port + ;; 2) run preprocessor to handle new macros +(define (read-and-preprocess-line port) + (if (null? (stuffed-lines)) + (preprocess-line (read-line port)) + (let* ((temp-lines (stuffed-lines)) + (next-stuffed-line (car temp-lines)) + (rest-stuffed-lines (cdr temp-lines))) + (stuffed-lines rest-stuffed-lines) + (preprocess-line next-stuffed-line)))) + + + ;; Read a single property from the port. ;; If it's a section header, returns a symbol. ;; If it's a name/value pair, returns a pair. +;; If it's a blank line, returns #f (define read-property (case-lambda (() (read-property (current-input-port))) ((port) - (let ((line (read-line port)) - (name-value-patt (string-append "([^:;=#]+?)" (property-separator-patt) "(.*?) *"))) - (match-string line - ;; Section header. - ((" *\\[(.*?)\\] *([;#].*)?" section comment) - (string->symbol section)) - ;; Name/value pair. - ((name-value-patt name value) - (let ((name (string->symbol name))) - (let lp ((value value)) - (match-string value - ;; Quoted string. - (("\"(.*?)\"" value) + (let ((line + (read-and-preprocess-line port)) + (name-value-patt + (string-append + "([^:;=#]+?)" + (property-separator-patt) + "(.*?) *"))) + (match-string + line + + ;; Empty string. + (("") #f) + ;; Section header. + ((" *\\[(.*?)\\] *([;#].*)?" section comment) + (string->symbol section)) + ;; Name/value pair. + ((name-value-patt name value) + (let ((name (string->symbol name))) + (let lp ((value value)) + (match-string + value + ;; Quoted string. + (("\"(.*?)\"" value) + (cons name value)) + ;; Number. + (("[-+]?[0-9]+\\.?[0-9]*") + (cons name (with-input-from-string value read))) + ;; Trailing comment. + (("(.*?) *[;#].*" match) + (lp match)) + (else + (cond + ((allow-empty-values?) (cons name value)) - ;; Number. - (("[-+]?[0-9]+\\.?[0-9]*") - (cons name (with-input-from-string value read))) - ;; Trailing comment. - (("(.*?) *[;#].*" match) - (lp match)) + ((zero? (string-length value)) + (ini-error + 'read-ini + "Empty value" + line)) (else - (cond - ((allow-empty-values?) - (cons name value)) - ((zero? (string-length value)) - (ini-error - 'read-ini - "Empty value" - line)) - (else - (let ((mapped (assoc value (property-value-map)))) - (if mapped - (cons name (cdr mapped)) - (cons name value)))))))))) - ;; Unrecognized. - (else - (if (allow-bare-properties?) - (cons (string->symbol line) #t) - (ini-error + (let ((mapped (assoc value (property-value-map)))) + (if mapped + (cons name (cdr mapped)) + (cons name value)))))))))) + ;; Unrecognized. + (else + (if (allow-bare-properties?) + (cons (string->symbol line) #t) + (ini-error 'read-ini "Malformed INI directive" line)))))))) ;; cons a new section or property onto the configuration alist. (define (cons-property p alist) - (cond ((symbol? p) + (cond ((not p) alist) + ((symbol? p) (cons (list p) alist)) ((pair? p) (if (null? alist) @@ -151,11 +212,14 @@ ((input-port? in) (let lp ((alist `())) (chomp in) - (if (eof-object? (peek-char in)) - alist - (lp (cons-property - (read-property in) - alist))))) + (if + (and + (null? (stuffed-lines)) + (eof-object? (peek-char in))) + alist + (lp (cons-property + (read-property in) + alist))))) (else (error 'read-ini "Argument is neither a file nor input port" in)))))) diff --git a/test.scm b/test.scm new file mode 100644 index 0000000..51a95c0 --- /dev/null +++ b/test.scm @@ -0,0 +1,7 @@ +(print "Hello worldd") + +(set! a (cons 1 2)) + +(print (cdr a)) + +(include "ini-file.scm") diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 index 0000000..164306b --- /dev/null +++ b/tests/Makefile @@ -0,0 +1,36 @@ +CSCOPTS= + +SRCFILES = run.scm + +OFILES = $(SRCFILES:%.scm=%.o) + +#csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg + +help: + @echo "Makefile targets" + @echo "================" + @echo "make test2 - run tests round 2" + @echo "make test - run tests" + @echo "make clean - clean up .o's and binaries" + +ini-file.import.c: ini-file.scm + chicken-install -no-install + +test: run + ./run + +run: $(OFILES) ini-file.import.c + csc $(CSCOPTS) $(OFILES) -o run + +test2: run2 + ./run2 + +run2: run2.scm ini-file.import.c + csc $(CSCOPTS) run2.scm -o run2 + + +%.o : %.scm + csc $(CSCOPTS) -c $< + +clean: + rm -f *.o run_ini-file-test ini-file.import.* ini-file.c ini-file.so run2 diff --git a/tests/example2.ini b/tests/example2.ini new file mode 100644 index 0000000..f284bea --- /dev/null +++ b/tests/example2.ini @@ -0,0 +1,5 @@ +[foo] +a=b + +[include example.ini ] + diff --git a/tests/ini-file.meta b/tests/ini-file.meta new file mode 120000 index 0000000..cfc95fa --- /dev/null +++ b/tests/ini-file.meta @@ -0,0 +1 @@ +../ini-file.meta \ No newline at end of file diff --git a/tests/ini-file.scm b/tests/ini-file.scm new file mode 120000 index 0000000..ad1eb42 --- /dev/null +++ b/tests/ini-file.scm @@ -0,0 +1 @@ +../ini-file.scm \ No newline at end of file diff --git a/tests/ini-file.setup b/tests/ini-file.setup new file mode 120000 index 0000000..9b6cf9e --- /dev/null +++ b/tests/ini-file.setup @@ -0,0 +1 @@ +../ini-file.setup \ No newline at end of file diff --git a/tests/run.scm b/tests/run.scm index 9aa32c4..9e2fbb7 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -1,4 +1,9 @@ -(use srfi-78 ini-file) +(use srfi-78 ports extras) + +; test using ini-file in workspace +(include "../ini-file.scm") + +(import ini-file) (define default (default-section)) diff --git a/tests/run2.scm b/tests/run2.scm new file mode 100644 index 0000000..d3a9a0e --- /dev/null +++ b/tests/run2.scm @@ -0,0 +1,10 @@ +(use srfi-78 ports extras test yaml) + +; test using ini-file in workspace +(include "../ini-file.scm") + +(import ini-file) + +(let ((data (read-ini "example2.ini"))) + (print data)) + diff --git a/tests/run_ini-file-test b/tests/run_ini-file-test new file mode 100755 index 0000000..2ccd10c Binary files /dev/null and b/tests/run_ini-file-test differ