# 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 <http://www.gnu.org/licenses/>.
TODO
====
Loose ends
----------
15:09:29 error in calling find-and-mark-incomplete for run-id 5, exn=#<condition: (exn type)>
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
WW16
. split db into megatest.db (runs etc.) db/<something>.db
;; 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 <http://www.gnu.org/licenses/>.
;;
;;======================================================================
(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))
(declare (uses dbfile))
(declare (uses tasks))
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(import
(prefix sqlite3 sqlite3:) srfi-1
;; posix
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18) 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))
(include "common_records.scm")
(include "db_records.scm")
;;======================================================================
;; 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 <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit autoload))
(include "autoload/autoload.scm")
;;;; 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))))))
)
;; 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 <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit pgdb))
(declare (uses configf));; (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:))
;; ;; 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
(args:get-arg "-pgsync")
(if configdat
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
;; C L I E N T S
;;======================================================================
(import srfi-18
(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5message-digest matchable spiffy uri-common intarweb http-client
spiffy-request-vars uri-common intarweb directory-utils) ;; 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))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;; 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 (<procname> <args>) <body> )
(define (load-scm-file scm-file)
;;(print "load "scm-file)
(handle-exceptions
exn
'()
;; 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 <http://www.gnu.org/licenses/>.
;;
;;======================================================================
;; (use trace)
;; (import trace)
(include "altdb.scm")
;; Some of these routines use:
;;
;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html
;;
# 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 <http://www.gnu.org/licenses/>.
# Configure the build# Flavors include: simple, full and none
if [[ "$1"x == "x" ]];then PREFIX=$PWDelse PREFIX=$1fi# look at build.config (not a version controlled file and
#======================================================================# Configure stuff needed for eggs#======================================================================# create ulex.scm and dbmgr.scm
function configure_dependencies () { #====================================================================== # libnanomsg #======================================================================if [[ -e transport-flavor ]];then
if [[ ! $(ls /usr/lib/*/libnanomsg*) ]];then echo "libnanomsg build needed." echo "BUILD_NANOMSG=yes" >> makefile.inc fi FLAVOR=$(cat transport-flavor)
#====================================================================== # 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 FLAVOR=simple
echo "CHICKEN_PREFIX=$PREFIX/.$ARCHSTR" >> makefile.incCHICKEN_PREFIX=$PREFIX/bin/.$ARCHSTRif [[ ! $(type csi) ]];then echo "Chicken build needed." echo "BUILD_CHICKEN=yes" >> makefile.inc configure_dependencies echo "include chicken.makefile" >> makefile.incelse echo "CSIPATH=$(which csi)" >> makefile.inc CSIPATH=$(which csi) echo "CKPATH=$(dirname $(dirname $CSIPATH))" >> makefile.incfi
# Make setup scriptsecho "#!/bin/bash" > setup.shecho "export PATH=$CHICKEN_PREFIX/bin:\$PATH" >> setup.shecho "export LD_LIBRARY_PATH=$CHICKEN_PREFIX/lib" >> setup.shecho 'exec "$@"' >> setup.shchmod a+x setup.shsed -e "s/FLAVOR/$FLAVOR/" ulex.scm.template > ulex.scm
echo "setenv PATH $CHICKEN_PREFIX/bin:\$PATH" > setup.cshecho "setenv LD_LIBRARY_PATH $CHICKEN_PREFIX/lib" >> setup.cshsed -e "s/FLAVOR/$FLAVOR/" dbmgrmod.scm.template > dbmgrmod.scm
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"
;; 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 <http://www.gnu.org/licenses/>.
;;
;;======================================================================
(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))
(declare (uses keys))
(declare (uses items))
;; 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 <http://www.gnu.org/licenses/>.
;;
;;======================================================================
(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))
;; (declare (uses synchash))
(let ( (raw-debug-level (get-environment-variable "DUCTTAPE_DEBUG_LEVEL")) )
(if raw-debug-level
(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))
;; ducttape-debug-regex-filter suppresses non-matching debug messages
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit env))
(import
(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
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)
(begin
(exec (sql db "CREATE TABLE envvars (
;; 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 <http://www.gnu.org/licenses/>.
;;
(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)))
(define db (open-database "example.db"))
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit genexample))
(import
(use posix regex matchable) 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
#<<EOF
;; You should have at least one expect:required. This ensures that your process ran
;; comment out the line below and replace "put pattern here" with a pattern that will
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw)
(import
(use srfi-1 regex regex-case srfi-69) srfi-1 regex regex-case srfi-69
chicken.string
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 gutils))
;; NOTE: These functions will move to iuputils
(define (gutils:colors-similar? color1 color2)
(let* ((c1 (map string->number (string-split color1)))
(c2 (map string->number (string-split color2)))
;; 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 <http://www.gnu.org/licenses/>.
(import
(require-extension (srfi 18) extras tcp s11n)
(srfi 18)
;; extras
chicken.tcp
s11n
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
(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras)
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)
(declare (unit http-transport))
;; 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 <http://www.gnu.org/licenses/>.
;;
(import
(use (prefix sqlite3 sqlite3:) srfi-18) (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))
;;======================================================================
;; attempt to prevent overlapping updates of rollup files by queueing
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
(declare (unit margs))
;; (declare (uses common))
(import chicken.process-context
srfi-1
srfi-69
)
(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)
(hash-table-ref/default args:arg-hash arg (car default))))
;; (declare (uses ftail))
;; (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")
(import
(prefix sqlite3 sqlite3:) srfi-1
;; posix
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
readline apropos json http-client directory-utils typed-recordshttp-client srfi-18 extras format) 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)))
;; usage logging, careful with this, it is not designed to deal with all real world challenges!
;;
-status : Applies to runs, tests or steps depending on context
-modepatt key : load testpatt from <key> in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified
-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
Test data capture
-refdb2dat refdb : convert refdb to sexp or to format specified by s-dumpmode
formats: perl, ruby, sqlite3, csv (for csv the -o param
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 <patt> -target-patt <patt> -dumpmode <csv,json,plain-text>
-list-test-time : list time requered to complete each test in a run. It following following arguments
-runname <patt> -target <patt> -dumpmode <csv,json,plain-text>
;; MLAUNCH
;;
;; 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))
;; 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 <http://www.gnu.org/licenses/>.
;; 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))
(declare (uses items))
(declare (uses runconfig))
;; 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 <http://www.gnu.org/licenses/>.
;;
(import sqlite3 srfi-1
;; posix
regex regex-case srfi-69
;; dot-locking
(srfi 18)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables) ;; 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))
(declare (uses items))
(declare (uses runconfig))
;; 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 <http://www.gnu.org/licenses/>.
;;
(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)
(import
srfi-1
;; posix
(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)
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)
(declare (uses common))(declare (uses margs))(declare (uses configf));; (declare (uses rmt))(use ducttape-lib)
(import ducttape-lib)
(include "megatest-fossil-hash.scm")
(require-library stml)
;; stuff for the mapper and checker functions
;;
;; 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 <http://www.gnu.org/licenses/>.
;;======================================================================
(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))
;; (declare (uses launch))
;; 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 <http://www.gnu.org/licenses/>.
;;
(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"
"Configurations2/toolpanel"
"Configurations2/menubar"
;;======================================================================
;; 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 <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit pgdb))
(include "cgisetup/models/pgdb.scm")
;; 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 <http://www.gnu.org/licenses/>.
;;
(import
(require-extension (srfi 18) extras tcp s11n)
(srfi 18)
;; chicken.tcp
s11n
srfi-1
;; posix
srfi-69
;; hostinfo
(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3)(import (prefix sqlite3 sqlite3:))
;; dot-locking
z3
(prefix sqlite3 sqlite3:)
chicken.condition
chicken.file
chicken.process
chicken.process-context.posix
chicken.string
)
(declare (unit portlogger))
(declare (uses db))
;; lsof -i
(define (portlogger:open-db fname)
;; 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 <http://www.gnu.org/licenses/>.
;;
;;======================================================================
(import
format typed-records
chicken.condition
chicken.port
chicken.pretty-print
chicken.sort
chicken.string
chicken.time
srfi-1
srfi-18
srfi-69
(use format typed-records) ;; RADT => purpose of json format??
) ;; RADT => purpose of json format??
(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))
(declare (uses dbfile))
(include "common_records.scm")
;; (declare (uses rmtmod))
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
;; 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")
(define (runconfig:read fname target environ-patt)
;; 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 <http://www.gnu.org/licenses/>.
;;
(use srfi-69)
(import srfi-69)
(define (runs:queue-next-hed tal reg n regful)
(if regful
(car reg)
(car tal)))
(define (runs:queue-next-tal tal reg n regful)
;; 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 <http://www.gnu.org/licenses/>.
;;
(use defstruct)
(use scsh-process)
(import defstruct)
(import scsh-process)
(use srfi-18)
(use srfi-19)
(use refdb)
(import srfi-18)
(import srfi-19)
(import refdb)
(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
(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")
(include "megatest-fossil-hash.scm")
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
;; 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 <http://www.gnu.org/licenses/>.
;;
(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
(require-extension (srfi 18) extras tcp s11n)
(srfi 18)
;; extras
chicken.tcp
s11n
srfi-1
;; posix
(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils posix-extras matchable utils)(use spiffy uri-common intarweb http-client spiffy-request-vars) 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))
(declare (uses common))
(declare (uses db))
;; 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 <http://www.gnu.org/licenses/>.
(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))
(include "megatest-version.scm")
(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)
(define *args-hash* (make-hash-table))
(define spublish:help (conc "Usage: spublish [action [params ...]]
;; 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 <http://www.gnu.org/licenses/>.
;;
(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")
(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
;;
;; Copyright 2007-2011, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
(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)
(import srfi-69 regex)
(require-extension regex)
)
;; Copyright 2007-2011, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;
;; 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)
(define cmd #f)
;; to obscure and indirect database ids use one time keys
;;
;; (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
(loop (cond ;; in the unlikey event we have trouble getting a new var, keep increasing the size of the number
((< num 50) 100)
(if debugmode (session:log self "session:setup dbfname=" dbfname ", dbtype=" dbtype ", dbinit=" dbinit))
(if (eq? dbtype 'sqlite3)
;; 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")
(set! dbexists #t))))
(if debugmode (session:log self "INFO: setting up for pg db access to account info " dbinit)))
;; 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 <http://www.gnu.org/licenses/>.
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(import
(prefix sqlite3 sqlite3:) srfi-1
;; posix
(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) 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))
;;(declare (uses runconfig))
;;(declare (uses tests))
;;
;; Wrapper to enable running Megatest flows under teamcity
;;
;; 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
;;
(import
srfi-1
;; posix
(use srfi-1 posix srfi-69 srfi-18 regex defstruct)
srfi-69 srfi-18 regex defstruct)
(use trace)
(import trace)
;; (trace-call-sites #t)
(declare (uses margs))
(declare (uses rmt))
(declare (uses common))
;; (declare (uses megatest-version))
;; 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 <http://www.gnu.org/licenses/>.
;;
;;======================================================================
(use format)
(import format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw)
(import
sqlite3 srfi-1
;; posix
(use sqlite3 srfi-1 posix regex regex-case srfi-69)(import (prefix sqlite3 sqlite3:))
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))
(declare (uses gutils))
(declare (uses db))
;; 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 <http://www.gnu.org/licenses/>.
;;
(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
;; vg:instances-get-extents
;; vg:get-extents-for-two-rects
;; 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 <http://www.gnu.org/licenses/>.
;; 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
;; ;;
;; (defstruct vg:lib comps)
;; (defstruct vg:comp objs name file)