Index: apimod.scm ================================================================== --- apimod.scm +++ apimod.scm @@ -24,14 +24,13 @@ (declare (uses servermod)) (module apimod * -(import scheme chicken data-structures extras) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable - s11n z3 (prefix base64 base64:) regex stack srfi-13 - irregex) +(import scheme chicken.base chicken.irregex chicken.process-context.posix chicken.string chicken.time) +(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 format chicken.port srfi-1 matchable + s11n z3 (prefix base64 base64:) regex stack srfi-13) (import commonmod) (import dbmod) (import servermod) ;; (use (prefix ulex ulex:)) @@ -125,11 +124,11 @@ ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) ((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params)) ;; TEST DATA ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) - ((csv->test-data) (apply db:csv->test-data dbstruct params)) + ;;((csv->test-data) (apply db:csv->test-data dbstruct params)) ;; MISC ((sync-inmem->db) (let ((run-id (car params))) (db:sync-touched dbstruct run-id force-sync: #t))) ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -30,23 +30,28 @@ ;; (declare (uses testsmod)) (module dbmod * -(import scheme chicken data-structures extras) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 - srfi-69 format ports srfi-1 matchable stack regex +(import scheme (chicken base) ) +(import (prefix sqlite3 sqlite3:) typed-records srfi-18 + srfi-69 format (chicken port) srfi-1 matchable stack regex srfi-13 stack s11n (prefix base64 base64:) + (chicken process-context posix) + (chicken process-context) + (chicken process) (chicken sort) (chicken file posix) (chicken time) + (chicken time posix) (chicken pretty-print) (chicken format) + (chicken random) (chicken pathname) system-information z3 - csv csv-xml + ;;csv csv-xml directory-utils call-with-environment-variables) (import commonmod) (import keysmod) -(import files) +(import (chicken file) (chicken condition) (chicken string)) (import tasksmod) (import odsmod) ;; (import testsmod) (import (prefix mtargs args:)) (import (prefix mtconfigf configf:)) @@ -123,19 +128,19 @@ (let loop ((hed (car test-dirs)) (tal (cdr test-dirs))) ;; Setting MT_LINKTREE here is almost certainly unnecessary. (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) (if (and (common:file-exists? tconfig-file) - (file-read-access? tconfig-file)) + (file-readable? tconfig-file)) (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) (old-link-tree (get-environment-variable "MT_LINKTREE"))) - (if link-tree-path (setenv "MT_LINKTREE" link-tree-path)) + (if link-tree-path (set-environment-variable! "MT_LINKTREE" link-tree-path)) (let ((newtcfg (configf:read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...] (hash-table-set! *testconfigs* test-name newtcfg) (if old-link-tree - (setenv "MT_LINKTREE" old-link-tree) - (unsetenv "MT_LINKTREE")) + (set-environment-variable! "MT_LINKTREE" old-link-tree) + (unset-environment-variable! "MT_LINKTREE")) newtcfg)) (if (null? tal) (begin (debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name) #f) @@ -460,14 +465,14 @@ ;; (define *db-open-mutex* (make-mutex)) (define (db:lock-create-open fname initproc) (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local (raw-fname (pathname-file fname)) - (dir-writable (file-write-access? parent-dir)) + (dir-writable (file-writable? parent-dir)) (file-exists (common:file-exists? fname)) (file-write (if file-exists - (file-write-access? fname) + (file-writable? fname) dir-writable ))) ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped. (if file-write ;; dir-writable (condition-case (let* ((lockfname (conc fname ".lock")) @@ -546,11 +551,11 @@ (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) (mtdb (db:open-megatest-db)) (mtdbpath (db:dbdat-get-path mtdb)) (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) - (write-access (file-write-access? mtdbpath)) + (write-access (file-writable? mtdbpath)) ;(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) ; moving this before db:open-megatest-db is called. if wal mode is on -WAL and -shm file get created with causing the tmpdbmodtime timestamp always greater than mtdbmodtime ;(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) ;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced ;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f)) ;(fmt (file-modification-time tmpdbfname)) @@ -642,11 +647,11 @@ (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) ;;(db:initialize-run-id-db db) ))) - (write-access (file-write-access? dbpath))) + (write-access (file-writable? dbpath))) (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (cons db dbpath))) @@ -828,11 +833,11 @@ (let* ((dbpath (db:dbdat-get-path dbdat)) (dbdir (pathname-directory dbpath)) (fname (pathname-strip-directory dbpath))) (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.") (cond - ((not (file-write-access? dbdir)) + ((not (file-writable? dbdir)) (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname) #f) ;; handle special cases, megatest.db and monitor.db ;; @@ -915,17 +920,17 @@ -3) ((not (sqlite3:database? (db:dbdat-get-db todb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb) -4) - ((not (file-write-access? (db:dbdat-get-path todb))) + ((not (file-writable? (db:dbdat-get-path todb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb) -5) ((not (null? (let ((readonly-slave-dbs (filter (lambda (dbdat) - (not (file-write-access? (db:dbdat-get-path todb)))) + (not (file-writable? (db:dbdat-get-path todb)))) slave-dbs))) (for-each (lambda (bad-dbdat) (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat)) @@ -1266,11 +1271,11 @@ #f)) #;(define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn - (let ((sleep-time (random 30)) + (let ((sleep-time (pseudo-random-integer 30)) (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) (case err-status ((busy) (thread-sleep! sleep-time)) (else @@ -3632,11 +3637,11 @@ (define (tdb:get-prev-tol-for-test tdb test-id category variable) ;; Finish me? (values #f #f #f)) -(define (db:csv->test-data dbstruct run-id test-id csvdata) +#;(define (db:csv->test-data dbstruct run-id test-id csvdata) (debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata) (db:with-db dbstruct #f #f (lambda (db) (let* ((csvlist (csv->list (make-csv-reader @@ -4691,11 +4696,11 @@ (numkeys (length keypatt-alist)) (test-ids '()) (dbdat (db:get-db dbstruct)) (db (db:dbdat-get-db dbdat)) (windows (and pathmod (substring-index "\\" pathmod))) - (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id))) + (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (pseudo-random-integer 10000) "_" (current-process-id))) (runsheader (append (list "Run Id" "Runname") ; 0 1 (map car keypatt-alist) ; + N = length keypatt-alist (list "Testname" ; 2 "Item Path" ; 3 "Description" ; 4 @@ -4825,27 +4830,27 @@ actual-state " " actual-status " " event-time )) (prev-nbfake-log (get-environment-variable "NBFAKE_LOG"))) - (setenv "NBFAKE_LOG" (conc (cond + (set-environment-variable! "NBFAKE_LOG" (conc (cond ((and (directory-exists? test-rundir) - (file-write-access? test-rundir)) + (file-writable? test-rundir)) test-rundir) ((and (directory-exists? *toppath*) - (file-write-access? *toppath*)) + (file-writable? *toppath*)) *toppath*) (else (conc "/tmp/" (current-user-name)))) "/" logname)) (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG")) ;; (call-with-environment-variables ;; `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname))) ;; (lambda () (process-run fullcmd) (if prev-nbfake-log - (setenv "NBFAKE_LOG" prev-nbfake-log) - (unsetenv "NBFAKE_LOG")) + (set-environment-variable! "NBFAKE_LOG" prev-nbfake-log) + (unset-environment-variable! "NBFAKE_LOG")) )) ;; )) (define (mt:process-triggers dbstruct run-id test-id newstate newstatus) (if test-id (let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id))) Index: dcommonmod.scm ================================================================== --- dcommonmod.scm +++ dcommonmod.scm @@ -32,41 +32,41 @@ (declare (uses servermod)) (module dcommonmod * -(import scheme chicken data-structures extras) +(import scheme chicken.bitwise chicken.pathname chicken.process-context.posix chicken.condition chicken.sort chicken.process chicken.pretty-print chicken.base chicken.string chicken.time chicken.file.posix chicken.process-context) (import (prefix sqlite3 sqlite3:) - posix typed-records srfi-18 srfi-69 format ports srfi-1 + typed-records srfi-18 srfi-69 chicken.format chicken.port srfi-1 matchable (prefix iup iup:) canvas-draw ;; blindly copied from megamod (prefix base64 base64:) (prefix dbi dbi:) ;; (prefix nanomsg nmsg:) (prefix sqlite3 sqlite3:) call-with-environment-variables - csv - csv-xml - data-structures + ;;csv + ;;csv-xml + ;;data-structures directory-utils dot-locking - extras - files + ;;extras + chicken.file + chicken.random fmt - format + chicken.format hostinfo http-client intarweb - irregex + chicken.irregex matchable md5 message-digest pathname-expand pkts - ports - posix + chicken.port ;; queue regex regex-case s11n sparse-vectors @@ -79,13 +79,13 @@ srfi-13 srfi-18 srfi-69 stack stml2 - tcp + ;;tcp typed-records - udp + ;;udp uri-common z3 ) (import (prefix mtconfigf configf:)) @@ -98,11 +98,11 @@ (import runsmod) (import rmtmod) (import dbmod) (import canvas-draw) (import canvas-draw-iup) -(use (prefix iup iup:)) +(import (prefix iup iup:)) (import (prefix mtargs args:)) (define *tim* (iup:timer)) ;; (use (prefix ulex ulex:)) Index: ducttape/ducttape-lib.scm ================================================================== --- ducttape/ducttape-lib.scm +++ ducttape/ducttape-lib.scm @@ -49,19 +49,21 @@ *this-exe-dir* *this-exe-name* *this-exe-fullpath* ) - (import scheme chicken extras ports data-structures ) - (use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339) + (import scheme chicken.base chicken.port chicken.process chicken.io chicken.pathname chicken.process-context chicken.time chicken.process chicken.condition chicken.time.posix chicken.process-context.posix chicken.format chicken.file.posix) + (import regex ansi-escape-sequences test srfi-1 chicken.irregex slice srfi-13 rfc3339) ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process* - (use directory-utils uuid-lib filepath srfi-19 ) ; linenoise + ;;(import directory-utils uuid-lib filepath srfi-19 ) ; linenoise + (import directory-utils filepath srfi-19 ) ; linenoise ;; plugs a hole in posix-extras in latter chicken versions - (use posix-extras pathname-expand files) + (import pathname-expand chicken.file chicken.string) (define ##sys#expand-home-path pathname-expand) - (define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) )) + (define (realpath x) (print "Path: " x) (normalize-pathname (pathname-expand (or x "/dev/null")) )) + ;;(define (realpath x) (pathname-expand (or x "/dev/null"))) ;; (include "mimetypes.scm") ; provides ext->mimetype ;; (include "workweekdate.scm") ;; gathered from macosx: @@ -841,14 +843,14 @@ ("avi" . "video/x-msvideo") ("movie" . "video/x-sgi-movie") ("smv" . "video/x-smv") ("ice" . "x-conference/x-cooltalk"))) -(use srfi-19) -(use test) +(import srfi-19) +(import test) ;;(use format) -(use regex) +(import regex) ;(declare (unit wwdate)) ;; utility procedures to convert among ;; different ways to express date (wwdate, seconds since epoch, isodate) ;; ;; samples: @@ -1058,11 +1060,11 @@ (if (null? rest-path-items) #f (let* ((this-dir (car rest-path-items)) (next-rest (cdr rest-path-items)) (candidate (conc this-dir "/" exe))) - (if (file-execute-access? candidate) + (if (file-executable? candidate) candidate (loop next-rest))))))) @@ -1247,15 +1249,15 @@ (let ((num-debug-level (runs-ok (string->number raw-debug-level)))) (if (integer? num-debug-level) (begin (let ((new-num-debug-level (- num-debug-level 1))) (if (> new-num-debug-level 0) ;; decrement - (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level)) - (unsetenv "DUCTTAPE_DEBUG_LEVEL"))) + (set-environment-variable! "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level)) + (unset-environment-variable! "DUCTTAPE_DEBUG_LEVEL"))) num-debug-level) ; it was set and > 0, mode is value (begin - (unsetenv "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it + (unset-environment-variable! "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it #f))) ; value was invalid, mode is f #f)))) ; var not set, mode is f (define ducttape-debug-mode (if (ducttape-debug-level) #t #f)) @@ -1360,11 +1362,11 @@ (user (or (get-environment-variable "USER") "nouser")) (host (or (get-environment-variable "HOST") "nohost"))) (if logfile (begin (ducttape-log-file logfile) - (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file)))) + (set-environment-variable! "DUCTTAPE_LOG_FILE" (ducttape-log-file)))) (ducttape-append-logfile 'note (format #f "START - pid=~A ppid=~A argv=(~A) pwd=~A user=~A host=~A" pid ppid argv pwd user host) #t))) ;; log exit code (define (set-ducttape-log-exit-handler) @@ -1522,11 +1524,12 @@ (define (sendmail-proc sendmail-port) (define (wl line-str) (write-line line-str sendmail-port)) (define (get-uuid) - (string-upcase (uuid->string (uuid-generate)))) + "foo") + ;;(string-upcase (uuid->string (uuid-generate)))) (let ((mailpart-uuid (get-uuid)) (mailpart-body-uuid (get-uuid))) (define (boundary) @@ -1702,40 +1705,40 @@ ;; --quiet (let ((quiet-opts (skim-cmdline-opts-noarg-by-regex "--?quiet"))) (if (not (null? quiet-opts)) (begin - (setenv "DUCTTAPE_QUIET_MODE" "1") + (set-environment-variable! "DUCTTAPE_QUIET_MODE" "1") (ducttape-quiet-mode "1")))) ;; --silent (let ((silent-opts (skim-cmdline-opts-noarg-by-regex "--?silent"))) (if (not (null? silent-opts)) (begin - (setenv "DUCTTAPE_SILENT_MODE" "1") + (set-environment-variable! "DUCTTAPE_SILENT_MODE" "1") (ducttape-silent-mode "1")))) ;; -color (let ((color-opts (skim-cmdline-opts-noarg-by-regex "--?colou?r(ize)?"))) (if (not (null? color-opts)) (begin - (setenv "DUCTTAPE_COLORIZE" "1") + (set-environment-variable! "DUCTTAPE_COLORIZE" "1") (ducttape-color-mode "1")))) ;; -nocolor (let ((nocolor-opts (skim-cmdline-opts-noarg-by-regex "--?nocolou?r(ize)?"))) (if (not (null? nocolor-opts)) (begin - (unsetenv "DUCTTAPE_COLORIZE" ) + (unset-environment-variable! "DUCTTAPE_COLORIZE" ) (ducttape-color-mode #f)))) ;; -logfile (let ((logfile-opts (skim-cmdline-opts-withargs-by-regex "--?log(-?file)?"))) (if (not (null? logfile-opts)) (begin (ducttape-log-file (car (reverse logfile-opts))) - (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file))))) + (set-environment-variable! "DUCTTAPE_LOG_FILE" (ducttape-log-file))))) ;; -d -dd -d# (let ((debug-opts (skim-cmdline-opts-noarg-by-regex "-d(d*|\\d+)")) (initial-debuglevel (if (ducttape-debug-level) (ducttape-debug-level) 0) )) (if (not (null? debug-opts)) @@ -1750,19 +1753,19 @@ (ds (string-match "-(d+)" curopt)) (dnum (string-match "-d(\\d+)" curopt))) (cond (ds (loop restopts (+ debuglevel (string-length (cadr ds))))) (dnum (loop restopts (string->number (cadr dnum))))))))) - (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level)))))) + (set-environment-variable! "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level)))))) ;; -dp / --debug-pattern (let ((debugpat-opts (skim-cmdline-opts-withargs-by-regex "--?(debug-pattern|dp)"))) (if (not (null? debugpat-opts)) (begin (ducttape-debug-regex-filter (string-join debugpat-opts "|")) - (setenv "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter)))))) + (set-environment-variable! "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter)))))) ;;; following code commented out; side effects not wanted on startup ;; immediately activate logfile (will be noop if logfile disabled) ;;(ducttape-activate-logfile) Index: env-inc.scm ================================================================== --- env-inc.scm +++ env-inc.scm @@ -137,11 +137,11 @@ ;; (print "COMMON: " (string-intersperse common-parts "\n ")) (string-intersperse final separator))) (define (env:process-path-envvar varname separator patha pathb) (let ((newpath (env:merge-path-envvar separator patha pathb))) - (setenv varname newpath))) + (set-environment-variable! varname newpath))) (define (env:have-context db context) (> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context) 0)) Index: gutilsmod.scm ================================================================== --- gutilsmod.scm +++ gutilsmod.scm @@ -18,16 +18,16 @@ ;; ;;====================================================================== (require-library iup) (import (prefix iup iup:)) -(use canvas-draw) +(import canvas-draw) (use srfi-1 regex regex-case srfi-69) (declare (unit gutilsmod)) (module gutilsmod * -(import scheme chicken data-structures extras srfi-1) +(import scheme chicken.base chicken.string srfi-1) (include "gutils-inc.scm") ) Index: itemsmod.scm ================================================================== --- itemsmod.scm +++ itemsmod.scm @@ -23,11 +23,11 @@ (declare (uses mtconfigf)) (module itemsmod * -(import scheme (chicken base)) +(import scheme (chicken base) chicken.pretty-print chicken.string) (import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 format (chicken port) srfi-1 matchable) (import commonmod) (import(prefix mtconfigf configf:)) ;; (use (prefix ulex ulex:)) Index: launchmod.scm ================================================================== --- launchmod.scm +++ launchmod.scm @@ -23,13 +23,13 @@ (declare (uses commonmod)) (module launchmod * -(import scheme chicken data-structures extras files) -(import (prefix sqlite3 sqlite3:) posix typed-records - srfi-18 srfi-69 format ports srfi-1 matchable +(import scheme chicken.base chicken.file) +(import (prefix sqlite3 sqlite3:) typed-records + srfi-18 srfi-69 chicken.format chicken.port srfi-1 matchable z3 (prefix base64 base64:) regex - call-with-environment-variables csv) + call-with-environment-variables) (import commonmod) ) Index: megamod.scm ================================================================== --- megamod.scm +++ megamod.scm @@ -43,37 +43,43 @@ (declare (uses runsmod)) (module megamod * -(import scheme chicken data-structures extras) -(use +(import scheme chicken.base) +(import (prefix base64 base64:) (prefix dbi dbi:) ;; (prefix nanomsg nmsg:) (prefix sqlite3 sqlite3:) call-with-environment-variables - csv - csv-xml - data-structures + ;;csv + ;;csv-xml + ;;data-structures directory-utils dot-locking - extras - files + ;;extras + chicken.file + chicken.condition + chicken.process-context + chicken.process-context.posix + chicken.process + chicken.random + chicken.string fmt - format + chicken.format + system-information hostinfo http-client intarweb - irregex + chicken.irregex matchable md5 message-digest pathname-expand ;; pkts - ports - posix + chicken.port ;; queue regex regex-case s11n sparse-vectors @@ -85,13 +91,13 @@ srfi-4 srfi-13 srfi-18 srfi-69 stack - tcp + ;;tcp typed-records - udp + ;;udp uri-common z3 ) (import (prefix mtconfigf configf:)) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -20,13 +20,13 @@ ;; (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) -(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 tcp6) +(import (prefix sqlite3 sqlite3:) srfi-1 regex regex-case srfi-69 (prefix base64 base64:) + breadline apropos json http-client directory-utils typed-records + http-client srfi-18 chicken.format tcp6) ;; Added for csv stuff - will be removed ;; (use sparse-vectors) @@ -2363,13 +2363,12 @@ (repl)) (else (begin (set! *db* dbstruct) - (import extras) ;; might not be needed ;; (import csi) - (import readline) + (import breadline) (import apropos) (import dbmod) (import rmtmod) (import commonmod) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... Index: mtexec.scm ================================================================== --- mtexec.scm +++ mtexec.scm @@ -20,12 +20,12 @@ ;; (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) -(use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) - srfi-19 srfi-18 extras format pkts regex regex-case +(import srfi-1 srfi-69 breadline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) + srfi-19 srfi-18 chicken.format pkts regex regex-case (prefix dbi dbi:) ) ;; (declare (uses common)) ;; (declare (uses megatest-version)) @@ -105,13 +105,12 @@ (exit))) (if (or (args:get-arg "-repl") (args:get-arg "-load")) (begin - (import extras) ;; might not be needed ;; (import csi) - (import readline) + (import breadline) (import apropos) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (install-history-file (get-environment-variable "HOME") ".mtutil_history") ;; [homedir] [filename] [nlines]) (current-input-port (make-readline-port "mtutil> ")) Index: mtmod.scm ================================================================== --- mtmod.scm +++ mtmod.scm @@ -34,17 +34,17 @@ (declare (uses testsmod)) (module mtmod * -(import scheme chicken data-structures extras posix ports files) +(import scheme chicken.base chicken.port chicken.file chicken.string) -(use (prefix sqlite3 sqlite3:) +(import (prefix sqlite3 sqlite3:) srfi-69 regex srfi-18 srfi-13 srfi-1 call-with-environment-variables z3 (prefix base64 base64:) typed-records - csv directory-utils) + directory-utils) (import (prefix mtargs args:)) (import (prefix mtconfigf configf:)) (import commonmod) (import dbmod) Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -20,12 +20,12 @@ ;; (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) -(use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) - srfi-19 srfi-18 extras format pkts regex regex-case +(import srfi-1 srfi-69 breadline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) + srfi-19 srfi-18 chicken.format pkts regex regex-case (prefix dbi dbi:) nanomsg) ;; (declare (uses common)) ;; (declare (uses megatest-version)) @@ -1903,13 +1903,12 @@ (exit))) (if (or (args:get-arg "-repl") (args:get-arg "-load")) (begin - (import extras) ;; might not be needed ;; (import csi) - (import readline) + (import breadline) (import apropos) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (install-history-file (get-environment-variable "HOME") ".mtutil_history") ;; [homedir] [filename] [nlines]) (current-input-port (make-readline-port "mtutil> ")) Index: odsmod.scm ================================================================== --- odsmod.scm +++ odsmod.scm @@ -22,13 +22,13 @@ (declare (uses commonmod)) (module odsmod * -(import scheme (chicken base) (chicken string) (chicken port) (chicken io) (chicken file) csv-xml regex) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 - format ports srfi-1 matchable srfi-13) +(import scheme (chicken base) (chicken string) (chicken port) (chicken io) (chicken file) regex) +(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 + format (chicken port) (chicken process) srfi-1 matchable srfi-13) (import commonmod) ;; (use (prefix ulex ulex:)) (define ods:dirs '("Configurations2" Index: portlogger-inc.scm ================================================================== --- portlogger-inc.scm +++ portlogger-inc.scm @@ -26,11 +26,11 @@ (sqlite3:open-database fname) (begin (system (conc "rm -f " fname)) (sqlite3:open-database fname)))) (handler (sqlite3:make-busy-timeout 136000)) - (canwrite (file-write-access? fname))) + (canwrite (file-writable? fname))) ;; (db-init (lambda () ;; (sqlite3:execute ;; db ;; "CREATE TABLE IF NOT EXISTS ports ( ;; port INTEGER PRIMARY KEY, @@ -122,11 +122,11 @@ (string->number val)) (string->number val) 32768))) (portnum (or (portlogger:get-prev-used-port db) (+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range - (random (- 64000 lowport)))))) + (pseudo-random-integer (- 64000 lowport)))))) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -27,12 +27,12 @@ (declare (uses ulex)) (module rmtmod * -(import scheme chicken data-structures extras) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable) +(import scheme chicken.base chicken.time chicken.string chicken.condition chicken.sort chicken.file chicken.random) +(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 chicken.format chicken.port srfi-1 matchable) (import (prefix ulex ulex:)) (import commonmod) (import itemsmod) @@ -338,11 +338,11 @@ (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) (let* ((qry-is-write (not (member cmd api:read-only-queries))) (db-file-path (db:dbfile-path)) ;; 0)) (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t))) - (read-only (not (file-write-access? db-file-path))) + (read-only (not (file-writable? db-file-path))) (start (current-milliseconds)) (resdat (if (not (and read-only qry-is-write)) (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong.. exn ;; This is an attempt to detect that situation and recover gracefully @@ -362,11 +362,11 @@ (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd)) (if (not success) (if (> remretries 0) (begin (debug:print-error 0 *default-log-port* "local query failed. Trying again.") - (thread-sleep! (/ (random 5000) 1000)) ;; some random delay + (thread-sleep! (/ (pseudo-random-integer 5000) 1000)) ;; some random delay (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1))) (begin (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up") #f)) (begin @@ -946,11 +946,11 @@ (define (rmtmod:calc-ro-mode runremote *toppath*) (if (and runremote (remote-ro-mode-checked runremote)) (remote-ro-mode runremote) (let* ((dbfile (conc *toppath* "/megatest.db")) - (ro-mode (not (file-write-access? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future + (ro-mode (not (file-writable? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future (if runremote (begin (remote-ro-mode-set! runremote ro-mode) (remote-ro-mode-checked-set! runremote #t) ro-mode) Index: runsmod.scm ================================================================== --- runsmod.scm +++ runsmod.scm @@ -36,23 +36,24 @@ (declare (uses itemsmod)) (module runsmod * -(import scheme chicken data-structures extras ports files) - -(use (prefix base64 base64:) +(import scheme chicken.base chicken.random chicken.port chicken.file chicken.string) +(import chicken.time chicken.condition chicken.process chicken.process-context.posix chicken.process-context) +(import system-information chicken.process.signal chicken.sort chicken.file.posix chicken.io chicken.time.posix chicken.pretty-print) +(import chicken.pathname) +(import (prefix base64 base64:) (prefix sqlite3 sqlite3:) call-with-environment-variables - csv + ;;csv directory-utils format matchable message-digest md5 - ports - posix + chicken.port regex srfi-1 srfi-1 srfi-13 srfi-18 @@ -96,11 +97,11 @@ waitons testmode newtal itemmaps prereqs-not-met) (define (set-item-env-vars itemdat) (for-each (lambda (item) (debug:print 2 *default-log-port* "setenv " (car item) " " (cadr item)) - (setenv (car item) (cadr item))) + (set-environment-variable! (car item) (cadr item))) itemdat)) ;; Every time can-run-more-tests is called increment the delay ;; ;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine @@ -327,11 +328,11 @@ (keyvals (keys:target->keyval keys target)) (run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name))) ;; (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config")) (dbfile (conc *toppath* "/megatest.db")) - (readonly-mode (not (file-write-access? dbfile))) + (readonly-mode (not (file-writable? dbfile))) (test-records (make-hash-table)) ;; need to process runconfigs before generating these lists (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names #f) ;; (hash-table-keys all-tests-registry)) (test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts)) @@ -494,11 +495,11 @@ (if (not (null? test-names)) ;; BEGIN test-names loop (let loop ((hed (car test-names)) ;; NOTE: This is the main loop that iterates over the test-names (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc (debug:print-info 4 *default-log-port* "\n\ntestpatt elaboration loop => hed="hed " tal="tal" test-patts="test-patts" test-names="test-names) (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening. - (setenv "MT_TEST_NAME" hed) ;; + (set-environment-variable! "MT_TEST_NAME" hed) ;; (let*-values (((waitons waitors config) (tests:get-waitons hed all-tests-registry)) ;; NOTE: Have the config - can extract [waitons] section ((hed-mode) @@ -785,12 +786,12 @@ (and (member 'toplevel testmode) (null? non-completed))) (debug:print-info 4 *default-log-port* "cond branch - " "ei-2") (debug:print-info 4 *default-log-port* "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))") (let ((test-name (tests:testqueue-get-testname test-record))) - (setenv "MT_TEST_NAME" test-name) ;; - (setenv "MT_RUNNAME" runname) + (set-environment-variable! "MT_TEST_NAME" test-name) ;; + (set-environment-variable! "MT_RUNNAME" runname) (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process (let ((items-list (items:get-items-from-config tconfig))) (if (list? items-list) (begin (if (null? items-list) @@ -1916,11 +1917,11 @@ (val (cdr vardat))) (if (not (equal? (get-environment-variable var) val)) (handle-exceptions exn (debug:print-error 0 *default-log-port* "Failed to set " var " to " val) - (setenv var val))))) + (set-environment-variable! var val))))) all-vars) )) ;;====================================================================== ;; END OF NEW STUFF @@ -2067,11 +2068,11 @@ (bup-mutex (make-mutex)) (keep-records (args:get-arg "-keep-records"))) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode". (let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs)) (dbfile (conc *toppath* "/megatest.db")) - (readonly-mode (not (file-write-access? dbfile)))) + (readonly-mode (not (file-writable? dbfile)))) (when (and readonly-mode (member action write-access-actions)) (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .") (exit 1))) @@ -2873,16 +2874,16 @@ (thread-sleep! 5) (if (process:alive? pid) (process-signal pid signal/kill))))) ;; (call-with-environment-variables (let ((old-targethost (getenv "TARGETHOST"))) - (setenv "TARGETHOST" hostname) - (setenv "TARGETHOST_LOGF" "server-kills.log") + (set-environment-variable! "TARGETHOST" hostname) + (set-environment-variable! "TARGETHOST_LOGF" "server-kills.log") (system (conc "nbfake kill " pid)) - (if old-targethost (setenv "TARGETHOST" old-targethost)) - (unsetenv "TARGETHOST") - (unsetenv "TARGETHOST_LOGF")))) + (if old-targethost (set-environment-variable! "TARGETHOST" old-targethost)) + (unset-environment-variable! "TARGETHOST") + (unset-environment-variable! "TARGETHOST_LOGF")))) (debug:print-error 0 *default-log-port* "no record or improper record for " target "/" run-name " in tasks_queue in main.db")))) records))) (define (task:get-run-times) (let* ( @@ -3543,11 +3544,11 @@ (max maxload-in 0.5))) ;; so maxload must be greater than 0.5 for now BUG - FIXME? (first (car loadavg)) (next (cadr loadavg)) (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1 (loadjmp (- first next)) - (adjwait (min (+ 300 (random 10)) (abs (* (+ (random 10)(/ (- 1000 count) 10) waitdelay) (- first adjload) )) ))) ;; add some randomness to the time to break any alignment where netbatch dumps many jobs to machines simultaneously + (adjwait (min (+ 300 (pseudo-random-integer 10)) (abs (* (+ (pseudo-random-integer 10)(/ (- 1000 count) 10) waitdelay) (- first adjload) )) ))) ;; add some randomness to the time to break any alignment where netbatch dumps many jobs to machines simultaneously (debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload ", load: " first ", adjload: " adjload ", loadjmp: " loadjmp) (cond ((and (> first adjload) (> count 0)) @@ -3794,11 +3795,11 @@ (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))) + (read-only (not (file-writable? 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)) @@ -3932,11 +3933,11 @@ ;; (print "servers: " servers " ns: " ns) (if (or (and servers (null? servers)) (not servers) (and (list? servers) - (< (length servers) (random ns)))) ;; somewhere between 0 and numservers + (< (length servers) (pseudo-random-integer ns)))) ;; somewhere between 0 and numservers #f (let loop ((hed (car servers)) (tal (cdr servers))) (let ((res (server:check-server hed))) (if res @@ -3988,18 +3989,18 @@ ;; match current ip or hostname (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) (not (equal? curr-ip target-host))) (begin (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile) - (setenv "TARGETHOST" target-host))) + (set-environment-variable! "TARGETHOST" target-host))) - (setenv "TARGETHOST_LOGF" logfile) - (thread-sleep! (/ (random 5000) 1000)) ;; add about a random (up to 5 seconds) initial delay. It seems pretty common that many running tests request a server at the same time + (set-environment-variable! "TARGETHOST_LOGF" logfile) + (thread-sleep! (/ (pseudo-random-integer 5000) 1000)) ;; add about a random (up to 5 seconds) initial delay. It seems pretty common that many running tests request a server at the same time (common:wait-for-normalized-load load-limit " delaying server start due to load" target-host) ;; do not try starting servers on an already overloaded machine, just wait forever (system (conc "nbfake " cmdln)) - (unsetenv "TARGETHOST_LOGF") - (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) + (unset-environment-variable! "TARGETHOST_LOGF") + (if (get-environment-variable "TARGETHOST")(unset-environment-variable! "TARGETHOST")) (thread-join! log-rotate) (pop-directory))) ;; kind start up of servers, wait 40 seconds before allowing another server for a given ;; run-id to be launched @@ -4011,11 +4012,11 @@ (run-delay (+ (case call-num ((0) 0) ((1) 20) ((2) 300) (else 600)) - (random 5))) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously + (pseudo-random-integer 5))) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously (lock-file (conc areapath "/logs/server-start.lock"))) (if (> (- (current-seconds) when-run) run-delay) (begin (common:simple-file-lock-and-wait lock-file expire-time: 15) (server:run areapath) @@ -4089,11 +4090,11 @@ 0 (file-modification-time lockf))) ;; we started since current re-gen in flight, delay a little and try again (begin (debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it") - (thread-sleep! (+ 5 (random 5))) ;; delay between 5 and 10 seconds + (thread-sleep! (+ 5 (pseudo-random-integer 5))) ;; delay between 5 and 10 seconds (loop (common:simple-file-lock lockf)))))))))) (define (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename) (let ((counts (make-hash-table)) (statecounts (make-hash-table)) @@ -4770,11 +4771,11 @@ (let* ((targ-path (string-intersperse p "/")) (full-path (conc linktree "/" targ-path)) (run-name (car (reverse p)))) (if (and (common:file-exists? full-path) (directory? full-path) - (file-write-access? full-path)) + (file-writable? full-path)) (s:a run-name 'href (conc targ-path "/run-summary.html")) (begin (debug:print 0 *default-log-port* "INFO: Can't create " targ-path "/run-summary.html") (conc run-name " (Not able to create summary at " targ-path ")"))))))))))) (close-output-port oup) @@ -4809,11 +4810,11 @@ (tests-htree (common:list->htree tests-tree-dat)) (html-dir (conc linktree "/" (string-intersperse run-dir "/"))) (html-path (conc html-dir "/run-summary.html")) (oup (if (and (common:file-exists? html-dir) (directory? html-dir) - (file-write-access? html-dir)) + (file-writable? html-dir)) (open-output-file html-path) #f))) ;; (print "run-dir: " run-dir ", tests-tree-dat: " tests-tree-dat) (if oup (begin @@ -4841,11 +4842,11 @@ alt-file std-file)) (run-name (car (reverse p)))) (if (and (not (common:file-exists? full-targ)) (directory? full-targ) - (file-write-access? full-targ)) + (file-writable? full-targ)) (tests:summarize-test run-id (rmt:get-test-id run-id test-name item-path))) (if (common:file-exists? full-targ) (s:a run-name 'href html-file) @@ -4920,11 +4921,11 @@ (define (tests:summarize-test run-id test-id) (let* ((test-dat (rmt:get-test-info-by-id run-id test-id)) (out-dir (db:test-get-rundir test-dat)) (out-file (conc out-dir "/test-summary.html"))) ;; first verify we are able to write the output file - (if (not (file-write-access? out-dir)) + (if (not (file-writable? out-dir)) (debug:print 0 *default-log-port* "ERROR: cannot write test-summary.html to " out-dir) (let* (;; (steps-dat (rmt:get-steps-for-test run-id test-id)) (test-name (db:test-get-testname test-dat)) (item-path (db:test-get-item-path test-dat)) (full-name (db:test-make-full-name test-name item-path)) @@ -5124,11 +5125,11 @@ '()))) ;; return (conc status ": " comment) from the final section so that ;; the comment can be set in the step record in launch.scm ;; -(define (launch:load-logpro-dat run-id test-id stepname) +#;(define (launch:load-logpro-dat run-id test-id stepname) (let ((cname (conc stepname ".dat"))) (if (common:file-exists? cname) (let* ((dat (configf:read-config cname #f #f)) (csvr (db:logpro-dat->csv dat stepname)) (csvt (let-values (((fmt-cell fmt-record fmt-csv) (make-format ","))) @@ -5256,12 +5257,12 @@ (logfna (if logpro-used (conc stepname ".html") "")) (comment #f)) (if logpro-used (let ((datfile (conc stepname ".dat"))) ;; load the .dat file into the test_data table if it exists - (if (common:file-exists? datfile) - (set! comment (launch:load-logpro-dat run-id test-id stepname))) + ;;(if (common:file-exists? datfile) + ;; (set! comment (launch:load-logpro-dat run-id test-id stepname))) (rmt:test-set-log! run-id test-id (conc stepname ".html")))) (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna)) ;; set the test final status (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) (this-step-status (cond @@ -5415,12 +5416,12 @@ ;; check exit-info (vector-ref exit-info 1) (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1) (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig)) (stepname (car ezstep))) ;; if logpro-used read in the stepname.dat file - (if (and logpro-used (common:file-exists? (conc stepname ".dat"))) - (launch:load-logpro-dat run-id test-id stepname)) + ;;(if (and logpro-used (common:file-exists? (conc stepname ".dat"))) + ;; (launch:load-logpro-dat run-id test-id stepname)) (if (steprun-good? logpro-used (launch:einf-exit-code exit-info)) (if (not (null? tal)) (loop (car tal) (cdr tal) stepname)) (debug:print 0 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping"))) (debug:print 0 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep))))))))) @@ -5553,16 +5554,16 @@ (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) (link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) - (if testname (setenv "MT_TEST_NAME" testname)) - (if itempath (setenv "MT_ITEMPATH" itempath)) + (if testname (set-environment-variable! "MT_TEST_NAME" testname)) + (if itempath (set-environment-variable! "MT_ITEMPATH" itempath)) ;; get the info from the db and put it in the cache (if link-tree - (setenv "MT_LINKTREE" link-tree) + (set-environment-variable! "MT_LINKTREE" link-tree) (debug:print-error 0 *default-log-port* "linktree not set, should be set in megatest.config in [setup] section.")) (if (not vals) (let ((ht (make-hash-table))) (hash-table-set! *env-vars-by-run-id* run-id ht) (set! vals ht) @@ -5578,11 +5579,11 @@ (debug:print 2 *default-log-port* "setenv " key " " val) (safe-setenv key val))) ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1") ;;(BB> "*env-vars-by-run-id*/runid("run-id" vals="(hash-table->alist vals)) - (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) + (if (not (get-environment-variable "MT_TARGET"))(set-environment-variable! "MT_TARGET" target)) ;; we had a case where there was an exception generated by the hash-table-ref ;; due to *configdat* being #f Adding a handle and exit (let fatal-loop ((count 0)) (handle-exceptions exn @@ -5613,19 +5614,19 @@ (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block. ;;(bb-check-path msg: "runs:set-megatest-env-vars block 2") ;; Lets use this as an opportunity to put MT_RUNNAME in the environment (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) (if runname - (setenv "MT_RUNNAME" runname) + (set-environment-variable! "MT_RUNNAME" runname) (debug:print-error 0 *default-log-port* "no value for runname for id " run-id))) - (setenv "MT_RUN_AREA_HOME" *toppath*) + (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*) ;; if a testname and itempath are available set the remaining appropriate variables - (if testname (setenv "MT_TEST_NAME" testname)) - (if itempath (setenv "MT_ITEMPATH" itempath)) + (if testname (set-environment-variable! "MT_TEST_NAME" testname)) + (if itempath (set-environment-variable! "MT_ITEMPATH" itempath)) ;;(bb-check-path msg: "runs:set-megatest-env-vars block 3") (if (and testname link-tree) - (setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/" + (set-environment-variable! "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME") "/" (getenv "MT_TEST_NAME") (if (and itempath (not (equal? itempath ""))) @@ -5633,11 +5634,11 @@ "")))))) (define (launch:execute encoded-cmd) (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) (tconfigreg #f)) - (setenv "MT_CMDINFO" encoded-cmd) + (set-environment-variable! "MT_CMDINFO" encoded-cmd) ;;(bb-check-path msg: "launch:execute incoming") (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area (top-path (assoc/default 'toppath cmdinfo)) @@ -5671,11 +5672,11 @@ #f (if (substring-index "/" runscript) runscript ;; use unadultered if contains slashes (let ((fulln (conc work-area "/" runscript))) (if (and (common:file-exists? fulln) - (file-execute-access? fulln)) + (file-executable? fulln)) fulln runscript))))) ;; assume it is on the path (check-work-area (lambda () ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) @@ -5712,31 +5713,31 @@ (launch:test-copy testpath work-area)))) ;; one more time, change to the work-area directory (change-directory work-area))) ) ;; let* - (if contour (setenv "MT_CONTOUR" contour)) + (if contour (set-environment-variable! "MT_CONTOUR" contour)) ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ... ;; - (setenv "MT_TESTSUITENAME" areaname) - (setenv "MT_RUN_AREA_HOME" top-path) + (set-environment-variable! "MT_TESTSUITENAME" areaname) + (set-environment-variable! "MT_RUN_AREA_HOME" top-path) (set! *toppath* top-path) (change-directory *toppath*) ;; temporarily switch to the run area home - (setenv "MT_TEST_RUN_DIR" work-area) + (set-environment-variable! "MT_TEST_RUN_DIR" work-area) (launch:setup) ;; should be properly in the run area home now - (if contour (setenv "MT_CONTOUR" contour)) + (if contour (set-environment-variable! "MT_CONTOUR" contour)) ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ... ;; - (setenv "MT_TESTSUITENAME" areaname) - (setenv "MT_RUN_AREA_HOME" top-path) + (set-environment-variable! "MT_TESTSUITENAME" areaname) + (set-environment-variable! "MT_RUN_AREA_HOME" top-path) (set! *toppath* top-path) (change-directory *toppath*) ;; temporarily switch to the run area home - (setenv "MT_TEST_RUN_DIR" work-area) + (set-environment-variable! "MT_TEST_RUN_DIR" work-area) (launch:setup) ;; should be properly in the run area home now (set! tconfigreg (tests:get-all)) ;; mapping of testname => test source path (let ((sighand (lambda (signum) @@ -5860,19 +5861,19 @@ (let ((varval (string-split varpair "="))) (if (eq? (length varval) 2) (let ((var (car varval)) (val (cadr varval))) (debug:print 1 *default-log-port* "Adding pre-var/val " var " = " val " to the environment") - (setenv var val))))) + (set-environment-variable! var val))))) varpairs))) ;;(bb-check-path msg: "launch:execute post block 2") (for-each (lambda (varval) (let ((var (car varval)) (val (cadr varval))) (if val - (setenv var val) + (set-environment-variable! var val) (begin (debug:print-error 0 *default-log-port* "required variable " var " does not have a valid value. Exiting") (exit))))) (list (list "MT_TEST_RUN_DIR" work-area) @@ -5884,11 +5885,11 @@ (list "MT_TARGET" target) (list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) ;;(bb-check-path msg: "launch:execute post block 3") - (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) + (if mt-bindir-path (set-environment-variable! "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) ;;(bb-check-path msg: "launch:execute post block 4") ;; (change-directory top-path) ;; Can setup as client for server mode now ;; (client:setup) @@ -5903,11 +5904,11 @@ (let ((blacklist (configf:lookup *configdat* "setup" "blacklistvars"))) (if blacklist (let ((vars (string-split blacklist))) (save-environment-as-files "megatest" ignorevars: vars) (for-each (lambda (var) - (unsetenv var)) + (unset-environment-variable! var)) vars)) (save-environment-as-files "megatest"))) ;;(bb-check-path msg: "launch:execute post block 44") ;; open-run-close not needed for test-set-meta-info ;; (tests:set-full-meta-info #f test-id run-id 0 work-area) @@ -5918,11 +5919,11 @@ (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (common:file-exists? fullrunscript) - (not (file-execute-access? fullrunscript))) + (not (file-executable? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) ;; We are about to actually kick off the test ;; so this is a good place to remove the records for ;; any previous runs @@ -5930,11 +5931,11 @@ ;; now is also a good time to write the .testconfig file (let* ((tconfig-fname (conc work-area "/.testconfig")) (tconfig-tmpfile (conc tconfig-fname ".tmp")) (tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t))) ;; 'return-procs))) (configf:write-alist tconfig tconfig-tmpfile) - (file-move tconfig-tmpfile tconfig-fname #t)) + (move-file tconfig-tmpfile tconfig-fname #t)) ;; (let* ((m (make-mutex)) (kill-job? #f) (exit-info (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status (job-thread #f) @@ -6195,11 +6196,11 @@ (set! toppath *toppath*) (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*) + (set-environment-variable! "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 (rmt:get-keys)) (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* @@ -6210,11 +6211,11 @@ 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))) + (set-environment-variable! (car kt) (cadr kt))) key-vals) (configf: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)) @@ -6289,12 +6290,12 @@ (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))) + (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*) + (set-environment-variable! "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)) @@ -6322,11 +6323,11 @@ (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)) + (file-readable? cfname)) (configf: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)) @@ -7083,28 +7084,28 @@ (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)) (sections (if target (list "default" target) #f)) (data (begin - (setenv "MT_RUN_AREA_HOME" *toppath*) + (set-environment-variable! "MT_RUN_AREA_HOME" *toppath*) (if key-vals (for-each (lambda (kt) - (setenv (car kt) (cadr kt))) + (set-environment-variable! (car kt) (cadr kt))) 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) Index: serialize-env.scm ================================================================== --- serialize-env.scm +++ serialize-env.scm @@ -1,7 +1,7 @@ -(use z3) -(use base64) +(import z3) +(import chicken.port chicken.process-context chicken.pretty-print base64) (let* ((env-str (with-output-to-string (lambda () (pp (get-environment-variables))))) (zipped-env-str (z3:encode-buffer env-str)) (b64-env-str (base64-encode zipped-env-str))) (print b64-env-str)) Index: servermod.scm ================================================================== --- servermod.scm +++ servermod.scm @@ -26,14 +26,17 @@ (declare (uses tasksmod)) (module servermod * -(import scheme chicken data-structures extras files) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 - srfi-69 format ports srfi-1 matchable +(import scheme (chicken base) (chicken file) (chicken condition)) +(import (prefix sqlite3 sqlite3:) typed-records srfi-18 + srfi-69 format (chicken port) srfi-1 matchable directory-utils md5 message-digest regex + chicken.file.posix chicken.io chicken.sort chicken.time chicken.string + chicken.process chicken.process-context chicken.process-context.posix + chicken.random system-information stack) (import commonmod) (import dbmod) (import tasksmod) (import (prefix mtargs args:)) @@ -90,11 +93,11 @@ ;; clear out junk records ;; ((dejunk) (db:delay-if-busy mtdb) ;; ok to delay on mtdb - (when (file-write-access? (db:dbdat-get-path mtdb)) (db:clean-up mtdb)) + (when (file-writable? (db:dbdat-get-path mtdb)) (db:clean-up mtdb)) (db:clean-up tmpdb) (db:clean-up refndb)) ;; sync runs, test_meta etc. ;; @@ -189,11 +192,11 @@ ;; if the directory exists continue to get the list ;; otherwise attempt to create the logs dir and then ;; continue (if (if (directory-exists? (conc areapath "/logs")) '() - (if (file-write-access? areapath) + (if (file-writable? areapath) (begin (condition-case (create-directory (conc areapath "/logs") #t) (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs"))) (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list."))) @@ -288,11 +291,11 @@ (> (- now start-time) 0) ;; been running at least 0 seconds (< (- now mod-time) 16) ;; still alive - file touched in last 16 seconds (< (- now start-time) (+ (- (string->number (or (configf:lookup *configdat* "server" "runtime") "3600")) 180) - (random 360))) ;; under one hour running time +/- 180 + (pseudo-random-integer 360))) ;; under one hour running time +/- 180 )) #f)) srvlst) (lambda (a b) (< (list-ref a 3) @@ -311,11 +314,11 @@ (define (server:get-rand-best areapath) (let ((srvrs (server:get-best (server:get-list areapath)))) (if (and (list? srvrs) (not (null? srvrs))) (let* ((len (length srvrs)) - (idx (random len))) + (idx (pseudo-random-integer len))) (list-ref srvrs idx)) #f))) (define (server:record->url servr) Index: sharedat.scm ================================================================== --- sharedat.scm +++ sharedat.scm @@ -119,11 +119,11 @@ (exit 1))) (if (and path (directory? path) (file-read-access? path)) (let* ((dbpath (conc path "/spublish.db")) - (writeable (file-write-access? dbpath)) + (writeable (file-writable? dbpath)) (dbexists (file-exists? dbpath))) (handle-exceptions exn (begin (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath Index: subrunmod.scm ================================================================== --- subrunmod.scm +++ subrunmod.scm @@ -24,13 +24,14 @@ (declare (uses mtconfigf)) (module subrunmod * -(import scheme (chicken base)) -(use (prefix sqlite3 sqlite3:) typed-records srfi-18 - srfi-69 format (chicken port) srfi-1 matchable irregex +(import scheme (chicken base) chicken.file chicken.file.posix chicken.string ) +(import (prefix sqlite3 sqlite3:) typed-records srfi-18 + srfi-69 chicken.format (chicken port) srfi-1 matchable chicken.irregex + chicken.process chicken.process-context chicken.time call-with-environment-variables) (import commonmod) (import (prefix mtconfigf configf:)) Index: testsmod.scm ================================================================== --- testsmod.scm +++ testsmod.scm @@ -28,14 +28,14 @@ (declare (uses dbmod)) (module testsmod * -(import scheme chicken data-structures extras files) - -(use (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 - format ports srfi-1 matchable +(import scheme chicken.base chicken.file chicken.string chicken.process chicken.condition chicken.process-context) +(import chicken.sort chicken.file.posix chicken.io chicken.pathname chicken.process-context.posix) +(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 + chicken.format chicken.port srfi-1 matchable directory-utils regex srfi-13) (import commonmod) @@ -82,11 +82,11 @@ (define (keys:target-set-args keys target ht) (if target (let ((vals (string-split target "/"))) (if (eq? (length vals)(length keys)) (for-each (lambda (key val) - (setenv key val) + (set-environment-variable! key val) (if ht (hash-table-set! ht (conc ":" key) val))) keys vals) (debug:print-error 0 *default-log-port* "wrong number of values in " target ", should match " keys)) vals) @@ -521,11 +521,11 @@ (conc *toppath* "/tests/" test-name))) (test-configf (conc test-path "/testconfig")) (testexists (let loopa ((tries-left 30)) (cond ( - (and (common:file-exists? test-configf)(file-read-access? test-configf)) + (and (common:file-exists? test-configf)(file-readable? test-configf)) #t) ( (common:file-exists? test-configf) (debug:print 0 *default-log-port* "WARNING: Cannot read testconfig file: "test-configf) #f) @@ -545,11 +545,11 @@ #f))) (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data (if tcfg (hash-table-set! *testconfigs* test-full-name tcfg)) (if (and testexists cache-file - (file-write-access? cache-path) + (file-writable? cache-path) allow-write-cache) (let ((tpath (conc cache-path "/.testconfig"))) (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) (if (and tcfg (not (common:in-running-test?))) (configf:write-alist tcfg tpath)))) @@ -654,11 +654,11 @@ (let ((res (read-lines))) ;; (delete-file temp-path) res)))))) (define (tests:write-dot-file test-records fname sizex sizey) - (if (file-write-access? (pathname-directory fname)) + (if (file-writable? (pathname-directory fname)) (with-output-to-file fname (lambda () (map print (tests:tests->dot test-records sizex sizey)))))) (define (tests:tests->dot test-records sizex sizey) Index: ulex/ulex.scm ================================================================== --- ulex/ulex.scm +++ ulex/ulex.scm @@ -28,11 +28,11 @@ ;; (use rpc pkts mailbox sqlite3) (module ulex * -(import scheme posix-groups (chicken base) queues (chicken port) (chicken io) (chicken file) mailbox system-information) +(import scheme (chicken base) queues (chicken port) (chicken io) (chicken file) mailbox system-information) (import srfi-18 pkts matchable regex typed-records srfi-69 srfi-1 srfi-4 regex-case (prefix sqlite3 sqlite3:) (chicken foreign) Index: vg-inc.scm ================================================================== --- vg-inc.scm +++ vg-inc.scm @@ -371,20 +371,20 @@ b)) ;; Obsolete function ;; (define (vg:generate-color) - (vg:rgb->number (random 255) - (random 255) - (random 255))) + (vg:rgb->number (pseudo-random-integer 255) + (pseudo-random-integer 255) + (pseudo-random-integer 255))) ;; Need to return a string of random iup-color for graph ;; (define (vg:generate-color-rgb) - (conc (number->string (random 255)) " " - (number->string (random 255)) " " - (number->string (random 255)))) + (conc (number->string (pseudo-random-integer 255)) " " + (number->string (pseudo-random-integer 255)) " " + (number->string (pseudo-random-integer 255)))) (define (vg:iup-color->number iup-color) (apply vg:rgb->number (map string->number (string-split iup-color)))) ;;====================================================================== Index: vg_records.scm ================================================================== --- vg_records.scm +++ vg_records.scm @@ -17,11 +17,11 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; -(use simple-exceptions) +(import simple-exceptions) (define vg:lib-exn (make-exception "wrong record type, expected vg:lib." 'assert)) (define (pmake-vg:lib . params)(let ((v (if (null? params)(make-vector 2)(apply vector 'vg:lib params)))) v)) (define (make-vg:lib #!key (comps #f) ) @@ -30,11 +30,11 @@ (define-inline (vg:lib-comps vec)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-ref vec 1)(raise (vg:lib-exn 'vg:lib-comps 'xpr)))) (define-inline (vg:lib-comps-set! vec val)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-set! vec 1 val)(raise (vg:lib-exn 'comps)))) ;; Generated using make-vector-record -safe vg comp objs name file -(use simple-exceptions) +(import simple-exceptions) (define vg:comp-exn (make-exception "wrong record type, expected vg:comp." 'assert)) (define (pmake-vg:comp . params)(let ((v (if (null? params)(make-vector 4)(apply vector 'vg:comp params)))) v)) (define (make-vg:comp #!key (objs #f) (name #f) @@ -49,11 +49,11 @@ (define-inline (vg:comp-objs-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 1 val)(raise (vg:comp-exn 'objs)))) (define-inline (vg:comp-name-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 2 val)(raise (vg:comp-exn 'name)))) (define-inline (vg:comp-file-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 3 val)(raise (vg:comp-exn 'file)))) ;; Generated using make-vector-record -safe vg obj type pts fill-color text line-color call-back angle font attrib extents proc -(use simple-exceptions) +(import simple-exceptions) (define vg:obj-exn (make-exception "wrong record type, expected vg:obj." 'assert)) (define (pmake-vg:obj . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:obj params)))) v)) (define (make-vg:obj #!key (type #f) (pts #f) @@ -92,11 +92,11 @@ (define-inline (vg:obj-attrib-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 9 val)(raise (vg:obj-exn 'attrib)))) (define-inline (vg:obj-extents-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 10 val)(raise (vg:obj-exn 'extents)))) (define-inline (vg:obj-proc-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 11 val)(raise (vg:obj-exn 'proc)))) ;; Generated using make-vector-record -safe vg inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache -(use simple-exceptions) +(import simple-exceptions) (define vg:inst-exn (make-exception "wrong record type, expected vg:inst." 'assert)) (define (pmake-vg:inst . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:inst params)))) v)) (define (make-vg:inst #!key (libname #f) (compname #f) @@ -135,11 +135,11 @@ (define-inline (vg:inst-mirry-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 9 val)(raise (vg:inst-exn 'mirry)))) (define-inline (vg:inst-call-back-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 10 val)(raise (vg:inst-exn 'call-back)))) (define-inline (vg:inst-cache-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 11 val)(raise (vg:inst-exn 'cache)))) ;; Generated using make-vector-record -safe vg drawing libs insts scalex scaley xoff yoff cnv cache -(use simple-exceptions) +(import simple-exceptions) (define vg:drawing-exn (make-exception "wrong record type, expected vg:drawing." 'assert)) (define (pmake-vg:drawing . params)(let ((v (if (null? params)(make-vector 9)(apply vector 'vg:drawing params)))) v)) (define (make-vg:drawing #!key (libs #f) (insts #f)