Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -28,11 +28,14 @@ ezsteps.scm lock-queue.scm sdb.scm \ rmt.scm api.scm subrun.scm \ portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm # module source files -MSRCFILES = ftail.scm +MSRCFILES = ftail.scm db.scm common.scm + +# mtest module source files actually used by mtest building +MTMSRCFILES = ftail.scm # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ @@ -42,12 +45,13 @@ OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o)) +MTMOFILES = $(addprefix mofiles/,$(MTMSRCFILES:%.scm=%.o)) -mofiles/%.o : %.scm +mofiles/%.o : src/%.scm mkdir -p mofiles csc $(CSCOPTS) -J -c $< -o mofiles/$*.o ADTLSCR=mt_laststep mt_runstep mt_ezstep HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR)) @@ -65,21 +69,21 @@ PNGFILES = $(shell cd docs/manual;ls *png) #all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut -mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o - csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o mtest +mtest: $(OFILES) readline-fix.scm megatest.o $(MTMOFILES) + csc $(CSCOPTS) $(OFILES) $(MTMOFILES) megatest.o -o mtest -dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) - csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) -o dboard +dboard : $(OFILES) $(GOFILES) dashboard.scm $(MTMOFILES) + csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MTMOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard -mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm +mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm $(MOFILES) csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut TCMTOBJS = \ api.o \ archive.o \ @@ -99,11 +103,10 @@ megatest-version.o \ ods.o \ portlogger.o \ process.o \ rmt.o \ - rpc-transport.o \ runconfig.o \ runs.o \ server.o \ tasks.o \ tdb.o \ @@ -147,10 +150,12 @@ megatest.o : megatest-fossil-hash.scm rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm common_records.scm : altdb.scm vg.o dashboard.o : vg_records.scm dcommon.o : run_records.scm +mofiles/db.o : mofiles/common.o + # Temporary while transitioning to new routine # runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -708,18 +708,20 @@ (pathname-file *toppath*) #f))) ;; (pathname-file (current-directory))))) (define common:get-area-name common:get-testsuite-name) +;; get-db-tmp-area is improved/replicated src/db.scm +;; (define (common:get-db-tmp-area . junk) (if *db-cache-path* *db-cache-path* (if *toppath* ;; common:get-create-writeable-dir (handle-exceptions exn (begin - (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) + (debug:print-error 0 *default-log-port* "Couldn't create path to /tmp/ area") (exit 1)) (let ((dbpath (common:get-create-writeable-dir (list (conc "/tmp/" (current-user-name) "/megatest_localdb/" (common:get-testsuite-name) "/" @@ -1394,27 +1396,10 @@ ;; (define (common:lazy-convert inval) (let* ((as-num (if (string? inval)(string->number inval) #f))) (or as-num inval))) -;; convert string a=1; b=2; c=a silly thing; d= -;; to '((a . 1)(b . 2)(c . "a silly thing")(d . "")) -;; -(define (common:val->alist val #!key (convert #f)) - (let ((val-list (string-split-fields ";\\s*" val #:infix))) - (if val-list - (map (lambda (x) - (let ((f (string-split-fields "\\s*=\\s*" x #:infix))) - (case (length f) - ((0) `(,#f)) ;; null string case - ((1) `(,(string->symbol (car f)))) - ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f))) - (if convert (common:lazy-convert inval) inval)))) - (else f)))) - val-list) - '()))) - ;;====================================================================== ;; S Y S T E M S T U F F ;;====================================================================== ;; lazy-safe get file mod time. on any error (file not existing etc.) return 0 Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -242,10 +242,45 @@ (hash-table-set! ht section (config:assoc-safe-add (hash-table-ref ht section) key val metadata: meta)))) vars))))) (hash-table-keys ht)))) ht) +;;====================================================================== +;; Extended config lines, allows storing more hierarchial data in the config lines +;; ABC a=1; b=hello world; c=a +;; +;; NOTE: implementation is quite limited. You currently cannot have +;; semicolons in your string values. +;;====================================================================== + +;; convert string a=1; b=2; c=a silly thing; d= +;; to '((a . 1)(b . 2)(c . "a silly thing")(d . "")) +;; +(define (configf:val->alist val #!key (convert #f)) + (let ((val-list (string-split-fields ";\\s*" val #:infix))) + (if val-list + (map (lambda (x) + (let ((f (string-split-fields "\\s*=\\s*" x #:infix))) + (case (length f) + ((0) `(,#f)) ;; null string case + ((1) `(,(string->symbol (car f)))) + ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f))) + (if convert (common:lazy-convert inval) inval)))) + (else f)))) + val-list) + '()))) + +;; I don't want configf to turn into a weak yaml format but this extention is really useful +;; +(define (configf:section->val-alist cfgdat section-name #!key (convert #f)) + (let ((section (configf:get-section cfgdat section-name))) + (map (lambda (item) + (let ((key (car item)) + (val (cadr item))) ;; BUG IN WAIT. sections are not returned as proper alists, should fix this. + (cons key (configf:val->alist val convert: convert)))) + section))) + ;; 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) ;; allow-system: Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -29,15 +29,17 @@ (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) (declare (uses configf)) -;; (declare (uses rmt)) +(declare (uses db)) ;; WARNING: This is NOT the db from megatest/db.scm, is it src/db.scm (include "megatest-fossil-hash.scm") (require-library stml) + +(import (prefix db db:)) ;; stuff for the mapper and checker functions ;; (define *target-mappers* (make-hash-table)) (define *runname-mappers* (make-hash-table)) @@ -304,12 +306,10 @@ (define (megatest-param->mtutil-param param) (let* ((mapping-alist (common:get-param-mapping flavor: 'switch-symbol))) (alist-ref (string->symbol param) mapping-alist eq? param) param)) -(define val->alist common:val->alist) - (define (push-run-spec torun contour runkey spec) (configf:section-var-set! torun contour runkey (cons spec (or (configf:lookup torun contour runkey) '())))) @@ -666,11 +666,11 @@ ;; (define (create-run-pkt mtconf action area runkey target runname mode-patt tag-expr pktsdir reason contour sched dbdest append-conf runtrans) (let* ((good-val (lambda (inval)(and inval (string? inval)(not (string-null? inval))))) - (area-dat (common:val->alist (or (configf:lookup mtconf "areas" area) ""))) + (area-dat (configf:val->alist (or (configf:lookup mtconf "areas" area) ""))) (area-path (alist-ref 'path area-dat)) ;; (area-xlatr (alist-ref 'targtrans area-dat)) ;; (xlatr-key (if area-xlatr (string->symbol area-xlatr) #f)) (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f)) (mapper (if callname (hash-table-ref/default *runname-mappers* callname #f) #f))) @@ -765,11 +765,11 @@ (len-key (length keyparts)) (ruletype (if (> len-key 1)(cadr keyparts) #f)) (action (if (> len-key 2)(caddr keyparts) #f)) (optional (if (> len-key 3)(cadddr keyparts) #f)) ;; (val-list (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params - (val-alist (common:val->alist val)) + (val-alist (configf:val->alist val)) (runname (make-runname "" "")) (runtrans (alist-ref 'runtrans val-alist)) ;; these may or may not be defined and not all are used in each handler type in the case below (run-name (alist-ref 'run-name val-alist)) @@ -1010,11 +1010,11 @@ ;; now have to run populated (for-each (lambda (contour) (let* ((cval (or (configf:lookup mtconf "contours" contour) "")) - (cval-alist (common:val->alist cval)) ;; BEWARE ... NOT the same val-alist as above! + (cval-alist (configf:val->alist cval)) ;; BEWARE ... NOT the same val-alist as above! (areas (val-alist->areas cval-alist)) (selector (alist-ref 'selector cval-alist)) (mode-tag (and selector (string-split-fields "/" selector #:infix))) (mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f))) (tag-expr (and mode-tag (if (null? mode-tag) #f (car mode-tag))))) @@ -1028,11 +1028,11 @@ (lambda (runkeydat) (for-each (lambda (area) (if (area-allowed? area areas runkey contour mode-patt) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...) (let* ((aval (or (configf:lookup mtconf "areas" area) "")) - (aval-alist (common:val->alist aval)) + (aval-alist (configf:val->alist aval)) (runname (alist-ref 'runname runkeydat)) (runtrans (alist-ref 'runtrans runkeydat)) (reason (alist-ref 'message runkeydat)) (sched (alist-ref 'sched runkeydat)) @@ -1210,11 +1210,11 @@ ((run remove rerun rerun-clean rerun-all set-ss archive kill list) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (area (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section (areasec (if area (configf:lookup mtconf "areas" area) #f)) - (areadat (if areasec (common:val->alist areasec) #f)) + (areadat (if areasec (configf:val->alist areasec) #f)) (area-path (if areadat (alist-ref 'path areadat) #f)) (pktsdirs (configf:lookup mtconf "setup" "pktsdirs")) (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)) (adjargs (hash-table-copy args:arg-hash)) (new-ss (args:get-arg "-new"))) @@ -1349,16 +1349,24 @@ (print "received " instr ", running \"" script " " instr "\"") (system (conc script " '" instr "'")) (nn-send rep "ok") (loop (nn-recv rep)))) (print "ERROR: Port " portnum " already in use. Try another port"))))))) - ((gather) ;; gather all area db's into /tmp/$USER_megatest/alldbs + ((gatherdb) ;; gather all area db's into /tmp/$USER_megatest/alldbs (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) - (areas (get-area-names mtconf))) - (print "areas: " areas))) - + ;; (areas (get-area-names mtconf)) + (areas (configf:section->val-alist mtconf "areas"))) + (for-each + (lambda (area) + (let* ((area-name (car area)) + (area-info (cdr area)) + (area-path (alist-ref 'path area-info))) + (print "Area: " area) + (print " path: " area-path))) + areas))) + (else (let ((all-actions (sort (map conc (delete-duplicates (append *other-actions* (map car *action-keys*)))) string<=?))) (print "unrecognised action: \"" *action* "\", try one of; \"" (string-intersperse all-actions "\", \"") "\""))) )) ;; the end