Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -18,16 +18,16 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;;====================================================================== -(use srfi-69 posix) - -(declare (unit api)) -(declare (uses rmt)) -(declare (uses db)) -(declare (uses tasks)) +;; (use srfi-69 posix) +;; +;; (declare (unit api)) +;; (declare (uses rmt)) +;; (declare (uses db)) +;; (declare (uses tasks)) ;; allow these queries through without starting a server ;; (define api:read-only-queries '(get-key-val-pairs Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -15,20 +15,20 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') - -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18) - -(declare (unit archive)) -(declare (uses db)) -(declare (uses common)) - -(include "common_records.scm") -(include "db_records.scm") - +;; +;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18) +;; +;; (declare (unit archive)) +;; (declare (uses db)) +;; (declare (uses common)) +;; +;; (include "common_records.scm") +;; (include "db_records.scm") +;; ;;====================================================================== ;; ;;====================================================================== ;; NOT CURRENTLY USED @@ -39,11 +39,11 @@ (maxload 1.5) ;; max allowed load for this work (adisks (archive:get-archive-disks))) ;; get testdir size ;; - hand off du to job mgr (if (and (common:file-exists? testdir) - (file-is-writable? testdir)) + (file-writable? testdir)) (let* ((dused (jobrunner:run-job flavor ;; machine type maxload ;; max allowed load '() ;; prevars - environment vars to set for the job common:get-disk-space-used ;; if a proc call it, if a string it is a unix command ADDED autoload/autoload.egg Index: autoload/autoload.egg ================================================================== --- /dev/null +++ autoload/autoload.egg @@ -0,0 +1,5 @@ +((license "BSD") + (category lang-exts) + (author "Alex Shinn") + (synopsis "Load modules lazily") + (components (extension autoload))) ADDED autoload/autoload.meta Index: autoload/autoload.meta ================================================================== --- /dev/null +++ autoload/autoload.meta @@ -0,0 +1,9 @@ +;;; autoload.meta -*- Hen -*- + +((egg "autoload.egg") + (synopsis "Load modules lazily") + (category lang-exts) + (license "BSD") + (author "Alex Shinn") + (doc-from-wiki) + (files "autoload.meta" "autoload.scm" "autoload.release-info" "autoload.setup")) ADDED autoload/autoload.scm Index: autoload/autoload.scm ================================================================== --- /dev/null +++ autoload/autoload.scm @@ -0,0 +1,93 @@ +;;;; autoload.scm -- load modules lazily +;; +;; Copyright (c) 2005-2009 Alex Shinn +;; All rights reserved. +;; +;; BSD-style license: http://www.debian.org/misc/bsd.license + +;; Provides an Emacs-style autoload facility which takes the basic form +;; +;; (autoload unit procedure-name ...) +;; +;; such that the first time procedure-name is called, it will perform a +;; runtime require of 'unit and then apply the procedure from the newly +;; loaded unit to the args it was passed. Subsequent calls to +;; procedure-name will thereafter refer to the new procedure and will +;; thus not incur any overhead. +;; +;; You may also specify an alias for the procedure, and a default +;; procedure if the library can't be loaded: +;; +;; (autoload unit (name alias default) ...) +;; +;; In this case, although the procedure name from the unit is "name," +;; the form defines the autoload procedure as "alias." +;; +;; If the library can't be loaded then an error is signalled, unless +;; default is given, in which case the values are passed to that. +;; +;; Examples: +;; +;; ;; load iconv procedures lazily +;; (autoload iconv iconv iconv-open) +;; +;; ;; load some sqlite procedures lazily with "-" names +;; (autoload sqlite (sqlite:open sqlite-open) +;; (sqlite:execute sqlite-execute)) +;; +;; ;; load md5 library, falling back on slower scheme version +;; (autoload scheme-md5 (md5:digest scheme-md5:digest)) +;; (autoload md5 (md5:digest #f scheme-md5:digest)) + +(module autoload (autoload) + +(import scheme (chicken base)) + +(define-syntax autoload + (er-macro-transformer + (lambda (expr rename compare) + (let ((module (cadr expr)) + (procs (cddr expr)) + (_import (rename 'import)) + (_define (rename 'define)) + (_let (rename 'let)) + (_set! (rename 'set!)) + (_begin (rename 'begin)) + (_apply (rename 'apply)) + (_args (rename 'args)) + (_tmp (rename 'tmp)) + (_eval (rename 'eval)) + (_condition-case (rename 'condition-case))) + `(,_begin + ,@(map + (lambda (x) + (let* ((x (if (pair? x) x (list x))) + (name (car x)) + (full-name + (string->symbol + (string-append (symbol->string module) "#" + (symbol->string name)))) + (alias (or (and (pair? (cdr x)) (cadr x)) name)) + (default (and (pair? (cdr x)) (pair? (cddr x)) (caddr x)))) + (if default + `(,_define (,alias . ,_args) + (,_let ((,_tmp (,_condition-case + (,_begin + (,_eval + (begin (require-library ,module) + #f)) + (,_eval ',full-name)) + (exn () ,default)))) + (,_set! ,alias ,_tmp) + (,_apply ,_tmp ,_args))) + `(,_define (,alias . ,_args) + (,_let ((,_tmp (,_begin + (,_eval + (begin (require-library ,module) + #f)) + (,_eval ',full-name)))) + (,_set! ,alias ,_tmp) + (,_apply ,_tmp ,_args)))))) + procs)))))) + +) ADDED autoload/autoload.setup Index: autoload/autoload.setup ================================================================== --- /dev/null +++ autoload/autoload.setup @@ -0,0 +1,7 @@ + +(compile -s -O2 -j autoload autoload.scm) +(compile -s -O2 autoload.import.scm) + +(install-extension + 'autoload '("autoload.so" "autoload.import.so") + '((version 3.0) (syntax))) Index: call-with-environment-variables/call-with-environment-variables-core.scm ================================================================== --- call-with-environment-variables/call-with-environment-variables-core.scm +++ call-with-environment-variables/call-with-environment-variables-core.scm @@ -8,11 +8,11 @@ (cons var (get-environment-variable var)))) variables))) (dynamic-wind (lambda () (void)) (lambda () - (use posix) +;; (use posix) (for-each (lambda (var-value) (setenv (car var-value) (cdr var-value))) variables) (thunk)) (lambda () Index: call-with-environment-variables/call-with-environment-variables.scm ================================================================== --- call-with-environment-variables/call-with-environment-variables.scm +++ call-with-environment-variables/call-with-environment-variables.scm @@ -1,7 +1,10 @@ (module call-with-environment-variables (call-with-environment-variables) - (import scheme chicken) + (import scheme + chicken.base + chicken.process-context + ) - (include "call-with-environment-variables-core.scm")) + (include "call-with-environment-variables/call-with-environment-variables-core.scm")) Index: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ cgisetup/models/pgdb.scm @@ -16,25 +16,25 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -(declare (unit pgdb)) -(declare (uses configf)) - -;; I don't know how to mix compilation units and modules, so no module here. -;; -;; (module pgdb -;; ( -;; open-pgdb -;; ) -;; -;; (import scheme) -;; (import data-structures) -;; (import chicken) - -(use typed-records (prefix dbi dbi:)) +;; (declare (unit pgdb)) +;; (declare (uses configf)) +;; +;; ;; I don't know how to mix compilation units and modules, so no module here. +;; ;; +;; ;; (module pgdb +;; ;; ( +;; ;; open-pgdb +;; ;; ) +;; ;; +;; ;; (import scheme) +;; ;; (import data-structures) +;; ;; (import chicken) +;; +;; (use typed-records (prefix dbi dbi:)) ;; given a configdat lookup the connection info and open the db ;; (define (pgdb:open configdat #!key (dbname #f)(dbispec #f)) (let ((pgconf (or dbispec Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -18,22 +18,22 @@ ;;====================================================================== ;; 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 tasks)) ;; tasks are where stuff is maintained about what is running. - -(include "common_records.scm") -(include "db_records.scm") +;; (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 tasks)) ;; tasks are where stuff is maintained about what is running. +;; +;; (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)))) @@ -123,8 +123,8 @@ ))) (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. + (thread-sleep! 1) ;; (+ 5 (pseudo-random-integer (- 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 @@ -16,24 +16,24 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -(use srfi-1 data-structures posix regex-case (prefix base64 base64:) - format dot-locking csv-xml z3 udp ;; sql-de-lite - hostinfo md5 message-digest typed-records directory-utils stack - matchable regex posix (srfi 18) extras ;; tcp - (prefix nanomsg nmsg:) - (prefix sqlite3 sqlite3:) - pkts (prefix dbi dbi:) - ) - -(declare (unit common)) -;; (declare (uses commonmod)) -;; (import commonmod) - -(include "common_records.scm") +;; (use srfi-1 data-structures posix regex-case (prefix base64 base64:) +;; format dot-locking csv-xml z3 udp ;; sql-de-lite +;; hostinfo md5 message-digest typed-records directory-utils stack +;; matchable regex posix (srfi 18) extras ;; tcp +;; (prefix nanomsg nmsg:) +;; (prefix sqlite3 sqlite3:) +;; pkts (prefix dbi dbi:) +;; ) +;; +;; (declare (unit common)) +;; ;; (declare (uses commonmod)) +;; ;; (import commonmod) +;; +;; (include "common_records.scm") ;; (require-library margs) ;; (include "margs.scm") @@ -199,26 +199,31 @@ ;; Miscellaneous (define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers (define *numcpus-cache* (make-hash-table)) -(use posix-extras pathname-expand files) +;; (use posix-extras pathname-expand files) ;; this plugs a hole in posix-extras in recent chicken versions > 4.9) -(let-values (( (chicken-release-number chicken-major-version) - (apply values - (map string->number - (take - (string-split (chicken-version) ".") - 2))))) - (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")) )) +;; (let-values (( (chicken-release-number chicken-major-version) +;; (apply values +;; (map string->number +;; (take +;; (string-split (chicken-version) ".") +;; 2))))) +;; (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 (realpath x)(pathname-expand (or x "/dev/null")) ) +(define (realpath x) + (with-input-from-pipe + (string-append "readlink -f \""x"\"") + read-line)) (define (common:get-this-exe-fullpath #!key (argv (argv))) (let* ((this-script (cond ((and (> (length argv) 2) @@ -592,11 +597,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)) @@ -1205,11 +1210,11 @@ (if (null? dirs) #f (let loop ((hed (car dirs)) (tal (cdr dirs))) (let ((res (or (and (directory? hed) - (file-write-access? hed) + (file-writable? hed) hed) (handle-exceptions exn (begin (debug:print-info 0 *default-log-port* "could not create " hed @@ -1362,11 +1367,11 @@ 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)) + (file-writable? path-string)) path-string #f))) (define (common:get-linktree) (or (getenv "MT_LINKTREE") @@ -1469,11 +1474,11 @@ ((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*) + (if (file-writable? *toppath*) (begin (with-output-to-file hhf (lambda () (print bestadrs))) (begin @@ -1856,11 +1861,11 @@ (delfile (lambda (exn) (debug:print-info 1 *default-log-port* " removing bad file " fullpath ", exn=" exn) (delete-file* fullpath) #f))) (if (and (file-exists? fullpath) - (file-read-access? fullpath)) + (file-readable? fullpath)) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "failed to get cached info from " fullpath ", exn=" exn) #f) @@ -2162,11 +2167,11 @@ (define (common:get-num-cpus remote-host) (let* ((actual-host (or remote-host (get-host-name)))) ;; hosts had better not be changing the number of cpus too often! (or (hash-table-ref/default *numcpus-cache* actual-host #f) - (let* ((numcpus (or (common:get-cached-info actual-host "num-cpus" age: (+ 2592000 (random 3600))) + (let* ((numcpus (or (common:get-cached-info actual-host "num-cpus" age: (+ 2592000 (pseudo-random-integer 3600))) (let* ((proc (lambda () (let loop ((numcpu 0) (inl (read-line))) (if (eof-object? inl) (if (> numcpu 0) @@ -2194,11 +2199,11 @@ (define (common:wait-for-normalized-load maxnormload msg remote-host #!optional (rem-tries 5)) (let ((num-cpus (common:get-num-cpus remote-host))) (if num-cpus (common:wait-for-cpuload maxnormload num-cpus 15 msg: msg remote-host: remote-host) (begin - (thread-sleep! (random 60)) ;; we failed to get num cpus. wait a bit and try again + (thread-sleep! (pseudo-random-integer 60)) ;; we failed to get num cpus. wait a bit and try again (if (> rem-tries 0) (common:wait-for-normalized-load maxnormload msg remote-host (- rem-tries 1)) #f))))) ;;====================================================================== @@ -2273,11 +2278,11 @@ ;; overloaded and count expired (i.e. went to zero) (else (if (> num-tries 0) ;; should be "num-tries-left". (if (common:low-noise-print 30 (conc (round effective-load) "-load-acceptable-" effective-host)) (debug:print 0 *default-log-port* "Load on " effective-host " is acceptable at effective normalized load of " - effective-normalized-load " continuing.")) + normalized-effective-load " continuing.")) (debug:print 0 *default-log-port* "Load on " effective-host ", " first" could not be retrieved. Giving up and continuing.")))))) ;;====================================================================== ;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load @@ -2303,11 +2308,11 @@ ;; 0 ;; next))) ;; we will force a conservative calculation any time next is large. ;; (first-next-avg (/ (+ first next) 2)) ;; ;; add some randomness to the time to break any alignment ;; ;; where netbatch dumps many jobs to machines simultaneously -;; (adjwait (min (+ 300 (random 10)) (abs (* (+ (random 10) +;; (adjwait (min (+ 300 (pseudo-random-integer 10)) (abs (* (+ (pseudo-random-integer 10) ;; (/ (- 1000 count) 10) ;; waitdelay) ;; (- first adjmaxload) )))) ;; (load-jump-limit (configf:lookup-number *configdat* "setup" "load-jump-limit")) ;; ;; effective load accounts for load jumps, this should elminate all the first-next-avg, adjwait, load-jump-limit @@ -2317,11 +2322,11 @@ ;; (normalized-effective-load (/ effective-load numcpus)) ;; (will-wait (> normalized-effective-load maxload))) ;; ;; ;; let's let the user know once in a long while that load checking ;; ;; is happening but not constantly report it -;; #;(if (common:low-noise-print 30 (conc "cpuload" (or remote-host "localhost"))) ;; (> (random 100) 75) ;; about 25% of the time +;; #;(if (common:low-noise-print 30 (conc "cpuload" (or remote-host "localhost"))) ;; (> (pseudo-random-integer 100) 75) ;; about 25% of the time ;; (debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload ;; ", load: " first ", adjmaxload: " adjmaxload ", loadjmp: " loadjmp)) ;; ;; (debug:print-info 1 *default-log-port* ;; "On host: " effective-host @@ -2505,11 +2510,11 @@ (freespc (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)) + ((not (file-writable? 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) @@ -2520,11 +2525,11 @@ (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)) + ((not (file-writable? 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) @@ -3496,11 +3501,11 @@ (cond ((not (common:file-exists? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory " pktsdir " does not exist.")) ((not (directory? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not a directory.")) - ((not (file-read-access? pktsdir)) + ((not (file-readable? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not readable.")) (else (debug:print-info 0 *default-log-port* "Loading packets found in " pktsdir) (let ((pkts (glob (conc pktsdir "/*.pkt")))) (for-each @@ -3611,10 +3616,28 @@ #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 (dtests:get-pre-command #!key (default-override #f)) + (let* ((orig-pre-command "export CMD='") + (viewscreen-pre-command "viewscreen ") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) + (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \"")) + + +(define (dtests:get-post-command #!key (default-override #f)) + (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" + "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) + (viewscreen-post-command "") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) + (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;;====================================================================== ;; (define *common:telemetry-log-state* 'startup) ;; (define *common:telemetry-log-socket* #f) ;; ;; (define (common:telemetry-log-open) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -20,17 +20,17 @@ ;;====================================================================== ;; Config file handling ;;====================================================================== -(use regex regex-case matchable) ;; directory-utils) -(declare (unit configf)) -(declare (uses process)) -(declare (uses env)) -(declare (uses keys)) - -(include "common_records.scm") +;; (use regex regex-case matchable) ;; directory-utils) +;; (declare (unit configf)) +;; (declare (uses process)) +;; (declare (uses env)) +;; (declare (uses keys)) +;; +;; (include "common_records.scm") ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) (if toppath (let ((cfname (conc toppath "/" configname))) @@ -358,11 +358,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 (common:file-exists? include-script)(file-executable? 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 @@ -717,11 +717,11 @@ ;; 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)) (list #f (conc "ERROR: no refdb found at " refdb-path)) - (if (not (file-read-access? sheets-file)) + (if (not (file-readable? sheets-file)) (list #f (conc "ERROR: refdb file not readable at " refdb-path)) (let* ((sheets (with-input-from-file sheets-file (lambda () (let loop ((inl (read-line)) (res '())) Index: csv-xml/csv-xml.scm ================================================================== --- csv-xml/csv-xml.scm +++ csv-xml/csv-xml.scm @@ -28,46 +28,56 @@ #;list->sxml ; csv-writer? check-csv-writer error-csv-writer csv-writer-spec? check-csv-writer-spec error-csv-writer-spec) -(import scheme) +(import scheme + chicken.base + chicken.string + + moremacros + srfi-1 + srfi-13 + srfi-14 + type-checks + unicode-utils + ) #;(import (except chicken provide)) -(import chicken) +;; (import chicken) ;;; ;Need to process `#lang' as well. So just "commented out" the "offending" ;sections in the source. #;(define-syntax provide (syntax-rules () ((_ ?x0 ...) (begin)))) (define null '()) -(include "csv.ss") +(include "csv-xml/csv.ss") ;;; -(import (only data-structures conc intersperse ->string alist-ref string-translate*)) -(require-library data-structures) - -#;(import (only list-utils alist?)) -(import (only (srfi 1) every iota append! map)) -(require-library (srfi 1)) - -(import (only (srfi 13) string-index)) -(require-library (srfi 13)) - -(import (only (srfi 14) char-set:iso-control)) -(require-library (srfi 14)) - -(import (only type-checks define-check+error-type check-string check-list)) -(require-library type-checks) - -(import (only unicode-utils unicode-char->string)) -(require-library unicode-utils) - -(require-extension moremacros) +;; (import (only data-structures conc intersperse ->string alist-ref string-translate*)) +;; (require-library data-structures) +;; +;; #;(import (only list-utils alist?)) +;; (import (only (srfi 1) every iota append! map)) +;; (require-library (srfi 1)) +;; +;; (import (only (srfi 13) string-index)) +;; (require-library (srfi 13)) +;; +;; (import (only (srfi 14) char-set:iso-control)) +;; (require-library (srfi 14)) +;; +;; (import (only type-checks define-check+error-type check-string check-list)) +;; (require-library type-checks) +;; +;; (import (only unicode-utils unicode-char->string)) +;; (require-library unicode-utils) +;; +;; (require-extension moremacros) ;(from list-utils egg) (define (alist? obj) (if (pair? obj) (every pair? obj) @@ -101,8 +111,8 @@ (strip-trailing-whitespace? . ,strip-trailing-whitespace?) (newlines-in-quotes? . ,newlines-in-quotes?)) ) ;;; -(include "csv-out.impl") +(include "csv-xml/csv-out.impl") ) ;csv-xml Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -55,29 +55,29 @@ (iup:show (iup:dialog (iup:vbox (iup:label msg #:margin "40x40"))))) -(define (dtests:get-pre-command #!key (default-override #f)) - (let* ((orig-pre-command "export CMD='") - (viewscreen-pre-command "viewscreen ") - (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) - (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command)) - (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) - (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \"")) - - -(define (dtests:get-post-command #!key (default-override #f)) - (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" - "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) - (viewscreen-post-command "") - (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) - (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) - (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) - (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) - - +;; (define (dtests:get-pre-command #!key (default-override #f)) +;; (let* ((orig-pre-command "export CMD='") +;; (viewscreen-pre-command "viewscreen ") +;; (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) +;; (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command)) +;; (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) +;; (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \"")) +;; +;; +;; (define (dtests:get-post-command #!key (default-override #f)) +;; (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" +;; "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) +;; (viewscreen-post-command "") +;; (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) +;; (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) +;; (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) +;; (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) +;; +;; (define (test-info-panel testdat store-label widgets) (iup:frame #:title "Test Info" ; #:expand "YES" (iup:hbox ; #:expand "YES" (apply iup:vbox ; #:expand "YES" Index: datashare.scm ================================================================== --- datashare.scm +++ datashare.scm @@ -253,11 +253,11 @@ (print "ERROR: invalid path for storing database: " path)))) (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 Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -22,26 +22,26 @@ ;; Database access ;;====================================================================== ;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc -(use (srfi 18) extras tcp stack) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable) -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) - -(declare (unit db)) -(declare (uses common)) -(declare (uses keys)) -(declare (uses ods)) -(declare (uses client)) -(declare (uses mt)) - -(include "common_records.scm") -(include "db_records.scm") -(include "key_records.scm") -(include "run_records.scm") +;; (use (srfi 18) extras tcp stack) +;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable) +;; (import (prefix sqlite3 sqlite3:)) +;; (import (prefix base64 base64:)) +;; +;; (declare (unit db)) +;; (declare (uses common)) +;; (declare (uses keys)) +;; (declare (uses ods)) +;; (declare (uses client)) +;; (declare (uses mt)) +;; +;; (include "common_records.scm") +;; (include "db_records.scm") +;; (include "key_records.scm") +;; (include "run_records.scm") (define *number-of-writes* 0) (define *number-non-write-queries* 0) ;;====================================================================== @@ -58,10 +58,11 @@ (refndb #f) (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet (read-only #f) (stmt-cache (make-hash-table)) + (locdbs (make-hash-table)) ;; legacy junk in db_records ) ;; goal is to converge on one struct for an area but for now it is too confusing ;; record for keeping state,status and count for doing roll-ups in ;; iterated tests @@ -246,14 +247,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")) @@ -332,11 +333,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)) @@ -424,11 +425,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))) @@ -627,11 +628,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 ;; @@ -715,17 +716,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)) @@ -1039,11 +1040,11 @@ ;; (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db") ;; (exit 1)) ;; (let* ((th1 (make-thread ;; (lambda () ;; (if (and (common:file-exists? megatest-db) -;; (file-write-access? megatest-db)) +;; (file-writable? megatest-db)) ;; (begin ;; (db:sync-to-megatest.db dbstruct 'timestamps) ;; internally mutexes on *db-local-sync* ;; (debug:print-info 2 *default-log-port* "Done syncing to megatest.db")))) ;; "call-with-cached-db sync-to-megatest.db")) ;; (cache-db (db:cache-for-read-only @@ -1099,11 +1100,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. ;; @@ -1201,11 +1202,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 @@ -1772,11 +1773,11 @@ #t))))) (define (db:get-status-from-final-status-file run-dir) (let ((infile (conc run-dir "/.final-status"))) ;; first verify we are able to write the output file - (if (not (file-read-access? infile)) + (if (not (file-readable? infile)) (begin (debug:print 0 *default-log-port* "ERROR: cannot read " infile) (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir) #f ) @@ -4884,11 +4885,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 ADDED dbi/dbi.egg Index: dbi/dbi.egg ================================================================== --- /dev/null +++ dbi/dbi.egg @@ -0,0 +1,5 @@ +((license "BSD") + (category db) + (dependencies autoload sql-null) + (test-dependencies test) + (components (extension dbi))) ADDED dbi/dbi.meta Index: dbi/dbi.meta ================================================================== --- /dev/null +++ dbi/dbi.meta @@ -0,0 +1,21 @@ +;; -*- scheme -*- +( +; Your egg's license: +(license "BSD") + +; Pick one from the list of categories (see below) for your egg and enter it +; here. +(category db) + +; A list of eggs dbi depends on. If none, you can omit this declaration +; altogether. If you are making an egg for chicken 3 and you need to use +; procedures from the `files' unit, be sure to include the `files' egg in the +; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit). +; `depends' is an alias to `needs'. +(needs (autoload "3.0") sql-null) + +; A list of eggs required for TESTING ONLY. See the `Tests' section. +(test-depends test) + +(author "Matt Welland") +(synopsis "An abstract database interface.")) ADDED dbi/dbi.release-info Index: dbi/dbi.release-info ================================================================== --- /dev/null +++ dbi/dbi.release-info @@ -0,0 +1,7 @@ +(repo fossil "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}") +(uri zip "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}/zip/{egg-name}.zip?uuid={egg-release}") +(release "0.5") +(release "0.4") +(release "0.3") +(release "0.2") +(release "0.1") ADDED dbi/dbi.scm Index: dbi/dbi.scm ================================================================== --- /dev/null +++ dbi/dbi.scm @@ -0,0 +1,483 @@ +;;; dbi: Minimal gasket to postgresql, sqlite3 and mysql +;;; +;; Copyright (C) 2007-2018 Matt Welland +;; Copyright (C) 2016 Peter Bex +;; Redistribution and use in source and binary forms, with or without +;; modification, is permitted. +;; +;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;; DAMAGE. + +;; ONLY A LOWEST COMMON DEMOMINATOR IS SUPPORTED! + +;; d = db handle +;; t = statement handle +;; s = statement +;; l = proc +;; p = params +;; +;; sqlite3 postgres dbi +;; prepare: (prepare d s) n/a prepare (sqlite3, pg) +;; for-each (for-each-row l d s . p) (query-for-each l s d) for-each-row +;; for-each (for-each-row l t . p) n/a NOT YET +;; exec (exec d s . p) (query-tuples s d) +;; exec (exec t . p) n/a + +;; set to 'pg or 'sqlite3 +;; (define dbi:type 'sqlite3) ;; or 'pg +;; (dbi:open 'sqlite3 (list (cons 'dbname fullname))) + +;;====================================================================== +;; D B I +;;====================================================================== +(module dbi + (open db-dbtype db-conn for-each-row get-one get-one-row get-rows + exec close escape-string mk-db now database? with-transaction fold-row + prepare map-row convert prepare-exec get-res + + ;; TODO: These don't really belong here. Also, the naming is not + ;; consistent with the usual Scheme conventions. + pgdatetime-get-year pgdatetime-get-month pgdatetime-get-day + pgdatetime-get-hour pgdatetime-get-minute pgdatetime-get-second + pgdatetime-get-microsecond + pgdatetime-set-year! pgdatetime-set-month! pgdatetime-set-day! + pgdatetime-set-hour! pgdatetime-set-minute! pgdatetime-set-second! + pgdatetime-set-microsecond! + + lazy-bool) + +(import (chicken base) (chicken process) (chicken file) (chicken time) (chicken string) (chicken format) (chicken time posix) scheme srfi-1 srfi-13) +(import (chicken condition) autoload sql-null) + +(define-record-type db + (make-db dbtype dbconn) + db? + (dbtype db-dbtype db-dbtype-set!) + (dbconn db-conn db-conn-set!)) + +(define (missing-egg type eggname) + (lambda _ + (error (printf + "Cannot access ~A databases. Please install the ~S egg and try again." type eggname)))) + +;; (define (sqlite3:statement? h) #f) ;; dummy - hope it gets clobbered if sqlite3 gets loaded + +;; TODO: Make a convenience macro for this? +(define sqlite3-missing (missing-egg 'sqlite3 "sqlite3")) +(autoload sqlite3 + (open-database sqlite3:open-database sqlite3-missing) + (for-each-row sqlite3:for-each-row sqlite3-missing) + (execute sqlite3:execute sqlite3-missing) + (with-transaction sqlite3:with-transaction sqlite3-missing) + (finalize! sqlite3:finalize! sqlite3-missing) + (make-busy-timeout sqlite3:make-busy-timeout sqlite3-missing) + (set-busy-handler! sqlite3:set-busy-handler! sqlite3-missing) + (database? sqlite3:database? sqlite3-missing) + (prepare sqlite3:prepare sqlite3-missing) + (fold-row sqlite3:fold-row sqlite3-missing) + (map-row sqlite3:map-row sqlite3-missing) + (statement? sqlite3:statement? sqlite3-missing)) + +(define sql-de-lite-missing (missing-egg 'sql-de-lite "sql-de-lite")) +(autoload sql-de-lite + (open-database sql:open-database sql-de-lite-missing) + (close-database sql:close-database sql-de-lite-missing) + (for-each-row sql:for-each-row sql-de-lite-missing) + (fold-rows sql:fold-rows sql-de-lite-missing) + (exec sql:exec sql-de-lite-missing) + (fetch-value sql:fetch-value sql-de-lite-missing) + (with-transaction sql:with-transaction sql-de-lite-missing) + (finalize! sql:finalize! sql-de-lite-missing) + (make-busy-timeout sql:make-busy-timeout sql-de-lite-missing) + (set-busy-handler! sql:set-busy-handler! sql-de-lite-missing) + (query sql:query sql-de-lite-missing) + (sql sql:sql sql-de-lite-missing)) + +(define pg-missing (missing-egg 'pg "postgresql")) +(autoload postgresql + (connect pg:connect pg-missing) + (row-for-each pg:row-for-each pg-missing) + (with-transaction pg:with-transaction pg-missing) + (query pg:query pg-missing) + ;;(escape-string pg:escape-string pg-missing) + (disconnect pg:disconnect pg-missing) + (connection? pg:connection? pg-missing) + (row-fold pg:row-fold pg-missing) + (row-map pg:row-map pg-missing) + (affected-rows pg:affected-rows pg-missing) + (result? pg:result? pg-missing)) + +(define mysql-missing (missing-egg 'mysql "mysql-client")) +(autoload mysql-client + (make-mysql-connection mysql:make-connection mysql-missing) + (mysql-null? mysql:mysql-null? mysql-missing)) + +(define (open dbtype dbinit) + (make-db + dbtype + (case dbtype + ((sqlite3) (sqlite3:open-database (alist-ref 'dbname dbinit))) + ((sql-de-lite) (sql:open-database (alist-ref 'dbname dbinit))) + ((pg) (pg:connect dbinit)) + ((mysql) (mysql:make-connection (alist-ref 'host dbinit) + (alist-ref 'user dbinit) + (alist-ref 'password dbinit) + (alist-ref 'dbname dbinit) + port: (alist-ref 'port dbinit))) + (else (error "Unsupported dbtype " dbtype))))) + +(define (convert dbh) + (cond + ((database? dbh) dbh) + ((sqlite3:database? dbh) (make-db 'sqlite3 dbh)) + ((pg:connection? dbh) (make-db 'pg dbh)) + ((not mysql:mysql-null?) (make-db 'mysql dbh)) + (else (error "Unsupported database handle " dbh)))) + +(define (for-each-row proc dbh stmt . params) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sqlite3) (sqlite3:for-each-row + (lambda (first . remaining) + (let ((tuple (list->vector (cons first remaining)))) + (proc tuple))) + conn + (apply sqlparam stmt params))) + ((sql-de-lite)(apply sql:query (sql:for-each-row + (lambda (row) + (proc (list->vector row)))) + (sql:sql conn stmt) + params)) + ((pg) (pg:row-for-each + (lambda (tuple) + (proc (list->vector tuple))) + (pg:query conn (apply sqlparam stmt params)))) + ((mysql) (let* ((replaced-sql (apply sqlparam stmt params)) + (fetcher (conn replaced-sql))) + (fetcher (lambda (tuple) + (proc (list->vector tuple)))))) + (else (error "Unsupported dbtype " dbtype))))) + +;; common idiom is to seek a single value, #f if no match +;; NOTE: wish to return first found. Do the set only if not set +(define (get-one dbh stmt . params) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sql-de-lite) + (apply sql:query sql:fetch-value (sql:sql conn stmt) params)) + (else + (let ((res #f)) + (apply for-each-row + (lambda (row) + (if (not res) + (set! res (vector-ref row 0)))) + dbh + stmt + params) + res))))) + +;; common idiom is to seek a single value, #f if no match +;; NOTE: wish to return first found. Do the set only if not set +(define (get-one-row dbh stmt . params) + (let ((res #f)) + (apply for-each-row + (lambda (row) + (if (not res) + (set! res row))) + dbh + stmt + params) + res)) + +;; common idiom is to seek a list of rows, '() if no match +(define (get-rows dbh stmt . params) + (let ((res '())) + (apply for-each-row + (lambda (row) + (set! res (cons row res))) + dbh + stmt + params) + (reverse res))) + +(define (exec dbh stmt . params) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh)) + (junk #f)) + (case dbtype + ((sqlite3) (apply sqlite3:execute conn stmt params)) + ((sql-de-lite)(apply sql:exec (sql:sql conn stmt) params)) + ((pg) (pg:query conn (apply sqlparam stmt params))) + ((mysql) (conn (apply sqlparam stmt params))) + (else (error "Unsupported dbtype " dbtype))))) + +(define (with-transaction dbh proc) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sql-de-lite)(sql:with-transaction conn proc)) + ((sqlite3) (sqlite3:with-transaction + conn + (lambda () (proc)))) + ((pg) (pg:with-transaction + conn (lambda () (proc)))) + ((mysql) + (conn "START TRANSACTION") + (conn proc) + (conn "COMMIT")) + (else (error "Unsupported dbtype " dbtype))))) + +(define (prepare dbh stmt) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sql-de-lite) dbh) ;; nop? + ((sqlite3) (sqlite3:prepare conn stmt)) + ((pg) (exec dbh stmt) (cons (cons dbh (cadr (string-split stmt))) '())) + ((mysql) (print "WIP")) + (else (error "Unsupported dbtype" dbtype))))) + +(define (fold-row proc init dbh stmt . params) ;; expecting (proc init/prev res) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sql-de-lite) (apply sql:query (sql:fold-rows proc init) + (sql:sql conn stmt) params)) + ((sqlite3) (let ((newproc (lambda (prev . rem) + (proc rem prev)))) + (apply sqlite3:fold-row newproc init conn stmt params))) ;; (fold-row PROC INIT DATABASE SQL . PARAMETERS) + ((pg) (pg:row-fold proc init (exec dbh stmt params))) + ((mysql) (fold proc '() (get-rows dbh stmt))) + (else (error "Unsupported dbtype" dbtype))))) + +(define (map-row proc init dbh stmt . params) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sqlite3) (apply sqlite3:map-row proc conn stmt params)) + ((pg) (pg:row-map proc (exec dbh stmt params))) + ((mysql) (map proc (get-rows dbh stmt))) + (else (error "Unsupported dbtype" dbtype))))) + +(define (prepare-exec stmth . params) + (if (sqlite3:statement? stmth) + (apply sqlite3:execute stmth params)) + (if (pair? stmth) + (let* ((dbh (car (car stmth))) + (dbtype (db-dbtype dbh)) + (conn (db-conn dbh)) + (stmth-name (string->symbol (cdr (car stmth))))) + (apply pg:query conn stmth-name params)))) + +(define (get-res handle option) + (if (pg:result? handle) + (case option + ((affected-rows) (pg:affected-rows handle))))) + +(define (close dbh) + (cond + ((database? dbh) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sql-de-lite) (sql:close-database conn)) + ((sqlite3) (sqlite3:finalize! conn)) + ((pg) (pg:disconnect conn)) + ((mysql) (void)) ; The mysql-client egg doesn't support closing... + (else (error "Unsupported dbtype " dbtype))))) + ((pair? dbh) + (let ((stmt (conc "DEALLOCATE " (cdr (car dbh)) ";"))) + (exec (car (car dbh)) stmt))) + ((sqlite3:statement? dbh) ;; do this last so that *IF* it is a proper dbh it will be closed above and the sqlite3:statement? will not be called + (sqlite3:finalize! dbh)) + + )) + +;;====================================================================== +;; D B M I S C +;;====================================================================== + +(define (escape-string str) + (let ((parts (split-string str "'"))) + (string-intersperse parts "''"))) +;; (pg:escape-string val))) + +;; convert values to appropriate strings +;; +(define (sqlparam-val->string val) + (cond + ((list? val)(string-intersperse (map conc val) ",")) ;; (a b c) => a,b,c + ((string? val)(string-append "'" (escape-string val) "'")) + ((sql-null? val) "NULL") + ((number? val)(number->string val)) + ((symbol? val)(sqlparam-val->string (symbol->string val))) + ((boolean? val) + (if val "TRUE" "FALSE")) ;; should this be "TRUE" or 1? + ;; should this be "FALSE" or 0 or NULL? + ((vector? val) ;; 'tis a date NB// 5/29/2011 - this is badly borked BUGGY! + (sqlparam-val->string (time->string (seconds->local-time (current-seconds))))) + (else + (error "sqlparam: unknown type for value: " val) + ""))) + +;; (sqlparam "INSERT INTO foo(name,age) VALUES(?,?);" "bob" 20) +;; NB// 1. values only!! +;; 2. terminating semicolon required (used as part of logic) +;; +;; a=? 1 (number) => a=1 +;; a=? 1 (string) => a='1' +;; a=? #f => a=FALSE +;; a=? a (symbol) => a=a +;; +(define (sqlparam query . args) + (let* ((query-parts (string-split query "?")) + (num-parts (length query-parts)) + (num-args (length args))) + (if (not (= (+ num-args 1) num-parts)) + (error "ERROR, sqlparam: wrong number of arguments or missing semicolon, " num-args " for query " query) + (if (= num-args 0) query + (let loop ((section (car query-parts)) + (tail (cdr query-parts)) + (result "") + (arg (car args)) + (argtail (cdr args))) + (let* ((valstr (sqlparam-val->string arg)) + (newresult (string-append result section valstr))) + (if (null? argtail) ;; we are done + (string-append newresult (car tail)) + (loop + (car tail) + (cdr tail) + newresult + (car argtail) + (cdr argtail))))))))) + +;; a poorly written but non-broken split-string +;; +(define (split-string strng delim) + (if (eq? (string-length strng) 0) (list strng) + (let loop ((head (make-string 1 (car (string->list strng)))) + (tail (cdr (string->list strng))) + (dest '()) + (temp "")) + (cond ((equal? head delim) + (set! dest (append dest (list temp))) + (set! temp "")) + ((null? head) + (set! dest (append dest (list temp)))) + (else (set! temp (string-append temp head)))) ;; end if + (cond ((null? tail) + (set! dest (append dest (list temp))) dest) + (else (loop (make-string 1 (car tail)) (cdr tail) dest temp)))))) + +(define (database? dbh) + (if (db? dbh) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sqlite3) (if (sqlite3:database? conn) #t #f)) + ((sql-de-lite) #t) ;; don't know how to test for database + ((pg) (if (pg:connection? conn) #t #f)) + ((mysql) #t) + (else (error "Unsupported dbtype " dbtype)))) #f)) + +;;====================================================================== +;; Convienence routines +;;====================================================================== + +;; make a db from a list of statements or open it if it already exists +(define (mk-db path file stmts) + (let* ((fname (conc path "/" file)) + (dbexists (file-exists? fname)) + (dbh (if dbexists (open 'sqlite3 (list (cons 'dbname fname))) #f))) + (if (not dbexists) + (begin + (system (conc "mkdir -p " path)) ;; create the path + (set! dbh (open 'sqlite3 (list (cons 'dbname fname)))) + (for-each + (lambda (sqry) + (exec dbh sqry)) + stmts))) + (sqlite3:set-busy-handler! + (db-conn dbh) (sqlite3:make-busy-timeout 1000000)) + dbh)) + +(define (now dbh) + (let ((dbtype (db-dbtype dbh))) + (case dbtype + ((sqlite3) "datetime('now')") + ;; Standard SQL + (else "now()")))) + +(define (make-pgdatetime)(make-vector 7)) +(define (pgdatetime-get-year vec) (vector-ref vec 0)) +(define (pgdatetime-get-month vec) (vector-ref vec 1)) +(define (pgdatetime-get-day vec) (vector-ref vec 2)) +(define (pgdatetime-get-hour vec) (vector-ref vec 3)) +(define (pgdatetime-get-minute vec) (vector-ref vec 4)) +(define (pgdatetime-get-second vec) (vector-ref vec 5)) +(define (pgdatetime-get-microsecond vec) (vector-ref vec 6)) +(define (pgdatetime-set-year! vec val)(vector-set! vec 0 val)) +(define (pgdatetime-set-month! vec val)(vector-set! vec 1 val)) +(define (pgdatetime-set-day! vec val)(vector-set! vec 2 val)) +(define (pgdatetime-set-hour! vec val)(vector-set! vec 3 val)) +(define (pgdatetime-set-minute! vec val)(vector-set! vec 4 val)) +(define (pgdatetime-set-second! vec val)(vector-set! vec 5 val)) +(define (pgdatetime-set-microsecond! vec val)(vector-set! vec 6 val)) + +;; takes postgres date or timestamp +(define (pg-date->string pgdate) + (conc (pgdatetime-get-month pgdate) "/" + (pgdatetime-get-day pgdate) "/" + (pgdatetime-get-year pgdate))) + +;; takes postgres date or timestamp +(define (pg-datetime->string pgdate) + (conc (pgdatetime-get-month pgdate) "/" + (pgdatetime-get-day pgdate) "/" + (pgdatetime-get-year pgdate) " " + (pgdatetime-get-hour pgdate) ":" + (pgdatetime-get-minute pgdate)`)) + + + +;; map to 0 or 1 from a range of values +;; #f => 0 +;; #t => 1 +;; "0" => 0 +;; "1" => 1 +;; FALSE => 0 +;; TRUE => 1 +;; anything else => 1 +(define (lazy-bool val) + (case val + ((#f) 0) + ((#t) 1) + ((0) 0) + ((1) 1) + (else + (cond + ((string? val) + (let ((nval (string->number val))) + (if nval + (lazy-bool nval) + (cond + ((string=? val "FALSE") 0) + ((string=? val "TRUE") 1) + (else 1))))) + ((symbol? val) + (lazy-bool (symbol->string val))) + (else 1))))) +) ADDED dbi/dbi.setup Index: dbi/dbi.setup ================================================================== --- /dev/null +++ dbi/dbi.setup @@ -0,0 +1,11 @@ +;; Copyright 2007-2018, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +;;;; dbi.setup +(standard-extension 'dbi "0.5") ADDED dbi/example.scm Index: dbi/example.scm ================================================================== --- /dev/null +++ dbi/example.scm @@ -0,0 +1,69 @@ +;;; dbi: Minimal gasket to postgresql, sqlite3 and mysql +;;; +;; Copyright (C) 2007-2016 Matt Welland +;; Redistribution and use in source and binary forms, with or without +;; modification, is permitted. +;; +;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;; DAMAGE. + +;; WARNING: This example is basically useless, I'll rewrite it one of these days .... + +(require-library margs dbi) + +(define help "help me") + +(define remargs (args:get-args + (argv) + (list "-inf") + (list "-h") + args:arg-hash + 0)) + +;; define DBPATH in setup.scm +(include "setup.scm") + +(define (ftf:mk-db) + (let* ((fname (conc DBPATH "/ftfplan.db")) + (dbexists (file-exists? fname)) + (dbh (if dbexists (dbi:open 'sqlite3 (list (cons 'dbname fname))) #f))) + (if (not dbexists) + (begin + ;; (print "fullname: " fullname) + (system (conc "mkdir -p " DBPATH)) ;; create the path + (set! dbh (dbi:open 'sqlite3 (list (cons 'dbname fname)))) + (for-each + (lambda (sqry) + ;; (print sqry) + (dbi:exec dbh sqry)) + ;; types: 0 text, 1 jpg, 2 png, 3 svg, 4 spreadsheet, 5 audio, 6 video :: better specs to come... + (list + "CREATE TABLE pics (id INTEGER PRIMARY KEY,name TEXT,dat_id INTEGER,thumb_dat_id INTEGER,created_on INTEGER,owner_id INTEGER);" + "CREATE TABLE dats (id INTEGER PRIMARY KEY,md5sum TEXT,dat BLOB,type INTEGER);" + ;; on every modification a new tiddlers entry is created. When displaying the tiddlers do: + ;; select where created_on < somedate order by created_on desc limit 1 + "CREATE TABLE tiddlers (id INTEGER PRIMARY KEY,wiki_id INTEGER,name TEXT,rev INTEGER,dat_id INTEGER,created_on INTEGER,owner_id INTEGER);" + ;; rev and tag only utilized when user sets a tag. All results from a select as above for tiddlers are set to the tag + "CREATE TABLE revs (id INTEGER PRIMARY KEY,tag TEXT);" + ;; wikis is here for when postgresql support is added or if a sub wiki is created. + "CREATE TABLE wikis (id INTEGER PRIMARY KEY,key_name TEXT,title TEXT,created_on INTEGER);")) + )) + dbh)) + +(define db (ftf:mk-db)) + +(dbi:exec db "INSERT INTO pics (name,owner_id) VALUES ('bob',1);") +(dbi:for-each-row (lambda (row)(print "Name: " (vector-ref row 0) ", owner_id: " (vector-ref row 1))) + db + "SELECT name,owner_id FROM pics;") + Index: diff-report.scm ================================================================== --- diff-report.scm +++ diff-report.scm @@ -14,18 +14,19 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; -(declare (unit diff-report)) -(declare (uses common)) -(declare (uses rmt)) - -(include "common_records.scm") -(use matchable) -(use fmt) -(use ducttape-lib) +;; (declare (unit diff-report)) +;; (declare (uses common)) +;; (declare (uses rmt)) +;; +;; (include "common_records.scm") +;; (use matchable) +;; (use fmt) +;; (use ducttape-lib) + (define css "") (define (diff:tests-mindat->hash tests-mindat) (let* ((res (make-hash-table))) (for-each Index: env.scm ================================================================== --- env.scm +++ env.scm @@ -16,13 +16,13 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -(declare (unit env)) +;; (declare (unit env)) -(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables) +;; (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)) (db (open-database fname))) (if (not db-exists) Index: gen-data-for-graph.scm ================================================================== --- gen-data-for-graph.scm +++ gen-data-for-graph.scm @@ -31,21 +31,21 @@ (lambda () (loop ((for m (up-from (/ one-year-ago 60) (to (/ now 60))))) ;; days of the year (let ((thetime (* m 60)) (thehour (round (/ m 60)))) (let loop ((lastsec -1) - (sec (random 60)) + (sec (pseudo-random-integer 60)) (count 0)) (if (> sec lastsec) (exec (sql db "INSERT INTO alldat (event_time,var,val) VALUES (?,?,?)") (+ thetime sec) ;; (* sec 60)) "stuff" (if (even? thehour) - (random 1000) - (random 6)))) + (pseudo-random-integer 1000) + (pseudo-random-integer 6)))) (if (< count 20) - (loop (max sec lastsec)(random 60)(+ count 1)))))))) + (loop (max sec lastsec)(pseudo-random-integer 60)(+ count 1)))))))) (close-database db) ;; (with-transaction @@ -55,18 +55,18 @@ ;; (print "Day: " d) ;; (loop ((for h (up-from 1 (to 24)))) ;; (loop ((for m (up-from 1 (to 60)))) ;; (let ((thetime (+ beginning-2016 (* 365 24 60 60)(* h 60 60)(* m 60)))) ;; (let loop ((lastsec -1) -;; (sec (random 60)) +;; (sec (pseudo-random-integer 60)) ;; (count 0)) ;; (if (> sec lastsec) ;; (exec (sql db "INSERT INTO alldat (event_time,var,val) VALUES (?,?,?)") ;; (+ thetime sec) ;; (* sec 60)) ;; "stuff" ;; (if (even? h) -;; (random 100) -;; (random 6)))) +;; (pseudo-random-integer 100) +;; (pseudo-random-integer 6)))) ;; (if (< count 20) -;; (loop (max sec lastsec)(random 60)(+ count 1)))))))))) +;; (loop (max sec lastsec)(pseudo-random-integer 60)(+ count 1)))))))))) ;; ;; (close-database db) Index: genexample.scm ================================================================== --- genexample.scm +++ genexample.scm @@ -16,14 +16,14 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -(declare (unit genexample)) -(use posix regex matchable) - -(include "db_records.scm") +;; (declare (unit genexample)) +;; (use posix regex matchable) +;; +;; (include "db_records.scm") (define genexample:example-logpro #<. -(require-extension (srfi 18) extras tcp s11n) - - -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) - -(use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing) - +;; (require-extension (srfi 18) extras tcp s11n) +;; +;; +;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) +;; +;; (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing) +;; ;; Configurations for server (tcp-buffer-size 2048) (max-connections 2048) -(declare (unit http-transport)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tests)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. -(declare (uses server)) -;; (declare (uses daemon)) -(declare (uses portlogger)) -(declare (uses rmt)) - -(include "common_records.scm") -(include "db_records.scm") -(include "js-path.scm") +;; (declare (unit http-transport)) +;; +;; (declare (uses common)) +;; (declare (uses db)) +;; (declare (uses tests)) +;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. +;; (declare (uses server)) +;; ;; (declare (uses daemon)) +;; (declare (uses portlogger)) +;; (declare (uses rmt)) +;; +;; (include "common_records.scm") +;; (include "db_records.scm") +;; (include "js-path.scm") (require-library stml) (define (http-transport:make-server-url hostport) (if (not hostport) #f Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -19,14 +19,14 @@ ;; (define itemdat '((ripeness "green ripe overripe") ;; (temperature "cool medium hot") ;; (season "summer winter fall spring"))) -(declare (unit items)) -(declare (uses common)) - -(include "common_records.scm") +;; (declare (unit items)) +;; (declare (uses common)) +;; +;; (include "common_records.scm") ;; Puts out all combinations (define (process-itemlist hierdepth curritemkey itemlist) (let ((res '())) (if (not hierdepth) Index: keys.scm ================================================================== --- keys.scm +++ keys.scm @@ -19,18 +19,18 @@ ;;====================================================================== ;; Run keys, these are used to hierarchially organise tests and run areas ;;====================================================================== -(use sqlite3 srfi-1 posix regex regex-case srfi-69) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit keys)) -(declare (uses common)) - -(include "key_records.scm") -(include "common_records.scm") +;; (use sqlite3 srfi-1 posix regex regex-case srfi-69) +;; (import (prefix sqlite3 sqlite3:)) +;; +;; (declare (unit keys)) +;; (declare (uses common)) +;; +;; (include "key_records.scm") +;; (include "common_records.scm") (define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... (string-intersperse keys ",")) (define (args:usage . a) #f) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -19,28 +19,28 @@ ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== -(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 - call-with-environment-variables csv) -(use typed-records pathname-expand matchable) - -(import (prefix base64 base64:)) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit launch)) -(declare (uses subrun)) -(declare (uses common)) -(declare (uses configf)) -(declare (uses db)) -(declare (uses ezsteps)) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "megatest-fossil-hash.scm") +;; (use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 +;; call-with-environment-variables csv) +;; (use typed-records pathname-expand matchable) +;; +;; (import (prefix base64 base64:)) +;; (import (prefix sqlite3 sqlite3:)) +;; +;; (declare (unit launch)) +;; (declare (uses subrun)) +;; (declare (uses common)) +;; (declare (uses configf)) +;; (declare (uses db)) +;; (declare (uses ezsteps)) +;; +;; (include "common_records.scm") +;; (include "key_records.scm") +;; (include "db_records.scm") +;; (include "megatest-fossil-hash.scm") ;;====================================================================== ;; ezsteps ;;====================================================================== @@ -307,11 +307,11 @@ ;; no point in sticking around. Exit now. But run end of run before exiting? (launch:end-of-run-check run-id) (exit))) (if (hash-table-ref/default misc-flags 'keep-going #f) (begin - (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses + (thread-sleep! 3) ;; (+ 3 (pseudo-random-integer 6))) ;; add some jitter to the call home time to spread out the db accesses (if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free) (if do-sync (current-seconds) last-sync))))))) @@ -357,11 +357,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)) @@ -614,11 +614,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 @@ -628,11 +628,11 @@ (tconfig-tmpfile (conc tconfig-fname ".tmp")) (tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs))) (scripts (configf:get-section tconfig "scripts"))) ;; create .testconfig file (configf:write-alist tconfig tconfig-tmpfile) - (file-move tconfig-tmpfile tconfig-fname #t) + (move-file tconfig-tmpfile tconfig-fname #t) (delete-file* ".final-status") ;; extract scripts from testconfig and write them to files in test run dir (for-each (lambda (scriptdat) @@ -913,11 +913,11 @@ #f (car cachefiles))) ;; (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) (rccachef (if (null? cachefiles) #f (cdr cachefiles)))) ;; (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) - ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-write-access? cachedir) (not (common:in-running-test?))))) + ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-writable? 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) @@ -1094,11 +1094,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)) (read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special. *toppath*))) (define (get-best-disk confdat testconfig) Index: margs.scm ================================================================== --- margs.scm +++ margs.scm @@ -14,11 +14,11 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . -(declare (unit margs)) +;; (declare (unit margs)) ;; (declare (uses common)) (define args:arg-hash (make-hash-table)) (define (args:get-arg arg . default) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -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))))) +) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -15,29 +15,29 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit mt)) -(declare (uses db)) -(declare (uses common)) -(declare (uses items)) -(declare (uses runconfig)) -(declare (uses tests)) -(declare (uses server)) -(declare (uses runs)) -(declare (uses rmt)) -;; (declare (uses filedb)) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "test_records.scm") +;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables) +;; (import (prefix sqlite3 sqlite3:)) +;; +;; (declare (unit mt)) +;; (declare (uses db)) +;; (declare (uses common)) +;; (declare (uses items)) +;; (declare (uses runconfig)) +;; (declare (uses tests)) +;; (declare (uses server)) +;; (declare (uses runs)) +;; (declare (uses rmt)) +;; ;; (declare (uses filedb)) +;; +;; (include "common_records.scm") +;; (include "key_records.scm") +;; (include "db_records.scm") +;; (include "run_records.scm") +;; (include "test_records.scm") ;; This is the Megatest API. All generally "useful" routines will be wrapped or extended ;; here. ;;====================================================================== @@ -155,14 +155,14 @@ event-time )) (prev-nbfake-log (get-environment-variable "NBFAKE_LOG"))) (setenv "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 @@ -285,11 +285,11 @@ (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)) (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...] (hash-table-set! *testconfigs* test-name newtcfg) Index: mutils/mutils.scm ================================================================== --- mutils/mutils.scm +++ mutils/mutils.scm @@ -12,22 +12,37 @@ ;; (module mutils * - (import chicken scheme + (import scheme + + chicken.base + chicken.file + chicken.file.posix + chicken.port + chicken.process + chicken.process-context + chicken.random + chicken.condition + chicken.io + chicken.time + chicken.string + ;; data-structures posix srfi-1 ;; srfi-13 srfi-69 - ports - extras + srfi-98 + regex - posix - data-structures matchable + sparse-vectors + system-information + ) + (define (mutils:hierhash-ref hh . keys) (if (null? keys) #f (let loop ((ht hh) @@ -90,12 +105,10 @@ (if (or (string-match comment l) (string-match blank l)) (loop (read-line fh) res) (loop (read-line fh) (cons l res))))))) -(use sparse-vectors) - ;; this is a simple two dimensional sparse array ;; ONLY TWO DIMENSIONS!!! SEE ARRAY-LIB IF YOUR NEEDS ARE GREATER!! ;; (define (mutils:make-sparse-array) @@ -189,12 +202,13 @@ ;;====================================================================== ;; Other utils ;;====================================================================== (define (check-write-create fpath) - (and (file-write-access? fpath) - (let ((fname (conc fpath "/.junk-" (current-seconds) "-" (random 10000)))) + (and (file-writable? fpath) + (let ((fname (conc fpath "/.junk-" (current-seconds) "-" + (pseudo-random-integer 10000)))) ;;(print "trying to create/remove " fname) (handle-exceptions exn #f (begin Index: ods.scm ================================================================== --- ods.scm +++ ods.scm @@ -14,13 +14,13 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; -(use csv-xml regex) -(declare (unit ods)) -(declare (uses common)) +;; (use csv-xml regex) +;; (declare (unit ods)) +;; (declare (uses common)) (define ods:dirs '("Configurations2" "Configurations2/toolpanel" "Configurations2/menubar" Index: pkts/pkts.scm ================================================================== --- pkts/pkts.scm +++ pkts/pkts.scm @@ -162,12 +162,13 @@ ;; utility procs increment-string ;; used to get indexes for strings in ref pkts make-report ;; make a .dot file ) -(import chicken scheme data-structures posix srfi-1 regex srfi-13 srfi-69 ports extras) -(use crypt sha1 message-digest (prefix dbi dbi:) typed-records) +(import (chicken base) scheme (chicken process) (chicken time posix) (chicken io) (chicken file)) +(import chicken.process-context.posix (chicken string) (chicken time) (chicken sort) (chicken file posix) (chicken condition) srfi-1 regex srfi-13 srfi-69 (chicken port) ) +(import crypt sha1 message-digest (prefix dbi dbi:) typed-records) ;;====================================================================== ;; DATA MANIPULATION UTILS ;;====================================================================== @@ -695,11 +696,11 @@ (cond ((not (file-exists? pktsdir)) (print "ERROR: packets directory " pktsdir " does not exist.")) ((not (directory? pktsdir)) (print "ERROR: packets directory path " pktsdir " is not a directory.")) - ((not (file-read-access? pktsdir)) + ((not (file-readable? pktsdir)) (print "ERROR: packets directory path " pktsdir " is not readable.")) (else ;; (print "INFO: Loading packets found in " pktsdir) (let ((pkts (glob (conc pktsdir "/*.pkt")))) (for-each Index: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -34,11 +34,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, @@ -130,11 +130,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: process.scm ================================================================== --- process.scm +++ process.scm @@ -20,12 +20,12 @@ ;;====================================================================== ;; Process convience utils ;;====================================================================== -(use regex directory-utils) -(declare (unit process)) +;; (use regex directory-utils) +;; (declare (unit process)) (define (process:conservative-read port) (let loop ((res "")) (if (not (eof-object? (peek-char port))) (loop (conc res (read-char port))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -16,16 +16,16 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;;====================================================================== -(use format typed-records) ;; RADT => purpose of json format?? - -(declare (unit rmt)) -(declare (uses api)) -(declare (uses http-transport)) -(include "common_records.scm") +;; (use format typed-records) ;; RADT => purpose of json format?? +;; +;; (declare (unit rmt)) +;; (declare (uses api)) +;; (declare (uses http-transport)) +;; (include "common_records.scm") ;; (declare (uses rmtmod)) ;; (import rmtmod) ;; @@ -371,11 +371,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 @@ -395,11 +395,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 @@ -974,11 +974,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: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -18,16 +18,16 @@ ;;====================================================================== ;; read a config file, loading only the section pertinent ;; to this run field1val/field2val/field3val ... ;;====================================================================== -(use format directory-utils) - -(declare (unit runconfig)) -(declare (uses common)) - -(include "common_records.scm") +;; (use format directory-utils) +;; +;; (declare (unit runconfig)) +;; (declare (uses common)) +;; +;; (include "common_records.scm") (define (runconfig:read fname target environ-patt) (let ((ht (make-hash-table))) (if target (hash-table-set! ht target '())) (read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f)))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -15,31 +15,31 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) - posix-extras directory-utils pathname-expand typed-records format sxml-serializer - sxml-modifications matchable) - -(declare (unit runs)) -(declare (uses db)) -(declare (uses common)) -(declare (uses items)) -(declare (uses runconfig)) -(declare (uses tests)) -(declare (uses server)) -(declare (uses mt)) -(declare (uses archive)) -;; (declare (uses filedb)) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "test_records.scm") - +;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) +;; posix-extras directory-utils pathname-expand typed-records format sxml-serializer +;; sxml-modifications matchable) +;; +;; (declare (unit runs)) +;; (declare (uses db)) +;; (declare (uses common)) +;; (declare (uses items)) +;; (declare (uses runconfig)) +;; (declare (uses tests)) +;; (declare (uses server)) +;; (declare (uses mt)) +;; (declare (uses archive)) +;; ;; (declare (uses filedb)) +;; +;; (include "common_records.scm") +;; (include "key_records.scm") +;; (include "db_records.scm") +;; (include "run_records.scm") +;; (include "test_records.scm") +;; ;; (include "debugger.scm") ;; use this struct to facilitate refactoring ;; @@ -128,11 +128,11 @@ (endt (+ startt duration))) ((or proc runs:parallel-runners-mgmt) rdat) (let loop () (let* ((wstart (current-seconds))) (if (< wstart endt) - (let* ((work-time (random 10))) + (let* ((work-time (pseudo-random-integer 10))) #;(debug:print-info 0 *default-log-port* "working for " work-time " seconds. Total work: " rtime ", elapsed time: " (- wstart startt)) (thread-sleep! work-time) (set! rtime (+ rtime work-time)) ((or proc runs:parallel-runners-mgmt) rdat) @@ -508,11 +508,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)) @@ -2342,11 +2342,11 @@ (keep-records (args:get-arg "-keep-records")) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode". (test-records '())) ;; for tasks that we wish to operate on all tests in one fell swoop (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))) @@ -2565,11 +2565,11 @@ (substring-index run-name rundir) (tests:glob-like-match (conc "%/" target "/%") rundir) ) (begin (set! lasttpath (db:test-get-rundir new-test-dat)) ;; remember this path for run removal - (set! lastrealpath (remove-last-path-directory (resolve-pathname lasttpath))) + (set! lastrealpath (remove-last-path-directory (realpath lasttpath))) (hash-table-set! run-paths-hash lastrealpath 1) (runs:remove-test-directory new-test-dat mode) ;; 'remove-all) ) (begin (debug:print 2 *default-log-port* "Not removing directory " rundir " because either it doesn't exist or has a bad name") @@ -2733,11 +2733,11 @@ ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f))) (debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) (if (and real-dir (> (string-length real-dir) 5) (common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. - (let* ((realpath (resolve-pathname run-dir))) + (let* ((realpath (realpath run-dir))) (debug:print-info 1 *default-log-port* "Recursively removing " realpath) (if (common:file-exists? realpath) (runs:safe-delete-test-dir realpath) (debug:print 0 *default-log-port* "WARNING: test dir " realpath " appears to not exist or is not readable"))) (if real-dir @@ -2959,12 +2959,11 @@ '(*TOP* (*PI* xml "version='1.0'") (testsuite))) (define (runs:update-junit-test-reporter-xml run-id) - (let* ( - (junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml")) + (let* ((junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml")) (junit-test-report-dir (configf:lookup *configdat* "runs" "junit-test-report-dir")) (xml-dir (if (and junit-test-reporter (equal? junit-test-reporter "yes" )) (if junit-test-report-dir junit-test-report-dir (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))) @@ -3003,33 +3002,33 @@ (test-state (vector-ref test 3)) (comment (vector-ref test 14)) (test-status (vector-ref test 4)) (exc-msg (conc "No bucket for State " test-state " Status " test-status)) (new-doc (cond - ((member test-state (list "RUNNING" )) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc)) - ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc)) - ((member test-status (list "PASS" "WARN" "WAIVED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc)) - ((member test-status (list "FAIL" "CHECK")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc)) - ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc)) - ((member test-status (list "SKIP")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc)) - (else - (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status)) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc)))) - (new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) - (+ error-cnt 1) - error-cnt)) - (new-fail-cnt (if (member test-status (list "FAIL" "CHECK")) - (+ fail-cnt 1) - fail-cnt))) + ((member test-state (list "RUNNING" )) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc)) + ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc)) + ((member test-status (list "PASS" "WARN" "WAIVED")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc)) + ((member test-status (list "FAIL" "CHECK")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc)) + ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc)) + ((member test-status (list "SKIP")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc)) + (else + (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status)) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc)))) + (new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) + (+ error-cnt 1) + error-cnt)) + (new-fail-cnt (if (member test-status (list "FAIL" "CHECK")) + (+ fail-cnt 1) + fail-cnt))) (if (null? tail) - (let* ((final-doc ((sxml-modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc))) + (let* ((final-doc ((modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc))) (debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt) (handle-exceptions exn (let* ((msg ((condition-property-accessor 'exn 'message) exn))) (debug:print 0 *default-log-port* (conc "WARNING: Failed to update file" xml-path". Message:" msg ", exn=" exn))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -14,30 +14,30 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; -(require-extension (srfi 18) extras tcp s11n) - -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest - directory-utils posix-extras matchable) - -(use spiffy uri-common intarweb http-client spiffy-request-vars) - -(declare (unit server)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. -;; (declare (uses synchash)) -(declare (uses http-transport)) -;;(declare (uses rpc-transport)) -(declare (uses launch)) -;; (declare (uses daemon)) - -(include "common_records.scm") -(include "db_records.scm") +;; (require-extension (srfi 18) extras tcp s11n) +;; +;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest +;; directory-utils posix-extras matchable) +;; +;; (use spiffy uri-common intarweb http-client spiffy-request-vars) +;; +;; (declare (unit server)) +;; +;; (declare (uses common)) +;; (declare (uses db)) +;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. +;; ;; (declare (uses synchash)) +;; (declare (uses http-transport)) +;; ;;(declare (uses rpc-transport)) +;; (declare (uses launch)) +;; ;; (declare (uses daemon)) +;; +;; (include "common_records.scm") +;; (include "db_records.scm") (define (server:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) @@ -154,11 +154,11 @@ (begin (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile) (setenv "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 + (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 #;(common:wait-for-homehost-load load-limit (conc " delaying server start due to load on homehost. limit is " load-limit)) (system (conc "nbfake " cmdln)) (unsetenv "TARGETHOST_LOGF") (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) @@ -219,11 +219,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. exn=" exn))) @@ -308,11 +308,11 @@ (< (- now mod-time) 16) ;; still alive - file touched in last 16 seconds (or (not (configf:lookup *configdat* "server" "runtime")) ;; skip if not set (< (- now start-time) (+ (- (string->number (configf:lookup *configdat* "server" "runtime")) 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) @@ -331,11 +331,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->id servr) (handle-exceptions @@ -410,11 +410,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) (let* ((start-flag (conc areapath "/logs/server-start-last"))) (common:simple-file-lock-and-wait lock-file expire-time: 15) (debug:print-info 0 *default-log-port* "server:kind-run: touching " start-flag) @@ -455,11 +455,11 @@ (servers (server:get-best (server:get-list areapath)))) (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 Index: stml2/cookie.scm ================================================================== --- stml2/cookie.scm +++ stml2/cookie.scm @@ -45,11 +45,11 @@ ;; (declare (unit cookie)) (module cookie * -(import chicken scheme data-structures extras srfi-13 ports posix) +(import (chicken base) scheme queues srfi-13 (chicken port) (chicken io)(chicken file) (chicken format) (chicken string) (chicken time posix)) (require-extension srfi-1 srfi-13 srfi-14 regex) ;; (use srfi-1 srfi-13 srfi-14 regex) ;; (declare (export parse-cookie-string construct-cookie-string)) Index: stml2/stml2.scm ================================================================== --- stml2/stml2.scm +++ stml2/stml2.scm @@ -12,17 +12,17 @@ ;; (declare (unit stml)) (module stml2 * -(import chicken scheme data-structures extras srfi-13 ports posix srfi-69 files srfi-1) +(import (chicken random) (chicken base) (chicken string) (chicken time) scheme queues srfi-13 (chicken port) (chicken io) (chicken file) srfi-69 srfi-1 (chicken condition) (chicken time posix) (chicken process-context posix) (chicken pathname) (chicken blob) (chicken format) (chicken process) (chicken process-context)) (import cookie) -(use (prefix dbi dbi:) (prefix crypt c:) typed-records) +(import (prefix dbi dbi:) (prefix crypt c:) typed-records) ;; (declare (uses misc-stml)) -(use regex) +(import regex) ;; The (usually global) sdat contains everything about the session ;; (defstruct sdat ;; database @@ -421,11 +421,11 @@ ;; (s:get-key 'n 1) => "n99e1882" n=number 99e is the week number since 1970, remainder is random ;; (s:key->val "n1882") => 1 ;; ;; first letter is a type: n=number, s=string, b=boolean (define (s:get-key key-type val) - (let ((mkrandstr (lambda (innum)(number->string (random innum) 16))) + (let ((mkrandstr (lambda (innum)(number->string (pseudo-random-integer innum) 16))) (week (number->string (quotient (current-seconds) (* 7 24 60 60)) 16))) (let loop ((siz 1000) (key (conc key-type week (mkrandstr 100))) (num 0)) (if (s:session-var-get key) ;; have a collision @@ -649,11 +649,11 @@ #;(define (session:get-nth-char nth) (substring session:valid-chars nth (+ nth 1))) #;(define (session:get-rand-char) - (session:get-nth-char (random session:num-valid-chars))) + (session:get-nth-char (pseudo-random-integer session:num-valid-chars))) #;(define (session:make-rand-string len) (let loop ((res "") (n 1)) (if (> n len) res @@ -664,11 +664,11 @@ ;; #;(define (session:generic-make-rand-string len seed-string) (let ((num-chars (string-length seed-string))) (let loop ((res "") (n 1)) - (let ((char-num (random num-chars))) + (let ((char-num (pseudo-random-integer num-chars))) (if (> n len) res (loop (string-append res (substring seed-string char-num (+ char-num 1))) (+ n 1))))))) ;; Rely on crypt egg's default settings being secure enough, accept @@ -1429,11 +1429,11 @@ (define (session:get-nth-char nth) (substring session:valid-chars nth (+ nth 1))) (define (session:get-rand-char) - (session:get-nth-char (random session:num-valid-chars))) + (session:get-nth-char (pseudo-random-integer session:num-valid-chars))) (define (session:make-rand-string len) (let loop ((res "") (n 1)) (if (> n len) res @@ -1444,11 +1444,11 @@ ;; (define (session:generic-make-rand-string len seed-string) (let ((num-chars (string-length seed-string))) (let loop ((res "") (n 1)) - (let ((char-num (random num-chars))) + (let ((char-num (pseudo-random-integer num-chars))) (if (> n len) res (loop (string-append res (substring seed-string char-num (+ char-num 1))) (+ n 1))))))) @@ -1707,11 +1707,11 @@ ;; The 'auto method will distribute dbs across the disk using hash ;; of user host and user. TODO ;; (if (eq? dbfname 'auto) ;; This is the auto assignment of a db based on hash of IP (let ((dbpath (pathname-directory dbfname))) ;; do a couple sanity checks here to make setting up easier (if debugmode (session:log self "INFO: setting up for sqlite3 db access to " dbfname)) - (if (not (file-write-access? dbpath)) + (if (not (file-writable? dbpath)) (session:log self "WARNING: Cannot write to " dbpath) (if debugmode (session:log self "INFO: " dbpath " is writeable"))) (if (file-exists? dbfname) (begin ;; (session:log self "setting dbexists to #t") Index: subrun.scm ================================================================== --- subrun.scm +++ subrun.scm @@ -16,30 +16,30 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) - posix-extras directory-utils pathname-expand typed-records format - call-with-environment-variables) -(declare (unit subrun)) -;;(declare (uses runs)) -(declare (uses db)) -(declare (uses common)) -;;(declare (uses items)) -;;(declare (uses runconfig)) -;;(declare (uses tests)) -;;(declare (uses server)) -(declare (uses mt)) -;;(declare (uses archive)) -;; (declare (uses filedb)) - -;(include "common_records.scm") -;;(include "key_records.scm") -(include "db_records.scm") ;; provides db:test-get-id -;;(include "run_records.scm") -;;(include "test_records.scm") +;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) +;; posix-extras directory-utils pathname-expand typed-records format +;; call-with-environment-variables) +;; (declare (unit subrun)) +;; ;;(declare (uses runs)) +;; (declare (uses db)) +;; (declare (uses common)) +;; ;;(declare (uses items)) +;; ;;(declare (uses runconfig)) +;; ;;(declare (uses tests)) +;; ;;(declare (uses server)) +;; (declare (uses mt)) +;; ;;(declare (uses archive)) +;; ;; (declare (uses filedb)) +;; +;; ;(include "common_records.scm") +;; ;;(include "key_records.scm") +;; (include "db_records.scm") ;; provides db:test-get-id +;; ;;(include "run_records.scm") +;; ;;(include "test_records.scm") (define (subrun:subrun-test-initialized? test-run-dir) (if (and (common:file-exists? (conc test-run-dir "/subrun-area") ) (common:file-exists? (conc test-run-dir "/testconfig.subrun") )) #t Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -16,18 +16,18 @@ ;; along with Megatest. If not, see . ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit tasks)) -(declare (uses db)) -(declare (uses rmt)) -(declare (uses common)) -(declare (uses pgdb)) +;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format) +;; (import (prefix sqlite3 sqlite3:)) +;; +;; (declare (unit tasks)) +;; (declare (uses db)) +;; (declare (uses rmt)) +;; (declare (uses common)) +;; (declare (uses pgdb)) ;; (import pgdb) ;; pgdb is a module (include "task_records.scm") (include "db_records.scm") @@ -107,25 +107,25 @@ (debug:print 5 *default-log-port* " exn=" (condition->list exn)))) (let* ((dbpath (db:dbfile-path )) ;; (tasks:get-task-db-path)) (dbfile (conc dbpath "/monitor.db")) (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away (exists (common:file-exists? dbpath)) - (write-access (file-write-access? dbpath)) + (write-access (file-writable? dbpath)) (mdb (cond ;; what the hek is *toppath* doing here? - ((and (string? *toppath*)(file-write-access? *toppath*)) + ((and (string? *toppath*)(file-writable? *toppath*)) (sqlite3:open-database dbfile)) - ((file-read-access? dbpath) (sqlite3:open-database dbfile)) + ((file-readable? dbpath) (sqlite3:open-database dbfile)) (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath)) (handler (sqlite3:make-busy-timeout 36000))) (if (and exists (not write-access)) (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control (sqlite3:set-busy-handler! mdb handler) (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) ;; (if (or (and (not exists) - ;; (file-write-access? *toppath*)) - ;; (not (file-read-access? dbpath))) + ;; (file-writable? *toppath*)) + ;; (not (file-readable? dbpath))) ;; (begin ;; ;; TASKS QUEUE MOVED TO main.db ;; ;; (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -20,27 +20,27 @@ ;;====================================================================== ;; Database access ;;====================================================================== -(require-extension (srfi 18) extras tcp) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) - -(declare (unit tdb)) -(declare (uses common)) -(declare (uses keys)) -(declare (uses ods)) -(declare (uses client)) -(declare (uses mt)) -(declare (uses db)) - -(include "common_records.scm") -(include "db_records.scm") -(include "key_records.scm") -(include "run_records.scm") +;; (require-extension (srfi 18) extras tcp) +;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) +;; (import (prefix sqlite3 sqlite3:)) +;; (import (prefix base64 base64:)) +;; +;; (declare (unit tdb)) +;; (declare (uses common)) +;; (declare (uses keys)) +;; (declare (uses ods)) +;; (declare (uses client)) +;; (declare (uses mt)) +;; (declare (uses db)) +;; +;; (include "common_records.scm") +;; (include "db_records.scm") +;; (include "key_records.scm") +;; (include "run_records.scm") ;;====================================================================== ;; ;; T E S T D A T A B A S E S ;; @@ -57,14 +57,14 @@ ;; (define (open-test-db work-area) (debug:print-info 11 *default-log-port* "open-test-db " work-area) (if (and work-area (directory? work-area) - (file-read-access? work-area)) + (file-readable? work-area)) (let* ((dbpath (conc work-area "/testdat.db")) (dbexists (common:file-exists? dbpath)) - (work-area-writeable (file-write-access? work-area)) + (work-area-writeable (file-writable? work-area)) (db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem exn (begin (print-call-chain (current-error-port)) (debug:print 2 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" @@ -73,12 +73,12 @@ (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access (if (or work-area-writeable dbexists) (sqlite3:open-database dbpath) (sqlite3:open-database ":memory:")))) - (tdb-writeable (and (file-write-access? work-area) - (file-write-access? dbpath))) + (tdb-writeable (and (file-writable? work-area) + (file-writable? dbpath))) (handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) (if (and tdb-writeable Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -20,31 +20,31 @@ ;;====================================================================== ;; Tests ;;====================================================================== -(declare (unit tests)) -(declare (uses lock-queue)) -(declare (uses db)) -(declare (uses tdb)) -(declare (uses common)) -;; (declare (uses dcommon)) ;; needed for the steps processing -(declare (uses items)) -(declare (uses runconfig)) -;; (declare (uses sdb)) -(declare (uses server)) -;;(declare (uses stml2)) - -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) -(import (prefix sqlite3 sqlite3:)) -(require-library stml) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "test_records.scm") +;; (declare (unit tests)) +;; (declare (uses lock-queue)) +;; (declare (uses db)) +;; (declare (uses tdb)) +;; (declare (uses common)) +;; ;; (declare (uses dcommon)) ;; needed for the steps processing +;; (declare (uses items)) +;; (declare (uses runconfig)) +;; ;; (declare (uses sdb)) +;; (declare (uses server)) +;; ;;(declare (uses stml2)) +;; +;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) +;; (import (prefix sqlite3 sqlite3:)) +;; (require-library stml) +;; +;; (include "common_records.scm") +;; (include "key_records.scm") +;; (include "db_records.scm") +;; (include "run_records.scm") +;; (include "test_records.scm") (include "js-path.scm") (define (init-java-script-lib) (set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js")) ) @@ -559,11 +559,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)) @@ -1214,11 +1214,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) @@ -1253,11 +1253,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 @@ -1285,11 +1285,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) @@ -1418,11 +1418,11 @@ (let* ((test-dat (rmt:get-test-info-by-id run-id test-id)) (out-dir (db:test-get-rundir test-dat)) (status-file (conc out-dir "/.final-status")) ) ;; 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 .final-status to " out-dir) (let* ((outp (open-output-file status-file)) (status (db:test-get-status test-dat)) (state (db:test-get-state test-dat))) @@ -1436,11 +1436,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)) @@ -1595,11 +1595,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) @@ -1619,11 +1619,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)))) @@ -1728,11 +1728,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: vg.scm ================================================================== --- vg.scm +++ vg.scm @@ -379,20 +379,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)))) ;;======================================================================