Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -25,20 +25,26 @@
server.scm configf.scm db.scm keys.scm margs.scm \
process.scm runs.scm tasks.scm tests.scm genexample.scm \
http-transport.scm tdb.scm client.scm mt.scm \
ezsteps.scm lock-queue.scm rmt.scm api.scm \
subrun.scm portlogger.scm archive.scm env.scm \
- diff-report.scm cgisetup/models/pgdb.scm
+ diff-report.scm pgdb.scm
-# module source files
-MSRCFILES = dbmod.scm dbfile.scm debugprint.scm mtargs.scm commonmod.scm
+# cgisetup/models/pgdb.scm
all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt
+# module source files
+MSRCFILES = dbmod.scm dbfile.scm debugprint.scm mtargs.scm commonmod.scm \
+ ducttape-lib.scm pkts.scm dbi.scm autoload.scm stml2.scm
+
# dbmod.import.o is just a hack here
mofiles/dbfile.o : mofiles/debugprint.o dbmod.import.o
-mofiles/debugprint.o : mofiles/mtargs.o
+mofiles/debugprint.o : mofiles/margs.o
+
+#
+common.o : mofiles/margs.o
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \
# mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \
# rmtmod.scm apimod.scm
@@ -47,10 +53,19 @@
dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \
vg.scm
OFILES = $(SRCFILES:%.scm=%.o)
GOFILES = $(GUISRCF:%.scm=%.o)
+
+TMPMODS = $(SRCFILES:%.scm=tmpmods/%.scm)
+OTMPMODS = $(SRCFILES:%.scm=tmpmods/%.o)
+
+tmpmods/%.scm : %.scm utils/makemodulewrap.sh
+ ./utils/makemodulewrap.sh $*
+
+tmpmods/%.o : tmpmods/%.scm
+ csc $(CSCOPTS) -J -c $< -o tmpmods/$*.o
MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
# compiled import files
MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)
@@ -103,11 +118,11 @@
# include makefile.inc
TCMTOBJS = \
api.o \
archive.o \
- cgisetup/models/pgdb.o \
+ pgdb.o \
client.o \
common.o \
configf.o \
db.o \
env.o \
@@ -153,11 +168,16 @@
$(PREFIX)/share/db/mt-pg.sql : mt-pg.sql
mkdir -p $(PREFIX)/share/db
$(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql
# Special dependencies for the includes
-$(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm
+$(MOFILE) $(MOIMPFILES) $(MSRCFILES) : megatest-fossil-hash.scm
+
+mofiles/dbi.o : mofiles/autoload.o
+mofiles/pkts.o : mofiles/dbi.o
+mofiles/dbfile.o : mofiles/debugprint.o
+mofiles/debugprint.o : mofiles/mtargs.o
mofiles/commonmod.o : megatest-fossil-hash.scm
common.o : mofiles/commonmod.o
# mofiles/dbmod.o : mofiles/configfmod.o
@@ -214,11 +234,11 @@
echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new
if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi
$(OFILES) $(GOFILES) : common_records.scm
-%.o : %.scm $(MOFILES)
+%.o : %.scm $(MOFILES) tmpmods/%.o
csc $(CSCOPTS) -c $< $(MOFILES)
$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper
@echo Installing to PREFIX=$(PREFIX)
$(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest
Index: TODO
==================================================================
--- TODO
+++ TODO
@@ -15,10 +15,21 @@
# You should have received a copy of the GNU General Public License
# along with Megatest. If not, see .
TODO
====
+
+Loose ends
+----------
+
+15:09:29 error in calling find-and-mark-incomplete for run-id 5, exn=#
+ might be related to initial conditions in the db. (no run entry in runs table?).
+
+. -list-servers not correct
+. move *remotedat* into bigdata
+. add back server stats on exit (look in rmt:run in rmtmod.scm)
+
WW15
. fill newview matrix with data, filter pipeline gui elements
. improve [script], especially indent handling
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -18,11 +18,16 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;;======================================================================
-(use srfi-69 posix)
+(import srfi-69
+ ;; posix
+ chicken.process-context.posix
+ chicken.time
+ chicken.string
+ )
(declare (unit api))
(declare (uses rmt))
(declare (uses db))
(declare (uses dbmod))
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -16,11 +16,28 @@
;; 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)
+(import
+ (prefix sqlite3 sqlite3:) srfi-1
+ ;; posix
+ regex regex-case srfi-69 format md5 message-digest srfi-18
+ srfi-13
+
+ chicken.file
+ chicken.io
+ chicken.pathname
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.string
+ chicken.time
+ chicken.time.posix
+ chicken.condition
+
+ )
(declare (unit archive))
(declare (uses db))
(declare (uses common))
ADDED autoload.scm
Index: autoload.scm
==================================================================
--- /dev/null
+++ autoload.scm
@@ -0,0 +1,23 @@
+;;======================================================================
+;; Copyright 2019, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit autoload))
+
+(include "autoload/autoload.scm")
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: cgisetup/models/pgdb.scm
==================================================================
--- cgisetup/models/pgdb.scm
+++ cgisetup/models/pgdb.scm
@@ -16,25 +16,36 @@
;; 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))
+
+
+(import
+ chicken.sort
+ chicken.string
+ srfi-1
+ srfi-69
+ chicken.condition
+ typed-records
+ )
+
+;; (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,13 +18,28 @@
;;======================================================================
;; 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)
+(import 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)
+ chicken.port
+ chicken.pretty-print
+ chicken.process-context.posix
+ chicken.string
+ chicken.time
+ system-information
+
+ )
(declare (unit client))
(declare (uses common))
(declare (uses db))
Index: codescanlib.scm
==================================================================
--- codescanlib.scm
+++ codescanlib.scm
@@ -16,18 +16,18 @@
;; along with Megatest. If not, see .
;;
;; gotta compile with csc, doesn't work with csi -s for whatever reason
-(use srfi-69)
-(use matchable)
-(use utils)
-(use ports)
-(use extras)
-(use srfi-1)
-(use posix)
-(use srfi-12)
+(import srfi-69)
+(import matchable)
+(import utils)
+(import ports)
+(import extras)
+(import srfi-1)
+(import posix)
+(import srfi-12)
;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define ( ) )
(define (load-scm-file scm-file)
;;(print "load "scm-file)
(handle-exceptions
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -16,26 +16,69 @@
;; 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))
+(declare (uses pkts))
+(declare (uses dbi))
+(declare (uses margs))
+
+(import
+ srfi-1
+ srfi-69
+ ;; data-structures posix
+ regex-case (prefix base64 base64:)
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.format
+ chicken.io
+ chicken.pathname
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.process.signal
+ chicken.string
+ chicken.sort
+ chicken.time
+ chicken.time.posix
+
+ ;; dot-locking
+ ;; csv-xml
+ z3
+ ;; udp ;; sql-de-lite
+ ;; hostinfo
+ md5
+ message-digest typed-records
+ ;; directory-utils
+ sparse-vectors
+ stack
+ matchable regex
+ ;; posix
+ (srfi 18)
+ srfi-13
+
+ system-information
+ ;; extras ;; tcp
+ (prefix nanomsg nmsg:)
+ (prefix sqlite3 sqlite3:)
+ pkts
+ (prefix dbi dbi:)
+ margs
+ )
+
+;; (import posix-extras pathname-expand files)
+
(import commonmod)
(include "common_records.scm")
-
+(define setenv set-environment-variable!)
;; (require-library margs)
;; (include "margs.scm")
;; (define old-exit exit)
;;
@@ -199,14 +242,12 @@
;; Miscellaneous
(define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers
(define *numcpus-cache* (make-hash-table))
-(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)
+#;(let-values (( (chicken-release-number chicken-major-version)
(apply values
(map string->number
(take
(string-split (chicken-version) ".")
2)))))
@@ -214,11 +255,12 @@
(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) (resolve-pathname (pathname-expand (or x "/dev/null")) ))
+(define (realpath x)(with-input-from-pipe (conc "realpath \""x"\"") read-line))
(define (common:get-this-exe-fullpath #!key (argv (argv)))
(let* ((this-script
(cond
((and (> (length argv) 2)
@@ -304,24 +346,10 @@
(else "FAIL")))
(define (common:logpro-exit-code->test-status exit-code)
(status-sym->string (common:logpro-exit-code->status-sym exit-code)))
-(defstruct remote
- (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag )
- (server-url #f) ;; (server:check-if-running *toppath*) #f))
- (server-id #f)
- (server-info (if *toppath* (server:check-if-running *toppath*) #f))
- (last-server-check 0) ;; last time we checked to see if the server was alive
- (connect-time (current-seconds))
- (conndat #f)
- (transport *transport-type*)
- (server-timeout (server:expiration-timeout))
- (force-server #f)
- (ro-mode #f)
- (ro-mode-checked #f)) ;; flag that indicates we have checked for ro-mode
-
;; launching and hosts
(defstruct host
(reachable #f)
(last-update 0)
(last-used 0)
@@ -371,53 +399,10 @@
(conc megatest-version "-" megatest-fossil-hash))
(define (common:version-signature)
(conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
-;;======================================================================
-;; from metadat lookup MEGATEST_VERSION
-;;
-(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB
- (rmt:get-var "MEGATEST_VERSION"))
-
-(define (common:get-last-run-version-number)
- (string->number
- (substring (common:get-last-run-version) 0 6)))
-
-(define (common:set-last-run-version)
- (rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
-
-;;======================================================================
-;; postive number if megatest version > db version
-;; negative number if megatest version < db version
-(define (common:version-db-delta)
- (- megatest-version (common:get-last-run-version-number)))
-
-(define (common:version-changed?)
- (not (equal? (common:get-last-run-version)
- (common:version-signature))))
-
-(define (common:api-changed?)
- (not (equal? (substring (->string megatest-version) 0 4)
- (substring (conc (common:get-last-run-version)) 0 4))))
-
-;;======================================================================
-;; Move me elsewhere ...
-;; RADT => Why do we meed the version check here, this is called only if version misma
-;;
-(define (common:cleanup-db dbstruct #!key (full #f))
- (apply db:multi-db-sync
- dbstruct
- 'schema
- 'killservers
- 'adj-target
- 'new2old
- '(dejunk)
- )
- (if (common:api-changed?)
- (common:set-last-run-version)))
-
(define (common:snapshot-file filepath #!key (subdir ".") )
(if (file-exists? filepath)
(let* ((age-sec (lambda (file)
(if (file-exists? file)
(- (current-seconds) (file-modification-time file))
@@ -696,19 +681,19 @@
""))))
(define (common:alist-ref/default key alist default)
(or (alist-ref key alist) default))
-(define (common:low-noise-print waitval . keys)
- (let* ((key (string-intersperse (map conc keys) "-" ))
- (lasttime (hash-table-ref/default *common:denoise* key 0))
- (currtime (current-seconds)))
- (if (> (- currtime lasttime) waitval)
- (begin
- (hash-table-set! *common:denoise* key currtime)
- #t)
- #f)))
+;; (define (common:low-noise-print waitval . keys)
+;; (let* ((key (string-intersperse (map conc keys) "-" ))
+;; (lasttime (hash-table-ref/default *common:denoise* key 0))
+;; (currtime (current-seconds)))
+;; (if (> (- currtime lasttime) waitval)
+;; (begin
+;; (hash-table-set! *common:denoise* key currtime)
+;; #t)
+;; #f)))
(define (common:get-megatest-exe)
(or (getenv "MT_MEGATEST") "megatest"))
(define (common:read-encoded-string instr)
@@ -3467,10 +3452,43 @@
(debug:print 0 *default-log-port* "joining threads failed. exn=" exn)
#t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception
(thread-join! thread))
)))
(hash-table-keys *common:thread-punchlist*)))
+
+;;======================================================================
+;; L O G G I N G D B
+;;======================================================================
+
+(define (open-logging-db)
+ (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
+ (dbexists (common:file-exists? dbpath))
+ (db (sqlite3:open-database dbpath))
+ (handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout")
+ (string->number (args:get-arg "-override-timeout"))
+ 136000)))) ;; 136000)))
+ (sqlite3:set-busy-handler! db handler)
+ (if (not dbexists)
+ (begin
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);")
+ (db:set-sync db) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;"))
+ ))
+ db))
+
+(define (db:log-local-event . loglst)
+ (let ((logline (apply conc loglst)))
+ (db:log-event logline)))
+
+(define (db:log-event logline)
+ (let ((db (open-logging-db)))
+ (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);"
+ logline
+ (current-directory)
+ (string-intersperse (argv) " ")
+ (current-process-id))
+ (sqlite3:finalize! db)
+ logline))
;;======================================================================
;; (define *common:telemetry-log-state* 'startup)
;; (define *common:telemetry-log-socket* #f)
;;
Index: common_records.scm
==================================================================
--- common_records.scm
+++ common_records.scm
@@ -16,11 +16,11 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;;======================================================================
-;; (use trace)
+;; (import trace)
(include "altdb.scm")
;; Some of these routines use:
;;
@@ -205,11 +205,11 @@
;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
(define (BBpp arg)
(pp (BBpp_ arg)))
-;(use define-macro)
+;(import define-macro)
(define-syntax inspect
(syntax-rules ()
[(_ x)
;; (with-output-to-port (current-error-port)
(printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -18,20 +18,39 @@
;;======================================================================
(declare (unit commonmod))
-(use srfi-69)
+(import srfi-69)
(module commonmod
*
-(import scheme chicken data-structures extras files)
-(import (prefix sqlite3 sqlite3:)
- posix typed-records srfi-18 srfi-69
- md5 message-digest
- regex srfi-1)
+ (import
+ scheme
+ chicken.base
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.io
+ chicken.pathname
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.string
+ chicken.time
+ system-information
+
+ ;; data-structures extras files
+ (prefix sqlite3 sqlite3:)
+ ;; posix typed-records
+ srfi-18
+ srfi-69
+ md5
+ message-digest
+ regex
+ srfi-1
+ )
;;======================================================================
;; CONTENTS
;;
;; config file utils
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -20,15 +20,32 @@
;;======================================================================
;; Config file handling
;;======================================================================
-(use regex regex-case matchable) ;; directory-utils)
(declare (unit configf))
(declare (uses process))
(declare (uses env))
(declare (uses keys))
+
+(import
+ regex regex-case matchable
+ chicken.condition
+ chicken.file
+ chicken.io
+ chicken.pathname
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.process-context
+ chicken.sort
+ chicken.string
+ chicken.time
+ srfi-1
+ srfi-13
+ srfi-69
+)
(include "common_records.scm")
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
Index: configure
==================================================================
--- configure
+++ configure
@@ -15,87 +15,18 @@
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Megatest. If not, see .
-# Configure the build
-
-if [[ "$1"x == "x" ]];then
- PREFIX=$PWD
-else
- PREFIX=$1
-fi
-
-
-#======================================================================
-# Configure stuff needed for eggs
-#======================================================================
-
-function configure_dependencies () {
-
- #======================================================================
- # libnanomsg
- #======================================================================
-
- if [[ ! $(ls /usr/lib/*/libnanomsg*) ]];then
- echo "libnanomsg build needed."
- echo "BUILD_NANOMSG=yes" >> makefile.inc
- fi
-
- #======================================================================
- # postgresql libraries
- #======================================================================
-
- if [[ ! $(ls /usr/lib/*/libpq.*) ]];then
- echo "Postgresql build needed."
- echo "BUILD_POSTGRES=yes" >> makefile.inc
- fi
-
- if [[ ! $(ls /usr/lib/*/libsqlite3.*) ]];then
- echo "Sqlite3 build needed."
- echo "BUILD_SQLITE3=yes" >> makefile.inc
- fi
-
-}
-
-#======================================================================
-# Initialize makefile.inc
-#======================================================================
-
-echo "" > makefile.inc
-
-#======================================================================
-# Do we need Chicken?
-#======================================================================
-
-if [[ -e /usr/bin/sw_vers ]]; then
- ARCHSTR=$(/usr/bin/sw_vers -productVersion)
-else
- ARCHSTR=$(lsb_release -sr)
-fi
-
-echo "CHICKEN_PREFIX=$PREFIX/.$ARCHSTR" >> makefile.inc
-CHICKEN_PREFIX=$PREFIX/bin/.$ARCHSTR
-
-if [[ ! $(type csi) ]];then
- echo "Chicken build needed."
- echo "BUILD_CHICKEN=yes" >> makefile.inc
- configure_dependencies
- echo "include chicken.makefile" >> makefile.inc
-else
- echo "CSIPATH=$(which csi)" >> makefile.inc
- CSIPATH=$(which csi)
- echo "CKPATH=$(dirname $(dirname $CSIPATH))" >> makefile.inc
-fi
-
-# Make setup scripts
-echo "#!/bin/bash" > setup.sh
-echo "export PATH=$CHICKEN_PREFIX/bin:\$PATH" >> setup.sh
-echo "export LD_LIBRARY_PATH=$CHICKEN_PREFIX/lib" >> setup.sh
-echo 'exec "$@"' >> setup.sh
-chmod a+x setup.sh
-
-echo "setenv PATH $CHICKEN_PREFIX/bin:\$PATH" > setup.csh
-echo "setenv LD_LIBRARY_PATH $CHICKEN_PREFIX/lib" >> setup.csh
-
-echo "All done creating makefile.inc, feel free to edit it!"
-echo "run \"setup.sh bash\" or source setup.csh to get PATH and LD_LIBRARY_PATH adjusted"
+# Flavors include: simple, full and none
+
+# look at build.config (not a version controlled file and
+# create ulex.scm and dbmgr.scm
+
+if [[ -e transport-flavor ]];then
+ FLAVOR=$(cat transport-flavor)
+else
+ FLAVOR=simple
+fi
+
+sed -e "s/FLAVOR/$FLAVOR/" ulex.scm.template > ulex.scm
+sed -e "s/FLAVOR/$FLAVOR/" dbmgrmod.scm.template > dbmgrmod.scm
Index: dashboard-context-menu.scm
==================================================================
--- dashboard-context-menu.scm
+++ dashboard-context-menu.scm
@@ -21,18 +21,33 @@
;;======================================================================
;; implementation of context menu that pops up on
;; right click on test cell in Runs & Runs Summary Tabs
;;======================================================================
-(use format fmt)
+(import format fmt)
(require-library iup)
(import (prefix iup iup:))
-(use canvas-draw)
+(import canvas-draw)
+
+(import
+ srfi-1
+ ;; posix
+ regex regex-case srfi-69
+
+chicken.pathname
+chicken.port
+chicken.pretty-print
+chicken.process
+chicken.string
+chicken.time
+chicken.condition
+chicken.process-context
+
+ )
-(use srfi-1 posix regex regex-case srfi-69)
-(use (prefix sqlite3 sqlite3:))
+(import (prefix sqlite3 sqlite3:))
(declare (unit dashboard-context-menu))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
Index: dashboard-guimonitor.scm
==================================================================
--- dashboard-guimonitor.scm
+++ dashboard-guimonitor.scm
@@ -20,19 +20,31 @@
;;======================================================================
;; Test info panel
;;======================================================================
-(use format)
+(import format)
(require-library iup)
(import (prefix iup iup:))
-(use canvas-draw)
+(import canvas-draw)
+
+(import sqlite3 srfi-1
+ ;; posix
+ regex regex-case srfi-69)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69)
-(import (prefix sqlite3 sqlite3:))
+(import
+ (prefix sqlite3 sqlite3:)
+ chicken.file.posix
+ chicken.port
+ chicken.pretty-print
+ chicken.string
+ chicken.time
+
+
+)
(declare (unit dashboard-guimonitor))
(declare (uses common))
(declare (uses keys))
(declare (uses db))
(declare (uses tasks))
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -20,18 +20,33 @@
;;======================================================================
;; Test info panel
;;======================================================================
-(use format fmt)
+(import format fmt)
(require-library iup)
(import (prefix iup iup:))
-(use canvas-draw)
+(import canvas-draw)
-(use srfi-1 posix regex regex-case srfi-69)
-(use (prefix sqlite3 sqlite3:))
+(import
+ srfi-1
+ ;; posix
+ regex regex-case srfi-69
+ chicken.file
+ chicken.file.posix
+ chicken.port
+ chicken.pretty-print
+ chicken.string
+ chicken.time
+ srfi-18
+ chicken.condition
+ chicken.process-context
+
+)
+
+(import (prefix sqlite3 sqlite3:))
(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -16,19 +16,22 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;;======================================================================
-(use format)
+(import format)
(require-library iup)
(import (prefix iup iup:))
-(use canvas-draw)
+(import canvas-draw)
(import canvas-draw-iup)
-(use ducttape-lib)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
+(import ducttape-lib)
+(import
+ sqlite3 srfi-1
+ ;; posix
+ regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))
(import dbfile)
(declare (uses common))
(declare (uses margs))
Index: datashare.scm
==================================================================
--- datashare.scm
+++ datashare.scm
@@ -15,29 +15,29 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;; ==> (module datashare
-;; ==> (use ssax)
-;; ==> (use sxml-serializer)
-;; ==> (use sxml-modifications)
-;; ==> (use regex)
-;; ==> (use srfi-69)
-;; ==> (use regex-case)
-;; ==> (use posix)
-;; ==> (use json)
-;; ==> (use csv)
-;; ==> (use srfi-18)
-;; ==> (use format)
+;; ==> (import ssax)
+;; ==> (import sxml-serializer)
+;; ==> (import sxml-modifications)
+;; ==> (import regex)
+;; ==> (import srfi-69)
+;; ==> (import regex-case)
+;; ==> (import posix)
+;; ==> (import json)
+;; ==> (import csv)
+;; ==> (import srfi-18)
+;; ==> (import format)
;; ==>
-;; ==> (use (prefix iup iup:))
+;; ==> (import (prefix iup iup:))
;; ==> (import (prefix ini-file ini:))
;; ==>
-;; ==> (use canvas-draw)
+;; ==> (import canvas-draw)
;; ==> (import canvas-draw-iup)
;; ==>
-;; ==> (use sqlite3 srfi-1 posix regex regex-case srfi-69)
+;; ==> (import sqlite3 srfi-1 posix regex regex-case srfi-69)
;; ==> (import (prefix sqlite3 sqlite3:))
;; ==>
;; ==> (declare (uses configf))
;; ==> (declare (uses tree))
;; ==> (declare (uses margs))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -22,31 +22,53 @@
;; Database access
;;======================================================================
;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc
-(use (srfi 18)
- extras
- tcp
- stack
- (prefix sqlite3 sqlite3:)
- srfi-1
- posix
- regex
- regex-case
- srfi-69
- csv-xml
- s11n
- md5
- message-digest
- (prefix base64 base64:)
- format
- dot-locking
- z3
- typed-records
- matchable
- files)
+(import
+ (srfi 18)
+ ;; extras
+ ;; tcp
+ stack
+ (prefix sqlite3 sqlite3:)
+ srfi-1
+ ;; posix
+ regex
+ regex-case
+ srfi-69
+ ;; csv-xml
+ s11n
+ md5
+ message-digest
+ (prefix base64 base64:)
+ ;; format
+ ;; dot-locking
+ z3
+ typed-records
+ matchable
+ ;; files
+ srfi-13
+
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.format
+ chicken.io
+ chicken.pathname
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.sort
+ chicken.string
+ chicken.time
+ chicken.time.posix
+
+
+
+ )
(declare (unit db))
(declare (uses common))
(declare (uses dbmod))
;; (declare (uses debugprint))
@@ -1266,43 +1288,10 @@
;; (db (dbr:dbdat-dbh dbdat))
;; (res '())
;; (blocks '())) ;; a block is an archive chunck that can be added too if there is space
;; (sqlite3:for-each-row #f)
-;;======================================================================
-;; L O G G I N G D B
-;;======================================================================
-
-(define (open-logging-db)
- (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname)
- (dbexists (common:file-exists? dbpath))
- (db (sqlite3:open-database dbpath))
- (handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout")
- (string->number (args:get-arg "-override-timeout"))
- 136000)))) ;; 136000)))
- (sqlite3:set-busy-handler! db handler)
- (if (not dbexists)
- (begin
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);")
- (db:set-sync db) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;"))
- ))
- db))
-
-(define (db:log-local-event . loglst)
- (let ((logline (apply conc loglst)))
- (db:log-event logline)))
-
-(define (db:log-event logline)
- (let ((db (open-logging-db)))
- (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);"
- logline
- (current-directory)
- (string-intersperse (argv) " ")
- (current-process-id))
- (sqlite3:finalize! db)
- logline))
-
;;======================================================================
;; D B U T I L S
;;======================================================================
;;======================================================================
@@ -5044,5 +5033,21 @@
)
)
0)
+;; PULLED FROM COMMON
+
+;;======================================================================
+;;
+(define (common:cleanup-db dbstruct #!key (full #f))
+ (apply db:multi-db-sync
+ dbstruct
+ 'schema
+ 'killservers
+ 'adj-target
+ 'new2old
+ '(dejunk)
+ )
+ (if (common:api-changed?)
+ (common:set-last-run-version)))
+
Index: dbfile.scm
==================================================================
--- dbfile.scm
+++ dbfile.scm
@@ -17,31 +17,49 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit dbfile))
-;; (declare (uses debugprint))
+(declare (uses debugprint))
(declare (uses commonmod))
(module dbfile
*
- (import scheme
- chicken
- data-structures
- extras
- matchable)
-
-(import (prefix sqlite3 sqlite3:)
- posix typed-records srfi-18 srfi-1
- srfi-69
- stack
- files
- ports
-
- commonmod
- )
+ (import
+ scheme
+
+ chicken.base
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.io
+ chicken.pathname
+ chicken.port
+ chicken.process
+ chicken.process-context.posix
+ chicken.sort
+ chicken.time
+ chicken.string
+
+ ;; data-structures
+ ;; extras
+ matchable
+ (prefix sqlite3 sqlite3:)
+ ;; posix
+ typed-records
+ srfi-18
+ srfi-1
+ srfi-69
+ stack
+ system-information
+ ;; files
+ ;; ports
+
+ commonmod
+ debugprint
+ )
;; (import debugprint)
;;======================================================================
;; R E C O R D S
@@ -306,11 +324,11 @@
;;
;; NOTE: returns a dbdat not a dbstruct!
;;
(define (dbfile:open-sqlite3-db dbpath init-proc)
(let* ((dbexists (file-exists? dbpath))
- (write-access (file-write-access? dbpath))
+ (write-access (file-writable? dbpath))
(db (dbfile:cautious-open-database dbpath init-proc))) #;(sqlite3:open-database dbpath)
(dbfile:inc-db-open dbpath)
(sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000))
(sqlite3:execute db (conc "PRAGMA synchronous = 0;"))
;; (init-proc db)
@@ -470,22 +488,20 @@
;; (db:multi-db-sync subdb 'old2new)) ;; migrate data from megatest.db automatically
tmpdb))
(define (dbfile:cautious-open-database fname init-proc #!optional (tries-left 50))
-
- (let* ((busy-file (conc fname"-journal"))
- (delay-time (* (- 51 tries-left) 1.1))
- (write-access (file-write-access? fname))
- (dir-access (file-write-access? (pathname-directory fname)))
- (retry (lambda ()
- (thread-sleep! delay-time)
- (if (> tries-left 0)
- (dbfile:cautious-open-database fname init-proc (- tries-left 1))))))
+ (let* ((busy-file (conc fname"-journal"))
+ (delay-time (* (- 51 tries-left) 1.1))
+ (write-access (file-writable? fname))
+ (dir-access (file-writable? (pathname-directory fname)))
+ (retry (lambda ()
+ (thread-sleep! delay-time)
+ (if (> tries-left 0)
+ (dbfile:cautious-open-database fname init-proc (- tries-left 1))))))
(assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up."))
-
- (if (and (file-write-access? fname)
+ (if (and (file-writable? fname)
(file-exists? busy-file))
(begin
(dbfile:print-err "INFO: dbfile:cautious-open-database: journal file " busy-file " exists, trying again in few seconds.")
(thread-sleep! 1)
(if (eq? tries-left 2)
@@ -527,11 +543,11 @@
(retry))
(exn ()
(dbfile:print-err exn "ERROR: Unknown error with database " fname " message: "
((condition-property-accessor 'exn 'message) exn))
(retry)))))
- #;(if (file-write-access? fname)
+ #;(if (file-writable? fname)
(dbfile:simple-file-release-lock lock-file))
result))))
(define (dbfile:brute-force-salvage-db fname)
(let* ((backupfname (conc fname"-"(current-process-id)".bak"))
@@ -547,11 +563,11 @@
(retry (lambda ()
(thread-sleep! delay-time)
(if (> tries-left 0)
(dbfile:cautious-open-database fname init-proc (- tries-left 1))))))
(assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up."))
- (if (and (file-write-access? fname) (not (dbfile:simple-file-lock lock-file expire-time: 3)))
+ (if (and (file-writable? fname) (not (dbfile:simple-file-lock lock-file expire-time: 3)))
(begin
(dbfile:print-err "INFO: dbfile:cautious-open-database: lock file " lock-file " exists, trying again in few seconds.")
(thread-sleep! 1)
(if (eq? tries-left 2)
(begin
@@ -578,11 +594,11 @@
(retry))
(exn ()
(dbfile:print-err exn "ERROR: Unknown error with database " fname " message: "
((condition-property-accessor 'exn 'message) exn))
(retry)))))
- (if (file-write-access? fname)
+ (if (file-writable? fname)
(dbfile:simple-file-release-lock lock-file)
)
result))))
@@ -886,17 +902,17 @@
-3)
((not (sqlite3:database? (dbr:dbdat-dbh todb)))
(dbfile:print-err "db:sync-tables called with todb not a database " todb)
-4)
- ((not (file-write-access? (dbr:dbdat-dbfile todb)))
+ ((not (file-writable? (dbr:dbdat-dbfile todb)))
(dbfile:print-err "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? (dbr:dbdat-dbfile todb))))
+ (not (file-writable? (dbr:dbdat-dbfile todb))))
slave-dbs)))
(for-each
(lambda (bad-dbdat)
(dbfile:print-err "db:sync-tables called with todb not a read-only database " bad-dbdat))
readonly-slave-dbs)
@@ -905,11 +921,11 @@
;; (dbfile:print-err "db:sync-tables: args are good")
(let ((stmts (make-hash-table)) ;; table-field => stmt
(all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 ))
(numrecs (make-hash-table))
- (start-time (current-milliseconds))
+ (start-time (current-process-milliseconds))
(tot-count 0))
(for-each ;; table
(lambda (tabledat)
(let* ((tablename (car tabledat))
(fields (cdr tabledat))
@@ -1049,11 +1065,11 @@
(append (list todb) slave-dbs)
)
)
)
tbls)
- (let* ((runtime (- (current-milliseconds) start-time))
+ (let* ((runtime (- (current-process-milliseconds) start-time))
(should-print (or ;; (debug:debug-mode 12)
(common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate.
(for-each
(lambda (dat)
(let ((tblname (car dat))
Index: dbmod.scm
==================================================================
--- dbmod.scm
+++ dbmod.scm
@@ -21,14 +21,19 @@
(declare (unit dbmod))
(module dbmod
*
-(import scheme chicken data-structures extras)
-(import (prefix sqlite3 sqlite3:)
- posix typed-records srfi-18
- srfi-69)
+(import
+ scheme
+ chicken.string
+ ;; chicken data-structures extras
+ (prefix sqlite3 sqlite3:)
+ ;; posix
+ typed-records srfi-18
+ srfi-69
+ )
(define (db:run-id->dbname run-id)
(cond
((number? run-id)(conc run-id ".db"))
((not run-id) "main.db")
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -16,16 +16,33 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;;======================================================================
-(use format)
+(import format)
(require-library iup)
(import (prefix iup iup:))
-(use canvas-draw)
+(import canvas-draw)
(import canvas-draw-iup)
-(use regex typed-records matchable)
+(import regex typed-records matchable
+
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.sort
+ chicken.string
+ chicken.time
+ srfi-1
+ srfi-18
+ srfi-69
+
+ )
(declare (unit dcommon))
(declare (uses gutils))
(declare (uses db))
Index: debugprint.scm
==================================================================
--- debugprint.scm
+++ debugprint.scm
@@ -6,15 +6,22 @@
*
;;(import scheme chicken data-structures extras files ports)
(import
scheme
- chicken
- data-structures
- posix
- ports
- extras
+ chicken.base
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.time
+ chicken.port
+ chicken.time.posix
+ chicken.string
+ system-information
+ ;; data-structures
+ ;; posix
+ ;; ports
+ ;; extras
;; scheme
;; chicken.base
;; chicken.string
;; chicken.time
@@ -45,11 +52,11 @@
;; if we were handed a bad verbosity rule then we will override it with 1 and continue
(if (not (verbosity))(verbosity 1))
(if (and (not (args:get-arg "-debug-noprop"))
(or (args:get-arg "-debug")
(not (get-environment-variable "MT_DEBUG_MODE"))))
- (setenv #;set-environment-variable! "MT_DEBUG_MODE" (if (list? (verbosity))
+ (set-environment-variable! "MT_DEBUG_MODE" (if (list? (verbosity))
(string-intersperse (map conc (verbosity)) ",")
(conc (verbosity)))))))
;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
Index: diff-report.scm
==================================================================
--- diff-report.scm
+++ diff-report.scm
@@ -17,15 +17,31 @@
;;
(declare (unit diff-report))
(declare (uses common))
(declare (uses rmt))
+(declare (uses ducttape-lib))
+(import
+ matchable
+ fmt
+ ducttape-lib
+
+ chicken.port
+ chicken.pretty-print
+ chicken.sort
+ chicken.string
+ chicken.time
+ chicken.time.posix
+ srfi-1
+ srfi-69
+ srfi-13
+
+ )
+
(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: ducttape/ducttape-lib.scm
==================================================================
--- ducttape/ducttape-lib.scm
+++ ducttape/ducttape-lib.scm
@@ -44,24 +44,55 @@
isodate->wwdate
wwdate->seconds
wwdate->isodate
current-wwdate
current-isodate
- *this-exe-dir*
- *this-exe-name*
- *this-exe-fullpath*
+ ;; *this-exe-dir*
+ ;; *this-exe-name*
+ ;; *this-exe-fullpath*
)
- (import scheme chicken extras ports data-structures )
- (use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339)
- ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process*
- (use directory-utils uuid-lib filepath srfi-19 ) ; linenoise
-
- ;; plugs a hole in posix-extras in latter chicken versions
- (use posix-extras pathname-expand files)
- (define ##sys#expand-home-path pathname-expand)
- (define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) ))
+(import
+ scheme
+ ;; chicken extras ports data-structures )
+ ;; (use posix
+ regex ansi-escape-sequences test srfi-1
+
+ chicken.base
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.format
+ chicken.irregex
+ chicken.io
+ chicken.string
+ chicken.time
+ chicken.time.posix
+ chicken.pathname
+ chicken.port
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+
+ slice
+ srfi-13
+ srfi-19
+ rfc3339
+ ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process*
+ ;; directory-utils
+ uuid-lib
+ ;; filepath srfi-19 ) ; linenoise
+
+ ;; plugs a hole in posix-extras in latter chicken versions
+ ;; (use posix-extras pathname-expand files)
+ srfi-19
+ test
+;;(use format)
+ )
+
+ ;; (define ##sys#expand-home-path pathname-expand)
+;; (define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) ))
;; (include "mimetypes.scm") ; provides ext->mimetype
;; (include "workweekdate.scm")
;; gathered from macosx:
@@ -841,14 +872,10 @@
("avi" . "video/x-msvideo")
("movie" . "video/x-sgi-movie")
("smv" . "video/x-smv")
("ice" . "x-conference/x-cooltalk")))
-(use srfi-19)
-(use test)
-;;(use format)
-(use regex)
;(declare (unit wwdate))
;; utility procedures to convert among
;; different ways to express date (wwdate, seconds since epoch, isodate)
;;
;; samples:
@@ -1058,19 +1085,19 @@
(if (null? rest-path-items)
#f
(let* ((this-dir (car rest-path-items))
(next-rest (cdr rest-path-items))
(candidate (conc this-dir "/" exe)))
- (if (file-execute-access? candidate)
+ (if (file-executable? candidate)
candidate
(loop next-rest)))))))
;;;; define some handy globals
;; resolve fullpath to this script or binary.
- (define (__get-this-script-fullpath #!key (argv (argv)))
+ #;(define (__get-this-script-fullpath #!key (argv (argv)))
(let* ((this-script
(cond
((and (> (length argv) 2)
(string-match "^(.*/csi|csi)$" (car argv))
(string-match "^-(s|ss|sx|script)$" (cadr argv)))
@@ -1079,13 +1106,13 @@
;;(foo (begin (print "hello "(find-exe "/bin/sh") #f)))
(fullpath (or (find-exe this-script) (realpath this-script))))
fullpath))
- (define *this-exe-fullpath* (__get-this-script-fullpath))
- (define *this-exe-dir* (pathname-directory *this-exe-fullpath*))
- (define *this-exe-name* (pathname-strip-directory *this-exe-fullpath*))
+ ;; (define *this-exe-fullpath* (__get-this-script-fullpath))
+ ;; (define *this-exe-dir* (pathname-directory *this-exe-fullpath*))
+ ;; (define *this-exe-name* (pathname-strip-directory *this-exe-fullpath*))
;;;; utility procedures
@@ -1247,15 +1274,15 @@
(let ((num-debug-level (runs-ok (string->number raw-debug-level))))
(if (integer? num-debug-level)
(begin
(let ((new-num-debug-level (- num-debug-level 1)))
(if (> new-num-debug-level 0) ;; decrement
- (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level))
- (unsetenv "DUCTTAPE_DEBUG_LEVEL")))
+ (set-environment-variable! "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level))
+ (unset-environment-variable! "DUCTTAPE_DEBUG_LEVEL")))
num-debug-level) ; it was set and > 0, mode is value
(begin
- (unsetenv "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it
+ (unset-environment-variable! "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it
#f))) ; value was invalid, mode is f
#f)))) ; var not set, mode is f
(define ducttape-debug-mode (if (ducttape-debug-level) #t #f))
@@ -1360,11 +1387,11 @@
(user (or (get-environment-variable "USER") "nouser"))
(host (or (get-environment-variable "HOST") "nohost")))
(if logfile
(begin
(ducttape-log-file logfile)
- (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file))))
+ (set-environment-variable! "DUCTTAPE_LOG_FILE" (ducttape-log-file))))
(ducttape-append-logfile 'note (format #f "START - pid=~A ppid=~A argv=(~A) pwd=~A user=~A host=~A" pid ppid argv pwd user host) #t)))
;; log exit code
(define (set-ducttape-log-exit-handler)
@@ -1500,12 +1527,10 @@
(if dir dir (get-tmpdir))
"/" prefix ".XXXXXX"))))
(close-output-port (open-output-file* fd))
path))
-
-
;;http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment
;; write send-email using:
;; - isys-foreach-stdin-line
;; - formatting in http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment
(define (sendmail to_addr subject body
@@ -1575,13 +1600,13 @@
(wl body)
(body-boundary))
(define (attach-file file #!key (content-id #f))
(let* ((filename
- (filepath:take-file-name file))
+ (pathname-file file))
(ext-with-dot
- (filepath:take-extension file))
+ (pathname-extension file))
(ext (string-take-right
ext-with-dot
(- (string-length ext-with-dot) 1)))
(mimetype (ext->mimetype ext))
(uuencode-command (conc "uuencode " file " " filename)))
@@ -1702,40 +1727,40 @@
;; --quiet
(let ((quiet-opts (skim-cmdline-opts-noarg-by-regex "--?quiet")))
(if (not (null? quiet-opts))
(begin
- (setenv "DUCTTAPE_QUIET_MODE" "1")
+ (set-environment-variable! "DUCTTAPE_QUIET_MODE" "1")
(ducttape-quiet-mode "1"))))
;; --silent
(let ((silent-opts (skim-cmdline-opts-noarg-by-regex "--?silent")))
(if (not (null? silent-opts))
(begin
- (setenv "DUCTTAPE_SILENT_MODE" "1")
+ (set-environment-variable! "DUCTTAPE_SILENT_MODE" "1")
(ducttape-silent-mode "1"))))
;; -color
(let ((color-opts (skim-cmdline-opts-noarg-by-regex "--?colou?r(ize)?")))
(if (not (null? color-opts))
(begin
- (setenv "DUCTTAPE_COLORIZE" "1")
+ (set-environment-variable! "DUCTTAPE_COLORIZE" "1")
(ducttape-color-mode "1"))))
;; -nocolor
(let ((nocolor-opts (skim-cmdline-opts-noarg-by-regex "--?nocolou?r(ize)?")))
(if (not (null? nocolor-opts))
(begin
- (unsetenv "DUCTTAPE_COLORIZE" )
+ (unset-environment-variable! "DUCTTAPE_COLORIZE" )
(ducttape-color-mode #f))))
;; -logfile
(let ((logfile-opts (skim-cmdline-opts-withargs-by-regex "--?log(-?file)?")))
(if (not (null? logfile-opts))
(begin
(ducttape-log-file (car (reverse logfile-opts)))
- (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file)))))
+ (set-environment-variable! "DUCTTAPE_LOG_FILE" (ducttape-log-file)))))
;; -d -dd -d#
(let ((debug-opts (skim-cmdline-opts-noarg-by-regex "-d(d*|\\d+)"))
(initial-debuglevel (if (ducttape-debug-level) (ducttape-debug-level) 0) ))
(if (not (null? debug-opts))
@@ -1750,19 +1775,19 @@
(ds (string-match "-(d+)" curopt))
(dnum (string-match "-d(\\d+)" curopt)))
(cond
(ds (loop restopts (+ debuglevel (string-length (cadr ds)))))
(dnum (loop restopts (string->number (cadr dnum)))))))))
- (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level))))))
+ (set-environment-variable! "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level))))))
;; -dp / --debug-pattern
(let ((debugpat-opts (skim-cmdline-opts-withargs-by-regex "--?(debug-pattern|dp)")))
(if (not (null? debugpat-opts))
(begin
(ducttape-debug-regex-filter (string-join debugpat-opts "|"))
- (setenv "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter))))))
+ (set-environment-variable! "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter))))))
;;; following code commented out; side effects not wanted on startup
;; immediately activate logfile (will be noop if logfile disabled)
;;(ducttape-activate-logfile)
Index: env.scm
==================================================================
--- env.scm
+++ env.scm
@@ -18,11 +18,17 @@
;;======================================================================
(declare (unit env))
-(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
+(import
+ sql-de-lite ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
+chicken.string
+srfi-1
+srfi-69
+chicken.process-context
+)
(define (env:open-db fname)
(let* ((db-exists (common:file-exists? fname))
(db (open-database fname)))
(if (not db-exists)
Index: ezsteps.scm
==================================================================
--- ezsteps.scm
+++ ezsteps.scm
@@ -17,12 +17,29 @@
;; along with Megatest. If not, see .
;;
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-(use srfi-1 posix regex srfi-69 directory-utils call-with-environment-variables posix-extras
- z3 csv typed-records pathname-expand matchable)
+(import
+ srfi-1
+ ;; posix regex srfi-69
+ ;; directory-utils
+ ;; call-with-environment-variables posix-extras
+ z3
+ ;; csv
+ typed-records pathname-expand matchable
+ chicken.file
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.string
+ chicken.time
+ srfi-18
+ srfi-69
+ chicken.process-context
+ regex
+ )
(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
Index: gen-data-for-graph.scm
==================================================================
--- gen-data-for-graph.scm
+++ gen-data-for-graph.scm
@@ -13,11 +13,11 @@
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-(use foof-loop sql-de-lite posix)
+(import foof-loop sql-de-lite posix)
(define beginning-2016 1451636435.0)
(define now (current-seconds))
(define one-year-ago (- now (* 365 24 60 60)))
Index: genexample.scm
==================================================================
--- genexample.scm
+++ genexample.scm
@@ -17,11 +17,23 @@
;; along with Megatest. If not, see .
;;======================================================================
(declare (unit genexample))
-(use posix regex matchable)
+(import
+ regex matchable
+ chicken.file
+ chicken.file.posix
+ chicken.io
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.string
+ srfi-1
+ srfi-69
+ srfi-13
+ )
(include "db_records.scm")
(define genexample:example-logpro
#<.
-(require-extension (srfi 18) extras tcp s11n)
-
+(import
+ (srfi 18)
+ ;; extras
+ chicken.tcp
+ s11n
+ srfi-1
+ ;; posix
+ regex regex-case srfi-69
+ ;; hostinfo
+ md5 message-digest
+ ;;posix-extras
-(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras)
+ spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing
+
+chicken.condition
+chicken.file
+chicken.pathname
+chicken.port
+chicken.pretty-print
+chicken.process
+chicken.process-context
+chicken.process-context.posix
+chicken.string
+chicken.time
+chicken.time.posix
+system-information
+srfi-13
+chicken.io
-(use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)
+ )
;; Configurations for server
(tcp-buffer-size 2048)
(max-connections 2048)
@@ -45,10 +69,14 @@
(include "js-path.scm")
(import dbfile commonmod)
(require-library stml)
+
+(define setenv set-environment-variable!)
+(define getenv get-environment-variable)
+
(define (http-transport:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
Index: index-tree.scm
==================================================================
--- index-tree.scm
+++ index-tree.scm
@@ -20,11 +20,11 @@
;;======================================================================
;; Tests
;;======================================================================
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
+(import sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(declare (unit tests))
(declare (uses lock-queue))
(declare (uses db))
Index: items.scm
==================================================================
--- items.scm
+++ items.scm
@@ -21,12 +21,26 @@
;; (temperature "cool medium hot")
;; (season "summer winter fall spring")))
(declare (unit items))
(declare (uses common))
+
+(import
+ chicken.file
+ chicken.io
+ chicken.port
+ chicken.pretty-print
+ chicken.string
+ chicken.time
+ chicken.process-context
+ srfi-1
+ srfi-69)
+
(include "common_records.scm")
+(define setenv set-environment-variable!)
+(define getenv get-environment-variable)
;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
(let ((res '()))
(if (not hierdepth)
Index: keys.scm
==================================================================
--- keys.scm
+++ keys.scm
@@ -19,12 +19,19 @@
;;======================================================================
;; 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:))
+(import sqlite3 srfi-1
+ ;; posix
+ regex regex-case srfi-69 (prefix sqlite3 sqlite3:)
+ chicken.port
+ chicken.pretty-print
+ chicken.string
+ chicken.time
+ srfi-13
+)
(declare (unit keys))
(declare (uses common))
(include "key_records.scm")
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -19,13 +19,35 @@
;;======================================================================
;; 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
+ chicken.bitwise
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.io
+ chicken.pathname
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.process.signal
+ chicken.sort
+ chicken.string
+ chicken.time
+ srfi-1
+ srfi-69
+ system-information
+
+ regex regex-case base64 sqlite3 srfi-18 directory-utils
+ ;; posix-extras
+ z3
+ ;; call-with-environment-variables csv)
+ typed-records pathname-expand matchable)
(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))
(declare (unit launch))
@@ -33,10 +55,13 @@
(declare (uses common))
(declare (uses configf))
(declare (uses db))
(declare (uses ezsteps))
+(define getenv get-environment-variable)
+(define setenv set-environment-variable!)
+
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "megatest-fossil-hash.scm")
Index: lock-queue.scm
==================================================================
--- lock-queue.scm
+++ lock-queue.scm
@@ -14,11 +14,19 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-(use (prefix sqlite3 sqlite3:) srfi-18)
+(import
+ (prefix sqlite3 sqlite3:) srfi-18
+ chicken.file
+ chicken.process
+ chicken.time
+ sqlite3
+ chicken.condition
+ chicken.string
+ )
(declare (unit lock-queue))
(declare (uses common))
(declare (uses tasks))
@@ -247,7 +255,7 @@
(loop (lock-queue:any-younger? dbdat mystart test-id)))))))))
(sqlite3:finalize! db)
result))))))
-;; (use trace)
+;; (import trace)
;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state)
Index: margs.scm
==================================================================
--- margs.scm
+++ margs.scm
@@ -17,10 +17,24 @@
(declare (unit margs))
;; (declare (uses common))
+(module margs
+ *
+
+(import
+ scheme
+ chicken.base
+ chicken.process-context
+ srfi-1
+ srfi-69
+
+ )
+
+(define help #f)
+
(define args:arg-hash (make-hash-table))
(define (args:get-arg arg . default)
(if (null? default)
(hash-table-ref/default args:arg-hash arg #f)
@@ -89,5 +103,6 @@
(define (args:print-args remargs arg-hash)
(print "ARGS: " remargs)
(for-each (lambda (arg)
(print " " arg " " (hash-table-ref/default arg-hash arg #f)))
(hash-table-keys arg-hash)))
+)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -58,35 +58,64 @@
;; (import ftail)
(import dbmod
commonmod
dbfile)
+
+(import
+chicken.condition
+ chicken.file
+ chicken.pathname
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.process.signal
+ chicken.repl
+ chicken.sort
+ chicken.string
+ chicken.time
+ chicken.time.posix
+ srfi-1
+ srfi-13
+ srfi-69
+ system-information
+
+ )
(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 "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 sqlite3 sqlite3:) srfi-1
+ ;; posix
+ regex regex-case srfi-69 (prefix base64 base64:)
+ breadline apropos json http-client
+ ;; directory-utils
+ typed-records
+ http-client srfi-18
+ ;; extras
+ (chicken.format)
-;; Added for csv stuff - will be removed
-;;
-(use sparse-vectors)
+ ;; Added for csv stuff - will be removed
+ ;;
+ sparse-vectors)
(require-library mutils)
(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
(dbfile:db-init-proc db:initialize-main-db)
-;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
+;; load the ~/.megatestrc file, put (import trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
;;
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
(if (common:file-exists? debugcontrolf)
(load debugcontrolf)))
@@ -163,11 +192,11 @@
-tagexpr tag1,tag2%,.. : select tests with tags matching expression
Test helpers (for use inside tests)
-step stepname
- -test-status : set the state and status of a test (use :state and :status)
+ -test-status : set the state and status of a test (import :state and :status)
-setlog logfname : set the path/filename to the final log relative to the test
directory. may be used with -test-status
-set-toplog logfname : set the overall log for a suite of sub-tests
-summarize-items : for an itemized test create a summary html
-m comment : insert a comment for this test
@@ -246,11 +275,11 @@
will substitute %s for the sheet name in generating
multiple sheets)
-o : output file for refdb2dat (defaults to stdout)
-archive cmd : archive runs specified by selectors to one of disks specified
in the [archive-disks] section.
- cmd: keep-html, restore, save, save-remove, get, replicate-db (use
+ cmd: keep-html, restore, save, save-remove, get, replicate-db (import
-dest to set destination), -include path1,path2... to get or save specific files
-generate-html : create a simple html dashboard for browsing your runs
-generate-html-structure : create a top level html veiw to list targets/runs and a Run view within each run directory.
-list-run-time : list time requered to complete runs. It supports following switches
-run-patt -target-patt -dumpmode
@@ -2399,13 +2428,13 @@
(repl))
(else
(begin
(set! *db* dbstructs)
- (import extras) ;; might not be needed
+ ;; (import extras) ;; might not be needed
;; (import csi)
- (import readline)
+ (import breadline)
(import apropos)
(import dbfile)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(if *use-new-readline*
Index: mlaunch.scm
==================================================================
--- mlaunch.scm
+++ mlaunch.scm
@@ -23,11 +23,11 @@
;; take jobs from the given queue and keep launching them keeping
;; the cpu load at the targeted level
;;
;;======================================================================
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)
+(import sqlite3 srfi-1 posix regex regex-case srfi-69 format)
(declare (unit mlaunch))
(declare (uses db))
(declare (uses common))
Index: monitor.scm
==================================================================
--- monitor.scm
+++ monitor.scm
@@ -15,11 +15,11 @@
;; 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 sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
+(import sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
(import (prefix sqlite3 sqlite3:))
(declare (unit runs))
(declare (uses db))
(declare (uses common))
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -15,11 +15,26 @@
;; 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 sqlite3 srfi-1
+ ;; posix
+ regex regex-case srfi-69
+ ;; dot-locking
+ (srfi 18)
+ ;; posix-extras directory-utils call-with-environment-variables
+ chicken.file
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.process-context.posix
+ chicken.string
+ chicken.time
+ chicken.condition
+ chicken.process-context
+ )
(import (prefix sqlite3 sqlite3:))
(declare (unit mt))
(declare (uses db))
(declare (uses common))
Index: mtargs/mtargs.scm
==================================================================
--- mtargs/mtargs.scm
+++ mtargs/mtargs.scm
@@ -26,12 +26,19 @@
print-args
any-defined?
help
)
-(import scheme chicken data-structures extras posix ports files)
-(use srfi-69 srfi-1)
+ (import
+ scheme
+ chicken.base
+ chicken.process-context
+ ;; scheme
+ ;; chicken data-structures extras posix ports files
+ srfi-69
+ srfi-1
+ )
(define arg-hash (make-hash-table))
(define help "")
(define (get-arg arg . default)
Index: mtexec.scm
==================================================================
--- mtexec.scm
+++ mtexec.scm
@@ -20,21 +20,27 @@
;; (include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
-(use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
- srfi-19 srfi-18 extras format pkts regex regex-case
- (prefix dbi dbi:)
- )
+(import
+ srfi-1
+ ;; posix
+ srfi-69
+ breadline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
+ srfi-19 srfi-18
+ ;; extras format
+ pkts regex regex-case
+ (prefix dbi dbi:)
+ )
;; (declare (uses common))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))
-;; (use ducttape-lib)
+;; (import ducttape-lib)
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;; (require-library stml)
@@ -100,13 +106,13 @@
(exit)))
(if (or (args:get-arg "-repl")
(args:get-arg "-load"))
(begin
- (import extras) ;; might not be needed
+ ;; (import extras) ;; might not be needed
;; (import csi)
- (import readline)
+ (import breadline)
(import apropos)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(install-history-file (get-environment-variable "HOME") ".mtutil_history") ;; [homedir] [filename] [nlines])
(current-input-port (make-readline-port "mtutil> "))
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -13,29 +13,37 @@
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
+
+(declare (uses common))
+(declare (uses margs))
+(declare (uses configf))
+(declare (uses pkts))
+;; (declare (uses rmt))
;; (include "common.scm")
(include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
-(use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
- srfi-19 srfi-18 extras format pkts regex regex-case
- (prefix dbi dbi:)
- (prefix sqlite3 sqlite3:)
- nanomsg)
-
-(declare (uses common))
-(declare (uses margs))
-(declare (uses configf))
-;; (declare (uses rmt))
-
-(use ducttape-lib)
+(import
+ srfi-1
+ ;; posix
+ srfi-69 breadline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
+ srfi-19 srfi-18
+ ;; extras
+ chicken.format
+ pkts regex regex-case
+ (prefix dbi dbi:)
+ (prefix sqlite3 sqlite3:)
+ nanomsg)
+
+
+(import ducttape-lib)
(include "megatest-fossil-hash.scm")
(require-library stml)
@@ -824,11 +832,11 @@
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt))))))
-;; (use trace)(trace create-run-pkt)
+;; (import trace)(trace create-run-pkt)
(define (contains list x) (cond ((null? list) #f) ((eq? (car list) x) #t) (else (contains (cdr list) x))))
;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (generate-run-pkts mtconf toppath)
@@ -1329,11 +1337,11 @@
"") (if (member action '("-run" "-rerun-clean" "-rerun-all" "-kill-rerun"))
"-rerun DEAD,ABORT,KILLED"
""))
pkta)))
-;; (use trace)(trace pkt->cmdline)
+;; (import trace)(trace pkt->cmdline)
(define (write-pkt pktsdir uuid pkt)
(if pktsdir
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
@@ -1951,13 +1959,13 @@
(exit)))
(if (or (args:get-arg "-repl")
(args:get-arg "-load"))
(begin
- (import extras) ;; might not be needed
+ ;; (import extras) ;; might not be needed
;; (import csi)
- (import readline)
+ (import breadline)
(import apropos)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(install-history-file (get-environment-variable "HOME") ".mtutil_history") ;; [homedir] [filename] [nlines])
(current-input-port (make-readline-port "mtutil> "))
Index: newdashboard.scm
==================================================================
--- newdashboard.scm
+++ newdashboard.scm
@@ -16,18 +16,18 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;======================================================================
-(use format)
+(import format)
-(use (prefix iup iup:))
+(import (prefix iup iup:))
-(use canvas-draw)
+(import canvas-draw)
(import canvas-draw-iup)
-(use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
+(import sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
(prefix dbi dbi:))
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
Index: ods.scm
==================================================================
--- ods.scm
+++ ods.scm
@@ -14,11 +14,18 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-(use csv-xml regex)
+(import ;; csv-xml
+ chicken.port
+ chicken.process
+ chicken.string
+ regex
+ srfi-13
+ )
+
(declare (unit ods))
(declare (uses common))
(define ods:dirs
'("Configurations2"
ADDED pgdb.scm
Index: pgdb.scm
==================================================================
--- /dev/null
+++ pgdb.scm
@@ -0,0 +1,23 @@
+;;======================================================================
+;; Copyright 2019, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit pgdb))
+
+(include "cgisetup/models/pgdb.scm")
Index: pkts/pkts.scm
==================================================================
--- pkts/pkts.scm
+++ pkts/pkts.scm
@@ -162,12 +162,32 @@
;; 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
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.io
+ chicken.port
+ chicken.process
+ chicken.process-context.posix
+ chicken.time
+ chicken.time.posix
+ chicken.sort
+ chicken.string
+ scheme
+
+ ;; data-structures posix
+ srfi-1 regex srfi-13 srfi-69
+ ;; ports extras)
+ crypt sha1 message-digest
+ (prefix dbi dbi:)
+ typed-records)
;;======================================================================
;; DATA MANIPULATION UTILS
;;======================================================================
@@ -695,11 +715,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
@@ -15,14 +15,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)
+(import
+ (srfi 18)
+ ;; chicken.tcp
+ s11n
+
+ srfi-1
+ ;; posix
+ srfi-69
+ ;; hostinfo
+ ;; dot-locking
+ z3
+ (prefix sqlite3 sqlite3:)
+
+chicken.condition
+chicken.file
+chicken.process
+chicken.process-context.posix
+chicken.string
-(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3)
-(import (prefix sqlite3 sqlite3:))
+ )
(declare (unit portlogger))
(declare (uses db))
;; lsof -i
Index: process.scm
==================================================================
--- process.scm
+++ process.scm
@@ -20,11 +20,20 @@
;;======================================================================
;; Process convience utils
;;======================================================================
-(use regex directory-utils)
+(import
+ regex directory-utils
+ chicken.condition
+ chicken.file
+ chicken.io
+ chicken.process
+ chicken.process-context.posix
+ chicken.string
+ srfi-18
+)
(declare (unit process))
(define (process:conservative-read port)
(let loop ((res ""))
(if (not (eof-object? (peek-char port)))
Index: records-vs-vectors-vs-coops.scm
==================================================================
--- records-vs-vectors-vs-coops.scm
+++ records-vs-vectors-vs-coops.scm
@@ -17,11 +17,11 @@
;; (include "vg.scm")
;; (declare (uses vg))
-(use foof-loop defstruct coops)
+(import foof-loop defstruct coops)
(defstruct obj type fill-color angle)
(define (make-vg:obj)(make-vector 3))
(define-inline (vg:obj-get-type vec) (vector-ref vec 0))
@@ -29,11 +29,11 @@
(define-inline (vg:obj-get-angle vec) (vector-ref vec 2))
(define-inline (vg:obj-set-type! vec val)(vector-set! vec 0 val))
(define-inline (vg:obj-set-fill-color! vec val)(vector-set! vec 1 val))
(define-inline (vg:obj-set-angle! vec val)(vector-set! vec 2 val))
-(use simple-exceptions)
+(import simple-exceptions)
(define vgs:obj-exn (make-exception "wrong record type, expected vgs:obj." 'assert))
(define (make-vgs:obj)(let ((v (make-vector 4)))(vector-set! v 0 'vgs:obj) v))
(define-inline (vgs:obj-type vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 1)(raise (vgs:obj-exn 'vgs:obj-type 'xpr))))
(define-inline (vgs:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 2)(raise (vgs:obj-exn 'vgs:obj-fill-color 'xpr))))
(define-inline (vgs:obj-angle vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 3)(raise (vgs:obj-exn 'vgs:obj-angle 'xpr))))
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -16,11 +16,23 @@
;; 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??
+(import
+ format typed-records
+ chicken.condition
+ chicken.port
+ chicken.pretty-print
+ chicken.sort
+ chicken.string
+ chicken.time
+ srfi-1
+ srfi-18
+ srfi-69
+
+ ) ;; RADT => purpose of json format??
(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))
(declare (uses dbfile))
@@ -1094,5 +1106,35 @@
#;(set-functions rmt:send-receive remote-server-url-set!
http-transport:close-connections remote-conndat-set!
debug:print debug:print-info
remote-ro-mode remote-ro-mode-set!
remote-ro-mode-checked-set! remote-ro-mode-checked)
+
+;; PULLED FROM COMMON
+
+;;======================================================================
+;; from metadat lookup MEGATEST_VERSION
+;;
+(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB
+ (rmt:get-var "MEGATEST_VERSION"))
+
+(define (common:get-last-run-version-number)
+ (string->number
+ (substring (common:get-last-run-version) 0 6)))
+
+(define (common:set-last-run-version)
+ (rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
+
+;;======================================================================
+;; postive number if megatest version > db version
+;; negative number if megatest version < db version
+(define (common:version-db-delta)
+ (- megatest-version (common:get-last-run-version-number)))
+
+(define (common:version-changed?)
+ (not (equal? (common:get-last-run-version)
+ (common:version-signature))))
+
+(define (common:api-changed?)
+ (not (equal? (substring (->string megatest-version) 0 4)
+ (substring (conc (common:get-last-run-version)) 0 4))))
+
Index: runconfig.scm
==================================================================
--- runconfig.scm
+++ runconfig.scm
@@ -18,11 +18,18 @@
;;======================================================================
;; read a config file, loading only the section pertinent
;; to this run field1val/field2val/field3val ...
;;======================================================================
-(use format directory-utils)
+(import format directory-utils
+ chicken.port
+ chicken.pretty-print
+ chicken.string
+ chicken.time
+ srfi-1
+ srfi-69
+ chicken.process-context)
(declare (unit runconfig))
(declare (uses common))
(include "common_records.scm")
Index: runs-launch-loop-test.scm
==================================================================
--- runs-launch-loop-test.scm
+++ runs-launch-loop-test.scm
@@ -13,11 +13,11 @@
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-(use srfi-69)
+(import srfi-69)
(define (runs:queue-next-hed tal reg n regful)
(if regful
(car reg)
(car tal)))
@@ -36,11 +36,11 @@
(cdr reg)
(if (eq? (length tal) 1)
'()
reg)))
-(use trace)
+(import trace)
(trace runs:queue-next-hed
runs:queue-next-tal
runs:queue-next-reg)
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -15,13 +15,34 @@
;; 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)
+(import
+ (prefix sqlite3 sqlite3:) srfi-1
+ ;; posix
+ regex regex-case srfi-69 (srfi 18)
+ srfi-13
+ ;; posix-extras directory-utils pathname-expand
+ typed-records format sxml-serializer
+ sxml-modifications matchable
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.io
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.process.signal
+ chicken.sort
+ chicken.string
+ chicken.time
+ chicken.time.posix
+ system-information
+)
(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
Index: sauthorize.scm
==================================================================
--- sauthorize.scm
+++ sauthorize.scm
@@ -15,18 +15,18 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-(use defstruct)
-(use scsh-process)
-
-(use srfi-18)
-(use srfi-19)
-(use refdb)
-
-(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
+(import defstruct)
+(import scsh-process)
+
+(import srfi-18)
+(import srfi-19)
+(import refdb)
+
+(import sql-de-lite srfi-1 posix regex regex-case srfi-69)
;(declare (uses common))
;(declare (uses configf))
(declare (uses margs))
(include "megatest-version.scm")
Index: serialize-env.scm
==================================================================
--- serialize-env.scm
+++ serialize-env.scm
@@ -1,7 +1,7 @@
-(use z3)
-(use base64)
+(import z3)
+(import base64)
(let* ((env-str (with-output-to-string (lambda () (pp (get-environment-variables)))))
(zipped-env-str (z3:encode-buffer env-str))
(b64-env-str (base64-encode zipped-env-str)))
(print b64-env-str))
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -14,16 +14,42 @@
;;
;; 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)
+(import
+ chicken.file
+ chicken.file.posix
+ chicken.io
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.sort
+ chicken.string
+ chicken.time
+ srfi-4
+ system-information
-(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest
- directory-utils posix-extras matchable utils)
+ (srfi 18)
+ ;; extras
+ chicken.tcp
+ s11n
-(use spiffy uri-common intarweb http-client spiffy-request-vars)
+ srfi-1
+ ;; posix
+ regex regex-case srfi-69
+ ;; hostinfo
+ md5 message-digest
+ ;; directory-utils posix-extras
+ matchable
+ ;; utils
+ chicken.condition
+
+ spiffy uri-common intarweb http-client spiffy-request-vars
+ )
(declare (unit server))
(declare (uses commonmod))
@@ -39,10 +65,24 @@
(import commonmod)
(include "common_records.scm")
(include "db_records.scm")
+(defstruct remote
+ (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag )
+ (server-url #f) ;; (server:check-if-running *toppath*) #f))
+ (server-id #f)
+ (server-info (if *toppath* (server:check-if-running *toppath*) #f))
+ (last-server-check 0) ;; last time we checked to see if the server was alive
+ (connect-time (current-seconds))
+ (conndat #f)
+ (transport *transport-type*)
+ (server-timeout (server:expiration-timeout))
+ (force-server #f)
+ (ro-mode #f)
+ (ro-mode-checked #f)) ;; flag that indicates we have checked for ro-mode
+
(define (server:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
Index: sharedat.scm
==================================================================
--- sharedat.scm
+++ sharedat.scm
@@ -15,28 +15,28 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
-(use defstruct)
-
-;; (use ssax)
-;; (use sxml-serializer)
-;; (use sxml-modifications)
-;; (use regex)
-;; (use srfi-69)
-;; (use regex-case)
-;; (use posix)
-;; (use json)
-;; (use csv)
-(use srfi-18)
-(use format)
+(import defstruct)
+
+;; (import ssax)
+;; (import sxml-serializer)
+;; (import sxml-modifications)
+;; (import regex)
+;; (import srfi-69)
+;; (import regex-case)
+;; (import posix)
+;; (import json)
+;; (import csv)
+(import srfi-18)
+(import format)
(require-library ini-file)
(import (prefix ini-file ini:))
-(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
+(import sql-de-lite srfi-1 posix regex regex-case srfi-69)
;; (import (prefix sqlite3 sqlite3:))
;;
(declare (uses configf))
;; (declare (uses tree))
(declare (uses margs))
Index: spublish.scm
==================================================================
--- spublish.scm
+++ spublish.scm
@@ -14,17 +14,17 @@
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
-(use defstruct)
-(use scsh-process)
-(use refdb)
-(use srfi-18)
-(use srfi-19)
-(use format)
-(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
+(import defstruct)
+(import scsh-process)
+(import refdb)
+(import srfi-18)
+(import srfi-19)
+(import format)
+(import sql-de-lite srfi-1 posix regex regex-case srfi-69)
;(declare (uses configf))
;; (declare (uses tree))
(declare (uses margs))
@@ -32,11 +32,11 @@
(include "megatest-fossil-hash.scm")
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
(include "sauth-paths.scm")
(include "sauth-common.scm")
(define (toplevel-command . args) #f)
-(use readline)
+(import readline)
;;
;; GLOBALS
;;
(define *spublish:current-tab-number* 0)
@@ -505,11 +505,11 @@
(define (toplevel-command . args) #f)
(define (spublish:shell area)
; (print area)
- (use readline)
+ (import readline)
(let* ((path '())
(prompt "spublish> ")
(args (argv))
(usr (current-user-name) )
Index: sretrieve.scm
==================================================================
--- sretrieve.scm
+++ sretrieve.scm
@@ -15,16 +15,16 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-(use defstruct)
-(use scsh-process)
-(use srfi-18)
-(use srfi-19)
-(use refdb)
-(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
+(import defstruct)
+(import scsh-process)
+(import srfi-18)
+(import srfi-19)
+(import refdb)
+(import sql-de-lite srfi-1 posix regex regex-case srfi-69)
;(declare (uses common))
;(declare (uses configf))
(declare (uses margs))
(include "megatest-version.scm")
@@ -32,11 +32,11 @@
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
(include "sauth-paths.scm")
(include "sauth-common.scm")
(define (toplevel-command . args) #f)
-(use readline)
+(import readline)
;;
@@ -719,11 +719,11 @@
Version: " megatest-fossil-hash)
)
;(define (toplevel-command . args) #f)
(define (sretrieve:shell area)
; (print area)
- (use readline)
+ (import readline)
(let* ((path '())
(prompt "sretrieve> ")
(args (argv))
(usr (current-user-name) )
(top-areas (sretrieve:get-accessable-projects area))
@@ -916,11 +916,11 @@
; res)))
(define (toplevel-command . args) #f)
(define (sretrieve:process-action action . args)
; (print action)
- ; (use readline)
+ ; (import readline)
(case (string->symbol action)
((get)
(if (< (length args) 2)
(begin
(sauth:print-error "Missing arguments; " )
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/formdat.scm
==================================================================
--- stml2/formdat.scm
+++ stml2/formdat.scm
@@ -10,12 +10,11 @@
;; (declare (unit formdat))
(module formdat
*
-(import chicken scheme data-structures extras srfi-13 ports )
-(use html-filter)
+(import chicken scheme data-structures extras srfi-13 ports html-filter)
-(use regex)
-(require-extension srfi-69)
+(import regex)
+(import srfi-69)
)
Index: stml2/html-filter.scm
==================================================================
--- stml2/html-filter.scm
+++ stml2/html-filter.scm
@@ -11,11 +11,11 @@
(module html-filter
*
(import chicken scheme data-structures extras srfi-13 ports )
-(use misc-stml)
+(import misc-stml)
-(require-extension regex)
+(import regex)
;;
)
Index: stml2/misc-stml.scm
==================================================================
--- stml2/misc-stml.scm
+++ stml2/misc-stml.scm
@@ -16,9 +16,8 @@
(module misc-stml
*
(import chicken scheme data-structures extras srfi-13 ports posix)
-(use regex (prefix dbi dbi:))
-(use (prefix crypt c:))
-(use (prefix dbi dbi:))
+(import regex (prefix dbi dbi:))
+(import (prefix crypt c:))
)
Index: stml2/rollup-pages.scm
==================================================================
--- stml2/rollup-pages.scm
+++ stml2/rollup-pages.scm
@@ -1,6 +1,6 @@
-(use regex posix srfi-69 srfi-1)
+(import regex posix srfi-69 srfi-1)
(define extract-rx (regexp "pages\\/(.*)_(view|ctrl).scm"))
(define (print-page-wrapper lookup page)
(print "(define (pages:" page " session db shared)")
Index: stml2/session.scm
==================================================================
--- stml2/session.scm
+++ stml2/session.scm
@@ -11,10 +11,9 @@
(module session
*
(import chicken scheme data-structures extras srfi-13 ports posix files srfi-1)
-(use (prefix dbi dbi:) srfi-69)
-(require-extension regex)
-(use cookie stmlcommon) ;; (declare (uses cookie))
+(import (prefix dbi dbi:) srfi-69 regex)
+(import cookie stmlcommon) ;; (declare (uses cookie))
)
Index: stml2/setup.scm
==================================================================
--- stml2/setup.scm
+++ stml2/setup.scm
@@ -9,13 +9,12 @@
(module setup
*
(import chicken scheme data-structures extras srfi-13 ports posix)
-(uses session misc-stml)
+(import session misc-stml)
;; (declare (unit setup))se
;; (declare (uses session))
-(require-extension srfi-69)
-(require-extension regex)
+(import srfi-69 regex)
)
Index: stml2/spiffyserver.scm
==================================================================
--- stml2/spiffyserver.scm
+++ stml2/spiffyserver.scm
@@ -1,8 +1,8 @@
;; This doesn't work yet
;;
-(use spiffy cgi-handler)
+(import spiffy cgi-handler)
(spiffy-debug-mode #t)
(spiffy-file-ext-handlers
`(("drcdb" . ,(cgi-handler* "/path/to/drcdb"))))
Index: stml2/sqlite3.scm
==================================================================
--- stml2/sqlite3.scm
+++ stml2/sqlite3.scm
@@ -9,11 +9,11 @@
;;
;; I used this to get a simple interactive sqlite editor on the nokia n800
;; since I couldn't get sqlite3 to install (for reasons I can't remember).
-(use sqlite3)
+(import sqlite3)
(define args (argv))
(define num-args (length args))
(define dbname #f)
Index: stml2/stml2.scm
==================================================================
--- stml2/stml2.scm
+++ stml2/stml2.scm
@@ -12,17 +12,39 @@
;; (declare (unit stml))
(module stml2
*
-(import chicken scheme data-structures extras srfi-13 ports posix srfi-69 files srfi-1)
+ (import
-(import cookie)
-(use (prefix dbi dbi:) (prefix crypt c:) typed-records)
+ (chicken base)
+ (chicken blob)
+ (chicken condition)
+ (chicken file)
+ (chicken format)
+ (chicken io)
+ (chicken pathname)
+ (chicken port)
+ (chicken process)
+ (chicken process-context posix)
+ (chicken process-context)
+ (chicken random)
+ (chicken string)
+ (chicken time posix)
+ (chicken time)
+ (prefix crypt c:)
+ (prefix dbi dbi:)
+ cookie
+ queues
+ regex
+ scheme
+ srfi-1
+ srfi-13
+ srfi-69
+ typed-records
-;; (declare (uses misc-stml))
-(use regex)
+ )
;; The (usually global) sdat contains everything about the session
;;
(defstruct sdat
;; database
@@ -421,11 +443,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 +671,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 +686,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
@@ -732,12 +754,12 @@
(else #f)))
;; NB// this is *illegal* pgint
(define (s:illegal-pgint val)
(cond
- ((> val 2147483647) 1)
- ((< val -2147483648) -1)
+ ((> val 2147483640.0) 1) ;; 2147483647
+ ((< val -2147483640.0) -1) ;; -2147483648
(else #f)))
(define (s:any->pgint val)
(let ((n (s:any->number val)))
(if n
@@ -1105,16 +1127,16 @@
;; (s:process-cgi-input (caaar dat))
(define (formdat:load-all-port inp)
(let* ((formdat (make-formdat:formdat))
(debugp #f))
- ;; (open-output-file (conc "/tmp/delme-" (current-user-id) ".log"))))
+ ;; (open-output-file (conc "/tmp/delme-" (current-user-id) ".log"))))
;; (write-string (read-string #f inp) #f debugp) ;; destroys all data!
(formdat:initialize formdat)
- (let ((alldats (formdat:dat->list inp 10e6 debug-port: debugp)))
+ (let ((alldats (formdat:dat->list inp 10e6 debug-port: #f debugp)))
- (if debugp (format debugp "formdat : alldats: ~A\n" alldats))
+ #;(if debugp (format debugp "formdat : alldats: ~A\n" alldats))
(let ((firstitem (car alldats))
(multipass #f))
(if (and (not (null? firstitem))
(not (null? (car firstitem))))
@@ -1150,11 +1172,11 @@
(if (and (not (null? alldats))
(not (null? (car alldats)))
(not (null? (caar alldats))))
(formdat:load formdat (s:process-cgi-input (caaar alldats))))) ;; munged))
;; (format debugp "formdat : name: ~A content: ~A\n" name content)
- (if debugp (close-output-port debugp))
+ #;(if debugp (close-output-port debugp))
;; (sdat-formdat-set! s:session formdat)
formdat))))
#|
(define inp (open-input-file "tests/example.post.in"))
@@ -1429,11 +1451,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 +1466,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 +1729,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: stml2/stmlcommon.scm
==================================================================
--- stml2/stmlcommon.scm
+++ stml2/stmlcommon.scm
@@ -13,8 +13,8 @@
(module stmlcommon
*
(import chicken scheme data-structures extras srfi-13 ports posix)
-(use (prefix dbi dbi:) regex (prefix crypt c:) srfi-69)
+(import (prefix dbi dbi:) regex (prefix crypt c:) srfi-69)
)
Index: stml2/stmlrun.scm
==================================================================
--- stml2/stmlrun.scm
+++ stml2/stmlrun.scm
@@ -11,9 +11,9 @@
;; (require-extension syntax-case)
;; (declare (run-time-macros))
;; (include "stmlcommon.scm")
-(require-library stml)
+(import stml)
(stml:main #f)
Index: stml2/test.scm
==================================================================
--- stml2/test.scm
+++ stml2/test.scm
@@ -1,8 +1,7 @@
-(use test md5)
+(import test md5)
-(require-extension sqlite3)
(import (prefix sqlite3 sqlite3:))
(require-library dbi)
;; (declare (uses stml))
Index: subrun.scm
==================================================================
--- subrun.scm
+++ subrun.scm
@@ -16,13 +16,28 @@
;; 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)
+(import
+ (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
+
+chicken.file
+chicken.file.posix
+chicken.irregex
+chicken.process
+chicken.string
+chicken.time
+chicken.process-context
+
+ )
(declare (unit subrun))
;;(declare (uses runs))
(declare (uses db))
(declare (uses common))
;;(declare (uses items))
Index: synchash.scm
==================================================================
--- synchash.scm
+++ synchash.scm
@@ -20,12 +20,12 @@
;;======================================================================
;; A hash of hashes that can be kept in sync by sending minial deltas
;;======================================================================
-(use format)
-(use srfi-1 srfi-69 sqlite3)
+(import format)
+(import srfi-1 srfi-69 sqlite3)
(import (prefix sqlite3 sqlite3:))
(declare (unit synchash))
(declare (uses db))
(declare (uses server))
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -16,19 +16,36 @@
;; 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 dbfile))
(declare (uses db))
(declare (uses rmt))
(declare (uses common))
(declare (uses pgdb))
+
+(import
+ sqlite3 srfi-1
+ ;; posix
+ regex regex-case srfi-69
+ ;; dot-locking
+ format
+ (prefix sqlite3 sqlite3:)
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.process
+ chicken.process-context.posix
+ chicken.process.signal
+ chicken.string
+ chicken.time
+ srfi-18
+ srfi-13
+ system-information
+ )
(import dbfile)
;; (import pgdb) ;; pgdb is a module
(include "task_records.scm")
Index: tcmt.scm
==================================================================
--- tcmt.scm
+++ tcmt.scm
@@ -21,13 +21,16 @@
;;
;; 1. Run the megatest process and pass it all the needed parameters
;; 2. Every five seconds check for state/status changes and print the info
;;
-(use srfi-1 posix srfi-69 srfi-18 regex defstruct)
+(import
+ srfi-1
+ ;; posix
+ srfi-69 srfi-18 regex defstruct)
-(use trace)
+(import trace)
;; (trace-call-sites #t)
(declare (uses margs))
(declare (uses rmt))
(declare (uses common))
Index: tdb.scm
==================================================================
--- tdb.scm
+++ tdb.scm
@@ -20,14 +20,29 @@
;;======================================================================
;; 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:))
+(import
+ (srfi 18)
+ ;; extras tcp)
+
+ sqlite3 srfi-1
+ ;; posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64
+
+ (prefix sqlite3 sqlite3:)
+ (prefix base64 base64:)
+ chicken.file.posix
+ chicken.io
+ chicken.port
+ chicken.pretty-print
+ chicken.sort
+ chicken.string
+ chicken.time
+ chicken.condition
+ srfi-69
+)
(declare (unit tdb))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -31,16 +31,41 @@
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
(declare (uses server))
-;;(declare (uses stml2))
+(declare (uses stml2))
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
-(import (prefix sqlite3 sqlite3:))
-(import commonmod)
-(require-library stml)
+(import
+ sqlite3 srfi-1
+ ;; posix regex regex-case srfi-69
+ ;; dot-locking
+ ;; tcp directory-utils
+ (prefix sqlite3 sqlite3:)
+ stml2
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.format
+ chicken.io
+ chicken.pathname
+ chicken.port
+ chicken.pretty-print
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.sort
+ chicken.string
+ chicken.time
+ srfi-13
+ srfi-18
+ srfi-69
+ system-information
+ regex
+
+ commonmod
+ )
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
Index: tree.scm
==================================================================
--- tree.scm
+++ tree.scm
@@ -16,17 +16,28 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;;======================================================================
-(use format)
+(import format)
(require-library iup)
(import (prefix iup iup:))
-(use canvas-draw)
+(import canvas-draw)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69)
-(import (prefix sqlite3 sqlite3:))
+(import
+ sqlite3 srfi-1
+ ;; posix
+ regex regex-case srfi-69
+ (prefix sqlite3 sqlite3:)
+ chicken.port
+ chicken.pretty-print
+ chicken.string
+ chicken.time
+ srfi-13
+ chicken.bitwise
+ srfi-69
+ )
(declare (unit tree))
(declare (uses margs))
(declare (uses launch))
;; (declare (uses megatest-version))
ADDED utils/makemodulewrap.sh
Index: utils/makemodulewrap.sh
==================================================================
--- /dev/null
+++ utils/makemodulewrap.sh
@@ -0,0 +1,15 @@
+#!/bin/bash
+
+MODNAME=$1
+
+mkdir -p tmpmods
+
+echo "(module $MODNAME
+ *
+
+(import
+ scheme
+ chicken.base)
+
+(include \"$MODNAME.scm\")
+)" > tmpmods/$MODNAME.scm
Index: vg-test.scm
==================================================================
--- vg-test.scm
+++ vg-test.scm
@@ -13,21 +13,21 @@
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-(use canvas-draw iup foof-loop)
+(import canvas-draw iup foof-loop)
(import canvas-draw-iup)
(load "vg.scm")
(define numtorun 1000)
;; (if (> (length (argv)) 1)
;; (string->number (cadr (argv)))
;; 1000))
- (use trace)
+ (import trace)
;; (trace
;; ;; vg:draw-rect
;; ;; vg:grow-rect
;; vg:get-extents-for-objs
;; vg:components-get-extents
Index: vg.scm
==================================================================
--- vg.scm
+++ vg.scm
@@ -16,15 +16,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 typed-records srfi-1)
+(import typed-records srfi-1)
(declare (unit vg))
-(use canvas-draw iup)
-(import canvas-draw-iup)
+(import canvas-draw iup)
+(import
+ canvas-draw-iup
+ chicken.bitwise
+ srfi-69
+ chicken.string
+ )
(include "vg_records.scm")
;; ;; structs
;; ;;
Index: vg_records.scm
==================================================================
--- vg_records.scm
+++ vg_records.scm
@@ -17,11 +17,11 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-(use simple-exceptions)
+(import simple-exceptions)
(define vg:lib-exn (make-exception "wrong record type, expected vg:lib." 'assert))
(define (pmake-vg:lib . params)(let ((v (if (null? params)(make-vector 2)(apply vector 'vg:lib params)))) v))
(define (make-vg:lib #!key
(comps #f)
)
@@ -30,11 +30,11 @@
(define-inline (vg:lib-comps vec)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-ref vec 1)(raise (vg:lib-exn 'vg:lib-comps 'xpr))))
(define-inline (vg:lib-comps-set! vec val)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-set! vec 1 val)(raise (vg:lib-exn 'comps))))
;; Generated using make-vector-record -safe vg comp objs name file
-(use simple-exceptions)
+(import simple-exceptions)
(define vg:comp-exn (make-exception "wrong record type, expected vg:comp." 'assert))
(define (pmake-vg:comp . params)(let ((v (if (null? params)(make-vector 4)(apply vector 'vg:comp params)))) v))
(define (make-vg:comp #!key
(objs #f)
(name #f)
@@ -49,11 +49,11 @@
(define-inline (vg:comp-objs-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 1 val)(raise (vg:comp-exn 'objs))))
(define-inline (vg:comp-name-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 2 val)(raise (vg:comp-exn 'name))))
(define-inline (vg:comp-file-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 3 val)(raise (vg:comp-exn 'file))))
;; Generated using make-vector-record -safe vg obj type pts fill-color text line-color call-back angle font attrib extents proc
-(use simple-exceptions)
+(import simple-exceptions)
(define vg:obj-exn (make-exception "wrong record type, expected vg:obj." 'assert))
(define (pmake-vg:obj . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:obj params)))) v))
(define (make-vg:obj #!key
(type #f)
(pts #f)
@@ -92,11 +92,11 @@
(define-inline (vg:obj-attrib-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 9 val)(raise (vg:obj-exn 'attrib))))
(define-inline (vg:obj-extents-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 10 val)(raise (vg:obj-exn 'extents))))
(define-inline (vg:obj-proc-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 11 val)(raise (vg:obj-exn 'proc))))
;; Generated using make-vector-record -safe vg inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache
-(use simple-exceptions)
+(import simple-exceptions)
(define vg:inst-exn (make-exception "wrong record type, expected vg:inst." 'assert))
(define (pmake-vg:inst . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:inst params)))) v))
(define (make-vg:inst #!key
(libname #f)
(compname #f)
@@ -135,11 +135,11 @@
(define-inline (vg:inst-mirry-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 9 val)(raise (vg:inst-exn 'mirry))))
(define-inline (vg:inst-call-back-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 10 val)(raise (vg:inst-exn 'call-back))))
(define-inline (vg:inst-cache-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 11 val)(raise (vg:inst-exn 'cache))))
;; Generated using make-vector-record -safe vg drawing libs insts scalex scaley xoff yoff cnv cache
-(use simple-exceptions)
+(import simple-exceptions)
(define vg:drawing-exn (make-exception "wrong record type, expected vg:drawing." 'assert))
(define (pmake-vg:drawing . params)(let ((v (if (null? params)(make-vector 9)(apply vector 'vg:drawing params)))) v))
(define (make-vg:drawing #!key
(libs #f)
(insts #f)