@@ -14,55 +14,187 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; +(include "mutils/mutils.scm") +(include "autoload/autoload.scm") +(include "dbi/dbi.scm") +(include "stml2/cookie.scm") +(include "stml2/stml2.scm") +(include "pkts/pkts.scm") +(include "csv-xml/csv-xml.scm") +;; (include "call-with-environment-variables/call-with-environment-variables.scm") + +(module megatest-main + * + + (import scheme + chicken.base + chicken.bitwise + chicken.condition + chicken.file + chicken.file.posix + chicken.format + chicken.io + chicken.irregex + chicken.pathname + chicken.port + chicken.pretty-print + chicken.process + chicken.process-context + chicken.process-context.posix + chicken.process.signal + chicken.random + chicken.repl + chicken.sort + chicken.string + chicken.time + chicken.time.posix + + (prefix sqlite3 sqlite3:) + (prefix base64 base64:) + csv-abnf + directory-utils + matchable + md5 + message-digest + queues + regex + regex-case + sql-de-lite + stack + typed-records + s11n + sparse-vectors + sxml-serializer + sxml-modifications + system-information + z3 + + srfi-1 + srfi-4 + srfi-18 + srfi-13 + srfi-98 + srfi-69 + + ;; local modules + mutils + csv-xml + + ) + ;; (include "common.scm") (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) - -(declare (uses common)) -;; (declare (uses megatest-version)) -(declare (uses margs)) -(declare (uses runs)) -(declare (uses launch)) -(declare (uses server)) -(declare (uses client)) -(declare (uses tests)) -(declare (uses genexample)) -;; (declare (uses daemon)) -(declare (uses db)) -;; (declare (uses dcommon)) - -(declare (uses tdb)) -(declare (uses mt)) -(declare (uses api)) -(declare (uses tasks)) ;; only used for debugging. -(declare (uses env)) -(declare (uses diff-report)) +(define setenv set-environment-variable!) +(define unsetenv unset-environment-variable!) + +;; (declare (uses common)) +;; ;; (declare (uses megatest-version)) +;; (declare (uses margs)) +;; (declare (uses runs)) +;; (declare (uses launch)) +;; (declare (uses server)) +;; (declare (uses client)) +;; (declare (uses tests)) +;; (declare (uses genexample)) +;; ;; (declare (uses daemon)) +;; (declare (uses db)) +;; ;; (declare (uses dcommon)) +;; +;; (declare (uses tdb)) +;; (declare (uses mt)) +;; (declare (uses api)) +;; (declare (uses tasks)) ;; only used for debugging. +;; (declare (uses env)) +;; (declare (uses diff-report)) ;; (declare (uses ftail)) ;; (import ftail) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") +(include "test_records.scm") (include "megatest-fossil-hash.scm") -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:) - readline apropos json http-client directory-utils typed-records - http-client srfi-18 extras format) +(import (prefix dbi dbi:)) +(import stml2) +(import pkts) + +(include "common.scm") +(include "configf.scm") +(include "margs.scm") +(include "process.scm") +(include "keys.scm") +(include "db.scm") +(include "rmt.scm") +(include "runs.scm") +(include "launch.scm") +(include "server.scm") +(include "client.scm") +(include "tests.scm") +(include "items.scm") +(include "subrun.scm") +(include "genexample.scm") +(include "tdb.scm") +(include "mt.scm") +(include "api.scm") +(include "tasks.scm") +(include "env.scm") +(include "diff-report.scm") +(include "cgisetup/models/pgdb.scm") +(include "runconfig.scm") +(include "archive.scm") +(include "ods.scm") +(include "http-transport.scm") + +;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:) +;; readline apropos json http-client directory-utils typed-records +;; http-client srfi-18 extras format) ;; Added for csv stuff - will be removed ;; -(use sparse-vectors) +;; (use sparse-vectors) +;; +;; (require-library mutils) -(require-library mutils) +;; copied from egg call-with-environment-variables +;; +(define (call-with-environment-variables variables thunk) + #;@("Sets up environment variable via dynamic-wind which are taken down after thunk." + (variables "An alist of the form {{'((\"var\" . \"value\") ...)}}") + (thunk "The thunk to execute with a modified environment")) + (let ((pre-existing-variables + (map (lambda (var-value) + (let ((var (car var-value))) + (cons var (get-environment-variable var)))) + variables))) + (dynamic-wind + (lambda () (void)) + (lambda () +;; (use posix) + (for-each (lambda (var-value) + (setenv (car var-value) (cdr var-value))) + variables) + (thunk)) + (lambda () + (for-each (lambda (var-value) + (let ((var (car var-value)) + (value (cdr var-value))) + (if value + (setenv var value) + (unsetenv var)))) + pre-existing-variables))))) + + (define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file ;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file @@ -72,11 +204,11 @@ (load debugcontrolf))) ;; usage logging, careful with this, it is not designed to deal with all real world challenges! ;; (if (and *usage-log-file* - (file-write-access? *usage-log-file*)) + (file-writable? *usage-log-file*)) (with-output-to-file *usage-log-file* (lambda () (print (if *usage-use-seconds* @@ -1000,11 +1132,11 @@ (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")) #f)) (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f))) (if (and cfgf (common:file-exists? cfgf) - (file-write-access? cfgf) + (file-writable? cfgf) (common:use-cache?)) (configf:read-alist cfgf) (let* ((keys (rmt:get-keys)) (target (common:args-get-target)) (key-vals (if target (keys:target->keyval keys target) #f)) @@ -1017,11 +1149,11 @@ key-vals)) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) (runconfig:read (conc *toppath* "/runconfigs.config") target #f)))) (if (and rundir ;; have all needed variabless (directory-exists? rundir) - (file-write-access? rundir)) + (file-writable? rundir)) (begin (if (not (common:in-running-test?)) (configf:write-alist data cfgf)) ;; force re-read of megatest.config - this resolves circular references between megatest.config (launch:setup force-reread: #t) @@ -1683,11 +1815,11 @@ ;; (print "runs:") ;; (pp runs) ;(print "sheets: ") ;; (pp sheets) (if (eq? dmode 'ods) - (let* ((tempdir (conc "/tmp/" (current-user-name) "/" (random 10000) "_" (current-process-id))) + (let* ((tempdir (conc "/tmp/" (current-user-name) "/" (pseudo-random-integer 10000) "_" (current-process-id))) (outputfile (or (args:get-arg "-o") "out.ods")) (ouf (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path? outputfile (begin (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") @@ -2331,11 +2463,11 @@ ;;====================================================================== ;; Start a repl ;;====================================================================== ;; fakeout readline -(include "readline-fix.scm") +;; (include "readline-fix.scm") (when (args:get-arg "-diff-rep") (when (and (not (args:get-arg "-diff-html")) @@ -2378,25 +2510,25 @@ (repl)) (else (begin (set! *db* dbstruct) - (import extras) ;; might not be needed + ;; (import extras) ;; might not be needed ;; (import csi) - (import readline) + ;; (import readline) (import apropos) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... - (if *use-new-readline* - (begin - (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) - (current-input-port (make-readline-port "megatest> "))) - (begin - (gnu-history-install-file-manager - (string-append - (or (get-environment-variable "HOME") ".") "/.megatest_history")) - (current-input-port (make-gnu-readline-port "megatest> ")))) + ;; (if *use-new-readline* + ;; (begin + ;; (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) + ;; (current-input-port (make-readline-port "megatest> "))) + ;; (begin + ;; (gnu-history-install-file-manager + ;; (string-append + ;; (or (get-environment-variable "HOME") ".") "/.megatest_history")) + ;; (current-input-port (make-gnu-readline-port "megatest> ")))) (if (args:get-arg "-repl") (repl) (load (args:get-arg "-load"))) ;; (db:close-all dbstruct) <= taken care of by on-exit call ) @@ -2550,5 +2682,6 @@ (case *globalexitstatus* ((0)(exit 0)) ((1)(exit 1)) ((2)(exit 2)) (else (exit 3))))) +)