Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -19,22 +19,26 @@ # rm .o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less SHELL=/bin/bash PREFIX=$(PWD) CSCOPTS= INSTALL=install -SRCFILES = common.scm items.scm launch.scm \ +SRCFILES = common.o items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm filedb.scm tdb.scm \ client.scm mt.scm \ - ezsteps.scm lock-queue.scm sdb.scm \ + ezsteps.scm lock-queue.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 +# sdb.scm \ +# module source files, NOTE: do not put ftail in this list yet! +MSRCFILES = mtdb.scm mtcommon.scm mtconfigf.scm + +# mtest module source files actually used by mtest building +MTMSRCFILES = # 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 \ @@ -44,12 +48,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)) @@ -67,22 +72,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 - - -dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) - csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) -o dboard - -ndboard : newdashboard.scm $(OFILES) $(GOFILES) - csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard - -mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm - csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut +mtest: $(OFILES) readline-fix.scm megatest.scm $(MTMOFILES) megatest-fossil-hash.scm + csc $(CSCOPTS) $(OFILES) $(MTMOFILES) megatest.scm -o mtest + +dboard : $(OFILES) $(GOFILES) dashboard.scm $(MTMOFILES) + csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MTMOFILES) -o dboard + +ndboard : newdashboard.scm $(MOFILES) gutils.o margs.o megatest-version.o + csc $(CSCOPTS) $(MOFILES) gutils.o margs.o megatest-version.o newdashboard.scm -o ndboard + +mtut: megatest-fossil-hash.scm megatest-version.o margs.o mtut.scm $(MOFILES) + csc $(CSCOPTS) $(MOFILES) megatest-version.o margs.o mtut.scm -o mtut TCMTOBJS = \ api.o \ archive.o \ cgisetup/models/pgdb.o \ @@ -101,11 +105,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 \ @@ -140,20 +143,22 @@ # $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm # csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl # Special dependencies for the includes tests.o db.o launch.o runs.o dashboard-tests.o dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o \ -archive.o megatest.o : db_records.scm +archive.o : db_records.scm tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm -db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm +db.o ezsteps.o keys.o launch.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm -megatest.o : megatest-fossil-hash.scm +# 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/mtdb.o : mofiles/mtcommon.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 @@ -292,11 +297,11 @@ $(MTQA_FOSSIL) : fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL) clean : - rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o + rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o *import.scm #====================================================================== # Make the records files #====================================================================== @@ -335,12 +340,10 @@ deploytarg/dboard : $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg mv deploytarg/deploytarg deploytarg/dboard -# DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \ -# megatest-version.o tdb.o ods.o mt.o keys.o datashare-testing/sd : datashare.scm $(OFILES) csc $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd datashare-testing/sdat: sharedat.scm $(OFILES) csc $(CSCOPTS) sharedat.scm $(OFILES) -o datashare-testing/sdat Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -38,11 +38,11 @@ (flavor 'plain) ;; type of machine to run jobs on (maxload 1.5) ;; max allowed load for this work (adisks (archive:get-archive-disks))) ;; get testdir size ;; - hand off du to job mgr - (if (and (common:file-exists? testdir) + (if (and (file-exists? testdir) (file-is-writable? testdir)) (let* ((dused (jobrunner:run-job flavor ;; machine type maxload ;; max allowed load '() ;; prevars - environment vars to set for the job @@ -145,11 +145,11 @@ (> (rmt:test-toplevel-num-items run-id test-name) 0))) (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path))) ;; note the trailing slash to get the dir inspite of it being a link (test-path (conc linktree "/" test-partial-path)) (mutex-lock! rp-mutex) - (test-physical-path (if (common:file-exists? test-path) + (test-physical-path (if (file-exists? test-path) (common:real-path test-path) #f)) (mutex-unlock! rp-mutex) (partial-path-index (if test-physical-path (substring-index test-partial-path test-physical-path) #f)) (test-base (if (and partial-path-index @@ -160,11 +160,11 @@ #f))) (cond (toplevel/children (debug:print 0 *default-log-port* "WARNING: cannot archive " test-name " with id " test-id " as it is a toplevel test with children")) - ((not (common:file-exists? test-path)) + ((not (file-exists? test-path)) (debug:print 0 *default-log-port* "WARNING: Cannot archive " test-name "/" item-path " as path " test-path " does not exist")) (else (debug:print 0 *default-log-port* "From test-dat=" test-dat " derived the following:\n" "test-partial-path = " test-partial-path "\n" @@ -188,13 +188,13 @@ (conc "-" compress) ;; or (conc "--compress=" compress) "-n" (conc (common:get-testsuite-name) "-" run-id) (conc "--strip-path=" disk-group)) test-paths)) (print-prefix #f)) ;; "Running: ")) ;; change to #f to turn off printing - (if (not (common:file-exists? archive-dir)) + (if (not (file-exists? archive-dir)) (create-directory archive-dir #t)) - (if (not (common:file-exists? (conc archive-dir "/HEAD"))) + (if (not (file-exists? (conc archive-dir "/HEAD"))) (begin ;; replace this with jobrunner stuff enventually (debug:print-info 0 *default-log-port* "Init bup in " archive-dir) ;; (mutex-lock! bup-mutex) (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix) @@ -241,11 +241,11 @@ (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path))) ;; note the trailing slash to get the dir inspite of it being a link (test-path (conc linktree "/" test-partial-path)) ;; if the old path was not deleted then prev-test-physical-path will end up pointing to a real directory (mutex-lock! rp-mutex) - (prev-test-physical-path (if (common:file-exists? test-path) + (prev-test-physical-path (if (file-exists? test-path) ;; (read-symbolic-link test-path #t) (common:real-path test-path) #f)) (mutex-unlock! rp-mutex) (new-test-physical-path (conc best-disk "/" test-partial-path)) @@ -258,11 +258,11 @@ ;; some sanity checks, move an existing path out of the way - iif it is not a toplevel with children ;; (if (and (not toplevel/children) ;; special handling needed for toplevel with children prev-test-physical-path - (common:file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in? + (file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in? (let* ((base (pathname-directory prev-test-physical-path)) (dirn (pathname-file prev-test-physical-path)) (newn (conc base "/." dirn))) (debug:print-error 0 *default-log-port* "the old directory " prev-test-physical-path ", still exists! Moving it to " newn) (rename-file prev-test-physical-path newn))) DELETED bin/sleeprunner Index: bin/sleeprunner ================================================================== --- bin/sleeprunner +++ /dev/null @@ -1,24 +0,0 @@ -#!/bin/bash - -# Copyright 2006-2017, Matthew Welland. -# -# This file is part of Megatest. -# -# Megatest is free software: you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. -# -# Megatest is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with Megatest. If not, see . - -if [[ $SLEEPRUNNER == "" ]];then -SLEEPRUNNER=0 -fi - -echo "nbfake $@ &> /dev/null" | at now + $SLEEPRUNNER minutes &> /dev/null Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -26,13 +26,12 @@ (prefix sqlite3 sqlite3:) pkts (prefix dbi dbi:) ) (declare (unit common)) - (include "common_records.scm") - +(declare (uses configf)) ;; (require-library margs) ;; (include "margs.scm") ;; (define old-exit exit) @@ -208,25 +207,31 @@ (or (> chicken-release-number 4) (and (eq? 4 chicken-release-number) (> chicken-major-version 9))))) (if resolve-pathname-broken? (define ##sys#expand-home-path pathname-expand)))) -(define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) )) +(define (realpath x) + (handle-exceptions + exn + #f + (resolve-pathname (pathname-expand (or x "/dev/null"))))) (define (common:get-this-exe-fullpath #!key (argv (argv))) - (let* ((this-script - (cond - ((and (> (length argv) 2) - (string-match "^(.*/csi|csi)$" (car argv)) - (string-match "^-(s|ss|sx|script)$" (cadr argv))) - (caddr argv)) - (else (car argv)))) + (let* ((this-script (cond + ((and (> (length argv) 2) + (string-match "^(.*/csi|csi)$" (car argv)) + (string-match "^-(s|ss|sx|script)$" (cadr argv))) + (caddr argv)) + (else (car argv)))) (fullpath (realpath this-script))) - fullpath)) -(define *common:this-exe-fullpath* (common:get-this-exe-fullpath)) -(define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*)) -(define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*)) + (or fullpath + (common:which this-script)))) ;; fall back on looking in the PATH for matching tool + +;; Let's not get these vars unless needed. +;; (define *common:this-exe-fullpath* (common:get-this-exe-fullpath)) +;; (define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*)) +;; (define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*)) @@ -358,11 +363,11 @@ (> (file-size fullname) 200000)) (and (string-match "^server-.*.log" file) (> (- (current-seconds) (file-modification-time fullname)) (* 8 60 60)))) (let ((gzfile (conc fullname ".gz"))) - (if (common:file-exists? gzfile) + (if (file-exists? gzfile) (begin (debug:print-info 0 *default-log-port* "removing " gzfile) (delete-file gzfile))) (debug:print-info 0 *default-log-port* "compressing " file) (system (conc "gzip " fullname))) @@ -388,11 +393,11 @@ "WARNING: Version mismatch!\n" " expected: " (common:version-signature) "\n" " got: " (common:get-last-run-version)) (cond ((get-environment-variable "MT_SKIP_DB_MIGRATE") #t) - ((and (common:file-exists? mtconf) (common:file-exists? dbfile) (not read-only) + ((and (file-exists? mtconf) (file-exists? dbfile) (not read-only) (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db (debug:print 0 *default-log-port* " I see you are the owner of megatest.config, attempting to cleanup and reset to new version") (handle-exceptions exn (begin @@ -399,14 +404,14 @@ (debug:print 0 *default-log-port* "Failed to switch versions.") (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) (exit 1)) (common:cleanup-db dbstruct))) - ((not (common:file-exists? mtconf)) + ((not (file-exists? mtconf)) (debug:print 0 *default-log-port* " megatest.config does not exist in this area. Cannot proceed with megatest version migration.") (exit 1)) - ((not (common:file-exists? dbfile)) + ((not (file-exists? dbfile)) (debug:print 0 *default-log-port* " megatest.db does not exist in this area. Cannot proceed with megatest version migration.") (exit 1)) ((not (eq? (current-user-id)(file-owner mtconf))) (debug:print 0 *default-log-port* " You do not own megatest.db in this area. Cannot proceed with megatest version migration.") (exit 1)) @@ -519,11 +524,11 @@ ;; (define (common:simple-file-lock fname #!key (expire-time 300)) (handle-exceptions exn #f ;; don't really care what went wrong right now. NOTE: I have not seen this one actually fail. - (if (common:file-exists? fname) + (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) @@ -530,11 +535,11 @@ (let ((key-string (conc (get-host-name) "-" (current-process-id)))) (with-output-to-file fname (lambda () (print key-string))) (thread-sleep! 0.25) - (if (common:file-exists? fname) + (if (file-exists? fname) (with-input-from-file fname (lambda () (equal? key-string (read-line)))) #f))))) @@ -708,18 +713,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) "/" @@ -915,19 +922,19 @@ #f (let loop ((hed (car cmds)) (tal (cdr cmds))) (let ((res (with-input-from-pipe (conc "which " hed) read-line))) (if (and (string? res) - (common:file-exists? res)) + (file-exists? res)) res (if (null? tal) #f (loop (car tal)(cdr tal)))))))) (define (common:get-install-area) (let ((exe-path (car (argv)))) - (if (common:file-exists? exe-path) + (if (file-exists? exe-path) (handle-exceptions exn #f (pathname-directory (pathname-directory @@ -1050,11 +1057,11 @@ (if message (debug:print-info 0 *default-log-port* message)) #f) (thunk) )) (define (common:file-exists? path-string #!key (silent #f)) - ;; this avoids stack dumps in the case where + ;; this avoids stack dumps in the case where file is not readable (I think this is due to a bug fixed in a later version of chicken) ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... (common:false-on-exception (lambda () (file-exists? path-string)) message: (if (not silent) (conc "Unable to access path: " path-string) @@ -1168,11 +1175,11 @@ (begin (mutex-unlock! *homehost-mutex*) (debug:print 0 *default-log-port* "ERROR: Failed to read .homehost file after trying five times. Giving up and exiting, message: " ((condition-property-accessor 'exn 'message) exn)) (exit 1))) (let ((hhf (conc *toppath* "/.homehost"))) - (if (common:file-exists? hhf) + (if (file-exists? hhf) (with-input-from-file hhf read-line) (if (file-write-access? *toppath*) (begin (with-output-to-file hhf (lambda () @@ -1393,11 +1400,10 @@ ;; if it looks like a number -> convert it to a number, else return it ;; (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))) @@ -2575,14 +2581,14 @@ ;; (define (common:load-views-config) (let* ((view-cfgdat (make-hash-table)) (home-cfgfile (conc (get-environment-variable "HOME") "/.mtviews.config")) (mthome-cfgfile (conc *toppath* "/.mtviews.config"))) - (if (common:file-exists? mthome-cfgfile) + (if (file-exists? mthome-cfgfile) (read-config mthome-cfgfile view-cfgdat #t)) ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas - (if (common:file-exists? home-cfgfile) + (if (file-exists? home-cfgfile) (read-config home-cfgfile view-cfgdat #t)) view-cfgdat)) ;;====================================================================== ;; H I E R A R C H I C A L H A S H T A B L E S @@ -2702,11 +2708,11 @@ (pdbpath (or (configf:lookup mtconf "setup" "pdbpath") pktsdir))) (cond ((not (and pktsdir toppath pdbpath)) (debug:print 0 *default-log-port* "ERROR: settings are missing in your megatest.config for area management.") (debug:print 0 *default-log-port* " you need to have pktsdir in the [setup] section.")) - ((not (common:file-exists? pktsdir)) + ((not (file-exists? pktsdir)) (debug:print 0 *default-log-port* "ERROR: pkts directory not found " pktsdir)) ((not (equal? (file-owner pktsdir)(current-effective-user-id))) (debug:print 0 *default-log-port* "ERROR: directory " pktsdir " is not owned by " (current-effective-user-name))) (else (let* ((pdb (open-queue-db pdbpath "pkts.db" @@ -2719,11 +2725,11 @@ mtconf (lambda (pktsdirs pktsdir pdb) (for-each (lambda (pktsdir) ;; look at all (cond - ((not (common:file-exists? pktsdir)) + ((not (file-exists? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory " pktsdir " does not exist.")) ((not (directory? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not a directory.")) ((not (file-read-access? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not readable.")) @@ -2836,5 +2842,51 @@ exn #t ;; just ignore it, it might have died in the meantime so joining it will throw an exception (thread-join! thread)) ))) (hash-table-keys *common:thread-punchlist*))) + + +;; moved to common.scm as it is very megatest specific + +;; pathenvvar will set the named var to the path of the config +(define (common: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)) + (set-fields (lambda (curr-section next-section ht path) + (let ((field-names (if ht (common:get-fields ht) '())) + (target (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target")))) + (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht) + (if (not (null? field-names))(keys:target-set-args field-names target #f)))))) + (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 post-section-procs: (list (cons "^fields$" set-fields)) #f)))) + (if toppath (change-directory curr-dir)) + (list configdat toppath configfile fname)))) + +;;;; return list (path fullpath configname) +(define (common: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 (common:setup) + (let* ((configf (find-config "megatest.config")) + (config (if configf (read-config configf #f #t) #f))) + (if config + (setenv "RUN_AREA_HOME" (pathname-directory configf))) + config)) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -25,25 +25,26 @@ (use regex regex-case) ;; directory-utils) (declare (unit configf)) (declare (uses process)) (declare (uses env)) (declare (uses keys)) +(declare (uses common)) (include "common_records.scm") ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) (if toppath (let ((cfname (conc toppath "/" configname))) - (if (common:file-exists? cfname) + (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 (common:file-exists? fullpath) + (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))))))))) @@ -242,10 +243,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: @@ -269,11 +305,11 @@ ;; ((port? path) "port") ;; (else (conc path)))) ;; (T . configf)) ;; *configdat* #t add-only: #t)) (if (and (not (port? path)) - (not (common:file-exists? path))) ;; for case where we are handed a port + (not (file-exists? path))) ;; for case where we are handed a port (begin (debug:print-info 1 *default-log-port* "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 (if (string? path) @@ -330,11 +366,11 @@ (common:nice-path (conc (if curr-conf-dir curr-conf-dir ".") "/" include-file))))) - (if (common:file-exists? full-conf) + (if (file-exists? full-conf) (begin ;; (push-directory conf-dir) (debug:print 9 *default-log-port* "Including: " full-conf) (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings @@ -349,11 +385,11 @@ (configf:script-rx ( x include-script params);; handle-exceptions ;; exn ;; (begin ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (if (and (common:file-exists? include-script)(file-execute-access? include-script)) + (if (and (file-exists? include-script)(file-execute-access? include-script)) (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections)) (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system)) (new-inp-port (common:with-env-vars env-delta @@ -595,11 +631,11 @@ (if (null? tal) newres (loop (car tal)(cdr tal) newres)))))) (define (configf:file->list fname) - (if (common:file-exists? fname) + (if (file-exists? fname) (let ((inp (open-input-file fname))) (let loop ((inl (read-line inp)) (res '())) (if (eof-object? inl) (begin @@ -648,11 +684,11 @@ (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))) + (let ((newval (config-lookup indat secname key))) ;; secname was sec. I think that was ;; 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 @@ -699,11 +735,11 @@ ;; 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 (common:file-exists? sheets-file)) + (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 () @@ -780,11 +816,11 @@ (begin (with-output-to-file fname ;; first write out the file (lambda () (pp dat))) - (if (common:file-exists? fname) ;; now verify it is readable + (if (file-exists? fname) ;; now verify it is readable (if (configf:read-alist fname) #t ;; data is good. (begin (handle-exceptions exn Index: dashboard-context-menu.scm ================================================================== --- dashboard-context-menu.scm +++ dashboard-context-menu.scm @@ -45,19 +45,24 @@ (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (define (dboard:launch-testpanel run-id test-id) - (let* (;; (cfg-sh (conc *common:this-exe-dir* "/cfg.sh")) + (let* ((exepath (common:get-this-exe-fullpath)) + (exedir (pathname-directory exepath)) + + ;; (cfg-sh (conc *common:this-exe-dir* "/cfg.sh")) ;; (cmd (conc - ;; (if (common:file-exists? cfg-sh) + ;; (if (file-exists? cfg-sh) ;; (conc "source "cfg-sh" && ") ;; "") ;; *common:this-exe-fullpath* ;; " -test " run-id "," test-id ;; " &")) - (cmd (conc *common:this-exe-dir*"/../dashboard " + + ;; (cmd (conc *common:this-exe-dir*"/../dashboard " + (cmd (conc exedir "/../dashboard " "-test " run-id "," test-id " &"))) (system cmd))) @@ -185,11 +190,11 @@ (status (vector-ref step 3))) (iup:menu-item (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")") #:action (lambda (obj) (let ((fullfile (conc rundir "/" logfile))) - (if (common:file-exists? fullfile) + (if (file-exists? fullfile) (dcommon:run-html-viewer fullfile) (message-window (conc "file " fullfile " not found")))))))) steps))))) (define (dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info) @@ -245,11 +250,11 @@ #:action (lambda (obj) (let* ((rundir (db:test-get-rundir test-info)) (logf (db:test-get-final_logf test-info)) (fullfile (conc rundir "/" logf))) - (if (common:file-exists? fullfile) + (if (file-exists? fullfile) (dcommon:run-html-viewer fullfile) (message-window (conc "file " fullfile " not found."))))) ) )) ;; example section for megatest.config: Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -255,11 +255,11 @@ ;; if there is a submegatest create a button to launch dashboard in that area ;; (define (submegatest-panel dbstruct keydat testdat runname testconfig) (let* ((test-run-dir (db:test-get-rundir testdat)) (subarea (subrun:get-runarea test-run-dir)) - (area-exists (and subarea (common:file-exists? subarea silent: #t)))) + (area-exists (and subarea (file-exists? subarea silent: #t)))) (if subarea (iup:frame #:title "Megatest Run Info" ; #:expand "YES" (iup:button "Launch Dashboard" @@ -478,11 +478,11 @@ "/")) (item-path (db:test-get-item-path testdat)) ;; this next block was added to fix a bug where variables were ;; needed. Revisit this. (runconfig (let ((runconfigf (conc *toppath* "/runconfigs.config"))) ;; no rush but it would be good to convert this call to use runconfig:read - (if (common:file-exists? runconfigf) + (if (file-exists? runconfigf) (handle-exceptions exn #f ;; do nothing, just keep on trucking .... (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) (make-hash-table)))) @@ -492,18 +492,18 @@ (handle-exceptions exn ;; NOTE: I've no idea why this was written this way. Research, study and fix needed! (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f allow-write-cache: #f) (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t allow-write-cache: #f)))) (viewlog (lambda (x) - (if (common:file-exists? logfile) + (if (file-exists? logfile) ;(system (conc "firefox " logfile "&")) (dcommon:run-html-viewer logfile) (message-window (conc "File " logfile " not found"))))) (view-a-log (lambda (lfile) (let ((lfilename (conc rundir "/" lfile))) ;; (print "lfilename: " lfilename) - (if (common:file-exists? lfilename) + (if (file-exists? lfilename) ;(system (conc "firefox " logfile "&")) (dcommon:run-html-viewer lfilename) (message-window (conc "File " lfilename " not found")))))) (xterm (lambda (x) (if (directory-exists? rundir) @@ -516,11 +516,11 @@ "MT_.*")) (message-window (conc "Directory " rundir " not found"))))) (widgets (make-hash-table)) (refreshdat (lambda () (let* ((curr-mod-time (file-modification-time db-path)) - ;; (max ..... (if (common:file-exists? testdat-path) + ;; (max ..... (if (file-exists? testdat-path) ;; (file-modification-time testdat-path) ;; (begin ;; (set! testdat-path (conc rundir "/testdat.db")) ;; 0)))) (need-update (or (and (>= curr-mod-time db-mod-time) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1950,11 +1950,11 @@ (let* ((success #t) ;; at any stage of the process set this flag to #f to skip downstream steps. Intention here is to recover gracefully if user provided tabs fail to load. (source (configf:lookup views-cfgdat view-name "source")) (viewgen (configf:lookup views-cfgdat view-name "viewgen")) (updater (configf:lookup views-cfgdat view-name "updater")) (result-child #f)) - (if (and (common:file-exists? source) + (if (and (file-exists? source) (file-read-access? source)) (handle-exceptions exn (begin (print-call-chain) @@ -2703,11 +2703,11 @@ (glob (conc dbdir "/*.db*")))))) (define (dashboard:monitor-changed? commondat tabdat) (let* ((run-update-time (current-seconds)) (monitor-db-path (dboard:tabdat-monitor-db-path tabdat)) - (monitor-modtime (if (and monitor-db-path (common:file-exists? monitor-db-path)) + (monitor-modtime (if (and monitor-db-path (file-exists? monitor-db-path)) (file-modification-time monitor-db-path) -1))) (if (and (eq? (dboard:commondat-curr-tab-num commondat) 0) (or (> monitor-modtime *last-monitor-update-time*) (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case @@ -3418,11 +3418,11 @@ ;; The heavy lifting starts here ;;====================================================================== (define (main) (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; - (if (and (common:file-exists? mtdb-path) + (if (and (file-exists? mtdb-path) (file-write-access? mtdb-path)) (if (not (args:get-arg "-skip-version-check")) (common:exit-on-version-changed))) (let* ((commondat (dboard:commondat-make))) ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... @@ -3477,12 +3477,12 @@ (thread-start! th2) (thread-join! th2))))) ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) - (if (common:file-exists? debugcontrolf) + (if (file-exists? debugcontrolf) (load debugcontrolf))) (if (args:get-arg "-repl") (repl) (main)) Index: datashare.scm ================================================================== --- datashare.scm +++ datashare.scm @@ -234,11 +234,11 @@ (if (and path (directory? path) (file-read-access? path)) (let* ((dbpath (conc path "/datashare.db")) (writeable (file-write-access? dbpath)) - (dbexists (common:file-exists? dbpath)) + (dbexists (file-exists? dbpath)) (handler (make-busy-timeout 136000))) (handle-exceptions exn (begin (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath @@ -421,11 +421,11 @@ paths)) ;; remove existing link and if possible ... ;; create path to next of tip of target, create link back to source (define (datashare:build-dir-make-link source target) - (if (common:file-exists? target)(datashare:backup-move target)) + (if (file-exists? target)(datashare:backup-move target)) (create-directory (pathname-directory target) #t) (create-symbolic-link source target)) (define (datashare:backup-move path) (let* ((trashdir (conc (pathname-directory path) "/.trash")) @@ -526,11 +526,11 @@ (define (datashare:path->lst path) (string-split path "/")) (define (datashare:pathdat-apply-heuristics configdat path) (cond - ((common:file-exists? path) "found") + ((file-exists? path) "found") (else (conc path " not installed")))) (define (datashare:get-view configdat) (iup:vbox (iup:hbox @@ -700,11 +700,11 @@ (define (datashare:find name paths) (if (null? paths) #f (let loop ((hed (car paths)) (tal (cdr paths))) - (if (common:file-exists? (conc hed "/" name)) + (if (file-exists? (conc hed "/" name)) hed (if (null? tal) #f (loop (car tal)(cdr tal))))))) @@ -714,11 +714,11 @@ (define (datashare:load-config exe-dir exe-name) (let* ((fname (conc exe-dir "/." exe-name ".config"))) (ini:property-separator-patt " * *") (ini:property-separator #\space) - (if (common:file-exists? fname) + (if (file-exists? fname) ;; (ini:read-ini fname) (read-config fname #f #t) (make-hash-table)))) (define (datashare:process-action configdat action . args) @@ -793,11 +793,11 @@ versions) (sqlite3:finalize! db))))) ;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION! (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc"))) - (if (common:file-exists? debugcontrolf) + (if (file-exists? debugcontrolf) (load debugcontrolf))) (define (main) (let* ((args (argv)) (prog (car args)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -213,20 +213,20 @@ (define (db:lock-create-open fname initproc) (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local (raw-fname (pathname-file fname)) (dir-writable (file-write-access? parent-dir)) - (file-exists (common:file-exists? fname)) + (file-exists (file-exists? fname)) (file-write (if file-exists (file-write-access? fname) dir-writable ))) ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped. (if file-write ;; dir-writable (condition-case (let* ((lockfname (conc fname ".lock")) (readyfname (conc parent-dir "/.ready-" raw-fname)) - (readyexists (common:file-exists? readyfname))) + (readyexists (file-exists? readyfname))) (if (not readyexists) (common:simple-file-lock-and-wait lockfname)) (let ((db (sqlite3:open-database fname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (sqlite3:execute db "PRAGMA synchronous = 0;") @@ -274,11 +274,11 @@ ;; ;; This routine creates the db. It is only called if the db is not already opened ;; ;; ;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) ;; (let* ((dbfile (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) -;; (dbexists (common:file-exists? dbfile)) +;; (dbexists (file-exists? dbfile)) ;; (db (db:lock-create-open dbfile (lambda (db) ;; (handle-exceptions ;; exn ;; (begin ;; ;; (release-dot-lock dbpath) @@ -314,14 +314,14 @@ (define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct (if (stack? tmpdb-stack) (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used (let* ((dbpath (db:dbfile-path )) ;; path to tmp db area - (dbexists (common:file-exists? dbpath)) + (dbexists (file-exists? dbpath)) (tmpdbfname (conc dbpath "/megatest.db")) - (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) - (mtdbexists (common:file-exists? (conc *toppath* "/megatest.db"))) + (dbfexists (file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) + (mtdbexists (file-exists? (conc *toppath* "/megatest.db"))) (mtdb (db:open-megatest-db)) (mtdbpath (db:dbdat-get-path mtdb)) (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) @@ -383,11 +383,11 @@ ;; NOTE: returns a dbdat not a dbstruct! ;; (define (db:open-megatest-db #!key (path #f)(name #f)) (let* ((dbdir (or path *toppath*)) (dbpath (conc dbdir "/" (or name "megatest.db"))) - (dbexists (common:file-exists? dbpath)) + (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) ;;(db:initialize-run-id-db db) ))) @@ -558,11 +558,11 @@ (tmpname (conc fname "." (current-process-id))) (tmpjnl (conc fnamejnl "." (current-process-id)))) (debug:print-error 0 *default-log-port* "" fname " appears corrupted. Making backup \"old/" fname "\"") (system (conc "cd " dbdir ";mkdir -p old;cat " fname " > old/" tmpname)) (system (conc "rm -f " dbpath)) - (if (common:file-exists? fnamejnl) + (if (file-exists? fnamejnl) (begin (debug:print-error 0 *default-log-port* "" fnamejnl " found, moving it to old dir as " tmpjnl) (system (conc "cd " dbdir ";mkdir -p old;cat " fnamejnl " > old/" tmpjnl)) (system (conc "rm -f " dbdir "/" fnamejnl)))) ;; attempt to recreate database @@ -932,11 +932,11 @@ (define (db:cache-for-read-only source target #!key (use-last-update #f)) (if (and (hash-table-ref/default *global-db-store* target #f) (>= (file-modification-time target)(file-modification-time source))) (hash-table-ref *global-db-store* target) (let* ((toppath (launch:setup)) - (targ-db-last-mod (if (common:file-exists? target) + (targ-db-last-mod (if (file-exists? target) (file-modification-time target) 0)) (cache-db (or (hash-table-ref/default *global-db-store* target #f) (db:open-megatest-db path: target))) (source-db (db:open-megatest-db path: source)) @@ -964,11 +964,11 @@ ;; (begin ;; (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db") ;; (exit 1)) ;; (let* ((th1 (make-thread ;; (lambda () -;; (if (and (common:file-exists? megatest-db) +;; (if (and (file-exists? megatest-db) ;; (file-write-access? megatest-db)) ;; (begin ;; (db:sync-to-megatest.db dbstruct 'timestamps) ;; internally mutexes on *db-local-sync* ;; (debug:print-info 2 *default-log-port* "Done syncing to megatest.db")))) ;; "call-with-cached-db sync-to-megatest.db")) @@ -1144,11 +1144,11 @@ (define (db:initialize-main-db dbdat) (when (not *configinfo*) (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f. (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... - (keys (keys:config-get-fields configdat)) + (keys (common:get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys:make-key/field-string configdat)) (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) @@ -1498,11 +1498,11 @@ ;; L O G G I N G D B ;;====================================================================== (define (open-logging-db) (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) - (dbexists (common:file-exists? dbpath)) + (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) (sqlite3:set-busy-handler! db handler) @@ -1654,11 +1654,11 @@ ;; ;; (db:delay-if-busy dbdat) (let* (;; (min-incompleted (filter (lambda (x) ;; (let* ((testpath (cadr x)) ;; (tdatpath (conc testpath "/testdat.db")) - ;; (dbexists (common:file-exists? tdatpath))) + ;; (dbexists (file-exists? tdatpath))) ;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete ;; (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim ;; incompleted)) (min-incompleted-ids (map car incompleted)) ;; do 'em all (all-ids (append min-incompleted-ids (map car oldlaunched)))) @@ -1885,11 +1885,11 @@ ;;====================================================================== (define (db:open-no-sync-db) (let* ((dbpath (db:dbfile-path)) (dbname (conc dbpath "/no-sync.db")) - (db-exists (common:file-exists? dbname)) + (db-exists (file-exists? dbname)) (db (sqlite3:open-database dbname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (if (not db-exists) (begin (sqlite3:execute db "PRAGMA synchronous = 0;") @@ -1960,11 +1960,11 @@ ;; use a global for some primitive caching, it is just silly to ;; re-read the db over and over again for the keys since they never ;; change ;; why get the keys from the db? why not get from the *configdat* -;; using keys:config-get-fields? +;; using common:get-fields? (define (db:get-keys dbstruct) (if *db-keys* *db-keys* (let ((res '())) (db:with-db dbstruct #f #f @@ -4106,11 +4106,11 @@ exn (begin (debug:print-info 0 *default-log-port* "WARNING: failed to test for existance of " dbfj) (thread-sleep! 1) (db:delay-if-busy count (- count 1))) - (common:file-exists? dbfj)) + (file-exists? dbfj)) (case count ((6) (thread-sleep! 0.2) (db:delay-if-busy count: 5)) ((5) @@ -4540,12 +4540,12 @@ (testname (vector-ref vb (+ 2 numkeys))) (item-path (vector-ref vb (+ 3 numkeys))) (final-log (vector-ref vb (+ 7 numkeys))) (run-dir (vector-ref vb (+ 18 numkeys))) (log-fpath (conc run-dir "/" final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/" - (debug:print 4 *default-log-port* "log: " log-fpath " exists: " (common:file-exists? log-fpath)) - (vector-set! vb (+ 7 numkeys) (if (common:file-exists? log-fpath) + (debug:print 4 *default-log-port* "log: " log-fpath " exists: " (file-exists? log-fpath)) + (vector-set! vb (+ 7 numkeys) (if (file-exists? log-fpath) (let ((newpath (conc pathmod "/" (string-intersperse keyvals "/") "/" runname "/" testname "/" (if (string=? item-path "") "" (conc "/" item-path)) final-log))) Index: env.scm ================================================================== --- env.scm +++ env.scm @@ -17,15 +17,16 @@ ;; along with Megatest. If not, see . ;;====================================================================== (declare (unit env)) +(declare (uses common)) (use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables) (define (env:open-db fname) - (let* ((db-exists (common:file-exists? fname)) + (let* ((db-exists (file-exists? fname)) (db (open-database fname))) (if (not db-exists) (begin (exec (sql db "CREATE TABLE envvars ( id INTEGER PRIMARY KEY, Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -45,19 +45,19 @@ (test-id (db:test-get-id testdat)) (run-id (db:test-get-run_id testdat)) (test-name (db:test-get-testname testdat)) (kill-job #f)) ;; for future use (on re-factoring with launch.scm code (let loop ((count 5)) - (if (common:file-exists? test-run-dir) + (if (file-exists? test-run-dir) (push-directory test-run-dir) (if (> count 0) (begin (debug:print 0 *default-log-port* "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times") (sleep 3) (loop (- count 1)))))) (debug:print-info 0 *default-log-port* "Running in directory " test-run-dir) - (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps")) + (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) (message-window "ERROR: You can only re-run steps defined via ezsteps") (begin (let loop ((ezstep (car ezstepslst)) @@ -83,11 +83,11 @@ (loop (car tal)(cdr tal) stepname #f)))) (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts " stepparms: " stepparms " stepcmd: " stepcmd) - (if (common:file-exists? (conc stepname ".logpro"))(set! logpro-used #t)) + (if (file-exists? (conc stepname ".logpro"))(set! logpro-used #t)) ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 *default-log-port* "script: " script) Index: filedb.scm ================================================================== --- filedb.scm +++ filedb.scm @@ -19,17 +19,18 @@ ;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex) (use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras) (import (prefix sqlite3 sqlite3:)) (declare (unit filedb)) +(declare (uses common)) (include "fdb_records.scm") ;; (include "settings.scm") (define (filedb:open-db dbpath) (let* ((fdb (make-filedb:fdb)) - (dbexists (common:file-exists? dbpath)) + (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath))) (filedb:fdb-set-db! fdb db) (filedb:fdb-set-dbpath! fdb dbpath) (filedb:fdb-set-pathcache! fdb (make-hash-table)) (filedb:fdb-set-idcache! fdb (make-hash-table)) Index: genexample.scm ================================================================== --- genexample.scm +++ genexample.scm @@ -17,10 +17,11 @@ ;; along with Megatest. If not, see . ;;====================================================================== (declare (unit genexample)) +(declare (uses common)) (use posix regex) (define genexample:example-logpro #<csv dat stepname)) (csvt (let-values (((fmt-cell fmt-record fmt-csv) (make-format ","))) (fmt-csv (map list->csv-record csvr)))) (status (configf:lookup dat "final" "exit-status")) @@ -104,11 +104,11 @@ (script "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\ (logpro-file (conc stepname ".logpro")) (html-file (conc stepname ".html")) (dat-file (conc stepname ".dat")) (tconfig-logpro (configf:lookup testconfig "logpro" stepname)) - (logpro-used (common:file-exists? logpro-file))) + (logpro-used (file-exists? logpro-file))) (debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams ", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd) (if (and tconfig-logpro @@ -126,11 +126,11 @@ " stepparams: " stepparams " stepcmd: " stepcmd) ;; ;; first source the previous environment ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") ;; (get-environment-variable "SHELL")) ".csh" ".sh")))) - ;; (if (and prevstep (common:file-exists? prev-env)) + ;; (if (and prevstep (file-exists? prev-env)) ;; (set! script (conc script "source " prev-env)))) ;; call the command using mt_ezstep ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd)) @@ -152,11 +152,11 @@ (with-output-to-file "Makefile.ezsteps" (lambda () (print stepname ".log :") (print "\t" cmd) - (if (common:file-exists? (conc stepname ".logpro")) + (if (file-exists? (conc stepname ".logpro")) (print "\tlogpro " stepname ".logpro " stepname ".html < " stepname ".log")) (print) (print stepname " : " stepname ".log") (print)) #:append) @@ -196,11 +196,11 @@ (logfna (if logpro-used (conc stepname ".html") "")) (comment #f)) (if logpro-used (let ((datfile (conc stepname ".dat"))) ;; load the .dat file into the test_data table if it exists - (if (common:file-exists? datfile) + (if (file-exists? datfile) (set! comment (launch:load-logpro-dat run-id test-id stepname))) (rmt:test-set-log! run-id test-id (conc stepname ".html")))) (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna)) ;; set the test final status (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) @@ -342,11 +342,11 @@ (list (list "subrun" (conc "{subrun=true} " mt-cmd))))))) ;; process the ezsteps (if ezsteps (begin - (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps")) + (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) (debug:print-error 0 *default-log-port* "ezsteps defined but ezstepslst is zero length") (let loop ((ezstep (car ezstepslst)) (tal (cdr ezstepslst)) @@ -355,11 +355,11 @@ ;; check exit-info (vector-ref exit-info 1) (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1) (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig)) (stepname (car ezstep))) ;; if logpro-used read in the stepname.dat file - (if (and logpro-used (common:file-exists? (conc stepname ".dat"))) + (if (and logpro-used (file-exists? (conc stepname ".dat"))) (launch:load-logpro-dat run-id test-id stepname)) (if (steprun-good? logpro-used (launch:einf-exit-code exit-info)) (if (not (null? tal)) (loop (car tal) (cdr tal) stepname)) (debug:print 0 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping"))) @@ -500,11 +500,11 @@ (fullrunscript (if (not runscript) #f (if (substring-index "/" runscript) runscript ;; use unadultered if contains slashes (let ((fulln (conc work-area "/" runscript))) - (if (and (common:file-exists? fulln) + (if (and (file-exists? fulln) (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path (check-work-area (lambda () ;; NFS might not have propagated the directory meta data to the run host - give it time if needed @@ -661,11 +661,11 @@ (list "default" target))) ;;(bb-check-path msg: "launch:execute post block 1") ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) - (if (or (common:file-exists? work-area) + (if (or (file-exists? work-area) (> count 10)) (change-directory work-area) (begin (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found") (thread-sleep! 10) @@ -738,11 +738,11 @@ ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript - (common:file-exists? fullrunscript) + (file-exists? fullrunscript) (not (file-execute-access? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) ;; We are about to actually kick off the test ;; so this is a good place to remove the records for @@ -837,22 +837,22 @@ (args:get-arg ":runname") (getenv "MT_RUNNAME"))) (fulldir (conc linktree "/" target "/" runname))) - (if (and linktree (common:file-exists? linktree)) ;; can't proceed without linktree + (if (and linktree (file-exists? linktree)) ;; can't proceed without linktree (begin (debug:print-info 0 *default-log-port* "Have -run with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%")) - (if (not (common:file-exists? fulldir)) + (if (not (file-exists? fulldir)) (create-directory fulldir #t)) ;; need to protect with exception handler (if (and target runname - (common:file-exists? fulldir)) + (file-exists? fulldir)) (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash)) (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash))) - (if (common:file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached + (if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached (begin (debug:print-info 0 *default-log-port* "Caching megatest.config in " tmpfile) (if (not (common:in-running-test?)) (configf:write-alist *configdat* tmpfile)) (system (conc "ln -sf " tmpfile " " targfile)))) @@ -930,21 +930,21 @@ #f (car cachefiles))) ;; (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) (rccachef (if (null? cachefiles) #f (cdr cachefiles)))) ;; (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) - ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-write-access? cachedir) (not (common:in-running-test?))))) + ;; (cancreate (and cachedir (file-exists? cachedir)(file-write-access? cachedir) (not (common:in-running-test?))))) (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource ;;(BB> "launch:setup-body -- cachefiles="cachefiles) (cond ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME ((and (not force-reread) mtcachef rccachef use-cache (get-environment-variable "MT_RUN_AREA_HOME") - (common:file-exists? mtcachef) - (common:file-exists? rccachef)) + (file-exists? mtcachef) + (file-exists? rccachef)) ;;(BB> "launch:setup-body -- cond branch 1 - use-cache") (set! *configdat* (configf:read-alist mtcachef)) ;;(BB> "launch:setup-body -- 1 set! *configdat*="*configdat*) (set! *runconfigdat* (configf:read-alist rccachef)) (set! *configinfo* (list *configdat* (get-environment-variable "MT_RUN_AREA_HOME"))) @@ -1054,11 +1054,11 @@ ;; additional house keeping (let* ((linktree (or (common:get-linktree) (conc *toppath* "/lt")))) (if linktree (begin - (if (not (common:file-exists? linktree)) + (if (not (file-exists? linktree)) (begin (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "Something went wrong when trying to create linktree dir at " linktree) @@ -1069,11 +1069,11 @@ exn (begin (debug:print-error 0 *default-log-port* "Something went wrong when trying to create link to linktree at " *toppath*) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))) (let ((tlink (conc *toppath* "/lt"))) - (if (not (common:file-exists? tlink)) + (if (not (file-exists? tlink)) (create-symbolic-link linktree tlink))))) (begin (debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config") ))) (if (and *toppath* @@ -1092,17 +1092,17 @@ (rccachef (cdr cachefiles))) ;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "...somepath.../.runconfigs.cfg-1.6427-7d1e789cb3f62f9cde719a4865bb51b3c17ea853" - ticket 220546342 ;; TODO - consider 1) using simple-lock to bracket cache write ;; 2) cache in hash on server, since need to do rmt: anyway to lock. - (if (and rccachef *runconfigdat* (not (common:file-exists? rccachef))) + (if (and rccachef *runconfigdat* (not (file-exists? rccachef))) (common:fail-safe (lambda () (configf:write-alist *runconfigdat* rccachef)) (conc "Could not write cache file - "rccachef)) ) - (if (and mtcachef *configdat* (not (common:file-exists? mtcachef))) + (if (and mtcachef *configdat* (not (file-exists? mtcachef))) (common:fail-safe (lambda () (configf:write-alist *configdat* mtcachef)) (conc "Could not write cache file - "mtcachef)) ) @@ -1196,17 +1196,17 @@ ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical ;; rundir shortdir (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path run-id) (debug:print 2 *default-log-port* "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) - (if (not (common:file-exists? linktree)) + (if (not (file-exists? linktree)) (begin (debug:print 0 *default-log-port* "WARNING: linktree did not exist! Creating it now at " linktree) (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree)))) ;; create the directory for the tests dir links, this is needed no matter what... (if (and (not (common:directory-exists? lnkbase)) - (not (common:file-exists? lnkbase))) + (not (file-exists? lnkbase))) (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "Problem creating linktree base at " lnkbase) (print-error-message exn (current-error-port))) @@ -1237,11 +1237,11 @@ (begin (debug:print-error 0 *default-log-port* " Failed to remove symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit 1)) (delete-file lnkpath))) - (if (not (or (common:file-exists? lnkpath) + (if (not (or (file-exists? lnkpath) (symbolic-link? lnkpath))) (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* " Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") @@ -1262,11 +1262,11 @@ (db:test-get-rundir testinfo) ;; ) ;; ) #f))) (hash-table-set! *toptest-paths* testname curr-test-path) ;; NB// Was this for the test or for the parent in an iterated test? (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath - (if (common:file-exists? lnkpath) + (if (file-exists? lnkpath) ;; (resolve-pathname lnkpath) (common:nice-path lnkpath) lnkpath) testname "" run-id) ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path) @@ -1301,11 +1301,11 @@ exn (begin (debug:print-error 0 *default-log-port* " Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit)) (if (symbolic-link? lnktarget) (delete-file lnktarget)) - (if (not (common:file-exists? lnktarget)) (create-symbolic-link test-path lnktarget))))) + (if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget))))) (if (not (directory? test-path)) (create-directory test-path #t)) ;; this is a hack, I don't know why out of the blue this path does not exist sometimes (if (and test-src-path (directory? test-path)) @@ -1471,11 +1471,11 @@ (list 'mt-bindir-path mt-bindir-path)))))))) ;; clean out step records from previous run if they exist ;; (rmt:delete-test-step-records run-id test-id) ;; if the dir does not exist we may have a itempath where individual variables are a path, launch anyway - (if (common:file-exists? work-area) + (if (file-exists? work-area) (change-directory work-area)) ;; so that log files from the launch process don't clutter the test dir (cond ;; ((and launcher hosts) ;; must be using ssh hostname ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param))) ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms)))) Index: lock-queue.scm ================================================================== --- lock-queue.scm +++ lock-queue.scm @@ -41,11 +41,11 @@ (let ((fname (lock-queue:db-dat-get-path dbdat))) (system (conc "rm -f " fname "*")))) (define (lock-queue:open-db fname #!key (count 10)) (let* ((actualfname (conc fname ".lockdb")) - (dbexists (common:file-exists? actualfname)) + (dbexists (file-exists? actualfname)) (db (sqlite3:open-database actualfname)) (handler (make-busy-timeout 136000))) (if dbexists (vector db actualfname) (begin @@ -172,12 +172,12 @@ ;; If we've tried ten times and failed there is a serious problem ;; try to remove the lock db and allow it to be recreated (handle-exceptions exn #f - (if (common:file-exists? journal)(delete-file journal)) - (if (common:file-exists? fname) (delete-file fname)) + (if (file-exists? journal)(delete-file journal)) + (if (file-exists? fname) (delete-file fname)) #f)))) (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id) (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))))) (define (lock-queue:steal-lock dbdat test-id #!key (count 10)) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -51,12 +51,12 @@ (declare (uses mt)) (declare (uses api)) (declare (uses tasks)) ;; only used for debugging. (declare (uses env)) (declare (uses diff-report)) -(declare (uses ftail)) -(import ftail) +;; (declare (uses ftail)) +;; (import ftail) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") @@ -68,11 +68,11 @@ (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file ;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file ;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) - (if (common:file-exists? debugcontrolf) + (if (file-exists? debugcontrolf) (load debugcontrolf))) ;; usage logging, careful with this, it is not designed to deal with all real world challenges! ;; (if (and *usage-log-file* @@ -438,11 +438,11 @@ (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) ;; before doing anything else change to the start-dir if provided ;; (if (args:get-arg "-start-dir") - (if (common:file-exists? (args:get-arg "-start-dir")) + (if (file-exists? (args:get-arg "-start-dir")) (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) (setenv "PWD" fullpath) (change-directory fullpath)) (begin (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") @@ -532,11 +532,11 @@ (let* ((htmlviewercmd (or (configf:lookup *configdat* "setup" "htmlviewercmd") (common:which '("firefox" "arora")))) (install-home (common:get-install-area)) (manual-html (conc install-home "/share/docs/megatest_manual.html"))) (if (and install-home - (common:file-exists? manual-html)) + (file-exists? manual-html)) (system (conc "(" htmlviewercmd " " manual-html " ) &")) (system (conc "(" htmlviewercmd " http://www.kiatoa.com/cgi-bin/fossils/megatest/doc/tip/docs/manual/megatest_manual.html ) &"))) (exit))) (if (args:get-arg "-version") @@ -787,11 +787,11 @@ (else (loop row (+ col 1) (append curr-row (list val)) result))))))))) (hash-table-keys results)))) ((sqlite3) (let* ((db-file (or out-file (pathname-file input-db))) - (db-exists (common:file-exists? db-file)) + (db-exists (file-exists? db-file)) (db (sqlite3:open-database db-file))) (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);")) (configf:map-all-hier-alist data (lambda (sheetname sectionname varname val) @@ -935,11 +935,11 @@ (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME")) (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")) #f)) (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f))) (if (and cfgf - (common:file-exists? cfgf) + (file-exists? cfgf) (file-write-access? cfgf) (common:use-cache?)) (configf:read-alist cfgf) (let* ((keys (rmt:get-keys)) (target (common:args-get-target)) @@ -1780,11 +1780,11 @@ (let* ((keys (rmt:get-keys)) ;; db:test-get-paths must not be run remote (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) (set! *didsomething* #t) (for-each (lambda (path) - (if (common:file-exists? path) + (if (file-exists? path) (print path))) paths))) ;; else do a general-run-call (general-run-call "-test-files" Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -201,11 +201,11 @@ "\n") (print-call-chain (current-error-port)) #f) (if (and test-name test-rundir) ;; #f means no dir set yet - ;; (common:file-exists? test-rundir) + ;; (file-exists? test-rundir) ;; (directory? test-rundir)) (call-with-environment-variables (list (cons "MT_TEST_NAME" (or test-name "no such test")) (cons "MT_TEST_RUN_DIR" (or test-rundir "no test directory yet")) (cons "MT_ITEMPATH" (or item-path ""))) @@ -271,11 +271,11 @@ (let ((test-dirs (tests:get-tests-search-path *configdat*))) (let loop ((hed (car test-dirs)) (tal (cdr test-dirs))) ;; Setting MT_LINKTREE here is almost certainly unnecessary. (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) - (if (and (common:file-exists? tconfig-file) + (if (and (file-exists? tconfig-file) (file-read-access? tconfig-file)) (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) (old-link-tree (get-environment-variable "MT_LINKTREE"))) (if link-tree-path (setenv "MT_LINKTREE" link-tree-path)) (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...] Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -1,6 +1,6 @@ -; Copyright 2006-2017, Matthew Welland. +;; Copyright 2006-2017, Matthew Welland. ;; ;; This file is part of Megatest. ;; ;; Megatest is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -25,20 +25,24 @@ (use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) srfi-18 extras format pkts regex regex-case (prefix dbi dbi:) nanomsg) -(declare (uses common)) +(declare (uses mtcommon)) (declare (uses megatest-version)) (declare (uses margs)) -(declare (uses configf)) -;; (declare (uses rmt)) +(declare (uses mtconfigf)) +(declare (uses mtdb)) ;; 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 mtdb db:)) +(import (prefix mtcommon common:)) +(import (prefix mtconfigf configf:)) + ;; stuff for the mapper and checker functions ;; (define *target-mappers* (make-hash-table)) (define *runname-mappers* (make-hash-table)) (define *area-checkers* (make-hash-table)) @@ -91,14 +95,14 @@ ;; ii. Check that we are in a legal megatest area? ;; iii. Have some form of authentication or record of the md5sum or similar of the file? ;; iv. Use compiled version in preference to .scm version. Thus there is a manual "blessing" ;; required to use .mtutil.scm. ;; -(if (common:file-exists? "megatest.config") - (if (common:file-exists? ".mtutil.so") +(if (file-exists? "megatest.config") + (if (file-exists? ".mtutil.so") (load ".mtutil.so") - (if (common:file-exists? ".mtutil.scm") + (if (file-exists? ".mtutil.scm") (load ".mtutil.scm")))) ;; main three types of run ;; "-run" => initiate a run ;; "-rerun-clean" => set failed, aborted, killed, etc. (not pass/fail) to NOT_STARTED and kick off run @@ -304,12 +308,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) '())))) @@ -321,11 +323,11 @@ (print "ERROR: failed to create directory " dest-dir " message: " ((condition-property-accessor 'exn 'message) exn)) (create-directory dest-dir #t)) (handle-exceptions exn (print "ERROR: failed to clone or sync 1ossil " url " message: " ((condition-property-accessor 'exn 'message) exn)) - (if (common:file-exists? targ-file) + (if (file-exists? targ-file) (system (conc "fossil pull --once " url " -R " targ-file)) (system (conc "fossil clone " url " " targ-file)) )))) (define (fossil:last-change-node-and-time fossils-dir fossil-name branch) @@ -666,11 +668,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 +767,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 +1012,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 +1030,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)) @@ -1200,21 +1202,21 @@ (let ((pktsdirs (configf:lookup mtconf "setup" "pktsdirs")) (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f))) pktsdir)) (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc"))) - (if (common:file-exists? debugcontrolf) + (if (file-exists? debugcontrolf) (load debugcontrolf))) (if *action* (case (string->symbol *action*) ((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"))) @@ -1302,16 +1304,16 @@ (let ((subcmd (car remargs))) (case (string->symbol subcmd) ((pgschema) (let* ((install-home (common:get-install-area)) (schema-file (conc install-home "/share/db/mt-pg.sql"))) - (if (common:file-exists? schema-file) + (if (file-exists? schema-file) (system (conc "/bin/cat " schema-file))))) ((sqlite3schema) (let* ((install-home (common:get-install-area)) (schema-file (conc install-home "/share/db/mt-sqlite3.sql"))) - (if (common:file-exists? schema-file) + (if (file-exists? schema-file) (system (conc "/bin/cat " schema-file))))) ((junk) (rmt:get-keys)))))) ((tsend) (if (null? remargs) @@ -1349,16 +1351,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 Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -26,20 +26,24 @@ (import canvas-draw-iup) (use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct (prefix dbi dbi:)) -(declare (uses common)) +(declare (uses mtcommon)) (declare (uses megatest-version)) (declare (uses margs)) +;; mofiles/mtdb.o mofiles/mtcommon.o mofiles/mtconfigf.o +;; dashboard-context-menu.o dashboard-tests.o dashboard-guimonitor.o +;; gutils.o dcommon.o tree.o vg.o newdashboard.scm -o ndboard + ;; (declare (uses launch)) ;; (declare (uses gutils)) ;; (declare (uses db)) ;; (declare (uses server)) ;; (declare (uses synchash)) -(declare (uses dcommon)) +;; (declare (uses dcommon)) ;; (declare (uses tree)) ;; ;; (include "common_records.scm") ;; (include "db_records.scm") ;; (include "key_records.scm") @@ -80,16 +84,16 @@ (if (args:get-arg "-h") (begin (print help) (exit))) -;; ease debugging by loading ~/.dashboardrc -(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) - (if (common:file-exists? debugcontrolf) - (load debugcontrolf))) - -(debug:setup) +;; ;; ease debugging by loading ~/.dashboardrc +;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) +;; (if (file-exists? debugcontrolf) +;; (load debugcontrolf))) +;; +;; (debug:setup) (define *tim* (iup:timer)) (define *ord* #f) (iup:attribute-set! *tim* "TIME" 300) @@ -122,592 +126,10 @@ (define (update-search x val) (hash-table-set! *searchpatts* x val)) -;; data for each specific tab goes here -;; -(defstruct dboard:tabdat - ;; runs - ((allruns '()) : list) ;; list of dboard:rundat records - ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records - ((done-runs '()) : list) ;; list of runs already drawn - ((not-done-runs '()) : list) ;; list of runs not yet drawn - (header #f) ;; header for decoding the run records - (keys #f) ;; keys for this run (i.e. target components) - ((numruns (string->number (or (args:get-arg "-cols") "10"))) : number) ;; - ((tot-runs 0) : number) - ((last-data-update 0) : number) ;; last time the data in allruns was updated - ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree - (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects - ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id - ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id - ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files - - ;; Runs view - ((buttondat (make-hash-table)) : hash-table) ;; - ((item-test-names '()) : list) ;; list of itemized tests - ((run-keys (make-hash-table)) : hash-table) - (runs-matrix #f) ;; used in newdashboard - ((start-run-offset 0) : number) ;; left-right slider value - ((start-test-offset 0) : number) ;; up-down slider value - ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12 - ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8 - ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string) ;; was 50 - ((all-test-names '()) : list) - - ;; Canvas and drawing data - (cnv #f) - (cnv-obj #f) - (drawing #f) - ((run-start-row 0) : number) - ((max-row 0) : number) - ((running-layout #f) : boolean) - (originx #f) - (originy #f) - ((layout-update-ok #t) : boolean) - ((compact-layout #t) : boolean) - - ;; Run times layout - ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere - (graph-matrix #f) - ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info - ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info - ((graph-matrix-row 1) : number) - ((graph-matrix-col 1) : number) - - ;; Controls used to launch runs etc. - ((command "") : string) ;; for run control this is the command being built up - (command-tb #f) ;; widget for the type of command; run, remove-runs etc. - (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns - (key-listboxes #f) - (key-lbs #f) - run-name ;; from run name setting widget - states ;; states for -state s1,s2 ... - statuses ;; statuses for -status s1,s2 ... - - ;; Selector variables - curr-run-id ;; current row to display in Run summary view - prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode - curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard - ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab - ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters - ((hide-empty-runs #f) : boolean) - ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs - (hide-not-hide-button #f) - ((searchpatts (make-hash-table)) : hash-table) ;; - ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control - ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f - (target #f) - (test-patts #f) - - ;; db info to file the .db files for the area - (access-mode (db:get-access-mode)) ;; use cached db or not - (dbdir #f) - (dbfpath #f) - (dbkeys #f) - ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp - (monitor-db-path #f) ;; where to find monitor.db - ro ;; is the database read-only? - - ;; tests data - ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display) - - ;; runs tree - ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id - (runs-tree #f) - ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?) - - ;; tab data - ((view-changed #t) : boolean) - ((xadj 0) : number) ;; x slider number (if using canvas) - ((yadj 0) : number) ;; y slider number (if using canvas) - ;; runs-summary tab state - ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list) - ((runs-summary-mode-buttons '()) : list) - ((runs-summary-mode 'one-run) : symbol) - ((runs-summary-mode-change-callbacks '()) : list) - (runs-summary-source-runname-label #f) - (runs-summary-dest-runname-label #f) - ;; runs summary view - - tests-tree ;; used in newdashboard - ) - - - -;; mtest is actually the megatest.config file -;; -(define (mtest toppath window-id) - (let* ((curr-row-num 0) - ;; (rawconfig (read-config (conc toppath "/megatest.config") #f 'return-string)) - (keys-matrix (iup:matrix)) ;; (dcommon:keys-matrix rawconfig)) - (setup-matrix (iup:matrix)) ;; (dcommon:section-matrix rawconfig "setup" "Varname" "Value")) - (jobtools-matrix (iup:matrix - #:expand "YES" - #:numcol 1 - #:numlin 5 - #:numcol-visible 1 - #:numlin-visible 3)) - (validvals-matrix (iup:matrix - #:expand "YES" - #:numcol 1 - #:numlin 2 - #:numcol-visible 1 - #:numlin-visible 2)) - (envovrd-matrix (iup:matrix - #:expand "YES" - #:numcol 1 - #:numlin 20 - #:numcol-visible 1 - #:numlin-visible 8)) - (disks-matrix (iup:matrix - #:expand "YES" - #:numcol 1 - #:numlin 20 - #:numcol-visible 1 - #:numlin-visible 8)) - ) - (iup:attribute-set! disks-matrix "0:0" "Disk Name") - (iup:attribute-set! disks-matrix "0:1" "Disk Path") - (iup:attribute-set! disks-matrix "WIDTH1" "120") - (iup:attribute-set! disks-matrix "WIDTH0" "100") - (iup:attribute-set! disks-matrix "ALIGNMENT1" "ALEFT") - (iup:attribute-set! disks-matrix "FIXTOTEXT" "C1") - (iup:attribute-set! disks-matrix "RESIZEMATRIX" "YES") - - ;; fill in existing info - (for-each - (lambda (mat fname) - (set! curr-row-num 1) - (for-each - (lambda (var) - (iup:attribute-set! mat (conc curr-row-num ":0") var) - ;; (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var)) - (set! curr-row-num (+ curr-row-num 1))) - '()));; (configf:section-vars rawconfig fname))) - (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix) - (list "setup" "jobtools" "validvalues" "env-override" "disks")) - - (for-each - (lambda (mat) - (iup:attribute-set! mat "0:1" "Value") - (iup:attribute-set! mat "0:0" "Var") - (iup:attribute-set! mat "ALIGNMENT1" "ALEFT") - (iup:attribute-set! mat "FIXTOTEXT" "C1") - (iup:attribute-set! mat "RESIZEMATRIX" "YES") - (iup:attribute-set! mat "WIDTH1" "120") - (iup:attribute-set! mat "WIDTH0" "100") - ) - (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix)) - - (iup:attribute-set! validvals-matrix "WIDTH1" "290") - (iup:attribute-set! envovrd-matrix "WIDTH1" "290") - - (iup:vbox - (iup:hbox - - (iup:vbox - (let ((tabs (iup:tabs - ;; The required tab - (iup:hbox - ;; The keys - (iup:frame - #:title "Keys (required)" - (iup:vbox - (iup:label (conc "Set the fields for organising your runs\n" - "here. Note: can only be changed before\n" - "running the first run when megatest.db\n" - "is created.")) - keys-matrix)) - (iup:vbox - ;; The setup section - (iup:frame - #:title "Setup" - (iup:vbox - (iup:label (conc "max_concurrent_jobs : limits total concurrent jobs (optional)\n" - "linktree : directory where linktree will be created.")) - setup-matrix)) - ;; The jobtools - (iup:frame - #:title "Jobtools" - (iup:vbox - (iup:label (conc "launcher : tool or script to run jobs (try nbfake)\n" - "useshell : use system to run your launcher\n" - "workhosts : spread jobs out on these hosts")) - jobtools-matrix)) - ;; The disks - (iup:frame - #:title "Disks" - (iup:vbox - (iup:label (conc "Enter names and existing paths of locations to run tests")) - disks-matrix)))) - ;; The optional tab - (iup:vbox - ;; The Environment Overrides - (iup:frame - #:title "Env override" - envovrd-matrix) - ;; The valid values - (iup:frame - #:title "Validvalues" - validvals-matrix) - )))) - (iup:attribute-set! tabs "TABTITLE0" "Required settings") - (iup:attribute-set! tabs "TABTITLE1" "Optional settings") - tabs)) - )))) - -;; The runconfigs.config file -;; -(define (rconfig window-id) - (iup:vbox - (iup:frame #:title "Default"))) - -;;====================================================================== -;; T E S T S -;;====================================================================== - -(define (tree-path->test-id path) - (if (not (null? path)) - (hash-table-ref/default (dboard:data-path-test-ids *data*) path #f) - #f)) - -(define (test-panel window-id) - (let* ((curr-row-num 0) - (viewlog (lambda (x) - (if (common:file-exists? logfile) - ;(system (conc "firefox " logfile "&")) - (iup:send-url logfile) - (message-window (conc "File " logfile " not found"))))) - (xterm (lambda (x) - (if (directory-exists? rundir) - (let ((shell (if (get-environment-variable "SHELL") - (conc "-e " (get-environment-variable "SHELL")) - ""))) - (system (conc "cd " rundir - ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) - (message-window (conc "Directory " rundir " not found"))))) - (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12")) - (command-launch-button (iup:button "Execute!" - ;; #:expand "HORIZONTAL" - #:size "50x" - #:action (lambda (x) - (let ((cmd (iup:attribute command-text-box "VALUE"))) - (system (conc cmd " &")))))) - (run-test (lambda (x) - (iup:attribute-set! - command-text-box "VALUE" - (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname - " -runtests " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - ";echo Press any key to continue;bash -c 'read -n 1 -s'\"")))) - (remove-test (lambda (x) - (iup:attribute-set! - command-text-box "VALUE" - (conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " :runname " runname - " -testpatt " (conc testname "/" (if (equal? item-path "") - "%" - item-path)) - " -v;echo Press any key to continue;bash -c 'read -n 1 -s'\"")))) - (run-info-matrix (iup:matrix - #:expand "YES" - ;; #:scrollbar "YES" - #:numcol 1 - #:numlin 4 - #:numcol-visible 1 - #:numlin-visible 4 - #:click-cb (lambda (obj lin col status) - (print "obj: " obj " lin: " lin " col: " col " status: " status)))) - (test-info-matrix (iup:matrix - #:expand "YES" - #:numcol 1 - #:numlin 7 - #:numcol-visible 1 - #:numlin-visible 7)) - (test-run-matrix (iup:matrix - #:expand "YES" - #:numcol 1 - #:numlin 5 - #:numcol-visible 1 - #:numlin-visible 5)) - (meta-dat-matrix (iup:matrix - #:expand "YES" - #:numcol 1 - #:numlin 5 - #:numcol-visible 1 - #:numlin-visible 5)) - (steps-matrix (iup:matrix - #:expand "YES" - #:numcol 6 - #:numlin 50 - #:numcol-visible 6 - #:numlin-visible 8)) - (data-matrix (iup:matrix - #:expand "YES" - #:numcol 8 - #:numlin 50 - #:numcol-visible 8 - #:numlin-visible 8)) - (updater (lambda (testdat) - (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)))) - - ;; Set the updater in updaters - ;; (hash-table-set! (dboard:data-updaters *data*) window-id updater) - ;; - (for-each - (lambda (mat) - ;; (iup:attribute-set! mat "0:1" "Value") - ;; (iup:attribute-set! mat "0:0" "Var") - (iup:attribute-set! mat "HEIGHT0" 0) - (iup:attribute-set! mat "ALIGNMENT1" "ALEFT") - ;; (iup:attribute-set! mat "FIXTOTEXT" "C1") - (iup:attribute-set! mat "RESIZEMATRIX" "YES")) - ;; (iup:attribute-set! mat "WIDTH1" "120") - ;; (iup:attribute-set! mat "WIDTH0" "100")) - (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix)) - - ;; Steps matrix - (iup:attribute-set! steps-matrix "0:1" "Step Name") - (iup:attribute-set! steps-matrix "0:2" "Start") - (iup:attribute-set! steps-matrix "WIDTH2" "40") - (iup:attribute-set! steps-matrix "0:3" "End") - (iup:attribute-set! steps-matrix "WIDTH3" "40") - (iup:attribute-set! steps-matrix "0:4" "Status") - (iup:attribute-set! steps-matrix "WIDTH4" "40") - (iup:attribute-set! steps-matrix "0:5" "Duration") - (iup:attribute-set! steps-matrix "WIDTH5" "40") - (iup:attribute-set! steps-matrix "0:6" "Log File") - (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") - ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") - (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") - ;; (iup:attribute-set! steps-matrix "WIDTH1" "120") - ;; (iup:attribute-set! steps-matrix "WIDTH0" "100") - - ;; Data matrix - ;; - (let ((rownum 1)) - (for-each - (lambda (x) - (iup:attribute-set! data-matrix (conc "0:" rownum) x) - (iup:attribute-set! data-matrix (conc "WIDTH" rownum) "50") - (set! rownum (+ rownum 1))) - (list "Category" "Variable" "Value" "Expected" "Tolerance" "Status" "Units" "Type" "Comment"))) - (iup:attribute-set! data-matrix "REDRAW" "ALL") - - (for-each - (lambda (data) - (let ((mat (car data)) - (keys (cadr data)) - (rownum 1)) - (for-each - (lambda (key) - (iup:attribute-set! mat (conc rownum ":0") key) - (set! rownum (+ rownum 1))) - keys) - (iup:attribute-set! mat "REDRAW" "ALL"))) - (list - (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" )) - (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment")) - (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration")) - (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description")))) - - (iup:split - #:orientation "HORIZONTAL" - (iup:vbox - (iup:hbox - (iup:vbox - run-info-matrix - test-info-matrix) - ;; test-info-matrix) - (iup:vbox - test-run-matrix - meta-dat-matrix)) - (iup:vbox - (iup:vbox - (iup:hbox - (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x" - (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x" - (iup:hbox - (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x" - (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x" - (iup:hbox - ;; hiup:split ;; hbox - ;; #:orientation "HORIZONTAL" - ;; #:value 300 - command-text-box - command-launch-button))) - (iup:vbox - (let ((tabs (iup:tabs - steps-matrix - data-matrix))) - (iup:attribute-set! tabs "TABTITLE0" "Test Steps") - (iup:attribute-set! tabs "TABTITLE1" "Test Data") - tabs))))) - -;; Test browser -(define (tests window-id) - (iup:split - (let* ((tb (iup:treebox - #:selection-cb - (lambda (obj id state) - ;; (print "obj: " obj ", id: " id ", state: " state) - (let* ((run-path (tree:node->path obj id)) - (test-id (tree-path->test-id (cdr run-path)))) - ;; (if test-id - ;; (hash-table-set! (dboard:data-curr-test-ids *data*) - ;; window-id test-id)) - (print "path: " (tree:node->path obj id) " test-id: " test-id)))))) - (iup:attribute-set! tb "VALUE" "0") - (iup:attribute-set! tb "NAME" "Runs") - ;;(iup:attribute-set! tb "ADDEXPANDED" "NO") - ;; (dboard:data-tests-tree-set! *data* tb) - tb) - (test-panel window-id))) - -;; The function to update the fields in the test view panel -(define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix) - ;; get test-id - ;; then get test record - (if testdat - (let* ((test-id 0) ;; (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f)) - (test-data (hash-table-ref/default testdat test-id #f)) - (run-id (db:test-get-run_id test-data)) - (targ/runname (hash-table-ref/default (dboard:data-run-keys *data*) - run-id - '())) - (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/"))) - (runname (if (null? targ/runname) "" (car (cdr targ/runname)))) - (steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id))) - - (if test-data - (begin - ;; - (for-each - (lambda (data) - (let ((mat (car data)) - (vals (cadr data)) - (rownum 1)) - (for-each - (lambda (key) - (let ((cell (conc rownum ":1"))) - (if (not (equal? (iup:attribute mat cell)(conc key))) - (begin - ;; (print "setting cell " cell " in matrix " mat " to value " key) - (iup:attribute-set! mat cell (conc key)) - (iup:attribute-set! mat "REDRAW" cell))) - (set! rownum (+ rownum 1)))) - vals))) - (list - (list run-info-matrix - (if test-id - (list (db:test-get-run_id test-data) - target - runname - "n/a") - (make-list 4 ""))) - (list test-info-matrix - (if test-id - (list test-id - (db:test-get-testname test-data) - (db:test-get-item-path test-data) - (db:test-get-state test-data) - (db:test-get-status test-data) - (seconds->string (db:test-get-event_time test-data)) - (db:test-get-comment test-data)) - (make-list 7 ""))) - (list test-run-matrix - (if test-id - (list (db:test-get-host test-data) - (db:test-get-uname test-data) - (db:test-get-diskfree test-data) - (db:test-get-cpuload test-data) - (seconds->hr-min-sec (db:test-get-run_duration test-data))) - (make-list 5 ""))) - )) - (dcommon:populate-steps steps-dat steps-matrix)))))) - ;;(list meta-dat-matrix - ;; (if test-id - ;; (list ( - - -;; db:test-get-id -;; db:test-get-run_id -;; db:test-get-testname -;; db:test-get-state -;; db:test-get-status -;; db:test-get-event_time -;; db:test-get-host -;; db:test-get-cpuload -;; db:test-get-diskfree -;; db:test-get-uname -;; db:test-get-rundir -;; db:test-get-item-path -;; db:test-get-run_duration -;; db:test-get-final_logf -;; db:test-get-comment -;; db:test-get-fullname - - -;;====================================================================== -;; R U N C O N T R O L -;;====================================================================== - -;; Overall runs browser -;; -(define (runs window-id) - (let* ((runs-matrix (iup:matrix - #:expand "YES" - ;; #:fittosize "YES" - #:scrollbar "YES" - #:numcol 100 - #:numlin 100 - #:numcol-visible 7 - #:numlin-visible 7 - #:click-cb (lambda (obj lin col status) - (print "obj: " obj " lin: " lin " col: " col " status: " status))))) - - (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES") - (iup:attribute-set! runs-matrix "WIDTH0" "100") - - ;; (dboard:data-runs-matrix-set! *data* runs-matrix) - (iup:hbox - (iup:frame - #:title "Runs browser" - (iup:vbox - runs-matrix))))) - -;; Browse and control a single run -;; -(define (runcontrol window-id) - (iup:hbox)) - -;;====================================================================== -;; D A S H B O A R D -;;====================================================================== - -;; Main Panel -(define (main-panel window-id) - (iup:dialog - #:title "Megatest Control Panel" - #:menu (dcommon:main-menu) - #:shrink "YES" - (let ((tabtop (iup:tabs - (runs window-id) - (tests window-id) - (runcontrol window-id) - (mtest *toppath* window-id) - (rconfig window-id) - ))) - (iup:attribute-set! tabtop "TABTITLE0" "Runs") - (iup:attribute-set! tabtop "TABTITLE1" "Tests") - (iup:attribute-set! tabtop "TABTITLE2" "Run Control") - (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") - (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") - tabtop))) - (define *current-window-id* 0) (define (newdashboard dbstruct) (let* ((data (make-hash-table)) (keys '()) ;; (db:get-keys dbstruct)) @@ -718,11 +140,11 @@ (statuses '()) (nextmintime (current-milliseconds)) (my-window-id *current-window-id*)) (set! *current-window-id* (+ 1 *current-window-id*)) ;; (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application - (iup:show (main-panel my-window-id)) + (iup:show (iup:button "Pushme")) ;; my-window-id)) ;; Yes, running iup:show will pop up a new panel ;; (iup:show (main-panel my-window-id)) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) @@ -736,7 +158,8 @@ ;; (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "...")) ) (debug:print-info 11 *default-log-port* "Server overloaded")))))) ;; (dboard:data-updaters-set! *data* (make-hash-table)) -(newdashboard #f) ;; *dbstruct-local*) +;; (newdashboard #f) ;; *dbstruct-local*) +(iup:show (iup:dialog (iup:vbox (iup:button "Hello world")))) (iup:main-loop) Index: ods.scm ================================================================== --- ods.scm +++ ods.scm @@ -206,11 +206,11 @@ ;; '( (sheet1 (r1c1 r1c2 r1c3 ...) ;; (r2c1 r2c3 r2c3 ...) ) ;; (sheet2 ( ... ) ;; ( ... ) ) ) (define (ods:list->ods path fname data) - (if (not (common:file-exists? path)) + (if (not (file-exists? path)) (print "ERROR: path to create ods data must pre-exist") (begin (with-output-to-file (conc path "/content.xml") (lambda () (ods:construct-dir path) Index: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -22,17 +22,18 @@ (use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3) (import (prefix sqlite3 sqlite3:)) (declare (unit portlogger)) (declare (uses db)) +(declare (uses common)) ;; lsof -i (define (portlogger:open-db fname) (let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away - (exists (common:file-exists? fname)) + (exists (file-exists? fname)) (db (if avail (sqlite3:open-database fname) (begin (system (conc "rm -f " fname)) (sqlite3:open-database fname)))) @@ -66,11 +67,11 @@ (begin ;; (release-dot-lock fname) (debug:print-error 0 *default-log-port* "portlogger:open-run-close failed. " proc " " params) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 5 *default-log-port* "exn=" (condition->list exn)) - (if (common:file-exists? fname)(delete-file fname)) ;; brutally get rid of it + (if (file-exists? fname)(delete-file fname)) ;; brutally get rid of it (print-call-chain (current-error-port))) (let* (;; (lock (obtain-dot-lock fname 2 9 10)) (db (portlogger:open-db fname)) (res (apply proc db params))) (sqlite3:finalize! db) Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -22,10 +22,11 @@ ;; Process convience utils ;;====================================================================== (use regex) (declare (unit process)) +(declare (uses common)) (define (process:conservative-read port) (let loop ((res "")) (if (not (eof-object? (peek-char port))) (loop (conc res (read-char port))) @@ -180,11 +181,11 @@ (define (process:alive? pid) (handle-exceptions exn ;; possibly pid is a process not a child, look in /proc to see if it is running still - (common:file-exists? (conc "/proc/" pid)) + (file-exists? (conc "/proc/" pid)) (let-values (((rpid exit-type exit-signal)(process-wait pid #t))) (and (number? rpid) (equal? rpid pid))))) (define (process:alive-on-host? host pid) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -21,10 +21,12 @@ (use format typed-records) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses api)) (declare (uses http-transport)) +(declare (uses common)) + (include "common_records.scm") ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -90,11 +90,11 @@ (let ((runconfigf (conc *toppath* "/runconfigs.config")) (targ (or (common:args-get-target) targ-from-db (get-environment-variable "MT_TARGET")))) (pop-directory) - (if (common:file-exists? runconfigf) + (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id #t keyvals environ-patt: (conc "(default" (if targ (conc "|" targ ")") ")"))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -365,11 +365,11 @@ ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; (define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names - (let* ((keys (keys:config-get-fields *configdat*)) + (let* ((keys (common:get-fields *configdat*)) (keyvals (keys:target->keyval keys target)) (run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name))) ;; (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config")) (dbfile (conc *toppath* "/megatest.db")) @@ -426,11 +426,11 @@ ;; force the starting of a server -- removed BB 17ww28 - no longer needed. ;;(debug:print 0 *default-log-port* "waiting on server...") ;;(server:start-and-wait *toppath*) (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process - (set! runconf (if (common:file-exists? runconfigf) + (set! runconf (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target) (begin (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf) #f))) @@ -1765,11 +1765,11 @@ (thread-sleep! 1) (loop))))) (if (not testdat) ;; should NOT happen (debug:print-error 0 *default-log-port* "failed to get test record for test-id " test-id)) (set! test-id (db:test-get-id testdat)) - (if (common:file-exists? test-path) + (if (file-exists? test-path) (change-directory test-path) (begin (debug:print-error 0 *default-log-port* "test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?") (change-directory *toppath*))) (case (if force ;; (args:get-arg "-force") @@ -1833,11 +1833,11 @@ (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))) (if (not (null? running-tests)) ;; have to skip (set! skip-test "Skipping due to previous tests running")))) ((and skip-check (configf:lookup test-conf "skip" "fileexists")) - (if (common:file-exists? (configf:lookup test-conf "skip" "fileexists")) + (if (file-exists? (configf:lookup test-conf "skip" "fileexists")) (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists"))))) ((and skip-check (configf:lookup test-conf "skip" "rundelay")) ;; run-ids = #f means *all* runs (let* ((numseconds (common:hms-string->seconds (configf:lookup test-conf "skip" "rundelay"))) @@ -2252,11 +2252,11 @@ ;; BB TODO - manage has-subrun case (if (and run-dir (not toplevel-with-children)) (let ((ddir (conc run-dir "/"))) (case (string->symbol (args:get-arg "-archive")) ((save save-remove keep-html) - (if (common:file-exists? ddir) + (if (file-exists? ddir) (debug:print-info 0 *default-log-port* "Estimating disk space usage for " test-fulln ": " (common:get-disk-space-used ddir))))))) (if (not (null? tal)) (loop (car tal)(cdr tal)))) ))) ) @@ -2289,11 +2289,11 @@ ) #t) (define (runs:remove-test-directory test mode) ;; remove-data-only) (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree - (real-dir (if (common:file-exists? run-dir) + (real-dir (if (file-exists? run-dir) ;; (resolve-pathname run-dir) (common:nice-path run-dir) #f)) (clean-mode (or mode 'remove-all)) (test-id (db:test-get-id test)) @@ -2316,14 +2316,14 @@ ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f))) (debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) (if (and real-dir (> (string-length real-dir) 5) - (common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. + (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. (begin ;; let* ((realpath (resolve-pathname run-dir))) (debug:print-info 1 *default-log-port* "Recursively removing " real-dir) - (if (common:file-exists? real-dir) + (if (file-exists? real-dir) (runs:safe-delete-test-dir real-dir) (debug:print 0 *default-log-port* "WARNING: test dir " real-dir " appears to not exist or is not readable"))) (if real-dir (debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist") (debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done"))) @@ -2381,11 +2381,11 @@ (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) - (set! keys (keys:config-get-fields *configdat*)) + (set! keys (common:get-fields *configdat*)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL (runconfig (read-config runconfigf #f #t environ-patt: #f))) (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) @@ -2536,11 +2536,11 @@ (define (runs:clean-cache target runname toppath) (if target (if runname (let* ((linktree (common:get-linktree)) ;; (if toppath (configf:lookup *configdat* "setup" "linktree"))) (runtop (conc linktree "/" target "/" runname)) - (files (if (common:file-exists? runtop) + (files (if (file-exists? runtop) (append (glob (conc runtop "/.megatest*")) (glob (conc runtop "/.runconfig*"))) '()))) (if (null? files) (debug:print-info 0 *default-log-port* "No cached megatest or runconfigs files found. None removed.") Index: sdb.scm ================================================================== --- sdb.scm +++ sdb.scm @@ -27,15 +27,16 @@ (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit sdb)) +(declare (uses common)) ;; (define (sdb:open fname) (let* ((dbpath (pathname-directory fname)) - (dbexists (let ((fe (common:file-exists? fname))) + (dbexists (let ((fe (file-exists? fname))) (if fe fe (begin (create-directory dbpath #t) #f)))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -517,14 +517,14 @@ (should-sync (and (not *time-to-exit*) (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed (start-time (current-seconds)) (cpu-load-adj (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f))) (mt-mod-time (file-modification-time mtpath)) - (last-sync-start (if (common:file-exists? start-file) + (last-sync-start (if (file-exists? start-file) (file-modification-time start-file) 0)) - (last-sync-end (if (common:file-exists? end-file) + (last-sync-end (if (file-exists? end-file) (file-modification-time end-file) 10)) (sync-period (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period (recently-synced (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db! (< mt-mod-time last-sync-start))) ADDED src/ftail.scm Index: src/ftail.scm ================================================================== --- /dev/null +++ src/ftail.scm @@ -0,0 +1,108 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + +;;====================================================================== + +(declare (unit ftail)) + +(module ftail + ( + open-tail-db + tail-write + tail-get-fid + file-tail + ) + +(import scheme chicken data-structures extras) +(use (prefix sqlite3 sqlite3:) posix typed-records) + +(define (open-tail-db ) + (let* ((basedir (create-directory (conc "/tmp/" (current-user-name)))) + (dbpath (conc basedir "/megatest_logs.db")) + (dbexists (file-exists? dbpath)) + (db (sqlite3:open-database dbpath)) + (handler (sqlite3:make-busy-timeout 136000))) + (sqlite3:set-busy-handler! db handler) + (sqlite3:execute db "PRAGMA synchronous = 0;") + (if (not dbexists) + (begin + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));") + )) + db)) + +(define (tail-write db fid lines) + (sqlite3:with-transaction + db + (lambda () + (for-each + (lambda (line) + (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line)) + lines)))) + +(define (tail-get-fid db fname) + (let ((fid (handle-exceptions + exn + #f + (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname)))) + (if fid + fid + (begin + (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname) + (tail-get-fid db fname))))) + +(define (file-tail fname #!key (db-in #f)) + (let* ((inp (open-input-file fname)) + (db (or db-in (open-tail-db))) + (fid (tail-get-fid db fname))) + (let loop ((inl (read-line inp)) + (lines '()) + (lastwr (current-seconds))) + (if (eof-object? inl) + (let ((timed-out (> (- (current-seconds) lastwr) 60))) + (if timed-out (tail-write db fid (reverse lines))) + (sleep 1) + (if timed-out + (loop (read-line inp) '() (current-seconds)) + (loop (read-line inp) lines lastwr))) + (let* ((savelines (> (length lines) 19))) + ;; (print inl) + (if savelines (tail-write db fid (reverse lines))) + (loop (read-line inp) + (if savelines + '() + (cons inl lines)) + (if savelines + (current-seconds) + lastwr))))))) + +;; offset -20 means get last 20 lines +;; +(define (tail-get-lines db fid offset count) + (if (> offset 0) + (sqlite3:map-row (lambda (id line) + (vector id line)) + db + "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count) + (reverse ;; get N from the end + (sqlite3:map-row (lambda (id line) + (vector id line)) + db + "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset))))) + +) ADDED src/mtcommon.scm Index: src/mtcommon.scm ================================================================== --- /dev/null +++ src/mtcommon.scm @@ -0,0 +1,289 @@ +;====================================================================== +;; Copyright 2006-2016, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; +;;====================================================================== + +;; NOTE: This is the db module, long term it will replace db.scm. +;; WARN: This module conflicts with db.scm as it uses sql-de-lite + +(declare (unit mtcommon)) + +(module mtcommon + ( + get-create-writeable-dir + print-error + print-info + log-event + debug-setup + debug-mode + check-verbosity + calc-verbosity + ) + +(import scheme chicken data-structures extras posix ports) +(use (prefix sql-de-lite sql:) posix typed-records format srfi-1 srfi-69) + +(defstruct ctrldat + (port (current-error-port)) + (verbosity 1) + (vcache (make-hash-table)) + (logging #f) ;; keep the flag and the db handle separate to enable overriding + (logdb #f) ;; might need to make this a stack of handles for threaded access + (toppath #f) ;; + ) + +(define *log* (make-ctrldat)) + +;; this was cached based on results from profiling but it turned out the profiling +;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching +;; in for now but can probably take it out later. +;; +(define (calc-verbosity vstr args) + (or (hash-table-ref/default (ctrldat-vcache *log*) vstr #f) + (let ((res (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)))) + ((hash-table-exists? args "-v") 2) + ((hash-table-exists? args "-q") 0) + (else 1)))) + (hash-table-set! (ctrldat-vcache *log*) vstr res) + res))) + +;; check verbosity, #t is ok +(define (check-verbosity verbosity vstr) + (if (not (or (number? verbosity) + (list? verbosity))) + (begin + (print "ERROR: Invalid debug value \"" vstr "\"") + #f) + #t)) + +(define (debug-mode n) + (let* ((verbosity (ctrldat-verbosity *log*))) + (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 args) + (let* ((debugstr (or (hash-table-ref/default args "-debug" #f) + (get-environment-variable "MT_DEBUG_MODE"))) + (verbosity (calc-verbosity debugstr args))) + ;; if we were handed a bad verbosity rule then we will override it with 1 and continue + (if (not (check-verbosity verbosity debugstr)) + (set! verbosity 1)) + (ctrldat-verbosity-set! *log* verbosity) + (if (or (hash-table-exists? args "-debug") + (not (get-environment-variable "MT_DEBUG_MODE"))) + (setenv "MT_DEBUG_MODE" (if (list? verbosity) + (string-intersperse (map conc verbosity) ",") + (conc verbosity)))))) + +(define (debug-print n e . params) + (if (debug-mode n) + (with-output-to-port (or e (current-error-port)) + (lambda () + (if (ctrldat-logging *log*) + (log-event (apply conc params)) + (apply print params) + ))))) + +;; ;; Brandon's debug printer shortcut (indulge me :) +;; (define *BB-process-starttime* (current-milliseconds)) +;; (define (BB> . in-args) +;; (let* ((stack (get-call-chain)) +;; (location "??")) +;; (for-each +;; (lambda (frame) +;; (let* ((this-loc (vector-ref frame 0)) +;; (temp (string-split (->string this-loc) " ")) +;; (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???"))) +;; (if (equal? this-func "BB>") +;; (set! location this-loc)))) +;; stack) +;; (let* ((color-on "\x1b[1m") +;; (color-off "\x1b[0m") +;; (dp-args +;; (append +;; (list 0 *default-log-port* +;; (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") ) +;; in-args))) +;; (apply debug:print dp-args)))) +;; +;; (define *BBpp_custom_expanders_list* (make-hash-table)) +;; +;; +;; +;; ;; register hash tables with BBpp. +;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE: +;; (cons hash-table? hash-table->alist)) +;; +;; ;; test name converter +;; (define (BBpp_custom_converter arg) +;; (let ((res #f)) +;; (for-each +;; (lambda (custom-type-name) +;; (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name)) +;; (custom-type-test (car custom-type-info)) +;; (custom-type-converter (cdr custom-type-info))) +;; (when (and (not res) (custom-type-test arg)) +;; (set! res (custom-type-converter arg))))) +;; (hash-table-keys *BBpp_custom_expanders_list*)) +;; (if res (BBpp_ res) arg))) +;; +;; (define (BBpp_ arg) +;; (cond +;; ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg))) +;; ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg))) +;; ((hash-table? arg) +;; (let ((al (hash-table->alist arg))) +;; (BBpp_ (cons HASH_TABLE: al)))) +;; ((null? arg) '()) +;; ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) +;; ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) +;; (else (BBpp_custom_converter arg)))) +;; +;; ;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp +;; (define (BBpp arg) +;; (pp (BBpp_ arg))) +;; +;; ;(use define-macro) +;; (define-syntax inspect +;; (syntax-rules () +;; [(_ x) +;; ;; (with-output-to-port (current-error-port) +;; (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x)))) +;; ;; ) +;; ] +;; [(_ x y ...) (begin (inspect x) (inspect y ...))])) + +(define (print-error n e . params) + ;; normal print + (if (debug-mode n) + (with-output-to-port (if (port? e) e (current-error-port)) + (lambda () + (if (ctrldat-logging *log*) + (log-event (apply conc params)) + ;; (apply print "pid:" (current-process-id) " " params) + (apply print "ERROR: " params) + )))) + ;; pass important messages to stderr + (if (and (eq? n 0)(not (eq? e (current-error-port)))) + (with-output-to-port (current-error-port) + (lambda () + (apply print "ERROR: " params) + )))) + +(define (print-info n e . params) + (if (debug-mode n) + (with-output-to-port (if (port? e) e (current-error-port)) + (lambda () + (if (ctrldat-logging *log*) + (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) + (log-event 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 "")) + +;;====================================================================== +;; L O G G I N G D B +;;====================================================================== + +(define (open-logging-db toppath) + (let* ((dbpath (conc (if toppath (conc toppath "/") "") "logging.db")) ;; fname) + (dbexists (file-exists? dbpath)) + (db (sql:open-database dbpath)) + (handler (sql:busy-timeout 136000))) ;; remove argument to override + (sql:set-busy-handler! db handler) + (if (not dbexists) + (sql:exec (sql:sql db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);"))) + (sql:exec (sql:sql db "PRAGMA synchronous = 0;")) + db)) + +(define (log-local-event toppath . loglst) + (let ((logline (apply conc loglst))) + (log-event logline))) + +(define (log-event toppath logline) + (let ((db (open-logging-db toppath))) + (sql:exec + (sql:sql db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);") + logline + (current-directory) + (string-intersperse (argv) " ") + (current-process-id)) + logline)) + +;;====================================================================== +;; paths and directories +;;====================================================================== + +;; return first path that can be created or already exists and is writable +;; +(define (get-create-writeable-dir dirs) + (if (null? dirs) + #f + (let loop ((hed (car dirs)) + (tal (cdr dirs))) + (let ((res (or (and (directory? hed) + (file-write-access? hed) + hed) + (handle-exceptions + exn + (begin + ;; (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.") + (print "INFO: could not create " hed ", this might cause problems down the road.") + #f) + (create-directory hed #t))))) + (if (and (string? res) + (directory? res)) + res + (if (null? tal) + #f + (loop (car tal)(cdr tal)))))))) + +(define old-file-exists? file-exists?) + +(define (file-exists? path-string) + ;; this avoids stack dumps. NOTE: The issues that triggered this approach might have been fixed TODO: test and remove if possible + ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... + (handle-exceptions + exn + #f + (old-file-exists? path-string))) + +) ADDED src/mtconfigf.scm Index: src/mtconfigf.scm ================================================================== --- /dev/null +++ src/mtconfigf.scm @@ -0,0 +1,975 @@ +;====================================================================== +;; Copyright 2006-2016, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; +;;====================================================================== + +;; NOTE: This is the configf module, long term it will replace configf.scm. + +(declare (unit mtconfigf)) + +(module mtconfigf + ( + + ) + +(import scheme chicken data-structures extras ports files) +(use posix typed-records srfi-18) +(use regex regex-case srfi-69 srfi-1 directory-utils extras srfi-13) +(import posix) + +;; very wierd, the reference to pathname-directory here fixes a reference to possibly unbound identifier problem +;; +;; (define (dummy-function path) +;; (pathname-directory path) +;; (absolute-pathname? path) +;; (normalize-pathname path)) + +(define debug:print-error print) +(define debug:print print) +(define debug:print-info print) +(define *default-log-port* (current-error-port)) + +(define (set-debug-printers normal-fn info-fn error-fn default-port) + (if error-fn (set! debug:print-error error-fn)) + (if info-fn (set! debug:print-info info-fn)) + (if normal-fn (set! debug:print normal-fn)) + (if default-port (set! *default-log-port* default-port))) + +;; if it looks like a number -> convert it to a number, else return it +;; +(define (lazy-convert inval) + (let* ((as-num (if (string? inval)(string->number inval) #f))) + (or as-num inval))) + +;; Moved to common +;; +;;;; return list (path fullpath configname) +;;(define (find-config configname #!key (toppath #f)) +;; (if toppath +;; (let ((cfname (conc toppath "/" configname))) +;; (if (common: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 (common: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 (assoc-safe-add alist key val #!key (metadata #f)) + (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) + (append newalist (list (if metadata + (list key val metadata) + (list key val)))))) + +(define (section-var-set! cfgdat section-name var value #!key (metadata #f)) + (hash-table-set! cfgdat section-name + (assoc-safe-add + (hash-table-ref/default cfgdat section-name '()) + var value metadata: metadata))) +;;====================================================================== +;; Environment handling stuff +;;====================================================================== + +(define (safe-file-exists? path) + (handle-exceptions exn #f (file-exists? path))) + +(define (read-link-f path) + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed.") + path) ;; just give up + (with-input-from-pipe + (conc "/bin/readlink -f " path) + (lambda () + (read-line))))) + +;; return a nice clean pathname made absolute +(define (nice-path dir) + (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) + (if match ;; using ~ for home? + (nice-path (conc (read-link-f (cadr match)) "/" (caddr match))) + (normalize-pathname (if (absolute-pathname? dir) + dir + (conc (current-directory) "/" dir)))))) + +(define (eval-string-in-environment str) + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment") + #f) + (let ((cmdres (cmd-run->list (conc "echo " str)))) + (if (null? cmdres) "" + (caar cmdres))))) + +(define (safe-setenv key val) + (if (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables. + (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\"") + (if (and (string? val) + (string? key)) + (handle-exceptions + exn + (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val) + (setenv key val)) + (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)))) + +;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) +;; execute thunk in context of environment modified as per this list +;; restore env to prior state then return value of eval'd thunk. +;; ** this is not thread safe ** +(define (with-env-vars delta-env-alist-or-hash-table thunk) + (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table) + (hash-table->alist delta-env-alist-or-hash-table) + delta-env-alist-or-hash-table)) + (restore-thunks + (filter + identity + (map (lambda (env-pair) + (let* ((env-var (car env-pair)) + (new-val (let ((tmp (cdr env-pair))) + (if (list? tmp) (car tmp) tmp))) + (current-val (get-environment-variable env-var)) + (restore-thunk + (cond + ((not current-val) (lambda () (unsetenv env-var))) + ((not (string? new-val)) #f) + ((eq? current-val new-val) #f) + (else + (lambda () (setenv env-var current-val)))))) + ;;(when (not (string? new-val)) + ;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist) + ;; (pp delta-env-alist) + ;; (exit 1)) + + + (cond + ((not new-val) ;; modify env here + (unsetenv env-var)) + ((string? new-val) + (setenv env-var new-val))) + restore-thunk)) + delta-env-alist)))) + (let ((rv (thunk))) + (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state + rv))) + +(define (cmd-run->list cmd #!key (delta-env-alist-or-hash-table '())) + (with-env-vars + delta-env-alist-or-hash-table + (lambda () + (let* ((fh (open-input-pipe cmd)) + (res (port->list fh)) + (status (close-input-pipe fh))) + (list res status))))) + +(define (port->list fh) + (if (eof-object? fh) #f + (let loop ((curr (read-line fh)) + (result '())) + (if (not (eof-object? curr)) + (loop (read-line fh) + (append result (list curr))) + result)))) + +;;====================================================================== +;; Make the regexp's needed globally available +;;====================================================================== + +(define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) +(define configf:script-rx (regexp "^\\[scriptinc\\s+(\\S+)([^\\]]*)\\]\\s*$")) ;; include output from a script +(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|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)")) + +(define (configf:system ht cmd) + (system cmd) + ) + +(define (process-line l ht allow-system #!key (linenum #f)) + (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) + (start-time (current-seconds)) + (cmdsym (string->symbol cmdtype)) + (fullcmd (case cmdsym + ((scheme scm) (conc "(lambda (ht)" cmd ")")) + ((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))")) + ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))")) + ((realpath rp)(conc "(lambda (ht)(nice-path \"" cmd "\"))")) + ((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))")) + ((mtrah) (conc "(lambda (ht)" + " (let ((extra \"" cmd "\"))" + " (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))" + " (if (string-null? extra) \"\" \"/\")" + " extra)))")) + ((get g) + (let* ((parts (string-split cmd)) + (sect (car parts)) + (var (cadr parts))) + (conc "(lambda (ht)(lookup ht \"" sect "\" \"" var "\"))"))) + ((runconfigs-get rget) (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 + (begin + (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\"") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + ;; (print "exn=" (condition->list exn)) + (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd))) + (if (or allow-system + (not (member cmdtype '("system" "shell" "sh")))) + (with-input-from-string fullcmd + (lambda () + (set! result ((eval (read)) ht)))) + (set! result (conc "#{(" cmdtype ") " cmd "}")))) + (case cmdsym + ((system shell scheme) + (let ((delta (- (current-seconds) start-time))) + (if (> delta 2) + (debug:print-info 0 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result) + (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result))))) + (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 *default-log-port* "shell result:\n" outres) + outres) + (begin + (with-output-to-port (current-error-port) + (lambda () + (print "ERROR: " cmd " returned bad exit code " status))) + "")))) + +;; 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) + (process-line inl ht allow-processing)) + ((return-string) + inl) + (else + (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)))))) + +(define (cfgdat->env-alist section cfgdat-ht allow-system) + (filter + (lambda (pair) + (let* ((var (car pair)) + (val (cdr pair))) + (cons var + (cond + ((and allow-system (procedure? val)) ;; if we decided to use something other than #t or #f for allow-system ('return-procs or 'return-string) , this may become problematic + (val)) + ((procedure? val) #f) + ((string? val) val) + (else "#f"))))) + (append + (hash-table-ref/default cfgdat-ht "default" '()) + (if (equal? section "default") '() (hash-table-ref/default cfgdat-ht section '()))))) + +(define (calc-allow-system allow-system section sections) + (if sections + (and (or (equal? "default" section) + (member section sections)) + allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings + allow-system)) + +;; given a config hash and a section name, apply that section to all matching sections (using wildcard % or regex if /..../) +;; remove the section when done so that there is no downstream clobbering +;; +(define (apply-wildcards ht section-name) + (if (hash-table-exists? ht section-name) + (let* ((vars (hash-table-ref ht section-name)) + (rxstr (if (string-contains section-name "%") + (string-substitute (regexp "%") ".*" section-name) + (string-substitute (regexp "^/(.*)/$") "\\1" section-name))) + (rx (regexp rxstr))) + ;; (print "\nsection-name: " section-name " rxstr: " rxstr) + (for-each + (lambda (section) + (if section + (let ((same-section (string=? section-name section)) + (rx-match (string-match rx section))) + ;; (print "section: " section " vars: " vars " same-section: " same-section " rx-match: " rx-match) + (if (and (not same-section) rx-match) + (for-each + (lambda (bundle) + ;; (print "bundle: " bundle) + (let ((key (car bundle)) + (val (cadr bundle)) + (meta (if (> (length bundle) 2)(caddr bundle) #f))) + (hash-table-set! ht section (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 (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 (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 (section->val-alist cfgdat section-name #!key (convert #f)) + (let ((section (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 (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: +;; #f - do not evaluate [system +;; #t - immediately evaluate [system and store result as string +;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time +;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time +;; 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 +;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path) +;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections +;; +;; NOTE: apply-wild variable is intentional (but a better name would be good) +;; +(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f) + (sections #f) (settings (make-hash-table)) (keep-filenames #f) + (post-section-procs '()) (apply-wild #t) ) + (debug:print 9 *default-log-port* "START: " path) +;; (if *configdat* +;; (common:save-pkt `((action . read-config) +;; (f . ,(cond ((string? path) path) +;; ((port? path) "port") +;; (else (conc path)))) +;; (T . configf)) +;; *configdat* #t add-only: #t)) + (if (and (not (port? path)) + (not (safe-file-exists? path))) ;; for case where we are handed a port + (begin + (debug:print-info 1 *default-log-port* "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 (if (string? path) + (open-input-file path) + path)) ;; we can be handed a port + (res (if (not ht)(make-hash-table) ht)) + (metapath (if keep-filenames + path #f)) + (process-wildcards (lambda (res curr-section-name) + (if (and apply-wild + (or (string-contains curr-section-name "%") ;; wildcard + (string-match "/.*/" curr-section-name))) ;; regex + (begin + (apply-wildcards res curr-section-name) + (hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res + (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) 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 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") + (if (eof-object? inl) + (begin + ;; process last section for wildcards + (process-wildcards res curr-section-name) + (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it. + (close-input-port inp)) + (if (list? sections) ;; delete all sections except given when sections is provided + (for-each + (lambda (section) + (if (not (member section sections)) + (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht + (hash-table-keys res))) + (debug:print 9 *default-log-port* "END: " path) + res + ) ;; retval + (regex-case + inl + (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f)) + + (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f)) + (configf:settings ( x setting val ) + (begin + (hash-table-set! settings setting val) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) 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 (safe-file-exists? full-conf) + (begin + ;; (push-directory conf-dir) + (debug:print 9 *default-log-port* "Including: " full-conf) + (read-config full-conf res allow-system environ-patt: environ-patt + curr-section: curr-section-name sections: sections settings: settings + keep-filenames: keep-filenames) + ;; (pop-directory) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (begin + (debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")") + (debug:print 2 *default-log-port* " " full-conf) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f))))) + (configf:script-rx ( x include-script params);; handle-exceptions + ;; exn + ;; (begin + ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") + ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (if (and (safe-file-exists? include-script)(file-execute-access? include-script)) + (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections)) + (env-delta (cfgdat->env-alist curr-section-name res local-allow-system)) + (new-inp-port + (with-env-vars + env-delta + (lambda () + (open-input-pipe (conc include-script " " params)))))) + (debug:print '(2 9) *default-log-port* "Including from script output: " include-script) + ;; (print "We got here, calling read-config next. Port is: " new-inp-port) + (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) + (close-input-port new-inp-port) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (begin + (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) + ) ;; ) + (configf:section-rx ( x section-name ) + (begin + ;; call post-section-procs + (for-each + (lambda (dat) + (let ((patt (car dat)) + (proc (cdr dat))) + (if (string-match patt curr-section-name) + (proc curr-section-name section-name res path)))) + post-section-procs) + ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards + ;; NOTE: we are processing the curr-section-name, NOT section-name. + (process-wildcards res curr-section-name) + (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) 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 "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later. + section-name + #f #f))) + (configf:key-sys-pr ( x key cmd ) + (if (calc-allow-system allow-system curr-section-name sections) + (let ((alist (hash-table-ref/default res curr-section-name '())) + (val-proc (lambda () + (let* ((start-time (current-seconds)) + (local-allow-system (calc-allow-system allow-system curr-section-name sections)) + (env-delta (cfgdat->env-alist curr-section-name res local-allow-system)) + (cmdres (cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars! + (delta (- (current-seconds) start-time)) + (status (cadr cmdres)) + (res (car cmdres))) + (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n")) + (if (not (eq? status 0)) + (begin + (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status + " output: " cmdres))) + (if (> delta 2) + (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) + (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) + (if (null? res) + "" + (string-intersperse res " ")))))) + (hash-table-set! res curr-section-name + (assoc-safe-add alist + key + (case (calc-allow-system allow-system curr-section-name sections) + ((return-procs) val-proc) + ((return-string) cmd) + (else (val-proc))) + metadata: metapath)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) + settings) + curr-section-name #f #f))) + + (configf:key-no-val ( x key val) + (let* ((alist (hash-table-ref/default res curr-section-name '())) + (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) + (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t") + (safe-setenv key fval) + (hash-table-set! res curr-section-name + (assoc-safe-add alist key fval metadata: metapath)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) + settings) + curr-section-name key #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 + (eval-string-in-environment val) + val))) + (debug:print-info 6 *default-log-port* "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 *default-log-port* " setting: [" curr-section-name "] " key " = " val) + (hash-table-set! res curr-section-name + (assoc-safe-add alist key realval metadata: metapath)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) 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 + (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 + (assoc-safe-add alist var-flag newval metadata: metapath)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) + (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"") + (set! var-flag #f) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) + ) ;; end loop + ))) + +;; moved to common.scm as it is very megatest specific +;; +;; ;; 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)) +;; (set-fields (lambda (curr-section next-section ht path) +;; (let ((field-names (if ht (common:get-fields ht) '())) +;; (target (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target")))) +;; (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht) +;; (if (not (null? field-names))(keys:target-set-args field-names target #f)))))) +;; (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 post-section-procs: (list (cons "^fields$" set-fields)) #f)))) +;; (if toppath (change-directory curr-dir)) +;; (list configdat toppath configfile fname)))) + +(define (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)) + +;; use to have definitive setting: +;; [foo] +;; var yes +;; +;; (var-is? cfgdat "foo" "var" "yes") => #t +;; +(define (var-is? cfgdat section var expected-val) + (equal? (lookup cfgdat section var) expected-val)) + +;; safely look up a value that is expected to be a number, return +;; a default (#f unless provided) +;; +(define (lookup-number cfgdat section varname #!key (default #f)) + (let* ((val (lookup cfgdat section varname)) + (res (if val + (string->number (string-substitute "\\s+" "" val #t)) + #f))) + (cond + (res res) + (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val)) + (else default)))) + +(define (section-vars cfgdat section) + (let ((sectdat (hash-table-ref/default cfgdat section '()))) + (if (null? sectdat) + '() + (map car sectdat)))) + +(define (get-section cfgdat section) + (hash-table-ref/default cfgdat section '())) + +(define (set-section-var cfgdat section var val) + (let ((sectdat (get-section cfgdat section))) + (hash-table-set! cfgdat section + (assoc-safe-add sectdat var val)))) + + ;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat) + ;; (list var val)))) + +;; moved to common +;; (define (setup) +;; (let* ((configf (find-config "megatest.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 (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 (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 (file->list fname) + (if (safe-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 (write-config indat fname #!key (required-sections '())) + (let* (;; step 1: Open the output file and read it into a list + (fdat (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 (compress-multi-lines 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! refdat 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 (lookup indat secname key))) ;; secname was sec. I think that was a bug + ;; 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-error 0 *default-log-port* "problem parsing line number " lnum "\"" hed "\""))))) + (else + (debug:print-error 0 *default-log-port* "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 (section-vars indat section))) + (for-each + (lambda (var) + (let ((val (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 required-sections (hash-table-keys indat)))) + + ;; step 5: Write out new file + (with-output-to-file fname + (lambda () + (for-each + (lambda (line) + (print line)) + (expand-multi-lines fdat)))))) + +;;====================================================================== +;; refdb +;;====================================================================== + +;; reads a refdb into an assoc array of assoc arrays +;; returns (list dat msg) +(define (read-refdb refdb-path) + (let ((sheets-file (conc refdb-path "/sheet-names.cfg"))) + (if (not (safe-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 (read-config 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 (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 (config->alist cfgdat) + (hash-table->alist cfgdat)) + +(define (alist->config adat) + (let ((ht (make-hash-table))) + (for-each + (lambda (section) + (hash-table-set! ht (car section)(cdr section))) + adat) + ht)) + +;; if +(define (read-alist fname) + (handle-exceptions + exn + #f + (alist->config + (with-input-from-file fname read)))) + +(define (write-alist cdat fname #!key (locker #f)(unlocker #f)) + (if (and locker (not (locker fname))) + (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname)) + (let* ((dat (config->alist cdat)) + (res + (begin + (with-output-to-file fname ;; first write out the file + (lambda () + (pp dat))) + + (if (file-exists? fname) ;; now verify it is readable + (if (read-alist fname) + #t ;; data is good. + (begin + (handle-exceptions + exn + #f + (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.") + (delete-file fname)) + #f)) + #f)))) + (if unlocker (unlocker fname)) + res)) + +;; convert hierarchial list to ini format +;; +(define (config->ini data) + (map + (lambda (section) + (let ((section-name (car section)) + (section-dat (cdr section))) + (print "\n[" section-name "]") + (map (lambda (dat-pair) + (let* ((var (car dat-pair)) + (val (cadr dat-pair)) + (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f))) + (if fname (print "# " var "=>" fname)) + (print var " " val))) + section-dat))) ;; (print "section-dat: " section-dat)) + (hash-table->alist data))) + +) ADDED src/mtdb.scm Index: src/mtdb.scm ================================================================== --- /dev/null +++ src/mtdb.scm @@ -0,0 +1,105 @@ +;====================================================================== +;; Copyright 2006-2016, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; +;;====================================================================== + +;; NOTE: This is the db module, long term it will replace db.scm. +;; WARN: This module conflicts with db.scm as it uses sql-de-lite + +(declare (unit mtdb)) +(declare (uses mtcommon)) + +(module mtdb + ( + get-db-tmp-area + ) + +(import scheme chicken data-structures extras (prefix mtcommon common:)) +(use (prefix sql-de-lite sql) posix typed-records) + +(define *default-log-port* (current-error-port)) + +;;====================================================================== +;; Database access +;;====================================================================== + + +;;====================================================================== +;; R E C O R D S +;;====================================================================== + +;; areas +;; run.db +;; runs => 1.db, 2.db ... + +;; each db entry is a pair ( db . dbfilepath ) +;; I propose this record evolves into the area record +;; +(defstruct dbr:dbstruct + (tmpdb #f) + (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack + (mtdb #f) + (refndb #f) + (homehost #f) ;; not used yet + (on-homehost #f) ;; not used yet + (read-only #f) + ) ;; goal is to converge on one struct for an area but for now it is too confusing + + +;; record for keeping state,status and count for doing roll-ups in +;; iterated tests +;; +(defstruct dbr:counts + (state #f) + (status #f) + (count 0)) + +;;====================================================================== +;; SQLITE3 HELPERS +;;====================================================================== + + +(define (general-sql-de-lite-error-dump exn stmt . params) + (let ((err-status ((condition-property-accessor 'sql-de-lite 'status #f) exn))) ;; RADT ... how does this work? + ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) + (print "err-status: " err-status) + (common:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port)))) + +;;====================================================================== +;; Manage the /tmp/ db mirror area +;;====================================================================== + +(define (get-db-tmp-area area-path area-name) + (let ((dbdir (conc "/tmp/" (current-user-name) + "/megatest_localdb/" + area-name "/" + (string-translate area-path "/" ".")))) + (if area-path ;; common:get-create-writeable-dir + (handle-exceptions + exn + (begin + (common:print-error 0 *default-log-port* "Couldn't create path to " dbdir) + (exit 1)) + (let ((dbpath (common:get-create-writeable-dir + (list dbdir)))) ;; #t)))) + dbpath)) + #f))) + + +) Index: subrun.scm ================================================================== --- subrun.scm +++ subrun.scm @@ -38,38 +38,38 @@ (include "db_records.scm") ;; provides db:test-get-id ;;(include "run_records.scm") ;;(include "test_records.scm") (define (subrun:subrun-test-initialized? test-run-dir) - (if (and (common:file-exists? (conc test-run-dir "/subrun-area") ) - (common:file-exists? (conc test-run-dir "/testconfig.subrun") )) + (if (and (file-exists? (conc test-run-dir "/subrun-area") ) + (file-exists? (conc test-run-dir "/testconfig.subrun") )) #t #f)) (define (subrun:launch-dashboard test-run-dir) (if (subrun:subrun-test-initialized? test-run-dir) (let* ((subarea (subrun:get-runarea test-run-dir))) - (if (and subarea (common:file-exists? subarea)) + (if (and subarea (file-exists? subarea)) (system (conc "cd " subarea ";env -i PATH=$PATH DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &")))))) (define (subrun:subrun-removed? test-run-dir) (if (subrun:subrun-test-initialized? test-run-dir) (let ((flagfile (conc test-run-dir "/subrun.removed"))) - (if (common:file-exists? flagfile) + (if (file-exists? flagfile) #t #f)) #t)) (define (subrun:set-subrun-removed test-run-dir) (let ((flagfile (conc test-run-dir "/subrun.removed"))) - (if (and (subrun:subrun-test-initialized? test-run-dir) (not (common:file-exists? flagfile))) + (if (and (subrun:subrun-test-initialized? test-run-dir) (not (file-exists? flagfile))) (with-output-to-file flagfile (lambda () (print (current-seconds))))))) (define (subrun:unset-subrun-removed test-run-dir) (let ((flagfile (conc test-run-dir "/subrun.removed"))) - (if (and (subrun:subrun-test-initialized? test-run-dir) (common:file-exists? flagfile)) + (if (and (subrun:subrun-test-initialized? test-run-dir) (file-exists? flagfile)) (delete-file flagfile)))) (define (subrun:testconfig-defines-subrun? testconfig) (configf:lookup testconfig "subrun" "runwait")) ;; we use runwait as the flag that a subrun is requested @@ -84,11 +84,11 @@ ;; we need to force the setting in the testconfig so it will ;; be preserved in the testconfig.subrun file (configf:set-section-var testconfig "subrun" "runarea" *toppath*)) (configf:set-section-var testconfig "logpro" "subrun" logpro) ;; append the logpro rules to the logpro section as stepname subrun - (if (common:file-exists? symlink-target) + (if (file-exists? symlink-target) (delete-file symlink-target)) (create-symbolic-link ra symlink-target) (configf:write-alist testconfig "testconfig.subrun"))) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -48,21 +48,21 @@ (print-call-chain (current-error-port)) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 5 *default-log-port* " exn=" (condition->list exn)) (debug:print 0 *default-log-port* "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain") #t) ;; if stuff goes wrong just allow it to move on - (let loop ((journal-exists (common:file-exists? fullpath)) + (let loop ((journal-exists (file-exists? fullpath)) (count n)) ;; wait ten times ... (if journal-exists (begin (if (and waiting-msg (eq? (modulo n 30) 0)) (debug:print 0 *default-log-port* waiting-msg)) (if (> count 0) (begin (thread-sleep! 1) - (loop (common:file-exists? fullpath) + (loop (file-exists? fullpath) (- count 1))) (begin (debug:print 0 *default-log-port* "ERROR: removing the journal file " fullpath ", this is not good. Look for disk full, write access and other issues.") (if remove (system (conc "rm -rf " fullpath))) #f))) @@ -106,11 +106,11 @@ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 5 *default-log-port* " exn=" (condition->list exn)))) (let* ((dbpath (db:dbfile-path )) ;; (tasks:get-task-db-path)) (dbfile (conc dbpath "/monitor.db")) (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away - (exists (common:file-exists? dbpath)) + (exists (file-exists? dbpath)) (write-access (file-write-access? dbpath)) (mdb (cond ;; what the hek is *toppath* doing here? ((and (string? *toppath*)(file-write-access? *toppath*)) (sqlite3:open-database dbfile)) ((file-read-access? dbpath) (sqlite3:open-database dbfile)) @@ -203,11 +203,11 @@ (system (conc "nbfake kill "kill-switch" "pid)) (when logfile (thread-sleep! 0.5) - (if (common:file-exists? gzfile) (delete-file gzfile)) + (if (file-exists? gzfile) (delete-file gzfile)) (system (conc "gzip " logfile)) (unsetenv "TARGETHOST_LOGF") (unsetenv "TARGETHOST")))) Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -59,11 +59,11 @@ (debug:print-info 11 *default-log-port* "open-test-db " work-area) (if (and work-area (directory? work-area) (file-read-access? work-area)) (let* ((dbpath (conc work-area "/testdat.db")) - (dbexists (common:file-exists? dbpath)) + (dbexists (file-exists? dbpath)) (work-area-writeable (file-write-access? work-area)) (db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem exn (begin (print-call-chain (current-error-port)) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -72,16 +72,16 @@ (define (tests:get-valid-tests test-registry tests-paths) (if (null? tests-paths) test-registry (let loop ((hed (car tests-paths)) (tal (cdr tests-paths))) - (if (common:file-exists? hed) + (if (file-exists? hed) (for-each (lambda (test-path) (let* ((tname (last (string-split test-path "/"))) (tconfig (conc test-path "/testconfig"))) (if (and (not (hash-table-ref/default test-registry tname #f)) - (common:file-exists? tconfig)) + (file-exists? tconfig)) (hash-table-set! test-registry tname test-path)))) (glob (conc hed "/*")))) (if (null? tal) test-registry (loop (car tal)(cdr tal)))))) @@ -350,11 +350,11 @@ (db:test-get-rundir prev-testdat)) ;; ) (waivers (if testconfig (configf:section-vars testconfig "waivers") '())) (waiver-rx (regexp "^(\\S+)\\s+(.*)$")) (diff-rule "diff %file1% %file2%") (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html")) - (if (not (common:file-exists? test-rundir)) + (if (not (file-exists? test-rundir)) (begin (debug:print-error 0 *default-log-port* "test run directory is gone, cannot propagate waiver") #f) (begin (push-directory test-rundir) @@ -367,11 +367,11 @@ (wparts (if waiver (string-match waiver-rx waiver) #f)) (waiver-rule (if wparts (cadr wparts) #f)) (waiver-glob (if wparts (caddr wparts) #f)) (logpro-file (if waiver (let ((fname (conc hed ".logpro"))) - (if (common:file-exists? fname) + (if (file-exists? fname) fname (begin (debug:print 0 *default-log-port* "INFO: No logpro file " fname " falling back to diff") #f))) #f)) @@ -1194,11 +1194,11 @@ '() (lambda (x p) (let* ((targ-path (string-intersperse p "/")) (full-path (conc linktree "/" targ-path)) (run-name (car (reverse p)))) - (if (and (common:file-exists? full-path) + (if (and (file-exists? full-path) (directory? full-path) (file-write-access? full-path)) (s:a run-name 'href (conc targ-path "/run-summary.html")) (begin (debug:print 0 *default-log-port* "INFO: Can't create " targ-path "/run-summary.html") @@ -1233,11 +1233,11 @@ path-parts)) test-dats)) (tests-htree (common:list->htree tests-tree-dat)) (html-dir (conc linktree "/" (string-intersperse run-dir "/"))) (html-path (conc html-dir "/run-summary.html")) - (oup (if (and (common:file-exists? html-dir) + (oup (if (and (file-exists? html-dir) (directory? html-dir) (file-write-access? html-dir)) (open-output-file html-path) #f))) ;; (print "run-dir: " run-dir ", tests-tree-dat: " tests-tree-dat) @@ -1261,21 +1261,21 @@ (item-path ;; (if (> (length p) 2) ;; test-name + run-name (string-intersperse p "/")) (full-targ (conc html-dir "/" targ-path)) (std-file (conc full-targ "/test-summary.html")) (alt-file (conc full-targ "/megatest-rollup-" test-name ".html")) - (html-file (if (common:file-exists? alt-file) + (html-file (if (file-exists? alt-file) alt-file std-file)) (run-name (car (reverse p)))) - (if (and (not (common:file-exists? full-targ)) + (if (and (not (file-exists? full-targ)) (directory? full-targ) (file-write-access? full-targ)) (tests:summarize-test run-id (rmt:get-test-id run-id test-name item-path))) - (if (common:file-exists? full-targ) + (if (file-exists? full-targ) (s:a run-name 'href html-file) (begin (debug:print 0 *default-log-port* "ERROR: can't access " full-targ) (conc "No summary for " run-name))))) )))))) @@ -1484,11 +1484,11 @@ ;; Gather data from test/task specifications ;;====================================================================== ;; (define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '())) ;; (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*"))))) -;; (set! tests (filter (lambda (test)(common:file-exists? (conc test "/testconfig"))) tests)) +;; (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests)) ;; (delete-duplicates ;; (filter (lambda (testname) ;; (tests:match test-patts testname #f)) ;; (map (lambda (testp) ;; (last (string-split testp "/"))) @@ -1519,11 +1519,11 @@ (let* ((use-cache (common:use-cache?)) (cache-path (tests:get-test-path-from-environment)) (cache-file (and cache-path (conc cache-path "/.testconfig"))) (cache-exists (and cache-file (not force-create) ;; if force-create then pretend there is no cache to read - (common:file-exists? cache-file))) + (file-exists? cache-file))) (cached-dat (if (and (not force-create) cache-exists use-cache) (handle-exceptions exn @@ -1543,11 +1543,11 @@ (let* ((treg (or test-registry (tests:get-all))) (test-path (or (hash-table-ref/default treg test-name #f) (conc *toppath* "/tests/" test-name))) (test-configf (conc test-path "/testconfig")) - (testexists (and (common:file-exists? test-configf)(file-read-access? test-configf))) + (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) (tcfg (if testexists (read-config test-configf #f system-allowed environ-patt: (if system-allowed "pre-launch-env-vars" #f)) @@ -1713,11 +1713,11 @@ ;; (define (tests:lazy-dot testrecords outtype sizex sizey) (let ((dfile (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dot")) (fname (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dotdat"))) (tests:write-dot-file testrecords dfile sizex sizey) - (if (common:file-exists? fname) + (if (file-exists? fname) (let ((res (with-input-from-file fname (lambda () (read-lines))))) (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname "&")) res)