Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -22,19 +22,19 @@ CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm runconfig.scm \ server.scm configf.scm db.scm \ process.scm runs.scm tests.scm genexample.scm \ - http-transport.scm filedb.scm tdb.scm client.scm mt.scm \ + http-transport.scm filedb.scm tdb.scm mt.scm \ ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \ subrun.scm archive.scm env.scm \ diff-report.scm # module source files MSRCFILES = dbmod.scm servermod.scm apimod.scm commonmod.scm rmtmod.scm \ ods.scm configfmod.scm transport.scm portlogger.scm tasks.scm \ - pgdb.scm margsmod.scm debugprint.scm + pgdb.scm margsmod.scm debugprint.scm client.scm MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o)) MOIMPFILES = $(MSRCFILES:%.scm=%.import.o) # ftail.scm rmtmod.scm commonmod.scm removed @@ -156,46 +156,10 @@ # Include the generated dependency file include build.inc # Special dependencies for the module includes $(OFILES) $(MOFILES) $(MOIMPFILES) : megatest-fossil-hash.scm -# we are going to generate this by running make without -j -# and only adding the needed deps. The full deps have too many -# circular deps and can not (yet) be resolved. - -## -## mofiles/dcommonmod.o mofiles/configfmod.o mofiles/ods.o mofiles/apimod.o mofiles/rmtmod.o mofiles/dbmod.o : \ -## mofiles/commonmod.o -## -## mofiles/dbmod.o : mofiles/ods.o -## mofiles/dbmod.o : mofiles/configfmod.o -## mofiles/servermod.o mofiles/rmtmod.o : mofiles/dbmod.o -## -## dcommon.o : mofiles/dcommonmod.o -## - -# megatest.o : $(MOIMPFILES) -# mofiles/commonmod.o : megatest-fossil-hash.scm -# mofiles/dbmod.o \ -# mofiles/servermod.o \ -# mofiles/apimod.o \ -# mofiles/dcommonmod.o \ -# mofiles/ods.o : mofiles/commonmod.o mofiles/configfmod.o -# -# mofiles/dcommonmod.o : mofiles/configfmod.o mofiles/dbmod.o -# mofiles/configfmod.o : mofiles/commonmod.o -# # mofiles/dbmod.o : mofiles/configfmod.o -# mofiles/rmtmod.o : mofiles/apimod.o -# # mofiles/servermod.o : mofiles/dbmod.o -# common.o : mofiles/commonmod.o -# -# # commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm -# -# tests.o db.o launch.o runs.o dashboard-tests.o \ -# # commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm -# -# 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 megatest-fossil-hash.scm # dashboard.o : mofiles/apimod.o @@ -205,42 +169,20 @@ db.o ezsteps.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o mofiles/tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm -# api.o rmt.o db.o : mofiles/apimod.o mofiles/dbmod.o mofiles/rmtmod.o mofiles/ods.o mofiles/commonmod.o common.o megatest.o dashboard.o : megatest-fossil-hash.scm megatest-version.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 megatest-version.scm - common_records.scm : altdb.scm -# mofiles/stml2.o : mofiles/cookie.o -# configf.o : mofiles/commonmod.o - vg.o dashboard.o : vg_records.scm megatest-version.scm dcommon.o : run_records.scm -# mofiles/dcommonmod.o mofiles/stml2.o : mofiles/cookie.o -# mofiles/dbmod.o : mofiles/ods.o -# mofiles/rmtmod.o : mofiles/dbmod.o - -# # special include based modules -# mofiles/pkts.o : pkts/pkts.scm -# mofiles/stml2.o : cookie.o -# # mofiles/mtargs.o : mtargs/mtargs.scm -# # mofiles/mtconfigf.o : mtconfigf/mtconfigf.scm -# mofiles/ulex.o : ulex/ulex.scm -# mofiles/mutils.o : mutils/mutils.scm -# mofiles/cookie.o : stml2/cookie.scm -# mofiles/stml2.o : stml2/stml2.scm - -# Temporary while transitioning to new routine -# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm # for the modularized stuff # mofiles/rmtmod.o : mofiles/commonmod.o megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm @@ -503,12 +445,12 @@ csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o launch.o lock-queue.o mofiles/margsmod.o mt.o mofiles/portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o mofiles/tasks.o tdb.o tests.o tree.o %.pdf : %.dot dot -Tpdf $*.dot -o $*.pdf -all.dot all-inc.dot : *.scm - gendeps all *.scm +all.dot all-inc.dot : *.scm cgisetup/models/pgdb.scm + gendeps all *.scm buildmanual: cd docs/manual && make wikipage=plan Index: apimod.scm ================================================================== --- apimod.scm +++ apimod.scm @@ -18,10 +18,11 @@ ;;====================================================================== (declare (unit apimod)) (declare (uses commonmod)) +(declare (uses debugprint)) (declare (uses dbmod)) (declare (uses tasks)) ;; (declare (uses servermod)) (module apimod @@ -28,10 +29,11 @@ * (import scheme chicken data-structures extras) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69) (import commonmod) +(import debugprint) (import dbmod) (import tasks) ;; (import servermod) ;; allow these queries through without starting a server Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -26,11 +26,13 @@ (declare (uses configfmod)) (import configfmod) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses dbmod)) (import dbmod) (declare (uses margsmod)) Index: build.inc ================================================================== --- build.inc +++ build.inc @@ -1,32 +1,54 @@ # To regenerate this file do: # (cd utils/;ck52 csc gendeps.scm) && ./utils/gendeps allunits *scm # cp allunits.inc build.inc # +mofiles/apimod.o : mofiles/commonmod.o +mofiles/apimod.o : mofiles/dbmod.o +mofiles/apimod.o : mofiles/debugprint.o mofiles/apimod.o : mofiles/tasks.o -mofiles/transport.o : mofiles/configfmod.o -mofiles/tasks.o : mofiles/configfmod.o -mofiles/servermod.o : mofiles/configfmod.o -mofiles/portlogger.o : mofiles/configfmod.o -mofiles/dcommonmod.o : mofiles/configfmod.o +mofiles/apimod.o : mofiles/client.o +mofiles/commonmod.o : mofiles/debugprint.o +mofiles/commonmod.o : mofiles/margsmod.o +mofiles/commonmod.o : mofiles/configfmod.o +mofiles/configfmod.o : mofiles/margsmod.o +mofiles/client.o : mofiles/servermod.o +mofiles/client.o : mofiles/rmtmod.o +mofiles/dbmod.o : mofiles/commonmod.o mofiles/dbmod.o : mofiles/configfmod.o +mofiles/dbmod.o : mofiles/debugprint.o +mofiles/dbmod.o : mofiles/margsmod.o mofiles/dbmod.o : mofiles/ods.o -mofiles/transport.o : mofiles/commonmod.o -mofiles/tasks.o : mofiles/commonmod.o -mofiles/servermod.o : mofiles/commonmod.o -mofiles/rmtmod.o : mofiles/commonmod.o -mofiles/portlogger.o : mofiles/commonmod.o -mofiles/ods.o : mofiles/commonmod.o mofiles/dcommonmod.o : mofiles/commonmod.o -mofiles/dbmod.o : mofiles/commonmod.o -mofiles/configfmod.o : mofiles/commonmod.o -mofiles/apimod.o : mofiles/commonmod.o -mofiles/rmtmod.o : mofiles/apimod.o -mofiles/tasks.o : mofiles/margsmod.o -mofiles/commonmod.o : mofiles/margsmod.o -mofiles/tasks.o : mofiles/dbmod.o -mofiles/servermod.o : mofiles/dbmod.o -mofiles/rmtmod.o : mofiles/dbmod.o +mofiles/dcommonmod.o : mofiles/configfmod.o +mofiles/dcommonmod.o : mofiles/debugprint.o +mofiles/debugprint.o : mofiles/margsmod.o +mofiles/ods.o : mofiles/commonmod.o +mofiles/ods.o : mofiles/debugprint.o +mofiles/portlogger.o : mofiles/commonmod.o +mofiles/portlogger.o : mofiles/configfmod.o mofiles/portlogger.o : mofiles/dbmod.o -mofiles/apimod.o : mofiles/dbmod.o +mofiles/portlogger.o : mofiles/debugprint.o +mofiles/rmtmod.o : mofiles/apimod.o +mofiles/rmtmod.o : mofiles/commonmod.o +mofiles/rmtmod.o : mofiles/configfmod.o +mofiles/rmtmod.o : mofiles/dbmod.o +mofiles/rmtmod.o : mofiles/debugprint.o +mofiles/rmtmod.o : mofiles/portlogger.o +mofiles/servermod.o : mofiles/commonmod.o +mofiles/servermod.o : mofiles/configfmod.o +mofiles/servermod.o : mofiles/dbmod.o +mofiles/servermod.o : mofiles/debugprint.o +mofiles/servermod.o : mofiles/rmtmod.o +mofiles/tasks.o : mofiles/commonmod.o +mofiles/tasks.o : mofiles/configfmod.o +mofiles/tasks.o : mofiles/dbmod.o +mofiles/tasks.o : mofiles/debugprint.o +mofiles/tasks.o : mofiles/margsmod.o +mofiles/tasks.o : mofiles/pgdb.o +mofiles/transport.o : mofiles/apimod.o +mofiles/transport.o : mofiles/commonmod.o +mofiles/transport.o : mofiles/configfmod.o +mofiles/transport.o : mofiles/debugprint.o mofiles/transport.o : mofiles/portlogger.o +mofiles/transport.o : mofiles/servermod.o Index: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ cgisetup/models/pgdb.scm @@ -21,10 +21,11 @@ (declare (unit pgdb)) (declare (uses configf)) (declare (uses configfmod)) (declare (uses commonmod)) (declare (uses margsmod)) +(declare (uses debugprint)) (module pgdb * (import scheme) @@ -31,10 +32,11 @@ (import data-structures) (import chicken) (import commonmod) (import configfmod) (import margsmod) +(import debugprint) (import srfi-1 srfi-69 typed-records (prefix dbi dbi:)) ;; given a configdat lookup the connection info and open the db ;; Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -18,122 +18,32 @@ ;;====================================================================== ;; C L I E N T S ;;====================================================================== -(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5 - message-digest matchable spiffy uri-common intarweb http-client - spiffy-request-vars uri-common intarweb directory-utils) - (declare (unit client)) (declare (uses common)) -(declare (uses db)) - (declare (uses commonmod)) -(import commonmod) - +(declare (uses db)) (declare (uses dbmod)) +(declare (uses debugprint)) +(declare (uses rmt)) +(declare (uses servermod)) + +(import commonmod) (import dbmod) +(import debugprint) +(import servermod) -(declare (uses rmt)) +(module client + * +(import scheme chicken data-structures extras ports) -(declare (uses servermod)) -(import servermod) +(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5 + message-digest matchable spiffy uri-common intarweb http-client + spiffy-request-vars uri-common intarweb directory-utils) (include "common_records.scm") (include "db_records.scm") -;; client:get-signature -(define (client:get-signature) - (if *my-client-signature* *my-client-signature* - (let ((sig (conc (get-host-name) " " (current-process-id)))) - (set! *my-client-signature* sig) - *my-client-signature*))) - -;; Not currently used! But, I think it *should* be used!!! -#;(define (client:logout serverdat) - (let ((ok (and (socket? serverdat) - (cdb:logout serverdat *toppath* (client:get-signature))))) - ok)) - -#;(define (client:connect iface port) - (http-transport:client-connect iface port) - #;(case (server:get-transport) - ((rpc) (rpc:client-connect iface port)) - ((http) (http:client-connect iface port)) - ((zmq) (zmq:client-connect iface port)) - (else (rpc:client-connect iface port)))) - -(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0)) - (client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects) - #;(case (server:get-transport) - ((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id)) - ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects)) - (else (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id)))) - -;; Do all the connection work, look up the transport type and set up the -;; connection if required. -;; -;; There are two scenarios. -;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline -;; 2. We are a run tests, list runs or other interactive process and we must figure out -;; *transport-type* and *runremote* from the monitor.db -;; -;; client:setup -;; -;; lookup_server, need to remove *runremote* stuff -;; - -(define (client:setup-http areapath #!key (remaining-tries 100) (failed-connects 0)(area-dat #f)) - (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries) - (server:start-and-wait areapath) - (if (<= remaining-tries 0) - (begin - (debug:print-error 0 *default-log-port* "failed to start or connect to server") - (exit 1)) - ;; - ;; Alternatively here, we can get the list of candidate servers and work our way - ;; through them searching for a good one. - ;; - (let* ((server-dat (server:get-rand-best areapath)) ;; (server:get-first-best areapath)) - (runremote (or area-dat *runremote*))) - (if (not server-dat) ;; no server found - (client:setup-http areapath remaining-tries: (- remaining-tries 1)) - (let ((host (cadr server-dat)) - (port (caddr server-dat)) - (server-id (caddr (cddr server-dat)))) - (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) - (if (and (not area-dat) - (not *runremote*)) - (begin - ;; POSSIBLE BUG. I removed the full initialization call. mrw - (set! *runremote* (create-remote-record)) - (let* ((server-info (remote-server-info *runremote*))) - (if server-info - (begin - (remote-server-url-set! *runremote* (server:record->url server-info)) - (remote-server-id-set! *runremote* (server:record->id server-info))))))) - (if (and host port server-id) - (let* ((start-res (http-transport:client-connect host port server-id)) - (ping-res (rmt:login-no-auto-client-setup start-res))) - (if (and start-res - ping-res) - (let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago - (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res) - (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) - start-res) - (begin ;; login failed but have a server record, clean out the record and try again - (debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332 - (case *transport-type* - ((http)(http-transport:close-connections))) - (remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id) - (thread-sleep! 1) - (client:setup-http areapath remaining-tries: (- remaining-tries 1)) - ))) - (begin ;; no server registered - ;; (server:kind-run areapath) - (server:start-and-wait areapath) - (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries) - (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. - (client:setup-http areapath remaining-tries: (- remaining-tries 1))))))))) - +) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -46,11 +46,13 @@ z3 ) (declare (unit common)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) ;; dbr:dbstruct is used here. should move it (declare (uses dbmod)) (import dbmod) @@ -61,87 +63,5 @@ (import servermod) (declare (uses margsmod)) (import margsmod) -;;====================================================================== -;; logic for getting homehost. Returns (host . at-home) -;; IF *toppath* is not set, wait up to five seconds trying every two seconds -;; (this is to accomodate the watchdog) -;; -(define (common:get-homehost #!key (trynum 5)) - ;; called often especially at start up. use mutex to eliminate collisions - (mutex-lock! *homehost-mutex*) - (cond - (*home-host* - (mutex-unlock! *homehost-mutex*) - *home-host*) - ((not *toppath*) - (mutex-unlock! *homehost-mutex*) - (launch:setup) ;; safely mutexed now - (if (> trynum 0) - (begin - (thread-sleep! 2) - (common:get-homehost trynum: (- trynum 1))) - #f)) - (else - (let* ((currhost (get-host-name)) - (bestadrs (server:get-best-guess-address currhost)) - ;; first look in config, then look in file .homehost, create it if not found - (homehost (or (configf:lookup *configdat* "server" "homehost" ) - (handle-exceptions - exn - (if (> trynum 0) - (let ((delay-time (* (- 5 trynum) 5))) - (mutex-unlock! *homehost-mutex*) - (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Failed to read .homehost file, delaying " - delay-time " seconds and trying again, message: " ((condition-property-accessor 'exn 'message) exn) - ", exn=" exn) - (thread-sleep! delay-time) - (common:get-homehost trynum: (- trynum 1))) - (begin - (mutex-unlock! *homehost-mutex*) - (debug:print 0 *default-log-port* "ERROR: ["(common:human-time) - "] 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) - (with-input-from-file hhf read-line) - (if (file-write-access? *toppath*) - (begin - (with-output-to-file hhf - (lambda () - (print bestadrs))) - (begin - (mutex-unlock! *homehost-mutex*) - (car (common:get-homehost)))) - #f)))))) - (at-home (or (equal? homehost currhost) - (equal? homehost bestadrs)))) - (set! *home-host* (cons homehost at-home)) - (mutex-unlock! *homehost-mutex*) - *home-host*)))) -(define (common:wait-for-homehost-load maxnormload msg) - (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local. - #f - (common:get-homehost))) - (hh (if hh-dat (car hh-dat) #f))) - (common:wait-for-normalized-load maxnormload msg hh))) - -;;====================================================================== -;; am I on the homehost? -;;====================================================================== -;;====================================================================== -;;====================================================================== -;; -(define (common:on-homehost?) - (let ((hh (common:get-homehost))) - (if hh - (cdr hh) - #f))) - -(define (common:run-sync?) - (and (common:on-homehost?) - (args:get-arg "-server"))) - Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -19,26 +19,29 @@ ;;====================================================================== (declare (unit commonmod)) (declare (uses margsmod)) (declare (uses debugprint)) +(declare (uses configfmod)) (module commonmod * ;;(import scheme chicken data-structures extras files ports) (import scheme chicken) (import margsmod) (import debugprint) +(import configfmod) (use data-structures extras files ports) (use (prefix base64 base64:) (prefix sqlite3 sqlite3:) (srfi 18) (prefix dbi dbi:) directory-utils + hostinfo format matchable md5 message-digest pkts @@ -45,10 +48,11 @@ posix regex regex-case sparse-vectors srfi-1 + srfi-4 srfi-13 srfi-69 stack stml2 typed-records @@ -67,41 +71,30 @@ ;; (if (null? code) ;; (old-exit) ;; (old-exit code))) (define *numcpus-cache* (make-hash-table)) + + ;;====================================================================== ;; use to transition to area-name (define (common:get-sync-lock-filepath) (let* ((tmp-area (common:get-db-tmp-area)) (lockfile (conc tmp-area "/megatest.db.sync-lock"))) lockfile)) - + (define (common:get-sync-lock-filepath) (let* ((tmp-area (common:get-db-tmp-area)) (lockfile (conc tmp-area "/megatest.db.sync-lock"))) lockfile)) ;;====================================================================== ;; (debug:print 0 *default-log-port* "Failed to find this executable! Using what can be found on the path") - -(define (configf:lookup cfgdat section var) - (if (hash-table? cfgdat) - (let ((sectdat (hash-table-ref/default cfgdat section '()))) - (if (null? sectdat) - #f - (let ((match (assoc var sectdat))) - (if match ;; (and match (list? match)(> (length match) 1)) - (cadr match) - #f)) - )) - #f)) - (define (common:get-testsuite-name) (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description. (configf:lookup *configdat* "setup" "testsuite" ) (getenv "MT_TESTSUITE_NAME") (pathname-file (or (if (string? *toppath* ) @@ -118,36 +111,54 @@ ;; generate auto name (conc (get-area-path-signature toppath short) "-" (common:get-testsuite-name toppath configdat))) +;; 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)))) + ;;====================================================================== ;; L O C K I N G M E C H A N I S M S ;;====================================================================== (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 " *db-cache-path* ", exn=" exn) - (exit 1)) - (let* ((tsname (common:get-testsuite-name)) - (dbpath (common:get-create-writeable-dir - (list (conc "/tmp/" (current-user-name) - "/megatest_localdb/" - tsname "/" - (string-translate *toppath* "/" ".")) - (conc "/tmp/" (current-process-id) ;; just in case we have an issue with the dir by own user name - "/megatest_localdb/" - tsname - (string-translate *toppath* "/" ".")) - )))) - (set! *db-cache-path* dbpath) - dbpath)) + exn + (begin + (debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path* ", exn=" exn) + (exit 1)) + (let* ((tsname (common:get-testsuite-name)) + (dbpath (common:get-create-writeable-dir + (list (conc "/tmp/" (current-user-name) + "/megatest_localdb/" + tsname "/" + (string-translate *toppath* "/" ".")) + (conc "/tmp/" (current-process-id) ;; just in case we have an issue with the dir by own user name + "/megatest_localdb/" + tsname + (string-translate *toppath* "/" ".")) + )))) + (set! *db-cache-path* dbpath) + dbpath)) #f))) ;;====================================================================== @@ -161,11 +172,10 @@ (include "megatest-version.scm") (include "megatest-fossil-hash.scm") ;; Move globals here -(define *default-log-port* (current-error-port)) (define *toppath* #f) (define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config (define *db-with-db-mutex* (make-mutex)) (define *max-api-process-requests* 0) (define *common:denoise* (make-hash-table)) ;; for low noise printing @@ -359,14 +369,14 @@ ;; ;; returns the directory or #f ;; (define (common:directory-writable? path-string) (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "Failed to identify access to " path-string ", exn=" exn) - #f) + exn + (begin + (debug:print 0 *default-log-port* "Failed to identify access to " path-string ", exn=" exn) + #f) (if (and (directory-exists? path-string) (file-write-access? path-string)) path-string #f))) @@ -396,11 +406,11 @@ ((M) 2628000) ;; aproximately one month ((y) 31536000) (else #f)))))))))) parts) time-secs)) - + (define (seconds->hr-min-sec secs) (let* ((hrs (quotient secs 3600)) (min (quotient (- secs (* hrs 3600)) 60)) (sec (- secs (* hrs 3600)(* min 60)))) (conc (if (> hrs 0)(conc hrs "hr ") "") @@ -525,33 +535,33 @@ (tal (cdr cron-items)) (type 'min) (type-tal '(hour dayofmonth month dayofweek)) (res '())) (regex-case - hed - (slash-rx ( _ base incr ) (let* ((basen (string->number base)) - (incrn (string->number incr)) - (expanded-vals (common:expand-cron-slash basen incrn (alist-ref type max-vals))) - (new-list-crons (fold (lambda (x myres) - (cons (conc (if (null? res) - "" - (conc (string-intersperse res " ") " ")) - x " " (string-intersperse tal " ")) - myres)) - '() expanded-vals))) - ;; (print "new-list-crons: " new-list-crons) - ;; (fold (lambda (x res) - ;; (if (list? x) - ;; (let ((newres (map common:cron-expand x))) - ;; (append x newres)) - ;; (cons x res))) - ;; '() - (flatten (map common:cron-expand new-list-crons)))) - ;; (map common:cron-expand (map common:cron-expand new-list-crons)))) - (else (if (null? tal) - cron-str - (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed))))))))))) + hed + (slash-rx ( _ base incr ) (let* ((basen (string->number base)) + (incrn (string->number incr)) + (expanded-vals (common:expand-cron-slash basen incrn (alist-ref type max-vals))) + (new-list-crons (fold (lambda (x myres) + (cons (conc (if (null? res) + "" + (conc (string-intersperse res " ") " ")) + x " " (string-intersperse tal " ")) + myres)) + '() expanded-vals))) + ;; (print "new-list-crons: " new-list-crons) + ;; (fold (lambda (x res) + ;; (if (list? x) + ;; (let ((newres (map common:cron-expand x))) + ;; (append x newres)) + ;; (cons x res))) + ;; '() + (flatten (map common:cron-expand new-list-crons)))) + ;; (map common:cron-expand (map common:cron-expand new-list-crons)))) + (else (if (null? tal) + cron-str + (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed))))))))))) ;;====================================================================== ;; given a cron string and the last time event was processed return #t to run or #f to not run ;; ;; min hour dayofmonth month dayofweek @@ -574,71 +584,71 @@ ;; 0 1 2 3 4 5 6 ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9) (vector->list now-time)) ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9) (vector->list last-done-time))) - ;; create all possible time slots - ;; remove invalid slots due to (for example) day of week - ;; get the start and end entries for the ref-seconds (current) time - ;; if last-done > ref-seconds => this is an ERROR! - ;; does the last-done time fall in the legit region? - ;; yes => #f do not run again this command - ;; no => #t ok to run the command - (for-each ;; month - (lambda (month) - (for-each ;; dayofmonth - (lambda (dom) - (for-each - (lambda (hr) ;; hour - (for-each - (lambda (minute) ;; minute - (let ((copy-now (apply vector (vector->list now-time)))) - (vector-set! copy-now 0 0) ;; force seconds to zero - (vector-set! copy-now 1 minute) - (vector-set! copy-now 2 hr) - (vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced - (vector-set! copy-now 4 month) - (let* ((copy-now-secs (local-time->seconds copy-now)) - (new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector - (if (or (not cdayofweek) - (equal? (vector-ref new-copy 6) - cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified - (if (or (not cdayofmonth) - (equal? (vector-ref new-copy 3) - (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified - (hash-table-set! all-times copy-now-secs new-copy)))))) - (if cmin - `(,cmin) ;; if given cmin, have to use it - (list (- nmin 1) nmin (+ nmin 1))))) ;; minute - (if chour - `(,chour) - (list (- nhour 1) nhour (+ nhour 1))))) ;; hour - (if cdayofmonth - `(,cdayofmonth) - (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1))))) - (if cmonth - `(,cmonth) - (list (- nmonth 1) nmonth (+ nmonth 1)))) - (let ((before #f) - (is-in #f)) - (for-each - (lambda (moment) - (if (and before - (<= before now-seconds) - (>= moment now-seconds)) - (begin - ;; (print) - ;; (print "Before: " (time->string (seconds->local-time before))) - ;; (print "Now: " (time->string (seconds->local-time now-seconds))) - ;; (print "After: " (time->string (seconds->local-time moment))) - ;; (print "Last: " (time->string (seconds->local-time last-done))) - (if (< last-done before) - (set! is-in before)) - )) - (set! before moment)) - (sort (hash-table-keys all-times) <)) - is-in))))) + ;; create all possible time slots + ;; remove invalid slots due to (for example) day of week + ;; get the start and end entries for the ref-seconds (current) time + ;; if last-done > ref-seconds => this is an ERROR! + ;; does the last-done time fall in the legit region? + ;; yes => #f do not run again this command + ;; no => #t ok to run the command + (for-each ;; month + (lambda (month) + (for-each ;; dayofmonth + (lambda (dom) + (for-each + (lambda (hr) ;; hour + (for-each + (lambda (minute) ;; minute + (let ((copy-now (apply vector (vector->list now-time)))) + (vector-set! copy-now 0 0) ;; force seconds to zero + (vector-set! copy-now 1 minute) + (vector-set! copy-now 2 hr) + (vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced + (vector-set! copy-now 4 month) + (let* ((copy-now-secs (local-time->seconds copy-now)) + (new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector + (if (or (not cdayofweek) + (equal? (vector-ref new-copy 6) + cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified + (if (or (not cdayofmonth) + (equal? (vector-ref new-copy 3) + (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified + (hash-table-set! all-times copy-now-secs new-copy)))))) + (if cmin + `(,cmin) ;; if given cmin, have to use it + (list (- nmin 1) nmin (+ nmin 1))))) ;; minute + (if chour + `(,chour) + (list (- nhour 1) nhour (+ nhour 1))))) ;; hour + (if cdayofmonth + `(,cdayofmonth) + (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1))))) + (if cmonth + `(,cmonth) + (list (- nmonth 1) nmonth (+ nmonth 1)))) + (let ((before #f) + (is-in #f)) + (for-each + (lambda (moment) + (if (and before + (<= before now-seconds) + (>= moment now-seconds)) + (begin + ;; (print) + ;; (print "Before: " (time->string (seconds->local-time before))) + ;; (print "Now: " (time->string (seconds->local-time now-seconds))) + ;; (print "After: " (time->string (seconds->local-time moment))) + ;; (print "Last: " (time->string (seconds->local-time last-done))) + (if (< last-done before) + (set! is-in before)) + )) + (set! before moment)) + (sort (hash-table-keys all-times) <)) + is-in))))) (define (common:extended-cron cron-str now-seconds-in last-done) (let ((expanded-cron (common:cron-expand cron-str))) (if (string? expanded-cron) (common:cron-event expanded-cron now-seconds-in last-done) @@ -720,34 +730,34 @@ ;;====================================================================== ;; lazy-safe get file mod time. on any error (file not existing etc.) return 0 ;; (define (common:lazy-modification-time fpath) (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "Failed to get modifcation time for " fpath ", treating it as zero. exn=" exn) - 0) - (if (file-exists? fpath) - (file-modification-time fpath) - 0))) + exn + (begin + (debug:print 0 *default-log-port* "Failed to get modifcation time for " fpath ", treating it as zero. exn=" exn) + 0) + (if (file-exists? fpath) + (file-modification-time fpath) + 0))) ;;====================================================================== ;; find timestamp of newest file associated with a sqlite db file (define (common:lazy-sqlite-db-modification-time fpath) (let* ((glob-list (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "Failed to glob " fpath "*, exn=" exn) - `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))) - (glob (conc fpath "*")))) + exn + (begin + (debug:print 0 *default-log-port* "Failed to glob " fpath "*, exn=" exn) + `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))) + (glob (conc fpath "*")))) (file-list (if (eq? 0 (length glob-list)) '("/no/such/file") glob-list))) - (apply max - (map - common:lazy-modification-time - file-list)))) + (apply max + (map + common:lazy-modification-time + file-list)))) ;;====================================================================== ;; execute thunk, return value. If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* . ;; arguments - thunk, message (define (common:fail-safe thunk warning-message-on-exception) @@ -762,38 +772,24 @@ (print-error-message exn) )))) (debug:print-info 0 *default-log-port* " -- continuing after nonfatal condition...") #f) (thunk))) -(define getenv get-environment-variable) -(define (safe-setenv key val) - (if (or (substring-index "!" key) - (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables. - (substring-index "." key)) ;; periods are not allowed in environment variables - (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"") - (if (and (string? val) - (string? key)) - (handle-exceptions - exn - (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val ", exn=" exn) - (setenv key val)) - (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)))) - (define home (getenv "HOME")) (define user (getenv "USER")) ;;====================================================================== ;; returns list of fd count, socket count (define (get-file-descriptor-count #!key (pid (current-process-id ))) (list - (length (glob (conc "/proc/" pid "/fd/*"))) - (length (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*"))))) + (length (glob (conc "/proc/" pid "/fd/*"))) + (length (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*"))))) + ) ) -) - + ;;====================================================================== ;; GLOBALS ;; CONTEXTS @@ -814,11 +810,11 @@ ;; (mutex-unlock! *context-mutex*) ;; (mutex-lock! cxt-mutex) ;; (let ((res (proc cxt))) ;; (mutex-unlock! cxt-mutex) ;; res)))) - + ;;====================================================================== ;; A hash table that can be accessed by #{scheme ...} calls in ;; config files. Allows communicating between confgs ;; (define *user-hash-data* (make-hash-table)) @@ -929,11 +925,11 @@ (let ((resolve-pathname-broken? (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 (common:get-this-exe-fullpath #!key (argv (argv))) (let* ((this-script (cond @@ -1003,11 +999,11 @@ #t #f)) (define (status-sym->string status-sym) (case status-sym - ((pass) "PASS") + ((pass) "PASS") ((fail) "FAIL") ((warn) "WARN") ((check) "CHECK") ((waived) "WAIVED") ((abort) "ABORT") @@ -1095,30 +1091,30 @@ ;; if age(.mins.gz) >= 1h: ;; copy .mins.gz .hrs.gz ;; copy .mins.gz (when (>= (age-mins minsfile) 1) - (copy minsfile hrsfile) - (copy+zip filepath minsfile)) + (copy minsfile hrsfile) + (copy+zip filepath minsfile)) ;; if age(.hrs.gz) >= 1d: ;; copy .hrs.gz .days.gz ;; copy .mins.gz .hrs.gz (when (>= (age-days hrsfile) 1) - (copy hrsfile daysfile) - (copy minsfile hrsfile)) + (copy hrsfile daysfile) + (copy minsfile hrsfile)) ;; if age(.days.gz) >= 1w: ;; copy .days.gz .weeks.gz ;; copy .hrs.gz .days.gz (when (>= (age-wks daysfile) 1) - (copy daysfile wksfile) - (copy hrsfile daysfile)) + (copy daysfile wksfile) + (copy hrsfile daysfile)) #t) #f)) - - + + ;;====================================================================== ;; S P A R S E A R R A Y S ;;====================================================================== (define (make-sparse-array) @@ -1171,13 +1167,13 @@ ;; if lock is older than expire-time then remove it and try again ;; to get the lock ;; (define (common:simple-file-lock fname #!key (expire-time 300)) (let ((fmod-time (handle-exceptions - ext - (current-seconds) - (file-modification-time fname)))) + ext + (current-seconds) + (file-modification-time fname)))) (if (common:file-exists? fname) (if (> (- (current-seconds) fmod-time) expire-time) (begin (handle-exceptions exn #f (delete-file* fname)) (common:simple-file-lock fname expire-time: expire-time)) @@ -1187,14 +1183,14 @@ (lambda () (print key-string))) (thread-sleep! 0.25) (if (common:file-exists? fname) (handle-exceptions exn - #f - (with-input-from-file fname - (lambda () - (equal? key-string (read-line))))) + #f + (with-input-from-file fname + (lambda () + (equal? key-string (read-line))))) #f))))) (define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) (let ((end-time (+ expire-time (current-seconds)))) (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) @@ -1206,13 +1202,13 @@ (loop (common:simple-file-lock fname expire-time: expire-time))) #f))))) (define (common:simple-file-release-lock fname) (handle-exceptions - exn - #f ;; I don't really care why this failed (at least for now) - (delete-file* fname))) + exn + #f ;; I don't really care why this failed (at least for now) + (delete-file* fname))) ;;====================================================================== ;; U S E F U L S T U F F ;;====================================================================== @@ -1331,21 +1327,21 @@ '("n/a" "na" "PASS" "FAIL" "WARN" "CHECK" "WAIVED" "DEAD" "SKIP")) ;; group tests into buckets corresponding to rollup ;;; Running, completed-pass, completed-non-pass + worst status, not started. ;; filter out -;(define (common:categorize-items-for-rollup in-tests) -; ( + ;(define (common:categorize-items-for-rollup in-tests) + ; ( (define (common:special-sort items order comp) (let ((items-order (map reverse order)) (acomp (or comp >))) (sort items - (lambda (a b) - (let ((a-num (cadr (or (assoc a items-order) '(0 0)))) - (b-num (cadr (or (assoc b items-order) '(0 0))))) - (acomp a-num b-num)))))) + (lambda (a b) + (let ((a-num (cadr (or (assoc a items-order) '(0 0)))) + (b-num (cadr (or (assoc b items-order) '(0 0))))) + (acomp a-num b-num)))))) ;;====================================================================== ;; ;; given a toplevel with currstate, currstatus apply state and status ;; ;; => (newstate . newstatus) ;; (define (common:apply-state-status currstate currstatus state status) @@ -1396,11 +1392,11 @@ ;; (else unknown-error-6))) ;; (else unknown-error-7))) ;; (cons ;; (if nstate (symbol->string nstate) nstate) ;; (if nstatus (symbol->string nstatus) nstatus)))) - + ;;====================================================================== ;; D E B U G G I N G S T U F F ;;====================================================================== (define (common:debug-setup) @@ -1451,11 +1447,11 @@ ;;====================================================================== ;; (let ((ohh (common:on-homehost?)) ;; (srv (args:get-arg "-server"))) ;; (and ohh srv))) - ;; (debug:print-info 0 *default-log-port* "common:run-sync? ohh=" ohh ", srv=" srv) +;; (debug:print-info 0 *default-log-port* "common:run-sync? ohh=" ohh ", srv=" srv) (define *wdnum* 0) (define *wdnum*mutex (make-mutex)) @@ -1531,11 +1527,11 @@ (common: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) (handle-exceptions exn @@ -1555,15 +1551,15 @@ (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. exn=" exn) - #f) + exn + (begin + (debug:print-info 0 *default-log-port* "could not create " hed + ", this might cause problems down the road. exn=" exn) + #f) (create-directory hed #t))))) (if (and (string? res) (directory? res)) res (if (null? tal) @@ -1575,20 +1571,20 @@ ;; (define (common:get-youngest glob-list) (let ((all-files (apply append (map (lambda (patt) (handle-exceptions - exn - '() - (glob patt))) + exn + '() + (glob patt))) glob-list)))) (fold (lambda (fname res) (let ((last-mod (car res)) (curmod (handle-exceptions - exn - 0 - (file-modification-time fname)))) + exn + 0 + (file-modification-time fname)))) (if (> curmod last-mod) (list curmod fname) res))) '(0 "n/a") all-files))) @@ -1597,12 +1593,12 @@ ;; use bash to expand a glob. Does NOT handle paths with spaces! ;; (define (common:bash-glob instr) (string-split (with-input-from-pipe - (conc "/bin/bash -c \"echo " instr "\"") - read-line))) + (conc "/bin/bash -c \"echo " instr "\"") + read-line))) ;;====================================================================== ;; Some safety net stuff ;;====================================================================== @@ -1612,11 +1608,11 @@ (if (list? inlst) inlst (begin (if message (debug:print-error 0 *default-log-port* message)) (or ovrd '())))) - + (define (common:get-fields cfgdat) (let ((fields (hash-table-ref/default cfgdat "fields" '()))) (map car fields))) (define keys:config-get-fields common:get-fields) @@ -1798,33 +1794,10 @@ ;;====================================================================== ;; S Y S T E M S T U F F ;;====================================================================== -;; return a nice clean pathname made absolute -(define (common:nice-path dir) - (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) - (if match ;; using ~ for home? - (common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match))) - (normalize-pathname (if (absolute-pathname? dir) - dir - (conc (current-directory) "/" dir)))))) - -;; make "nice-path" available in config files and the repl -(define nice-path common:nice-path) - -(define (common:read-link-f path) - (handle-exceptions - exn - (begin - (debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed. exn=" exn) - path) ;; just give up - (with-input-from-pipe - (conc "/bin/readlink -f " path) - (lambda () - (read-line))))) - ;;====================================================================== ;; returns *effective load* (not normalized) ;; (define (common:get-intercept onemin fivemin) (if (< onemin fivemin) ;; load is decreasing, just use the onemin load @@ -1861,64 +1834,64 @@ (delete-file* fullpath) #f))) (if (and (file-exists? fullpath) (file-read-access? fullpath)) (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "failed to get cached info from " fullpath ", exn=" exn) - #f) + exn + (begin + (debug:print 0 *default-log-port* "failed to get cached info from " fullpath ", exn=" exn) + #f) (debug:print 2 *default-log-port* "reading file " fullpath) (let ((real-age (- (current-seconds) (handle-exceptions - exn - (begin - (debug:print 1 *default-log-port* "Failed to read mod time on file " - fullpath ", using 0, exn=" exn) - 0) - (file-change-time fullpath))))) + exn + (begin + (debug:print 1 *default-log-port* "Failed to read mod time on file " + fullpath ", using 0, exn=" exn) + 0) + (file-change-time fullpath))))) (if (< real-age age) (handle-exceptions - exn - (delfile exn) - (let* ((res (with-input-from-file fullpath read))) - (if (eof-object? res) - (begin - (delfile "n/a") - #f) - res))) + exn + (delfile exn) + (let* ((res (with-input-from-file fullpath read))) + (if (eof-object? res) + (begin + (delfile "n/a") + #f) + res))) (begin (debug:print-info 2 *default-log-port* "file " fullpath " is too old (" real-age" seconds) to trust, skipping reading it") #f)))) (begin (debug:print 2 *default-log-port* "not reading file " fullpath) #f))) #f)) - + (define (common:write-cached-info key dtype dat) (if *toppath* (let* ((fulldir (conc *toppath* "/.sysdata")) (fullpath (conc fulldir "/" key "-" dtype ".log"))) (if (not (file-exists? fulldir))(create-directory fulldir #t)) (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "failed to write file " fullpath ", exn=" exn) - #f) - (with-output-to-file fullpath (lambda ()(pp dat))))) + exn + (begin + (debug:print 0 *default-log-port* "failed to write file " fullpath ", exn=" exn) + #f) + (with-output-to-file fullpath (lambda ()(pp dat))))) #f)) (define (common:raw-get-remote-host-load remote-host) (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "failed to ssh to " remote-host " and get loadavg. exn=" exn) - #f) ;; more specific handling of errors needed - (with-input-from-pipe - (conc "ssh " remote-host " cat /proc/loadavg") - (lambda ()(list (read)(read)(read)))))) + exn + (begin + (debug:print 0 *default-log-port* "failed to ssh to " remote-host " and get loadavg. exn=" exn) + #f) ;; more specific handling of errors needed + (with-input-from-pipe + (conc "ssh " remote-host " cat /proc/loadavg") + (lambda ()(list (read)(read)(read)))))) ;;====================================================================== ;; get cpu load by reading from /proc/loadavg, return all three values ;; (define (common:get-cpu-load remote-host) @@ -1925,31 +1898,31 @@ ;; (handle-exceptions ;; exn ;; (begin ;; (debug:print 0 *default-log-port* "failed to ssh or read loadavg from host " remote-host ", exn=" exn) ;; '(-99 -99 -99)) - (let* ((actual-hostname (or remote-host (get-host-name) "localhost"))) - (or (common:get-cached-info actual-hostname "cpu-load") - (let ((result (if remote-host - (map (lambda (res) - (if (eof-object? res) 9e99 res)) - (with-input-from-pipe - (conc "ssh " remote-host " cat /proc/loadavg") - (lambda ()(list (read)(read)(read))))) - (with-input-from-file "/proc/loadavg" - (lambda ()(list (read)(read)(read))))))) - (match - result - ((l1 l2 l3) - (if (and (number? l1) - (number? l2) - (number? l3)) - (begin - (common:write-cached-info actual-hostname "cpu-load" result) - result) - '(-1 -1 -1))) ;; -1 is bad result - (else '(-2 -2 -2))))))) ;; ) + (let* ((actual-hostname (or remote-host (get-host-name) "localhost"))) + (or (common:get-cached-info actual-hostname "cpu-load") + (let ((result (if remote-host + (map (lambda (res) + (if (eof-object? res) 9e99 res)) + (with-input-from-pipe + (conc "ssh " remote-host " cat /proc/loadavg") + (lambda ()(list (read)(read)(read))))) + (with-input-from-file "/proc/loadavg" + (lambda ()(list (read)(read)(read))))))) + (match + result + ((l1 l2 l3) + (if (and (number? l1) + (number? l2) + (number? l3)) + (begin + (common:write-cached-info actual-hostname "cpu-load" result) + result) + '(-1 -1 -1))) ;; -1 is bad result + (else '(-2 -2 -2))))))) ;; ) ;;====================================================================== ;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads ;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc. ;; keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load @@ -1976,12 +1949,12 @@ (define (common:get-normalized-cpu-load-raw remote-host) (let* ((actual-host (or remote-host (get-host-name)))) ;; #f is localhost (or (common:get-cached-info actual-host "normalized-load") (let ((data (if remote-host (with-input-from-pipe - (conc "ssh " remote-host " \"cat /proc/loadavg;cat /proc/cpuinfo;echo end\"") - read-lines) + (conc "ssh " remote-host " \"cat /proc/loadavg;cat /proc/cpuinfo;echo end\"") + read-lines) (append (with-input-from-file "/proc/loadavg" read-lines) (with-input-from-file "/proc/cpuinfo" read-lines) @@ -2016,20 +1989,20 @@ (list (cons 'proc act-proc) (cons 'core act-core) (cons 'phys act-phys))))) (common:write-cached-info actual-host "normalized-load" result) result) - (regex-case - hed - (load-rx ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num)) - (proc-rx ( x p ) (loop (car tal)(cdr tal) loads (max-num p proc-num) phys-num core-num)) - (phys-rx ( x p ) (loop (car tal)(cdr tal) loads proc-num (max-num p phys-num) core-num)) - (core-rx ( x c ) (loop (car tal)(cdr tal) loads proc-num phys-num (max-num c core-num))) - (else - (begin - ;; (print "NO MATCH: " hed) - (loop (car tal)(cdr tal) loads proc-num phys-num core-num))))))))))) + (regex-case + hed + (load-rx ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num)) + (proc-rx ( x p ) (loop (car tal)(cdr tal) loads (max-num p proc-num) phys-num core-num)) + (phys-rx ( x p ) (loop (car tal)(cdr tal) loads proc-num (max-num p phys-num) core-num)) + (core-rx ( x c ) (loop (car tal)(cdr tal) loads proc-num phys-num (max-num c core-num))) + (else + (begin + ;; (print "NO MATCH: " hed) + (loop (car tal)(cdr tal) loads proc-num phys-num core-num))))))))))) (define (common:unix-ping hostname) (let ((res (system (conc "ping -c 1 " hostname " > /dev/null")))) (eq? res 0))) @@ -2223,11 +2196,11 @@ (vector (regexp (cadr m))(string->symbol (caddr m))(cadr m)) (begin (debug:print 0 *default-log-port* "WARNING: Unrecognised rule \"" s "\" in clean-up specification.") #f)))) spec-strings)))) - + ;;====================================================================== ;; given a list of specs rx . rule and a file return the first matching rule ;; (define (common:file-find-rule fname rules) ;; rule is vector #( rx action rx-string) (let loop ((rule (car rules)) @@ -2297,11 +2270,11 @@ (debug:print-info 0 *default-log-port* (conc msg" : $PATH="path)) (if (string-match "^.*/isoenv-core/.*" path) (debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod (debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**"))))) - + (define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES"))) ;;(bb-check-path msg: "save-environment-as-files entry") (let ((envvars (get-environment-variables)) (whitesp (regexp "[^a-zA-Z0-9_\\-:,\\.\\/%$]")) (mungeval (lambda (val) @@ -2308,67 +2281,67 @@ (cond ((eq? val #t) "") ;; convert #t to empty string ((eq? val #f) #f) ;; convert #f to itself (still thinking about this one (else val))))) (with-output-to-file (conc fname ".csh") - (lambda () - (for-each (lambda (keyval) - (let* ((key (car keyval)) - (val (cdr keyval)) - (delim (if (string-search whitesp val) - "\"" - ""))) - (print (if (or (member key ignorevars) - (string-search whitesp key)) - "# setenv " - "setenv ") - key " " delim (mungeval val) delim))) - envvars))) - (with-output-to-file (conc fname ".sh") - (lambda () - (for-each (lambda (keyval) - (let* ((key (car keyval)) - (val (cdr keyval)) - (delim (if (string-search whitesp val) - "\"" - ""))) - (print (if (or (member key ignorevars) - (string-search whitesp key) - (string-search ":" key)) ;; internal only values to be skipped. - "# export " - "export ") - key "=" delim (mungeval val) delim))) - envvars))))) + (lambda () + (for-each (lambda (keyval) + (let* ((key (car keyval)) + (val (cdr keyval)) + (delim (if (string-search whitesp val) + "\"" + ""))) + (print (if (or (member key ignorevars) + (string-search whitesp key)) + "# setenv " + "setenv ") + key " " delim (mungeval val) delim))) + envvars))) + (with-output-to-file (conc fname ".sh") + (lambda () + (for-each (lambda (keyval) + (let* ((key (car keyval)) + (val (cdr keyval)) + (delim (if (string-search whitesp val) + "\"" + ""))) + (print (if (or (member key ignorevars) + (string-search whitesp key) + (string-search ":" key)) ;; internal only values to be skipped. + "# export " + "export ") + key "=" delim (mungeval val) delim))) + envvars))))) ;;====================================================================== ;; (define (common:propogate-mt-vars-to-subrun proc propogate-vars) (let ((vars (make-hash-table)) (var-patt "^MT_.*")) (for-each (lambda (vardat) ;; each env var - ;(for-each - ;(lambda (var-patt) - (if (string-match var-patt (car vardat)) - (let ((var (car vardat)) - (val (cdr vardat))) - (hash-table-set! vars var val) - (if (member var propogate-vars) - (begin - (print var " " (string-substitute "MT_" "PARENT_" var)) - (setenv (string-substitute "MT_" "PARENT_" var) val))) - (unsetenv var)))) -; var-patts)) + ;(for-each + ;(lambda (var-patt) + (if (string-match var-patt (car vardat)) + (let ((var (car vardat)) + (val (cdr vardat))) + (hash-table-set! vars var val) + (if (member var propogate-vars) + (begin + (print var " " (string-substitute "MT_" "PARENT_" var)) + (setenv (string-substitute "MT_" "PARENT_" var) val))) + (unsetenv var)))) + ; var-patts)) (get-environment-variables)) (cond ((string? proc)(system proc)) (proc (proc))) (hash-table-for-each vars (lambda (var val) - (if (member var propogate-vars) - (unsetenv (string-substitute "MT_" "PARENT_" var))) + (if (member var propogate-vars) + (unsetenv (string-substitute "MT_" "PARENT_" var))) (setenv var val))) vars)) (define (common:get-param-mapping #!key (flavor #f)) @@ -2462,11 +2435,11 @@ vars)) ;;====================================================================== ;; C O L O R S ;;====================================================================== - + (define (common:name->iup-color name) (case (string->symbol (string-downcase name)) ((red) "223 33 49") ((grey) "192 192 192") ((orange) "255 172 13") @@ -2653,20 +2626,20 @@ (newr (if (and patt repl) (begin (handle-exceptions exn (begin - (debug:print 0 *default-log-port* - "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl ", exn=" exn) + (debug:print 0 *default-log-port* + "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl ", exn=" exn) res) - (string-substitute patt repl res)) + (string-substitute patt repl res)) ) (begin (debug:print 0 *default-log-port* - "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl) + "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl) res)))) (if (null? tal) newr (loop (car tal)(cdr tal) newr))))))) @@ -2690,14 +2663,14 @@ (ssh-cmd (if is-local " " (conc "ssh " host " "))) (cmd (conc ssh-cmd "pstree -A " pid)) (output (with-input-from-pipe cmd read-lines))) (debug:print 2 *default-log-port* "Running " cmd " received " output) (if (eq? (length output) 0) - #f - #t)) + #f + #t)) #t)) - + ;;====================================================================== ;; N A N O M S G C L I E N T ;;====================================================================== ;; ;; @@ -2765,48 +2738,48 @@ ;; ;; ;; (define (mddb:get-dashboards) ;; (let ((db (mddb:open-db))) ;; (query fetch-column ;; (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;")))) - + ;;====================================================================== ;; NMSG AND NEW API ;;====================================================================== ;; nm based server experiment, keep around for now. ;; #;(define (nm:start-server dbconn #!key (given-host-name #f)) - (let* ((srvdat (start-raw-server given-host-name: given-host-name)) - (host-name (srvdat-host srvdat)) - (soc (srvdat-soc srvdat))) - - ;; start the queue processor (save for second round of development) - ;; - (thread-start! (make-thread! (lambda ()(queue-processor dbconn) "Queue processor"))) - ;; msg is an alist - ;; 'r host:port <== where to return the data - ;; 'p params <== data to apply the command to - ;; 'e j|s|l <== encoding of the params. default is s (sexp), if not specified is assumed to be default - ;; 'c command <== look up the function to call using this key - ;; - (let loop ((msg-in (nn-recv soc))) - (if (not (equal? msg-in "quit")) - (let* ((dat (decode msg-in)) - (host-port (alist-ref 'r dat)) ;; this is for the reverse req rep where the server is a client of the original client - (params (alist-ref 'p dat)) - (command (let ((c (alist-ref 'c dat)))(if c (string->symbol c) #f))) - (all-good (and host-port params command (hash-table-exists? *commands* command)))) - (if all-good - (let ((cmddat (make-qitem - command: command - host-port: host-port - params: params))) - (queue-push cmddat) ;; put request into the queue - (nn-send soc "queued")) ;; reply with "queued" - (print "ERROR: ["(common:human-time)"] BAD request " dat)) - (loop (nn-recv soc))))) - (nn-close soc))) +(let* ((srvdat (start-raw-server given-host-name: given-host-name)) + (host-name (srvdat-host srvdat)) + (soc (srvdat-soc srvdat))) + + ;; start the queue processor (save for second round of development) + ;; + (thread-start! (make-thread! (lambda ()(queue-processor dbconn) "Queue processor"))) + ;; msg is an alist + ;; 'r host:port <== where to return the data + ;; 'p params <== data to apply the command to + ;; 'e j|s|l <== encoding of the params. default is s (sexp), if not specified is assumed to be default + ;; 'c command <== look up the function to call using this key + ;; + (let loop ((msg-in (nn-recv soc))) + (if (not (equal? msg-in "quit")) + (let* ((dat (decode msg-in)) + (host-port (alist-ref 'r dat)) ;; this is for the reverse req rep where the server is a client of the original client + (params (alist-ref 'p dat)) + (command (let ((c (alist-ref 'c dat)))(if c (string->symbol c) #f))) + (all-good (and host-port params command (hash-table-exists? *commands* command)))) + (if all-good + (let ((cmddat (make-qitem + command: command + host-port: host-port + params: params))) + (queue-push cmddat) ;; put request into the queue + (nn-send soc "queued")) ;; reply with "queued" + (print "ERROR: ["(common:human-time)"] BAD request " dat)) + (loop (nn-recv soc))))) + (nn-close soc))) ;;====================================================================== ;; H I E R A R C H I C A L H A S H T A B L E S ;;====================================================================== @@ -2852,11 +2825,11 @@ (apply hh:set! new-sub-hh value (cdr keys))) (apply hh:set! sub-hh value (cdr keys)))) ;; call the sub-hierhash with remaining keys (begin (hh:set-ht! hh (make-hash-table)) (apply hh:set! hh value keys)))))) - + ;;====================================================================== ;; Manage pkts, used in servers, tests and likely other contexts so put ;; in common ;;====================================================================== @@ -2870,11 +2843,11 @@ (server . ((action . a) (pid . d) (ipaddr . i) (port . p) (parent . P))) - + (test . ((cpuuse . c) (diskuse . d) (item-path . i) (runname . r) (state . s) @@ -2898,50 +2871,10 @@ `(,(alist-ref 't x) . ,(string->number (alist-ref 'D x)))) pkts) (lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending (lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target -;;====================================================================== -;; 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 (common: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 *common:thread-punchlist* (make-hash-table)) (define (common:send-thunk-to-background-thread thunk #!key (name #f)) ;;(BB> "launched thread " name) @@ -2965,15 +2898,15 @@ (for-each (lambda (thread-name) (let* ((thread (hash-table-ref/default *common:thread-punchlist* thread-name #f))) (if thread (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "joining threads failed. exn=" exn) - #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception - (thread-join! thread)) + exn + (begin + (debug:print 0 *default-log-port* "joining threads failed. exn=" 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*))) ;;====================================================================== ;; (define *common:telemetry-log-state* 'startup) @@ -3045,58 +2978,58 @@ (loop (conc res (read-char port))) res))) (define (process:cmd-run-with-stderr->list cmd . params) ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) -;; (handle-exceptions -;; exn -;; (begin -;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) -;; (print " " ((condition-property-accessor 'exn 'message) exn)) -;; #f) - (let-values (((fh fho pid fhe) (if (null? params) - (process* cmd) - (process* cmd params)))) - (let loop ((curr (read-line fh)) - (result '())) - (let ((errstr (process:conservative-read fhe))) - (if (not (string=? errstr "")) - (set! result (append result (list errstr))))) - (if (not (eof-object? curr)) - (loop (read-line fh) - (append result (list curr))) - (begin - (close-input-port fh) - (close-input-port fhe) - (close-output-port fho) - result))))) ;; ) + ;; (handle-exceptions + ;; exn + ;; (begin + ;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) + ;; (print " " ((condition-property-accessor 'exn 'message) exn)) + ;; #f) + (let-values (((fh fho pid fhe) (if (null? params) + (process* cmd) + (process* cmd params)))) + (let loop ((curr (read-line fh)) + (result '())) + (let ((errstr (process:conservative-read fhe))) + (if (not (string=? errstr "")) + (set! result (append result (list errstr))))) + (if (not (eof-object? curr)) + (loop (read-line fh) + (append result (list curr))) + (begin + (close-input-port fh) + (close-input-port fhe) + (close-output-port fho) + result))))) ;; ) (define (process:cmd-run-with-stderr-and-exitcode->list cmd . params) ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) -;; (handle-exceptions -;; exn -;; (begin -;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) -;; (print " " ((condition-property-accessor 'exn 'message) exn)) -;; #f) - (let-values (((fh fho pid fhe) (if (null? params) - (process* cmd) - (process* cmd params)))) - (let loop ((curr (read-line fh)) - (result '())) - (let ((errstr (process:conservative-read fhe))) - (if (not (string=? errstr "")) - (set! result (append result (list errstr))))) - (if (not (eof-object? curr)) - (loop (read-line fh) - (append result (list curr))) - (begin - (let-values (((anotherpid normalexit? exitstatus) (process-wait pid))) - (close-input-port fh) - (close-input-port fhe) - (close-output-port fho) - (list result (if normalexit? exitstatus -1)))))))) + ;; (handle-exceptions + ;; exn + ;; (begin + ;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) + ;; (print " " ((condition-property-accessor 'exn 'message) exn)) + ;; #f) + (let-values (((fh fho pid fhe) (if (null? params) + (process* cmd) + (process* cmd params)))) + (let loop ((curr (read-line fh)) + (result '())) + (let ((errstr (process:conservative-read fhe))) + (if (not (string=? errstr "")) + (set! result (append result (list errstr))))) + (if (not (eof-object? curr)) + (loop (read-line fh) + (append result (list curr))) + (begin + (let-values (((anotherpid normalexit? exitstatus) (process-wait pid))) + (close-input-port fh) + (close-input-port fhe) + (close-output-port fho) + (list result (if normalexit? exitstatus -1)))))))) (define (process:cmd-run-proc-each-line cmd proc . params) ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) (handle-exceptions exn @@ -3106,11 +3039,11 @@ (debug:print 5 *default-log-port* "exn=" (condition->list exn)) #f) (let-values (((fh fho pid) (if (null? params) (process cmd) (process cmd params)))) - (let loop ((curr (read-line fh)) + (let loop ((curr (read-line fh)) (result '())) (if (not (eof-object? curr)) (loop (read-line fh) (append result (list (proc curr)))) (begin @@ -3123,27 +3056,10 @@ (let* ((fh (open-input-pipe cmd)) (res (port-proc->list fh proc)) (status (close-input-pipe fh))) (if (eq? status 0) res #f))) -(define (process:cmd-run->list cmd #!key (delta-env-alist-or-hash-table '())) - (common: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)))) (define (port-proc->list fh proc) (if (eof-object? fh) #f (let loop ((curr (proc (read-line fh))) (result '())) @@ -3173,20 +3089,20 @@ (let ((pid (if params (process-run cmdline params) (process-run cmdline)))) (let loop ((i 0)) (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) - (if (eq? pid-val 0) - (begin - (thread-sleep! 2) - (loop (+ i 1))) - (begin - (if (and run-dir - (directory-exists? run-dir)) - (pop-directory)) - (values pid-val exit-status exit-code))))))) - + (if (eq? pid-val 0) + (begin + (thread-sleep! 2) + (loop (+ i 1))) + (begin + (if (and run-dir + (directory-exists? run-dir)) + (pop-directory)) + (values pid-val exit-status exit-code))))))) + ;;====================================================================== ;; MISC PROCESS RELATED STUFF ;;====================================================================== (define (process:children proc) @@ -3205,20 +3121,20 @@ (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)) (let-values (((rpid exit-type exit-signal)(process-wait pid #t))) - (and (number? rpid) - (equal? rpid pid))))) + (and (number? rpid) + (equal? rpid pid))))) (define (process:alive-on-host? host pid) (let ((cmd (conc "ssh " host " ps -o pid= -p " pid))) (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "failed to identify if process " pid ", on host " host " is alive. exn=" exn) - #f) ;; anything goes wrong - assume the process in NOT running. + exn + (begin + (debug:print 0 *default-log-port* "failed to identify if process " pid ", on host " host " is alive. exn=" exn) + #f) ;; anything goes wrong - assume the process in NOT running. (with-input-from-pipe cmd (lambda () (let loop ((inl (read-line))) (if (eof-object? inl) @@ -3272,36 +3188,36 @@ ;; (define (tasks:kill-server hostname pid #!key (kill-switch "")) (debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname) (setenv "TARGETHOST" hostname) (let* ((logdir (if (directory-exists? "logs") - "logs/" - "")) + "logs/" + "")) (logfile (if logdir (conc "logs/server-"pid"-"hostname".log") #f)) (gzfile (if logfile (conc logfile ".gz")))) (setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log")) (system (conc "nbfake kill "kill-switch" "pid)) (when logfile - (thread-sleep! 0.5) - (if (common:file-exists? gzfile) (delete-file gzfile)) - (system (conc "gzip " logfile)) - - (unsetenv "TARGETHOST_LOGF") - (unsetenv "TARGETHOST")))) - + (thread-sleep! 0.5) + (if (common:file-exists? gzfile) (delete-file gzfile)) + (system (conc "gzip " logfile)) + + (unsetenv "TARGETHOST_LOGF") + (unsetenv "TARGETHOST")))) + ;;====================================================================== ;; hash-table tree to html list tree ;; ;; tipfunc takes two parameters: y the tip value and path the path to that point ;; (define (common:htree->html ht path tipfunc) (let ((datlist (sort (hash-table->alist ht) -;;====================================================================== -;;====================================================================== + ;;====================================================================== + ;;====================================================================== (lambda (a b) (string< (car a)(car b)))))) (if (null? datlist) (tipfunc #f path) ;; really shouldn't get here (s:ul @@ -3446,11 +3362,11 @@ (define (common:rotate-logs) (let* ((all-files (make-hash-table)) (stats (make-hash-table)) (inc-stat (lambda (key) (hash-table-set! stats key (+ (hash-table-ref/default stats key 0) 1)))) - (max-allowed (string->number (or (configf:lookup *configdat* "setup" "max-logfiles") "300")))) ;; name -> age + (max-allowed (string->number (or (configf:lookup *configdat* "setup" "max-logfiles") "300")))) ;; name -> age (if (not (directory-exists? "logs"))(create-directory "logs")) (directory-fold (lambda (file rem) (handle-exceptions exn @@ -3519,11 +3435,11 @@ exn (debug:print-error 0 *default-log-port* "failed to remove " fullname ", exn=" exn) (delete-file* fullname))))) files) (debug:print-info 0 *default-log-port* "Deleted " (length files) " files from logs, keeping " max-allowed " files.")))))) - + ;;====================================================================== ;; calculate a delay number based on a droop curve ;; inputs are: ;; - load-in, load as from uptime, NOT normalized ;; - numcpus, number of cpus, ideally use the real cpus, not threads @@ -3543,16 +3459,16 @@ ((and (> ratio .9) (<= ratio 1.1)) (+ 5 (* (- ratio .9) (/ 55 .2)))) ((> ratio 1.1) 60))) (match paramlst - ((r1 r2 s1 s2) - (debug:print 3 *default-log-port* "Using params r1=" r1 " r2=" r2 " s1=" s1 " s2=" s2) - (min (max (/ (expt r1 (* r2 s2 ratio)) s1) 0) 30)) - (else - (debug:print 0 *default-log-port* "BAD exp-params, should be \"r1 r2 s1 s2\" but got " paramstr) - 30))))) + ((r1 r2 s1 s2) + (debug:print 3 *default-log-port* "Using params r1=" r1 " r2=" r2 " s1=" s1 " s2=" s2) + (min (max (/ (expt r1 (* r2 s2 ratio)) s1) 0) 30)) + (else + (debug:print 0 *default-log-port* "BAD exp-params, should be \"r1 r2 s1 s2\" but got " paramstr) + 30))))) (define (common:print-delay-table) (let loop ((x 0)) (print x "," (common:get-delay x 1)) (if (< x 2) @@ -3565,23 +3481,23 @@ ;; (define (common:wait-for-cpuload maxnormload numcpus-in #!key (count 1000) (msg #f)(remote-host #f)(num-tries 5)) (let* ((loadavg (common:get-cpu-load remote-host)) - ;; not possible to have zero. If we get 1, it's possible that we got the previous default, and we should check again + ;; not possible to have zero. If we get 1, it's possible that we got the previous default, and we should check again (numcpus (if (<= 1 numcpus-in) (common:get-num-cpus remote-host) numcpus-in)) (first (car loadavg)) (next (cadr loadavg)) (adjmaxload (* maxnormload (max 1 numcpus))) ;; possible bug - ;; where numcpus - ;; (or could be - ;; maxload) is - ;; zero, crude - ;; fallback is to - ;; at least use 1 + ;; where numcpus + ;; (or could be + ;; maxload) is + ;; zero, crude + ;; fallback is to + ;; at least use 1 ;; effective load accounts for load jumps, this should elminate all the first-next-avg, adjwait, load-jump-limit ;; etc. (effective-load (common:get-intercept first next)) (recommended-delay (common:get-delay effective-load numcpus)) (effective-host (or remote-host "localhost")) @@ -3674,21 +3590,21 @@ dirpath))) (define (get-free-inodes path) (if (configf:lookup *configdat* "setup" "free-inodes-script") (with-input-from-pipe - (conc (configf:lookup *configdat* "setup" "free-inodes-script") " " path) -;;====================================================================== -;;====================================================================== -;;====================================================================== -;;====================================================================== -;;====================================================================== - - (lambda () - (let ((res (read-line))) - (if (string? res) - (string->number res))))) + (conc (configf:lookup *configdat* "setup" "free-inodes-script") " " path) + ;;====================================================================== + ;;====================================================================== + ;;====================================================================== + ;;====================================================================== + ;;====================================================================== + + (lambda () + (let ((res (read-line))) + (if (string? res) + (string->number res))))) (get-unix-inodes path))) ;;====================================================================== ;;====================================================================== ;;====================================================================== ;;====================================================================== @@ -3737,14 +3653,14 @@ ((not (common: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" - schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));")))) - (proc pktsdirs pktsdir pdb) - (dbi:close pdb)))))) + (let* ((pdb (open-queue-db pdbpath "pkts.db" + schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));")))) + (proc pktsdirs pktsdir pdb) + (dbi:close pdb)))))) ;;====================================================================== ;; check space in dbdir and in megatest dir ;; returns: ok/not dbspace required-space ;; @@ -3776,14 +3692,14 @@ ;;====================================================================== ;; paths is list of lists ((name path) ... ) ;; (define (common:get-disk-with-most-free-space disks minsize) (let* ((best #f) - (bestsize 0) - (default-min-inodes-string "1000000") - (default-min-inodes (string->number default-min-inodes-string)) - (min-inodes (or (string->number (if (configf:lookup *configdat* "setup" "min_inodes") (configf:lookup *configdat* "setup" "min_inodes") default-min-inodes-string)) default-min-inodes))) + (bestsize 0) + (default-min-inodes-string "1000000") + (default-min-inodes (string->number default-min-inodes-string)) + (min-inodes (or (string->number (if (configf:lookup *configdat* "setup" "min_inodes") (configf:lookup *configdat* "setup" "min_inodes") default-min-inodes-string)) default-min-inodes))) (for-each (lambda (disk-num) (let* ((dirpath (cadr (assoc disk-num disks))) (freespc (cond @@ -3800,33 +3716,33 @@ (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) -1) (else (get-df dirpath)))) (free-inodes (cond - ((not (directory? dirpath)) - (if (common:low-noise-print 300 "disks not a dir " disk-num) - (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) - -1) - ((not (file-write-access? dirpath)) - (if (common:low-noise-print 300 "disks not writeable " disk-num) - (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) - -1) - ((not (eq? (string-ref dirpath 0) #\/)) - (if (common:low-noise-print 300 "disks not a proper path " disk-num) - (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) - -1) - (else - (get-free-inodes dirpath)))) - ;;(free-inodes (get-free-inodes dirpath)) - ) - (debug:print 2 *default-log-port* "INFO: disk " disk-num " path " dirpath " free space " freespc " free inodes " free-inodes) + ((not (directory? dirpath)) + (if (common:low-noise-print 300 "disks not a dir " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) + -1) + ((not (file-write-access? dirpath)) + (if (common:low-noise-print 300 "disks not writeable " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) + -1) + ((not (eq? (string-ref dirpath 0) #\/)) + (if (common:low-noise-print 300 "disks not a proper path " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) + -1) + (else + (get-free-inodes dirpath)))) + ;;(free-inodes (get-free-inodes dirpath)) + ) + (debug:print 2 *default-log-port* "INFO: disk " disk-num " path " dirpath " free space " freespc " free inodes " free-inodes) (if (and (> freespc bestsize)(> free-inodes min-inodes )) (begin (set! best (cons disk-num dirpath)) (set! bestsize freespc))) - ;;(print "Processing: " disk-num " bestsize: " bestsize " best: " best " freespc: " freespc " min-inodes: " min-inodes " free-inodes: " free-inodes) - )) + ;;(print "Processing: " disk-num " bestsize: " bestsize " best: " best " freespc: " freespc " min-inodes: " min-inodes " free-inodes: " free-inodes) + )) (map car disks)) (if (and best (> bestsize minsize)) best #f))) ;; #f means no disk candidate found @@ -3890,11 +3806,10 @@ (with-output-to-file (conc pktsdir "/" uuid ".pkt") (lambda () (print pkt))))))))) ;; (set! *common:telemetry-log-socket* #f))))) - (define (common:get-linktree) (or (getenv "MT_LINKTREE") (if *configdat* (configf:lookup *configdat* "setup" "linktree") @@ -3906,8 +3821,381 @@ (lt (conc tp "/lt"))) (if (not tp)(debug:print 0 *default-log-port* "WARNING: cannot calculate best path for linktree, using " lt)) lt))) +(define (tests:get-tests-search-path cfgdat) + (let ((paths (let ((section (if cfgdat + (configf:get-section cfgdat "tests-paths") + #f))) + (if section + (map cadr section) + '())))) + (filter (lambda (d) + (if (directory-exists? d) + d + (begin + ;; (if (common:low-noise-print 60 "tests:get-tests-search-path" d) + ;; (debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path")) + #f))) + (append paths (list (conc *toppath* "/tests")))))) + +(define (server:get-best-guess-address hostname) + (let ((res #f)) + (for-each + (lambda (adr) + (if (not (eq? (u8vector-ref adr 0) 127)) + (set! res adr))) + ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME + (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) + (string-intersperse + (map number->string + (u8vector->list + (if res res (hostname->ip hostname)))) "."))) +;;====================================================================== +;; logic for getting homehost. Returns (host . at-home) +;; IF *toppath* is not set, wait up to five seconds trying every two seconds +;; (this is to accomodate the watchdog) +;; +(define (common:get-homehost #!key (trynum 5)) + ;; called often especially at start up. use mutex to eliminate collisions + (mutex-lock! *homehost-mutex*) + (cond + (*home-host* + (mutex-unlock! *homehost-mutex*) + *home-host*) + ((not *toppath*) + (mutex-unlock! *homehost-mutex*) + ((launch:setup) ;; safely mutexed now + (if (> trynum 0) + (begin + (thread-sleep! 2) + (common:get-homehost trynum: (- trynum 1))) + #f)) + (else + (let* ((currhost (get-host-name)) + (bestadrs (server:get-best-guess-address currhost)) + ;; first look in config, then look in file .homehost, create it if not found + (homehost (or (configf:lookup *configdat* "server" "homehost" ) + (handle-exceptions + exn + (if (> trynum 0) + (let ((delay-time (* (- 5 trynum) 5))) + (mutex-unlock! *homehost-mutex*) + (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Failed to read .homehost file, delaying " + delay-time " seconds and trying again, message: " ((condition-property-accessor 'exn 'message) exn) + ", exn=" exn) + (thread-sleep! delay-time) + (common:get-homehost trynum: (- trynum 1))) + (begin + (mutex-unlock! *homehost-mutex*) + (debug:print 0 *default-log-port* "ERROR: ["(common:human-time) + "] 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) + (with-input-from-file hhf read-line) + (if (file-write-access? *toppath*) + (begin + (with-output-to-file hhf + (lambda () + (print bestadrs))) + (begin + (mutex-unlock! *homehost-mutex*) + (car (common:get-homehost)))) + #f)))))) + (at-home (or (equal? homehost currhost) + (equal? homehost bestadrs)))) + (set! *home-host* (cons homehost at-home)) + (mutex-unlock! *homehost-mutex*) + *home-host*))))) + +(define (common:wait-for-homehost-load maxnormload msg) + (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local. + #f + (common:get-homehost))) + (hh (if hh-dat (car hh-dat) #f))) + (common:wait-for-normalized-load maxnormload msg hh))) + +;;====================================================================== +;; am I on the homehost? +;;====================================================================== +;;====================================================================== +;;====================================================================== +;; +(define (common:on-homehost?) + (let ((hh (common:get-homehost))) + (if hh + (cdr hh) + #f))) + +(define (common:run-sync?) + (and (common:on-homehost?) + (args:get-arg "-server"))) + + +;; gather available information, if legit read configs in this order: +;; +;; if have cache; +;; read it a return it +;; else +;; megatest.config (do not cache) +;; runconfigs.config (cache if all vars avail) +;; megatest.config (cache if all vars avail) +;; returns: +;; *toppath* +;; side effects: +;; sets; *configdat* (megatest.config info) +;; *runconfigdat* (runconfigs.config info) +;; *configstatus* (status of the read data) +;; +(define (launch:setup #!key (force-reread #f) (areapath #f)) + (mutex-lock! *launch-setup-mutex*) + (if (and *toppath* + (eq? *configstatus* 'fulldata) (not force-reread)) ;; got it all + (begin + (debug:print 2 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata") + (mutex-unlock! *launch-setup-mutex*) + *toppath*) + (let ((res (launch:setup-body force-reread: force-reread areapath: areapath))) + (mutex-unlock! *launch-setup-mutex*) + res))) + +(define (launch:setup-body #!key (force-reread #f) (areapath #f)) + (if (and (eq? *configstatus* 'fulldata) + *toppath* + (not force-reread)) ;; no need to reprocess + *toppath* ;; return toppath + (let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks *configdat* for use-cache setting. We do not have *configdat*. Bootstrapping problem here. + (toppath (common:get-toppath areapath)) + (target (common:args-get-target)) + (sections (if target (list "default" target) #f)) ;; for runconfigs + (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config + (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) + ;; checking for null cachefiles should not be necessary, I was seeing error car of '(), might be a chicken bug or a red herring ... + (mtcachef (if (null? cachefiles) + #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?))))) + (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)) + ;;(BB> "launch:setup-body -- cond branch 1 - use-cache") + (set! *configdat* (configf:read-alist mtcachef)) + (set! *db-keys* (common:get-fields *configdat*)) + ;;(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"))) + (set! *configstatus* 'fulldata) + (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) + *toppath*) + ;; there are no existing cached configs, do full reads of the configs and cache them + ;; we have all the info needed to fully process runconfigs and megatest.config + ((and ;; (not force-reread) ;; force-reread is irrelevant in the AND, could however OR it? + mtcachef + rccachef) ;; BB- why are we doing this without asking if caching is desired? + ;;(BB> "launch:setup-body -- cond branch 2") + (let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect + mtconfig + environ-patt: "env-override" + given-toppath: toppath + pathenvvar: "MT_RUN_AREA_HOME")) + (first-rundat (let ((toppath (if toppath + toppath + (car first-pass)))) + (read-config ;; (conc toppath "/runconfigs.config") ;; this should be converted to runconfig:read but it is non-trivial, leaving it for now. + (conc (if (string? toppath) + toppath + (get-environment-variable "MT_RUN_AREA_HOME")) + "/runconfigs.config") + *runconfigdat* #t + sections: sections)))) + (set! *runconfigdat* first-rundat) + (if first-pass ;; + (begin + ;;(BB> "launch:setup-body -- \"first-pass\"=first-pass") + (set! *configdat* (car first-pass)) + ;;(BB> "launch:setup-body -- 2 set! *configdat*="*configdat*) + (set! *configinfo* first-pass) + (set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it + (set! toppath *toppath*) + (set! *db-keys* (common:get-fields *configdat*)) + (if (not *toppath*) + (begin + (debug:print-error 0 *default-log-port* "you are not in a megatest area!") + (exit 1))) + (setenv "MT_RUN_AREA_HOME" *toppath*) + ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it + (let* ((keys (common:list-or-null *db-keys* ;; (common:get-fields (rmt:get-keys) + message: "Failed to retrieve keys in launch.scm. Please report this to the developers.")) + (key-vals (keys:target->keyval keys target)) + (linktree (common:get-linktree)) ;; (or (getenv "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))) + ; (if *configdat* + ; (configf:lookup *configdat* "setup" "linktree") + ; (conc *toppath* "/lt")))) + (second-pass (find-and-read-config + mtconfig + environ-patt: "env-override" + given-toppath: toppath + pathenvvar: "MT_RUN_AREA_HOME")) + (runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config + (for-each (lambda (kt) + (setenv (car kt) (cadr kt))) + key-vals) + (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ... + sections: sections))) + (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) + (mtcachef (car cachefiles)) + (rccachef (cdr cachefiles))) + ;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "/p/fdk/gwa/lefkowit/mtTesting/qa/primbeqa/links/p1222/11/PDK_r1.1.1/prim/clean/pcell_testgen/.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 rccachef + (common:fail-safe + (lambda () + (configf:write-alist runconfigdat rccachef)) + (conc "Could not write cache file - "rccachef))) + (if mtcachef + (common:fail-safe + (lambda () + (configf:write-alist *configdat* mtcachef)) + (conc "Could not write cache file - "mtcachef))) + (set! *runconfigdat* runconfigdat) + (if (and rccachef mtcachef) (set! *configstatus* 'fulldata)))) + ;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table + (set! *configdat* (make-hash-table)) + ))) + + ;; else read what you can and set the flag accordingly + ;; here we don't have either mtconfig or rccachef + (else + ;;(BB> "launch:setup-body -- cond branch 3 - else") + (let* ((cfgdat (find-and-read-config + (or (args:get-arg "-config") "megatest.config") + environ-patt: "env-override" + given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") + pathenvvar: "MT_RUN_AREA_HOME"))) + + (if (and cfgdat (list? cfgdat) (> (length cfgdat) 0) (hash-table? (car cfgdat))) + (let* ((toppath (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat))) + (rdat (read-config (conc toppath ;; convert this to use runconfig:read! + "/runconfigs.config") *runconfigdat* #t sections: sections))) + (set! *configinfo* cfgdat) + (set! *configdat* (car cfgdat)) + (set! *db-keys* (common:get-fields *configdat*)) + (set! *runconfigdat* rdat) + (set! *toppath* toppath) + (set! *configstatus* 'partial)) + (begin + (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.") + (exit 2)))))) + ;; COND ends here. + + ;; additional house keeping + (let* ((linktree (or (common:get-linktree) + (conc *toppath* "/lt")))) + (if linktree + (begin + (if (not (common: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) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) + (exit 1)) + (create-directory linktree #t)))) + (handle-exceptions + 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) ", exn=" exn)) + (let ((tlink (conc *toppath* "/lt"))) + (if (not (common: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* + (directory-exists? *toppath*)) + (begin + (setenv "MT_RUN_AREA_HOME" *toppath*) + (setenv "MT_TESTSUITENAME" (common:get-testsuite-name))) + (begin + (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.") + (set! *toppath* #f) ;; force it to be false so we return #f + #f)) + + ;; one more attempt to cache the configs for future reading + (let* ((cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) + (mtcachef (car cachefiles)) + (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))) + (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))) + (common:fail-safe + (lambda () + (configf:write-alist *configdat* mtcachef)) + (conc "Could not write cache file - "mtcachef)) + ) + (if (and rccachef mtcachef *runconfigdat* *configdat*) + (set! *configstatus* 'fulldata))) + + ;; if have -append-config then read and append here + (let ((cfname (args:get-arg "-append-config"))) + (if (and cfname + (file-read-access? cfname)) + (read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special. + *toppath*))) + +;; return paths depending on what info is available. +;; +(define (launch:get-cache-file-paths areapath toppath target mtconfig) + (let* ((use-cache (common:use-cache?)) + (runname (common:args-get-runname)) + (linktree (common:get-linktree)) + (testname (common:get-full-test-name)) + (rundir (if (and runname target linktree) + (common:directory-writable? (conc linktree "/" target "/" runname)) + #f)) + (testdir (if (and rundir testname) + (common:directory-writable? (conc rundir "/" testname)) + #f)) + (cachedir (or testdir rundir)) + (mtcachef (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) + (rccachef (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))) + (debug:print-info 6 *default-log-port* + "runname=" runname + "\n linktree=" linktree + "\n testname=" testname + "\n rundir=" rundir + "\n testdir=" testdir + "\n cachedir=" cachedir + "\n mtcachef=" mtcachef + "\n rccachef=" rccachef) + (cons mtcachef rccachef))) + ;;======================================================================the end + ) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -26,51 +26,17 @@ (declare (unit configf)) (declare (uses process)) (declare (uses env)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses configfmod)) (import configfmod) (declare (uses margsmod)) (import margsmod) (include "common_records.scm") -;; if -(define (configf:read-alist fname) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "read of alist " fname " failed. exn=" exn) - #f) - (configf:alist->config - (with-input-from-file fname read)))) - -(define (configf:write-alist cdat fname) - (if (not (common:faux-lock fname)) - (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname)) - (let* ((dat (configf:config->alist cdat)) - (res - (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 (configf:read-alist fname) - #t ;; data is good. - (begin - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" 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)))) - (common:faux-unlock fname) - res)) - Index: configfmod.scm ================================================================== --- configfmod.scm +++ configfmod.scm @@ -18,16 +18,18 @@ ;;====================================================================== (declare (unit configfmod)) (declare (uses margsmod)) +(declare (uses debugprint)) (module configfmod * (import scheme chicken data-structures extras files ports) (import margsmod) +(import debugprint) (use (prefix base64 base64:) (prefix dbi dbi:) (prefix sqlite3 sqlite3:) @@ -83,11 +85,11 @@ ;; safely look up a value that is expected to be a number, return ;; a default (#f unless provided) ;; (define (configf:lookup-number cfdat section varname #!key (default #f)) - (let* ((val (configf:lookup *configdat* section varname)) + (let* ((val (configf:lookup cfdat section varname)) (res (if val (string->number (string-substitute "\\s+" "" val #t)) #f))) (cond (res res) @@ -112,18 +114,18 @@ ;; 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))))))))) @@ -341,11 +343,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) @@ -426,11 +428,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 @@ -553,28 +555,10 @@ (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 ))) -;; 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)))) - ;;====================================================================== ;; lookup and manipulation routines ;;====================================================================== ;; (define (configf:assoc-safe-add alist key val #!key (metadata #f)) @@ -652,10 +636,89 @@ (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)) + +(define getenv get-environment-variable) +(define (safe-setenv key val) + (if (or (substring-index "!" key) + (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables. + (substring-index "." key)) ;; periods are not allowed in environment variables + (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"") + (if (and (string? val) + (string? key)) + (handle-exceptions + exn + (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val ", exn=" exn) + (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 (common: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))) + +;; return a nice clean pathname made absolute +(define (common:nice-path dir) + (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) + (if match ;; using ~ for home? + (common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match))) + (normalize-pathname (if (absolute-pathname? dir) + dir + (conc (current-directory) "/" dir)))))) + +;; make "nice-path" available in config files and the repl +(define nice-path common:nice-path) + +(define (common:read-link-f path) + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed. exn=" exn) + path) ;; just give up + (with-input-from-pipe + (conc "/bin/readlink -f " path) + (lambda () + (read-line))))) + ;;====================================================================== ;; Non destructive writing of config file ;;====================================================================== @@ -698,11 +761,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 @@ -793,20 +856,38 @@ (lambda () (for-each (lambda (line) (print line)) (configf:expand-multi-lines fdat)))))) + +(define (process:cmd-run->list cmd #!key (delta-env-alist-or-hash-table '())) + (common: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)))) ;;====================================================================== ;; refdb ;;====================================================================== ;; reads a refdb into an assoc array of assoc arrays ;; returns (list dat msg) (define (configf:read-refdb refdb-path) (let ((sheets-file (conc refdb-path "/sheet-names.cfg"))) - (if (not (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 () @@ -882,23 +963,60 @@ (if fname (print "# " var "=>" fname)) (print var " " val))) section-dat))) ;; (print "section-dat: " section-dat)) (hash-table->alist data))) -(define (tests:get-tests-search-path cfgdat) - (let ((paths (let ((section (if cfgdat - (configf:get-section cfgdat "tests-paths") - #f))) - (if section - (map cadr section) - '())))) - (filter (lambda (d) - (if (directory-exists? d) - d - (begin - ;; (if (common:low-noise-print 60 "tests:get-tests-search-path" d) - ;; (debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path")) - #f))) - (append paths (list (conc *toppath* "/tests")))))) - + +(define (configf: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)) + +;; if +(define (configf:read-alist fname) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "read of alist " fname " failed. exn=" exn) + #f) + (configf:alist->config + (with-input-from-file fname read)))) + +;;====================================================================== +;; DO THE LOCKING AROUND THE CALL +;;====================================================================== +;; +(define (configf:write-alist cdat fname) + #;(if (not (common:faux-lock fname)) + (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname)) + (let* ((dat (configf: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 (configf:read-alist fname) + #t ;; data is good. + (begin + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" 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)))) + ;; (common:faux-unlock fname) + res)) + ) Index: dashboard-context-menu.scm ================================================================== --- dashboard-context-menu.scm +++ dashboard-context-menu.scm @@ -41,11 +41,13 @@ ;; (declare (uses sdb)) ;; (declare (uses filedb)) (declare (uses subrun)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses configfmod)) (import configfmod) (declare (uses dbmod)) Index: dashboard-guimonitor.scm ================================================================== --- dashboard-guimonitor.scm +++ dashboard-guimonitor.scm @@ -36,11 +36,13 @@ (declare (uses db)) (declare (uses tasks)) (import tasks) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses dbmod)) (import dbmod) (include "common_records.scm") Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -40,11 +40,13 @@ ;; (declare (uses sdb)) ;; (declare (uses filedb)) (declare (uses subrun)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses configfmod)) (import configfmod) (declare (uses dbmod)) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -50,11 +50,13 @@ (declare (uses subrun)) ;; (declare (uses dashboard-main)) (declare (uses mt)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses commonmod.import)) (declare (uses configfmod)) (import configfmod) (declare (uses configfmod.import)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -36,11 +36,13 @@ ;; (declare (uses mt)) ;; (declare (uses margsmod)) ;; (import margsmod) ;; ;; (declare (uses commonmod)) +(declare (uses debugprint)) ;; (import commonmod) +(import debugprint) ;; ;; (declare (uses configfmod)) ;; (import configfmod) ;; ;; (declare (uses dbmod)) Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -18,18 +18,20 @@ ;;====================================================================== (declare (unit dbmod)) (declare (uses commonmod)) +(declare (uses debugprint)) (declare (uses ods)) (declare (uses configfmod)) (declare (uses margsmod)) (module dbmod * (import commonmod) +(import debugprint) (import ods) (import configfmod) (import margsmod) (import scheme chicken data-structures extras ports) @@ -5232,10 +5234,22 @@ (exit 1))) ;;(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] Syncer started (method="syncer")") ))) (debug:print-info 13 *default-log-port* "watchdog done.")) (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost")))) + +;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage +(define *watchdog* (make-thread + (lambda () + (handle-exceptions + exn + (begin + (print-call-chain) + (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) + (common:watchdog))) + "Watchdog thread")) + ;;====================================================================== ;; Move me elsewhere ... ;; RADT => Why do we meed the version check here, this is called only if version misma ;; @@ -5250,56 +5264,57 @@ 'new2old ;; (if full '(dejunk) ;; '()) ) - (if (common:api-changed?) - (common:set-last-run-version))) + (if (db:api-changed? dbstruct) + (db:set-last-run-version dbstruct))) ;;====================================================================== ;; Force a megatest cleanup-db if version is changed and skip-version-check not specified ;; Do NOT check if not on homehost! ;; (define (common:exit-on-version-changed) (if (common:on-homehost?) - (if (common:api-changed?) - (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")) - (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db")) - (read-only (not (file-write-access? dbfile))) - (dbstruct (db:setup #t))) - (debug:print 0 *default-log-port* - "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) - (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 - (debug:print 0 *default-log-port* "Failed to switch versions. exn=" exn) - (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)) - (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)) - (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)) - (read-only - (debug:print 0 *default-log-port* " You have read-only access to this area. Cannot proceed with megatest version migration.") - (exit 1)) - (else - (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"") - (exit 1))))))) + (let ((dbstruct (db:setup #t))) + (if (db:api-changed? dbstruct) + (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")) + (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db")) + (read-only (not (file-write-access? dbfile)))) + (debug:print 0 *default-log-port* + "WARNING: Version mismatch!\n" + " expected: " (common:version-signature) "\n" + " got: " (db:get-var dbstruct "MEGATEST_VERSION")) ;; (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) + (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 + (debug:print 0 *default-log-port* "Failed to switch versions. exn=" exn) + (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)) + (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)) + (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)) + (read-only + (debug:print 0 *default-log-port* " You have read-only access to this area. Cannot proceed with megatest version migration.") + (exit 1)) + (else + (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"") + (exit 1)))))))) + ;;====================================================================== ;; (begin ;; (debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.") ;; (exit 1)))) @@ -5420,20 +5435,31 @@ "disks" '("none" ""))) ;;====================================================================== ;; postive number if megatest version > db version ;; negative number if megatest version < db version -(define (common:version-db-delta) - (- megatest-version (common:get-last-run-version-number))) + +(define (db:get-last-run-version dbstruct) + (db:get-var dbstruct "MEGATEST_VERSION")) + +(define (db:set-last-run-version dbstruct) + (db:set-var dbstruct "MEGATEST_VERSION" (common:version-signature))) + +(define (db:get-last-run-version-number dbstruct) + (string->number + (substring (db:get-last-run-version dbstruct) 0 6))) + +(define (db:version-db-delta dbstruct) + (- megatest-version (db:get-last-run-version-number dbstruct))) -(define (common:version-changed?) - (not (equal? (common:get-last-run-version) +(define (db:version-changed? dbstruct) + (not (equal? (db:get-last-run-version dbstruct) (common:version-signature)))) -(define (common:api-changed?) +(define (db:api-changed? dbstruct) (not (equal? (substring (->string megatest-version) 0 4) - (substring (conc (common:get-last-run-version)) 0 4)))) + (substring (conc (db:get-last-run-version dbstruct)) 0 4)))) (define (server:writable-watchdog-bruteforce dbstruct) (thread-sleep! 1) ;; delay for startup (let* ((do-a-sync (server:get-bruteforce-syncer dbstruct)) (final-sync (server:get-bruteforce-syncer dbstruct fork-to-background: #t persist-until-sync: #t))) @@ -5581,7 +5607,108 @@ ;; time to exit, close the no-sync db here (db:no-sync-close-db no-sync-db stmt-cache) (if (common:low-noise-print 30) (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))))) ;;" this-wd-num="this-wd-num))))))) +;; moving this here as it needs access to db and cannot be in common. +;; + +(define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f)) + (let* ((sqlite-exe (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh + (sync-log (or ;; (args:get-arg "-sync-log") + (conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log"))) + (tmp-area (common:get-db-tmp-area)) + (tmp-db (conc tmp-area "/megatest.db")) + (staging-file (conc *toppath* "/.megatest.db")) + (mtdbfile (conc *toppath* "/megatest.db")) + (lockfile (common:get-sync-lock-filepath)) + (sync-cmd-core (conc sqlite-exe" " tmp-db " .dump | "sqlite-exe" " staging-file "&>"sync-log)) + (sync-cmd (if fork-to-background + (conc "/usr/bin/env NBFAKE_LOG="*toppath*"/logs/last-server-sync-"(current-process-id)".log nbfake \""sync-cmd-core" && /bin/mv -f " staging-file " " mtdbfile" \"") + sync-cmd-core)) + (default-min-intersync-delay 2) + (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: default-min-intersync-delay)) + (default-duty-cycle 0.1) + (duty-cycle (configf:lookup-number *configdat* "server" "sync-duty-cycle" default: default-duty-cycle)) + (last-sync-seconds 10) ;; we will adjust this to a measurement and delay last-sync-seconds * (1 - duty-cycle) + (calculate-off-time (lambda (work-duration duty-cycle) + (* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds))) + (off-time min-intersync-delay) ;; adjusted in closure below. + (do-a-sync + (lambda () + ;; (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync) + (let* ((finalres + (let retry-loop ((num-tries 0)) + (if (common:simple-file-lock lockfile) + (begin + (cond + ((not (or fork-to-background persist-until-sync)) + (debug:print 0 *default-log-port* "INFO: syncer thread sleeping for max of (server.minimum-intersync-delay="min-intersync-delay + " , off-time="off-time" seconds ]") + (thread-sleep! (max off-time min-intersync-delay))) + (else + (debug:print 0 *default-log-port* "INFO: syncer thread NOT sleeping ; maybe time-to-exit..."))) + + (if (not (configf:lookup *configdat* "server" "disable-db-snapshot")) + (common:snapshot-file mtdbfile subdir: ".db-snapshot")) + (delete-file* staging-file) + (let* ((start-time (current-milliseconds)) + (res (system sync-cmd)) + (dbbackupfile (conc mtdbfile ".backup")) + (res2 + (cond + ((eq? 0 res ) + (handle-exceptions + exn + #f + (if (file-exists? dbbackupfile) + (delete-file* dbbackupfile) + ) + (if (eq? 0 (file-size sync-log)) + (delete-file* sync-log)) + (system (conc "/bin/mv " staging-file " " mtdbfile)) + + (set! last-sync-seconds (/ (- (current-milliseconds) start-time) 1000)) + (set! off-time (calculate-off-time + last-sync-seconds + (cond + ((and (number? duty-cycle) (> duty-cycle 0) (< duty-cycle 1)) + duty-cycle) + (else + (debug:print 0 *default-log-port* "WARNING: ["(common:human-time)"] server.sync-duty-cycle is invalid. Should be a number between 0 and 1, but "duty-cycle" was specified. Using default value: "default-duty-cycle) + default-duty-cycle)))) + + (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec") + (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec ; with duty-cycle of "duty-cycle" off time is now "off-time) + 'sync-completed)) + (else + (system (conc "/bin/cp "sync-log" "sync-log".fail")) + (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail") + (if (file-exists? (conc mtdbfile ".backup")) + (system (conc "/bin/cp "mtdbfile ".backup " mtdbfile))) + #f)))) + (common:simple-file-release-lock lockfile) + ;; (BB> "released lockfile: " lockfile) + #;(when (common:file-exists? lockfile) + (BB> "DID NOT ACTUALLY RELEASE LOCKFILE")) + res2) ;; end let + );; end begin + ;; else + (cond + (persist-until-sync + (thread-sleep! 1) + (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; we're in a fork-to-background so we need to succeed. Let's wait a jiffy and and try again. num-tries="num-tries" (waiting for lockfile="lockfile" to disappear)") + (retry-loop (add1 num-tries))) + (else + (thread-sleep! (max off-time (+ last-sync-seconds min-intersync-delay))) + (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.") + 'parallel-sync-in-progress)) + ) ;; end if got lockfile + ) + )) + ;; (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres) + finalres) + ) ;; end lambda + )) + do-a-sync)) ) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -29,11 +29,13 @@ (declare (uses gutils)) (declare (uses db)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses dbmod)) (import dbmod) (declare (uses configfmod)) Index: dcommonmod.scm ================================================================== --- dcommonmod.scm +++ dcommonmod.scm @@ -18,10 +18,11 @@ ;;====================================================================== (declare (unit dcommonmod)) (declare (uses commonmod)) +(declare (uses debugprint)) (declare (uses configfmod)) (module dcommonmod * @@ -41,10 +42,11 @@ srfi-13 ) (import canvas-draw-iup) (import commonmod) +(import debugprint) (import configfmod) (include "common_records.scm") ;;====================================================================== Index: debugprint.scm ================================================================== --- debugprint.scm +++ debugprint.scm @@ -7,11 +7,11 @@ ;;(import scheme chicken data-structures extras files ports) (import scheme chicken) (import margsmod) (use data-structures extras files ports) -;; (use +(use ;; (prefix base64 base64:) ;; (prefix sqlite3 sqlite3:) ;; (srfi 18) ;; (prefix dbi dbi:) ;; directory-utils @@ -22,24 +22,25 @@ ;; pkts ;; posix ;; regex ;; regex-case ;; sparse-vectors -;; srfi-1 + srfi-1 ;; srfi-13 ;; srfi-69 ;; stack ;; stml2 ;; typed-records ;; z3 -;; ) + ) ;;====================================================================== ;; debug stuff ;;====================================================================== (define verbosity (make-parameter '())) +(define *default-log-port* (current-error-port)) ;;====================================================================== ;; (define (debug:print . params) #f) ;; (define (debug:print-info . params) #f) ;; Index: diff-report.scm ================================================================== --- diff-report.scm +++ diff-report.scm @@ -19,11 +19,13 @@ (declare (unit diff-report)) (declare (uses common)) (declare (uses rmt)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (include "common_records.scm") (use matchable) (use fmt) (use ducttape-lib) Index: env.scm ================================================================== --- env.scm +++ env.scm @@ -22,11 +22,13 @@ (declare (uses margsmod)) (import margsmod) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (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)) Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -33,11 +33,13 @@ ;; (declare (uses sdb)) ;; (declare (uses filedb)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses configfmod)) (import configfmod) (declare (uses dbmod)) Index: genexample.scm ================================================================== --- genexample.scm +++ genexample.scm @@ -20,11 +20,13 @@ (declare (unit genexample)) (use posix regex matchable) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses margsmod)) (import margsmod) (include "db_records.scm") Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -48,11 +48,13 @@ (import portlogger) (declare (uses rmt)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses configfmod)) (import configfmod) (declare (uses dbmod)) Index: index-tree.scm ================================================================== --- index-tree.scm +++ index-tree.scm @@ -31,11 +31,13 @@ (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -23,11 +23,13 @@ (declare (unit items)) (declare (uses common)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses configfmod)) (import configfmod) (include "common_records.scm") Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -34,11 +34,13 @@ (declare (uses configf)) (declare (uses db)) (declare (uses ezsteps)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses configfmod)) (import configfmod) (declare (uses dbmod)) @@ -849,271 +851,10 @@ (configf:write-alist *configdat* tmpfile)) (system (conc "ln -sf " tmpfile " " targfile)))) ))) (debug:print-info 1 *default-log-port* "No linktree yet, no caching configs."))))) - -;; gather available information, if legit read configs in this order: -;; -;; if have cache; -;; read it a return it -;; else -;; megatest.config (do not cache) -;; runconfigs.config (cache if all vars avail) -;; megatest.config (cache if all vars avail) -;; returns: -;; *toppath* -;; side effects: -;; sets; *configdat* (megatest.config info) -;; *runconfigdat* (runconfigs.config info) -;; *configstatus* (status of the read data) -;; -(define (launch:setup #!key (force-reread #f) (areapath #f)) - (mutex-lock! *launch-setup-mutex*) - (if (and *toppath* - (eq? *configstatus* 'fulldata) (not force-reread)) ;; got it all - (begin - (debug:print 2 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata") - (mutex-unlock! *launch-setup-mutex*) - *toppath*) - (let ((res (launch:setup-body force-reread: force-reread areapath: areapath))) - (mutex-unlock! *launch-setup-mutex*) - res))) - -;; return paths depending on what info is available. -;; -(define (launch:get-cache-file-paths areapath toppath target mtconfig) - (let* ((use-cache (common:use-cache?)) - (runname (common:args-get-runname)) - (linktree (common:get-linktree)) - (testname (common:get-full-test-name)) - (rundir (if (and runname target linktree) - (common:directory-writable? (conc linktree "/" target "/" runname)) - #f)) - (testdir (if (and rundir testname) - (common:directory-writable? (conc rundir "/" testname)) - #f)) - (cachedir (or testdir rundir)) - (mtcachef (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) - (rccachef (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))) - (debug:print-info 6 *default-log-port* - "runname=" runname - "\n linktree=" linktree - "\n testname=" testname - "\n rundir=" rundir - "\n testdir=" testdir - "\n cachedir=" cachedir - "\n mtcachef=" mtcachef - "\n rccachef=" rccachef) - (cons mtcachef rccachef))) - -(define (launch:setup-body #!key (force-reread #f) (areapath #f)) - (if (and (eq? *configstatus* 'fulldata) - *toppath* - (not force-reread)) ;; no need to reprocess - *toppath* ;; return toppath - (let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks *configdat* for use-cache setting. We do not have *configdat*. Bootstrapping problem here. - (toppath (common:get-toppath areapath)) - (target (common:args-get-target)) - (sections (if target (list "default" target) #f)) ;; for runconfigs - (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config - (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) - ;; checking for null cachefiles should not be necessary, I was seeing error car of '(), might be a chicken bug or a red herring ... - (mtcachef (if (null? cachefiles) - #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?))))) - (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)) - ;;(BB> "launch:setup-body -- cond branch 1 - use-cache") - (set! *configdat* (configf:read-alist mtcachef)) - (set! *db-keys* (common:get-fields *configdat*)) - ;;(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"))) - (set! *configstatus* 'fulldata) - (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) - *toppath*) - ;; there are no existing cached configs, do full reads of the configs and cache them - ;; we have all the info needed to fully process runconfigs and megatest.config - ((and ;; (not force-reread) ;; force-reread is irrelevant in the AND, could however OR it? - mtcachef - rccachef) ;; BB- why are we doing this without asking if caching is desired? - ;;(BB> "launch:setup-body -- cond branch 2") - (let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect - mtconfig - environ-patt: "env-override" - given-toppath: toppath - pathenvvar: "MT_RUN_AREA_HOME")) - (first-rundat (let ((toppath (if toppath - toppath - (car first-pass)))) - (read-config ;; (conc toppath "/runconfigs.config") ;; this should be converted to runconfig:read but it is non-trivial, leaving it for now. - (conc (if (string? toppath) - toppath - (get-environment-variable "MT_RUN_AREA_HOME")) - "/runconfigs.config") - *runconfigdat* #t - sections: sections)))) - (set! *runconfigdat* first-rundat) - (if first-pass ;; - (begin - ;;(BB> "launch:setup-body -- \"first-pass\"=first-pass") - (set! *configdat* (car first-pass)) - ;;(BB> "launch:setup-body -- 2 set! *configdat*="*configdat*) - (set! *configinfo* first-pass) - (set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it - (set! toppath *toppath*) - (set! *db-keys* (common:get-fields *configdat*)) - (if (not *toppath*) - (begin - (debug:print-error 0 *default-log-port* "you are not in a megatest area!") - (exit 1))) - (setenv "MT_RUN_AREA_HOME" *toppath*) - ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it - (let* ((keys (common:list-or-null (rmt:get-keys) - message: "Failed to retrieve keys in launch.scm. Please report this to the developers.")) - (key-vals (keys:target->keyval keys target)) - (linktree (common:get-linktree)) ;; (or (getenv "MT_LINKTREE")(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))) - ; (if *configdat* - ; (configf:lookup *configdat* "setup" "linktree") - ; (conc *toppath* "/lt")))) - (second-pass (find-and-read-config - mtconfig - environ-patt: "env-override" - given-toppath: toppath - pathenvvar: "MT_RUN_AREA_HOME")) - (runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config - (for-each (lambda (kt) - (setenv (car kt) (cadr kt))) - key-vals) - (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ... - sections: sections))) - (cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) - (mtcachef (car cachefiles)) - (rccachef (cdr cachefiles))) - ;; trap exception due to stale NFS handle -- Error: (open-output-file) cannot open file - Stale NFS file handle: "/p/fdk/gwa/lefkowit/mtTesting/qa/primbeqa/links/p1222/11/PDK_r1.1.1/prim/clean/pcell_testgen/.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 rccachef - (common:fail-safe - (lambda () - (configf:write-alist runconfigdat rccachef)) - (conc "Could not write cache file - "rccachef))) - (if mtcachef - (common:fail-safe - (lambda () - (configf:write-alist *configdat* mtcachef)) - (conc "Could not write cache file - "mtcachef))) - (set! *runconfigdat* runconfigdat) - (if (and rccachef mtcachef) (set! *configstatus* 'fulldata)))) - ;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table - (set! *configdat* (make-hash-table)) - ))) - - ;; else read what you can and set the flag accordingly - ;; here we don't have either mtconfig or rccachef - (else - ;;(BB> "launch:setup-body -- cond branch 3 - else") - (let* ((cfgdat (find-and-read-config - (or (args:get-arg "-config") "megatest.config") - environ-patt: "env-override" - given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") - pathenvvar: "MT_RUN_AREA_HOME"))) - - (if (and cfgdat (list? cfgdat) (> (length cfgdat) 0) (hash-table? (car cfgdat))) - (let* ((toppath (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat))) - (rdat (read-config (conc toppath ;; convert this to use runconfig:read! - "/runconfigs.config") *runconfigdat* #t sections: sections))) - (set! *configinfo* cfgdat) - (set! *configdat* (car cfgdat)) - (set! *db-keys* (common:get-fields *configdat*)) - (set! *runconfigdat* rdat) - (set! *toppath* toppath) - (set! *configstatus* 'partial)) - (begin - (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.") - (exit 2)))))) - ;; COND ends here. - - ;; additional house keeping - (let* ((linktree (or (common:get-linktree) - (conc *toppath* "/lt")))) - (if linktree - (begin - (if (not (common: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) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) - (exit 1)) - (create-directory linktree #t)))) - (handle-exceptions - 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) ", exn=" exn)) - (let ((tlink (conc *toppath* "/lt"))) - (if (not (common: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* - (directory-exists? *toppath*)) - (begin - (setenv "MT_RUN_AREA_HOME" *toppath*) - (setenv "MT_TESTSUITENAME" (common:get-testsuite-name))) - (begin - (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.") - (set! *toppath* #f) ;; force it to be false so we return #f - #f)) - - ;; one more attempt to cache the configs for future reading - (let* ((cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig)) - (mtcachef (car cachefiles)) - (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))) - (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))) - (common:fail-safe - (lambda () - (configf:write-alist *configdat* mtcachef)) - (conc "Could not write cache file - "mtcachef)) - ) - (if (and rccachef mtcachef *runconfigdat* *configdat*) - (set! *configstatus* 'fulldata))) - - ;; if have -append-config then read and append here - (let ((cfname (args:get-arg "-append-config"))) - (if (and cfname - (file-read-access? cfname)) - (read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special. - *toppath*))) - (define (get-best-disk confdat testconfig) (let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f)) (hash-table-ref/default confdat "disks" #f))) (minspace (let ((m (configf:lookup confdat "setup" "minspace"))) Index: lock-queue.scm ================================================================== --- lock-queue.scm +++ lock-queue.scm @@ -22,11 +22,13 @@ (declare (uses common)) (declare (uses tasks)) (import tasks) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) ;;====================================================================== ;; attempt to prevent overlapping updates of rollup files by queueing ;; update requests in an sqlite db ;;====================================================================== Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -28,11 +28,11 @@ (import margsmod) (declare (uses runs)) (declare (uses launch)) (declare (uses server)) -(declare (uses client)) + (declare (uses tests)) (declare (uses genexample)) (declare (uses db)) (declare (uses tdb)) @@ -46,12 +46,18 @@ (declare (uses diff-report)) ;; Needed for repl even if not used here in megatest.scm ;; ORDER MATTERS! +(declare (uses client)) +(import client) +(declare (uses client.import)) + (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses commonmod.import)) (declare (uses configfmod)) (import configfmod) (declare (uses configfmod.import)) @@ -524,21 +530,11 @@ (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ (setenv "MT_TARGET" targ))) ;; The watchdog is to keep an eye on things like db sync etc. ;; - -;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage -(define *watchdog* (make-thread - (lambda () - (handle-exceptions - exn - (begin - (print-call-chain) - (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) - (common:watchdog))) - "Watchdog thread")) +;; moved to commonmod ;;(if (not (args:get-arg "-server")) ;; (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog (let* ((no-watchdog-args '("-list-runs" Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -30,11 +30,13 @@ ;; (declare (uses runs)) (declare (uses rmt)) ;; (declare (uses filedb)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses configfmod)) (import configfmod) (declare (uses dbmod)) Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -34,11 +34,13 @@ (declare (uses configf)) ;; (declare (uses rmt)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses configfmod)) (import configfmod) (use ducttape-lib) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -32,11 +32,13 @@ (declare (uses megatest-version)) (declare (uses margsmod)) (import margsmod) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses dbmod)) (import dbmod) ;; (declare (uses launch)) Index: ods.scm ================================================================== --- ods.scm +++ ods.scm @@ -17,16 +17,18 @@ ;; (use csv-xml regex) (declare (unit ods)) (declare (uses commonmod)) +(declare (uses debugprint)) (module ods * (import scheme chicken data-structures extras files ports) (import commonmod) +(import debugprint) (import regex srfi-13 posix ) Index: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -20,10 +20,11 @@ (declare (unit portlogger)) ;; (declare (uses db)) (declare (uses commonmod)) +(declare (uses debugprint)) (declare (uses configfmod)) (declare (uses dbmod)) (module portlogger * @@ -32,10 +33,11 @@ (import (srfi 18) extras tcp s11n) (use (prefix sqlite3 sqlite3:) srfi-1 posix srfi-69 hostinfo dot-locking z3) (import commonmod) +(import debugprint) (import configfmod) (import dbmod) ;; lsof -i Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -24,7 +24,9 @@ (use regex directory-utils) (declare (unit process)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -18,25 +18,48 @@ ;;====================================================================== (declare (unit rmtmod)) (declare (uses commonmod)) +(declare (uses debugprint)) (declare (uses apimod)) (declare (uses dbmod)) -;; (declare (uses transport)) -;; (declare (uses servermod)) +(declare (uses configfmod)) +(declare (uses margsmod)) +(declare (uses portlogger)) (module rmtmod * -(import scheme chicken data-structures extras) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18) -(import commonmod) -(import dbmod) +(import scheme chicken data-structures extras ports) +(import (prefix sqlite3 sqlite3:) + directory-utils + intarweb + matchable + md5 + message-digest + uri-common + spiffy + spiffy-directory-listing + spiffy-request-vars + http-client + posix + posix-extras + regex + typed-records + srfi-1 + srfi-13 + srfi-18 + srfi-69 + tcp) (import apimod) -;; (import transport) -;; (import servermod) +(import commonmod) +(import debugprint) +(import dbmod) +(import configfmod) +(import margsmod) +(import portlogger) (defstruct alldat (areapath #f) (ulexdat #f) ) @@ -1460,23 +1483,10 @@ (if (and (string? tmo) (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below (* 3600 (string->number tmo)) 60))) -(define (server:get-best-guess-address hostname) - (let ((res #f)) - (for-each - (lambda (adr) - (if (not (eq? (u8vector-ref adr 0) 127)) - (set! res adr))) - ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME - (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) - (string-intersperse - (map number->string - (u8vector->list - (if res res (hostname->ip hostname)))) "."))) - ;; (define server:sync-lock-token "SERVER_SYNC_LOCK") ;; (define (server:release-sync-lock) ;; (db:no-sync-del! *no-sync-db* server:sync-lock-token)) ;; (define (server:have-sync-lock?) ;; (let* ((have-lock-pair (db:no-sync-get-lock *no-sync-db* server:sync-lock-token)) @@ -1489,111 +1499,10 @@ ;; (* 3 (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 180))) ;; (server:release-sync-lock) ;; (server:have-sync-lock?)) ;; (else #f)))) -;; moving this here as it needs access to db and cannot be in common. -;; - -(define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f)) - (let* ((sqlite-exe (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh - (sync-log (or ;; (args:get-arg "-sync-log") - (conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log"))) - (tmp-area (common:get-db-tmp-area)) - (tmp-db (conc tmp-area "/megatest.db")) - (staging-file (conc *toppath* "/.megatest.db")) - (mtdbfile (conc *toppath* "/megatest.db")) - (lockfile (common:get-sync-lock-filepath)) - (sync-cmd-core (conc sqlite-exe" " tmp-db " .dump | "sqlite-exe" " staging-file "&>"sync-log)) - (sync-cmd (if fork-to-background - (conc "/usr/bin/env NBFAKE_LOG="*toppath*"/logs/last-server-sync-"(current-process-id)".log nbfake \""sync-cmd-core" && /bin/mv -f " staging-file " " mtdbfile" \"") - sync-cmd-core)) - (default-min-intersync-delay 2) - (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: default-min-intersync-delay)) - (default-duty-cycle 0.1) - (duty-cycle (configf:lookup-number *configdat* "server" "sync-duty-cycle" default: default-duty-cycle)) - (last-sync-seconds 10) ;; we will adjust this to a measurement and delay last-sync-seconds * (1 - duty-cycle) - (calculate-off-time (lambda (work-duration duty-cycle) - (* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds))) - (off-time min-intersync-delay) ;; adjusted in closure below. - (do-a-sync - (lambda () - ;; (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync) - (let* ((finalres - (let retry-loop ((num-tries 0)) - (if (common:simple-file-lock lockfile) - (begin - (cond - ((not (or fork-to-background persist-until-sync)) - (debug:print 0 *default-log-port* "INFO: syncer thread sleeping for max of (server.minimum-intersync-delay="min-intersync-delay - " , off-time="off-time" seconds ]") - (thread-sleep! (max off-time min-intersync-delay))) - (else - (debug:print 0 *default-log-port* "INFO: syncer thread NOT sleeping ; maybe time-to-exit..."))) - - (if (not (configf:lookup *configdat* "server" "disable-db-snapshot")) - (common:snapshot-file mtdbfile subdir: ".db-snapshot")) - (delete-file* staging-file) - (let* ((start-time (current-milliseconds)) - (res (system sync-cmd)) - (dbbackupfile (conc mtdbfile ".backup")) - (res2 - (cond - ((eq? 0 res ) - (handle-exceptions - exn - #f - (if (file-exists? dbbackupfile) - (delete-file* dbbackupfile) - ) - (if (eq? 0 (file-size sync-log)) - (delete-file* sync-log)) - (system (conc "/bin/mv " staging-file " " mtdbfile)) - - (set! last-sync-seconds (/ (- (current-milliseconds) start-time) 1000)) - (set! off-time (calculate-off-time - last-sync-seconds - (cond - ((and (number? duty-cycle) (> duty-cycle 0) (< duty-cycle 1)) - duty-cycle) - (else - (debug:print 0 *default-log-port* "WARNING: ["(common:human-time)"] server.sync-duty-cycle is invalid. Should be a number between 0 and 1, but "duty-cycle" was specified. Using default value: "default-duty-cycle) - default-duty-cycle)))) - - (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec") - (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec ; with duty-cycle of "duty-cycle" off time is now "off-time) - 'sync-completed)) - (else - (system (conc "/bin/cp "sync-log" "sync-log".fail")) - (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail") - (if (file-exists? (conc mtdbfile ".backup")) - (system (conc "/bin/cp "mtdbfile ".backup " mtdbfile))) - #f)))) - (common:simple-file-release-lock lockfile) - ;; (BB> "released lockfile: " lockfile) - #;(when (common:file-exists? lockfile) - (BB> "DID NOT ACTUALLY RELEASE LOCKFILE")) - res2) ;; end let - );; end begin - ;; else - (cond - (persist-until-sync - (thread-sleep! 1) - (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; we're in a fork-to-background so we need to succeed. Let's wait a jiffy and and try again. num-tries="num-tries" (waiting for lockfile="lockfile" to disappear)") - (retry-loop (add1 num-tries))) - (else - (thread-sleep! (max off-time (+ last-sync-seconds min-intersync-delay))) - (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.") - 'parallel-sync-in-progress)) - ) ;; end if got lockfile - ) - )) - ;; (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres) - finalres) - ) ;; end lambda - )) - do-a-sync)) ;; (define (debug:print . params) #f) ;; (define (debug:print-info . params) #f) ;; ;; (define (set-functions dbgp dbgpinfo) @@ -2387,10 +2296,21 @@ (define (common:get-last-run-version-number) (string->number (substring (common:get-last-run-version) 0 6))) +(define (common:version-db-delta) + (- megatest-version (common:get-last-run-version-number))) + +(define (common:version-changed?) + (not (equal? (common:get-last-run-version) + (common:version-signature)))) + +(define (common:api-changed? dbstruct) + (not (equal? (substring (->string megatest-version) 0 4) + (substring (conc (common:get-last-run-version)) 0 4)))) + ;;====================================================================== ;; see defstruct host at top of file. ;; host: reachable last-update last-used last-cpuload ;; (define (common:update-host-loads-table hosts-raw) @@ -2552,8 +2472,104 @@ (if (null? tal) fallback-launcher (loop (car tal)(cdr tal)))))))) fallback-launcher))) +;;====================================================================== +;; everything from client moved here +;;====================================================================== +;; client:get-signature +(define (client:get-signature) + (if *my-client-signature* *my-client-signature* + (let ((sig (conc (get-host-name) " " (current-process-id)))) + (set! *my-client-signature* sig) + *my-client-signature*))) + +;; Not currently used! But, I think it *should* be used!!! +#;(define (client:logout serverdat) + (let ((ok (and (socket? serverdat) + (cdb:logout serverdat *toppath* (client:get-signature))))) + ok)) + +#;(define (client:connect iface port) + (http-transport:client-connect iface port) + #;(case (server:get-transport) + ((rpc) (rpc:client-connect iface port)) + ((http) (http:client-connect iface port)) + ((zmq) (zmq:client-connect iface port)) + (else (rpc:client-connect iface port)))) + +(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0)) + (client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects) + #;(case (server:get-transport) + ((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id)) + ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects)) + (else (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id)))) + +;; Do all the connection work, look up the transport type and set up the +;; connection if required. +;; +;; There are two scenarios. +;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline +;; 2. We are a run tests, list runs or other interactive process and we must figure out +;; *transport-type* and *runremote* from the monitor.db +;; +;; client:setup +;; +;; lookup_server, need to remove *runremote* stuff +;; + +(define (client:setup-http areapath #!key (remaining-tries 100) (failed-connects 0)(area-dat #f)) + (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries) + (server:start-and-wait areapath) + (if (<= remaining-tries 0) + (begin + (debug:print-error 0 *default-log-port* "failed to start or connect to server") + (exit 1)) + ;; + ;; Alternatively here, we can get the list of candidate servers and work our way + ;; through them searching for a good one. + ;; + (let* ((server-dat (server:get-rand-best areapath)) ;; (server:get-first-best areapath)) + (runremote (or area-dat *runremote*))) + (if (not server-dat) ;; no server found + (client:setup-http areapath remaining-tries: (- remaining-tries 1)) + (let ((host (cadr server-dat)) + (port (caddr server-dat)) + (server-id (caddr (cddr server-dat)))) + (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) + (if (and (not area-dat) + (not *runremote*)) + (begin + ;; POSSIBLE BUG. I removed the full initialization call. mrw + (set! *runremote* (create-remote-record)) + (let* ((server-info (remote-server-info *runremote*))) + (if server-info + (begin + (remote-server-url-set! *runremote* (server:record->url server-info)) + (remote-server-id-set! *runremote* (server:record->id server-info))))))) + (if (and host port server-id) + (let* ((start-res (http-transport:client-connect host port server-id)) + (ping-res (rmt:login-no-auto-client-setup start-res))) + (if (and start-res + ping-res) + (let ((runremote (or area-dat *runremote*))) ;; it might have been generated only a few statements ago + (remote-conndat-set! runremote start-res) ;; (hash-table-set! runremote run-id start-res) + (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) + start-res) + (begin ;; login failed but have a server record, clean out the record and try again + (debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... start-res=" start-res ", server-dat=" server-dat) ;; had runid. Fixes part of Randy;s ticket 1405717332 + (case *transport-type* + ((http)(http-transport:close-connections))) + (remote-conndat-set! runremote #f) ;; (hash-table-delete! runremote run-id) + (thread-sleep! 1) + (client:setup-http areapath remaining-tries: (- remaining-tries 1)) + ))) + (begin ;; no server registered + ;; (server:kind-run areapath) + (server:start-and-wait areapath) + (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries) + (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. + (client:setup-http areapath remaining-tries: (- remaining-tries 1))))))))) ) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -24,11 +24,13 @@ (declare (unit runconfig)) (declare (uses common)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (include "common_records.scm") (define (runconfig:read fname target environ-patt) (let ((ht (make-hash-table))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -31,11 +31,13 @@ (declare (uses mt)) (declare (uses archive)) ;; (declare (uses filedb)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses configfmod)) (import configfmod) (declare (uses dbmod)) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -32,11 +32,13 @@ ;; ;; (declare (uses http-transport)) ;; (declare (uses launch)) ;; ;; (declare (uses commonmod)) +(declare (uses debugprint)) ;; (import commonmod) +(import debugprint) ;; ;; (declare (uses dbmod)) ;; (import dbmod) ;; ;; (declare (uses configfmod)) Index: servermod.scm ================================================================== --- servermod.scm +++ servermod.scm @@ -18,10 +18,11 @@ ;;====================================================================== (declare (unit servermod)) (declare (uses commonmod)) +(declare (uses debugprint)) (declare (uses configfmod)) (declare (uses dbmod)) (declare (uses rmtmod)) (module servermod @@ -33,11 +34,12 @@ message-digest hostinfo regex matchable md5) (import commonmod) +(import debugprint) (import configfmod) (import dbmod) (import rmtmod) ) Index: subrun.scm ================================================================== --- subrun.scm +++ subrun.scm @@ -32,11 +32,13 @@ (declare (uses mt)) ;;(declare (uses archive)) ;; (declare (uses filedb)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses configfmod)) (import configfmod) (declare (uses dbmod)) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -19,10 +19,11 @@ ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (declare (unit tasks)) (declare (uses pgdb)) (declare (uses commonmod)) +(declare (uses debugprint)) (declare (uses configfmod)) (declare (uses dbmod)) (declare (uses margsmod)) (module tasks @@ -31,10 +32,11 @@ (import scheme chicken data-structures extras) (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format srfi-18) (import (prefix sqlite3 sqlite3:)) (import commonmod) +(import debugprint) (import configfmod) (import dbmod) (import margsmod) (import pgdb) Index: tcmt.scm ================================================================== --- tcmt.scm +++ tcmt.scm @@ -34,11 +34,13 @@ (import margsmod) ;; (declare (uses megatest-version)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (include "megatest-version.scm") (include "megatest-fossil-hash.scm") (include "db_records.scm") Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -34,11 +34,13 @@ (declare (uses db)) (declare (uses margsmod)) (import margsmod) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses dbmod)) (import dbmod) (declare (uses ods)) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -36,11 +36,13 @@ (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) (import (prefix sqlite3 sqlite3:)) (require-library stml) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses dbmod)) (import dbmod) (declare (uses configfmod)) Index: transport.scm ================================================================== --- transport.scm +++ transport.scm @@ -18,10 +18,11 @@ ;;====================================================================== (declare (unit transport)) (declare (uses commonmod)) +(declare (uses debugprint)) (declare (uses configfmod)) (declare (uses portlogger)) (declare (uses apimod)) (declare (uses servermod)) @@ -29,10 +30,11 @@ * (import scheme chicken data-structures extras ports) (import commonmod) +(import debugprint) (import configfmod) (import apimod) (import portlogger) (import servermod) Index: tree.scm ================================================================== --- tree.scm +++ tree.scm @@ -35,11 +35,13 @@ (declare (uses server)) ;; (declare (uses synchash)) (declare (uses dcommon)) (declare (uses commonmod)) +(declare (uses debugprint)) (import commonmod) +(import debugprint) (declare (uses dbmod)) (import dbmod) DELETED utils/gendeps.scm Index: utils/gendeps.scm ================================================================== --- utils/gendeps.scm +++ /dev/null @@ -1,138 +0,0 @@ -;; (require-library iup canvas-draw) - -;; It'd be better to use codescan.... - -(module gendeps - * - -(import - scheme - chicken.base - chicken.string - chicken.process-context - chicken.file - chicken.io - chicken.port - scheme - ;;extras - regex - regex-case - matchable - srfi-69 - ) - -(define (portprint p . args) - (with-output-to-port p - (lambda () - (apply print args)))) - -(define modules-without-mod - "(ods|transport|portlogger|tasks|pgdb)") - -(define (mofiles-adjust->dot-o inf) - (regex-case - inf - ("^.*mod$" _ (conc "mofiles/"inf".o")) - (modules-without-mod _ (conc "mofiles/"inf".o")) - ("pgdb" _ (conc "cgisetup/models/"inf".o")) - (else (conc inf".o")))) - -(define (hh-push ht k1 val) - (hash-table-set! ht k1 (cons val (hash-table-ref/default ht k1 '())))) - -(define (compunit targfname files) - (let* ((unitdata (make-hash-table)) - (moduledata (make-hash-table)) - (incldata (make-hash-table)) - (filesdata (make-hash-table)) - (unitdec (regexp "^\\(declare\\s+\\(unit\\s+([^\\s]+)\\)\\)")) - (unituse (regexp "^\\(declare\\s+\\(uses\\s+([^\\s]+)\\)\\)")) - (moduledec (regexp "^\\(module\\s+([\\S]+).*")) - (importuse (regexp "^\\(import\\s+(.*)\\)")) ;; captures string of imports (one line) - (dotport (open-output-file (conc targfname ".dot"))) - (incdotport (open-output-file (conc targfname"-inc.dot"))) - (incport (open-output-file (conc targfname ".inc"))) - ) - (portprint dotport "digraph usedeps {") - (portprint incdotport "digraph usedeps {") - (portprint incport "# To regenerate this file do: -# (cd utils/;ck52 csc gendeps.scm) && ./utils/gendeps allunits *scm -# cp allunits.inc build.inc -# -") - (for-each - (lambda (fname) - (let* ((sname (string-substitute "\\.scm$" "" fname))) - (print "Processing "fname" with core name of "sname) - (hash-table-set! filesdata sname fname) ;; record the existance of the src file - (with-input-from-file fname - (lambda () - (let loop ((inl (read-line))) - (if (not (eof-object? inl)) - (begin - (regex-case - inl - (unitdec (_ unitname) - (if (equal? sname unitname) ;; good if same - (if (not (hash-table-exists? unitdata unitname)) - (hash-table-set! unitdata unitname (make-hash-table))))) - (unituse (_ usingname) - (portprint dotport "\""usingname"\" -> \""sname"\"")) - (moduledec (_ modname) - (print "Found module "modname) - (hash-table-set! moduledata modname sname)) - (importuse (_ importname) - (print "Found import "importname) - (hh-push incldata importname sname)) - (else #f)) - (loop (read-line))))))))) - files) - (hash-table-for-each - incldata - (lambda (impname snames) - (for-each - (lambda (sname) - (if (hash-table-exists? moduledata impname) - (if (hash-table-exists? incldata sname) - (make-inc-entry incport incdotport sname impname) - (print "Skipping module "sname", it is not used by any other modules")) - (print "No module file found for import " impname))) - snames))) - (portprint dotport "}") - (portprint incdotport "}") - (close-output-port dotport) - (close-output-port incport) - (close-output-port incdotport))) - -(define (make-inc-entry incport incdotport sname impname) - (let* ((leftname (mofiles-adjust->dot-o sname)) - (rightname (mofiles-adjust->dot-o impname))) - (portprint incport - (if (or (string-search ".import$" sname) - (string-search ".import$" impname)) - "# " - "") - leftname" : "rightname) - (portprint incdotport "\""impname"\" -> \""sname"\""))) - -;; seen is hash of seen functions - -(define usage "Usage: gendeps targfile files... -") - -(define (main) - (match - (command-line-arguments) - (("help")(print usage)) - ((targfile . files) - (compunit targfile files)) - (else - (print "ERROR: Arguments not recognised.") - (print usage)))) -) - -(import - ;; (only iup show main-loop) - gendeps) - -(main)