Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -19,24 +19,30 @@ # rm .o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less SHELL=/bin/bash PREFIX=$(PWD) CSCOPTS= INSTALL=install -SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \ - server.scm configf.scm db.scm keys.scm margs.scm \ - process.scm runs.scm tasks.scm tests.scm genexample.scm \ - http-transport.scm filedb.scm tdb.scm client.scm mt.scm \ - ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \ - subrun.scm portlogger.scm archive.scm env.scm \ - diff-report.scm cgisetup/models/pgdb.scm +SRCFILES = + +# common.scm items.scm launch.scm ods.scm runconfig.scm \ +# server.scm configf.scm db.scm keys.scm margs.scm \ +# process.scm runs.scm tasks.scm tests.scm genexample.scm \ +# http-transport.scm filedb.scm tdb.scm client.scm mt.scm \ +# ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \ +# subrun.scm portlogger.scm archive.scm env.scm \ +# diff-report.scm cgisetup/models/pgdb.scm # module source files -MSRCFILES = +# MSRCFILES = # 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 +MSRCFILES = autoload.scm dbi.scm ducttape-lib.scm pkts.scm stml2.scm \ + cookie.scm mutils.scm mtargs.scm apimod.scm commonmod.scm \ + dbmod.scm rmtmod.scm debugprint.scm mtver.scm csv-xml.scm \ + servermod.scm hostinfo.scm adjutant.scm + +# commonmod.scm dbmod.scm adjutant.scm ulex.scm \ +# rmtmod.scm apimod.scm GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \ dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \ vg.scm @@ -48,21 +54,20 @@ MOIMPFILES = $(MSRCFILES:%.scm=%.import.o) %.import.o : %.import.scm csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o -# I'm not sure the cp is a good idea, changed a lot of things and it may not have been necessary... -# mofiles/%.o %.import.scm : %.scm megatest-fossil-hash.scm -# @[ -e mofiles ] || mkdir -p mofiles -# csc $(CSCOPTS) -I mofiles -I $* -J -c $< -o $*.o -# cp $*.o mofiles/$*.o -# @touch $*.import.scm # ensure it is touched after the .o is made - mofiles/%.o : %.scm mkdir -p mofiles csc $(CSCOPTS) -J -c $< -o mofiles/$*.o +# module dependencies +mofiles/stml2.o : mofiles/dbi.o +mofiles/dbi.o : mofiles/autoload.o +mofiles/apimod.o mofiles/dbmod.o mofiles/rmtmod.o : mofiles/commonmod.o +mofiles/commonmod.o : mofiles/mtargs.o mofiles/debugprint.o mofiles/megatest-version.o + ADTLSCR=mt_laststep mt_runstep mt_ezstep HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR)) DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR)) MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}') Index: adjutant.scm ================================================================== --- adjutant.scm +++ adjutant.scm @@ -20,12 +20,12 @@ (declare (unit adjutant)) (module adjutant * -(import scheme chicken data-structures extras files) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 +(import scheme chicken.base) +(import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 md5 message-digest regex srfi-1) (define (adjutant-run) (print "Running the adjutant!")) ADDED altdb-template.scm Index: altdb-template.scm ================================================================== --- /dev/null +++ altdb-template.scm @@ -0,0 +1,3 @@ +;; optional alternate db setup +(define *available-db* (make-hash-table)) +(import postgresql)(hash-table-set! *available-db* 'postgresql #t) Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -18,16 +18,16 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;;====================================================================== -(use srfi-69 posix) - -(declare (unit api)) -(declare (uses rmt)) -(declare (uses db)) -(declare (uses tasks)) +;; (use srfi-69 posix) +;; +;; (declare (unit api)) +;; (declare (uses rmt)) +;; (declare (uses db)) +;; (declare (uses tasks)) ;; allow these queries through without starting a server ;; (define api:read-only-queries '(get-key-val-pairs Index: apimod.scm ================================================================== --- apimod.scm +++ apimod.scm @@ -18,17 +18,21 @@ ;;====================================================================== (declare (unit apimod)) (declare (uses commonmod)) -(declare (uses ulex)) (module apimod * -(import scheme chicken data-structures extras) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18) -(import commonmod) -(import (prefix ulex ulex:)) +(import scheme + (prefix sqlite3 sqlite3:) + + typed-records + srfi-18 + + commonmod + + ) ) Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -15,48 +15,48 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') - -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18) - -(declare (unit archive)) -(declare (uses db)) -(declare (uses common)) - -(include "common_records.scm") -(include "db_records.scm") - +;; +;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18) +;; +;; (declare (unit archive)) +;; (declare (uses db)) +;; (declare (uses common)) +;; +;; (include "common_records.scm") +;; (include "db_records.scm") +;; ;;====================================================================== ;; ;;====================================================================== ;; NOT CURRENTLY USED ;; -(define (archive:main linktree target runname testname itempath options) - (let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempatt)) - (flavor 'plain) ;; type of machine to run jobs on - (maxload 1.5) ;; max allowed load for this work - (adisks (archive:get-archive-disks))) - ;; get testdir size - ;; - hand off du to job mgr - (if (and (common:file-exists? testdir) - (file-is-writable? testdir)) - (let* ((dused (jobrunner:run-job - flavor ;; machine type - maxload ;; max allowed load - '() ;; prevars - environment vars to set for the job - common:get-disk-space-used ;; if a proc call it, if a string it is a unix command - (list testdir))) - (apath (archive:get-archive testname itempath dused))) - (jobrunner:run-job - flavor - maxload - '() - archive:run-bup - (list testdir apath)))))) +;; (define (archive:main linktree target runname testname itempath options) +;; (let ((testdir (conc linktree "/" target "/" runname "/" testname "/" itempath)) +;; (flavor 'plain) ;; type of machine to run jobs on +;; (maxload 1.5) ;; max allowed load for this work +;; (adisks (archive:get-archive-disks))) +;; ;; get testdir size +;; ;; - hand off du to job mgr +;; (if (and (common:file-exists? testdir) +;; (file-writable? testdir)) +;; (let* ((dused (jobrunner:run-job +;; flavor ;; machine type +;; maxload ;; max allowed load +;; '() ;; prevars - environment vars to set for the job +;; common:get-disk-space-used ;; if a proc call it, if a string it is a unix command +;; (list testdir))) +;; (apath (archive:get-archive testname itempath dused))) +;; (jobrunner:run-job +;; flavor +;; maxload +;; '() +;; archive:run-bup +;; (list testdir apath)))))) ;; Get archive disks from megatest.config ;; (define (archive:get-archive-disks) (let ((section (configf:get-section *configdat* "archive-disks"))) ADDED attic/widgets.scm Index: attic/widgets.scm ================================================================== --- /dev/null +++ attic/widgets.scm @@ -0,0 +1,208 @@ +;; Copyright 2006-2017, 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 . + +(require-library srfi-4 iup) +(import srfi-4 iup + ;; iup-pplot + iup-glcanvas) ;; iup-web + +(define (popup dlg . args) + (apply show dlg #:modal? 'yes args) + (destroy! dlg)) + +(define (properties ih) + (popup (element-properties-dialog ih)) + 'default) + +(define dlg + (dialog + (vbox + (hbox ; headline + (fill) + (frame (label " Inspect control and dialog classes " + fontsize: 15)) + (fill) + margin: '0x0) + + (label "") + (label "Dialogs" fontsize: 12) + (hbox + (button "dialog" + action: (lambda (self) (properties (dialog (vbox))))) + (button "color-dialog" + action: (lambda (self) (properties (color-dialog)))) + (button "file-dialog" + action: (lambda (self) (properties (file-dialog)))) + (button "font-dialog" + action: (lambda (self) (properties (font-dialog)))) + (button "message-dialog" + action: (lambda (self) (properties (message-dialog)))) + (fill) + margin: '0x0) + (hbox + (button "layout-dialog" + action: (lambda (self) (properties (layout-dialog)))) + (button "element-properties-dialog" + action: (lambda (self) + (properties + (element-properties-dialog (create 'user))))) + (fill) + margin: '0x0) + + (label "") + (label "Composition widgets" fontsize: 12) + (hbox + (button "fill" + action: (lambda (self) (properties (fill)))) + (button "hbox" + action: (lambda (self) (properties (hbox)))) + (button "vbox" + action: (lambda (self) (properties (vbox)))) + (button "zbox" + action: (lambda (self) (properties (zbox)))) + (button "radio" + action: (lambda (self) (properties (radio (vbox))))) + (button "normalizer" + action: (lambda (self) (properties (normalizer)))) + (button "cbox" + action: (lambda (self) (properties (cbox)))) + (button "sbox" + action: (lambda (self) (properties (sbox (vbox))))) + (button "split" + action: (lambda (self) (properties (split (vbox) (vbox))))) + (fill) + margin: '0x0) + + (label "") + (label "Standard widgets" fontsize: 12) + (hbox + (button "button" + action: (lambda (self) (properties (button)))) + (button "canvas" + action: (lambda (self) (properties (canvas)))) + (button "frame" + action: (lambda (self) (properties (frame)))) + (button "label" + action: (lambda (self) (properties (label)))) + (button "listbox" + action: (lambda (self) (properties (listbox)))) + (button "progress-bar" + action: (lambda (self) (properties (progress-bar)))) + (button "spin" + action: (lambda (self) (properties (spin)))) + (fill) + margin: '0x0) + (hbox + (button "tabs" + action: (lambda (self) (properties (tabs)))) + (button "textbox" + action: (lambda (self) (properties (textbox)))) + (button "toggle" + action: (lambda (self) (properties (toggle)))) + (button "treebox" + action: (lambda (self) (properties (treebox)))) + (button "valuator" + action: (lambda (self) (properties (valuator "")))) + (fill) + margin: '0x0) + + (label "") + (label "Additional widgets" fontsize: 12) + (hbox + (button "cells" + action: (lambda (self) (properties (cells)))) + (button "color-bar" + action: (lambda (self) (properties (color-bar)))) + (button "color-browser" + action: (lambda (self) (properties (color-browser)))) + (button "dial" + action: (lambda (self) (properties (dial "")))) + (button "matrix" + action: (lambda (self) (properties (matrix)))) + (fill) + margin: '0x0) + (hbox + #;(button "pplot" + action: (lambda (self) (properties (pplot)))) + (button "glcanvas" + action: (lambda (self) (properties (glcanvas)))) + ;; (button "web-browser" + ;; action: (lambda (self) (properties (web-browser)))) + (fill) + margin: '0x0) + + (label "") + (label "Menu widgets" fontsize: 12) + (hbox + (button "menu" + action: (lambda (self) (properties (menu)))) + (button "menu-item" + action: (lambda (self) (properties (menu-item)))) + (button "menu-separator" + action: (lambda (self) (properties (menu-separator)))) + (fill) + margin: '0x0) + + (label "") + (label "Images" fontsize: 12) + (hbox + (button "image/palette" + action: (lambda (self) + (properties + (image/palette 1 1 (u8vector->blob (u8vector 0)))))) + (button "image/rgb" + action: (lambda (self) + (properties + (image/rgb 1 1 (u8vector->blob (u8vector 0)))))) + (button "image/rgba" + action: (lambda (self) + (properties + (image/rgba 1 1 (u8vector->blob (u8vector 0)))))) + (button "image/file" + action: (lambda (self) + (properties + ;; same attributes as image/palette + (image/palette 1 1 (u8vector->blob (u8vector 0)))))) + ;; needs a file in current directory + ;(image/file "chicken.ico")))) ; ok + ;(image/file "chicken.png")))) ; doesn't work + (fill) + margin: '0x0) + + (label "") + (label "Other widgets" fontsize: 12) + (hbox + (button "clipboard" + action: (lambda (self) (properties (clipboard)))) + (button "timer" + action: (lambda (self) (properties (timer)))) + (button "spinbox" + action: (lambda (self) (properties (spinbox (vbox))))) + (fill) + margin: '0x0) + + (fill) + (button "E&xit" + expand: 'horizontal + action: (lambda (self) 'close)) + ) + margin: '15x15 + title: "Iup inspector")) + +(show dlg) +(main-loop) +(exit 0) 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))) ADDED call-with-environment-variables/call-with-environment-variables-core.scm Index: call-with-environment-variables/call-with-environment-variables-core.scm ================================================================== --- /dev/null +++ call-with-environment-variables/call-with-environment-variables-core.scm @@ -0,0 +1,25 @@ +(define (call-with-environment-variables variables thunk) + @("Sets up environment variable via dynamic-wind which are taken down after thunk." + (variables "An alist of the form {{'((\"var\" . \"value\") ...)}}") + (thunk "The thunk to execute with a modified environment")) + (let ((pre-existing-variables + (map (lambda (var-value) + (let ((var (car var-value))) + (cons var (get-environment-variable var)))) + variables))) + (dynamic-wind + (lambda () (void)) + (lambda () +;; (use posix) + (for-each (lambda (var-value) + (setenv (car var-value) (cdr var-value))) + variables) + (thunk)) + (lambda () + (for-each (lambda (var-value) + (let ((var (car var-value)) + (value (cdr var-value))) + (if value + (setenv var value) + (unsetenv var)))) + pre-existing-variables))))) ADDED call-with-environment-variables/call-with-environment-variables.meta Index: call-with-environment-variables/call-with-environment-variables.meta ================================================================== --- /dev/null +++ call-with-environment-variables/call-with-environment-variables.meta @@ -0,0 +1,11 @@ +((synopsis "Set up and take down environment vars") + (author "Peter Danenberg") + (email "pcd@roxygen.org") + (user "klutometis") + (repo "https://github.com/klutometis/call-with-environment-variables") + (category os) + (license "BSD") + (depends (hahn "0.9.3") + setup-helper) + (test-depends test) + (foreign-depends)) ADDED call-with-environment-variables/call-with-environment-variables.release-info Index: call-with-environment-variables/call-with-environment-variables.release-info ================================================================== --- /dev/null +++ call-with-environment-variables/call-with-environment-variables.release-info @@ -0,0 +1,10 @@ +(repo git "git://github.com/klutometis/{egg-name}.git") +(uri targz "https://github.com/klutometis/{egg-name}/tarball/{egg-release}") +(release "0.1") +(release "0.1.1") +(release "0.1.2") +(release "0.1.3") +(release "0.1.4") +(release "0.1.5") +(release "0.1.6") +(release "0.1.7") ADDED call-with-environment-variables/call-with-environment-variables.scm Index: call-with-environment-variables/call-with-environment-variables.scm ================================================================== --- /dev/null +++ call-with-environment-variables/call-with-environment-variables.scm @@ -0,0 +1,10 @@ +(module + call-with-environment-variables + (call-with-environment-variables) + + (import scheme + chicken.base + chicken.process-context + ) + + (include "call-with-environment-variables/call-with-environment-variables-core.scm")) ADDED call-with-environment-variables/call-with-environment-variables.setup Index: call-with-environment-variables/call-with-environment-variables.setup ================================================================== --- /dev/null +++ call-with-environment-variables/call-with-environment-variables.setup @@ -0,0 +1,10 @@ +(use hahn setup-helper-mod) + +(verify-extension-name "call-with-environment-variables") + +(setup-shared-extension-module + 'call-with-environment-variables + (extension-version "0.1.6") + compile-options: '(-X hahn)) + +(run-hahn -o call-with-environment-variables.wiki call-with-environment-variables-core.scm) ADDED call-with-environment-variables/call-with-environment-variables.wiki Index: call-with-environment-variables/call-with-environment-variables.wiki ================================================================== --- /dev/null +++ call-with-environment-variables/call-with-environment-variables.wiki @@ -0,0 +1,54 @@ +== call-with-environment-variables + +Set up and take down environment vars +[[toc:]] +=== {{call-with-environment-variables}} +(call-with-environment-variables variables thunk) → unspecified +Sets up environment variable via dynamic-wind which are taken down after thunk. +; {{variables}} : An alist of the form {{'(("var" . "value") ...)}} +; {{thunk}} : The thunk to execute with a modified environment +(define (call-with-environment-variables variables thunk) + (let ((pre-existing-variables + (map (lambda (var-value) + (let ((var (car var-value))) + (cons var (get-environment-variable var)))) + variables))) + (dynamic-wind + (lambda () (void)) + (lambda () + (use posix) + (for-each + (lambda (var-value) (setenv (car var-value) (cdr var-value))) + variables) + (thunk)) + (lambda () + (for-each + (lambda (var-value) + (let ((var (car var-value)) (value (cdr var-value))) + (if value (setenv var value) (unsetenv var)))) + pre-existing-variables))))) + +=== About this egg + +==== Author + +[[/users/klutometis|Peter Danenberg]] +==== Repository +[[https://github.com/klutometis/call-with-environment-variables]] +==== License +BSD +==== Dependencies +* [[(hahn 0.9.3)]] +* [[setup-helper]] + +==== Versions +; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1|0.1]] : Initial release +; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.1|0.1.1]] : Add the actual code. +; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.2|0.1.2]] : Fix versions. +; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.3|0.1.3]] : Update docs. +; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.4|0.1.4]] : With a note about cock-utils +; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.5|0.1.5]] : Docs +; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.6|0.1.6]] : Use hahn. +==== Colophon + +Documented by [[/egg/hahn|hahn]]. Index: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ cgisetup/models/pgdb.scm @@ -16,25 +16,25 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -(declare (unit pgdb)) -(declare (uses configf)) - -;; I don't know how to mix compilation units and modules, so no module here. -;; -;; (module pgdb -;; ( -;; open-pgdb -;; ) -;; -;; (import scheme) -;; (import data-structures) -;; (import chicken) - -(use typed-records (prefix dbi dbi:)) +;; (declare (unit pgdb)) +;; (declare (uses configf)) +;; +;; ;; I don't know how to mix compilation units and modules, so no module here. +;; ;; +;; ;; (module pgdb +;; ;; ( +;; ;; open-pgdb +;; ;; ) +;; ;; +;; ;; (import scheme) +;; ;; (import data-structures) +;; ;; (import chicken) +;; +;; (use typed-records (prefix dbi dbi:)) ;; given a configdat lookup the connection info and open the db ;; (define (pgdb:open configdat #!key (dbname #f)(dbispec #f)) (let ((pgconf (or dbispec Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -18,22 +18,22 @@ ;;====================================================================== ;; C L I E N T S ;;====================================================================== -(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5 - message-digest matchable spiffy uri-common intarweb http-client - spiffy-request-vars uri-common intarweb directory-utils) - -(declare (unit client)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. - -(include "common_records.scm") -(include "db_records.scm") +;; (use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5 +;; message-digest matchable spiffy uri-common intarweb http-client +;; spiffy-request-vars uri-common intarweb directory-utils) +;; +;; (declare (unit client)) +;; +;; (declare (uses common)) +;; (declare (uses db)) +;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. +;; +;; (include "common_records.scm") +;; (include "db_records.scm") ;; client:get-signature (define (client:get-signature) (if *my-client-signature* *my-client-signature* (let ((sig (conc (get-host-name) " " (current-process-id)))) @@ -123,8 +123,8 @@ ))) (begin ;; no server registered ;; (server:kind-run areapath) (server:start-and-wait areapath) (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries) - (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. + (thread-sleep! 1) ;; (+ 5 (pseudo-random-integer (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. (client:setup-http areapath remaining-tries: (- remaining-tries 1))))))))) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -16,24 +16,24 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -(use srfi-1 data-structures posix regex-case (prefix base64 base64:) - format dot-locking csv-xml z3 udp ;; sql-de-lite - hostinfo md5 message-digest typed-records directory-utils stack - matchable regex posix (srfi 18) extras ;; tcp - (prefix nanomsg nmsg:) - (prefix sqlite3 sqlite3:) - pkts (prefix dbi dbi:) - ) - -(declare (unit common)) -;; (declare (uses commonmod)) -;; (import commonmod) - -(include "common_records.scm") +;; (use srfi-1 data-structures posix regex-case (prefix base64 base64:) +;; format dot-locking csv-xml z3 udp ;; sql-de-lite +;; hostinfo md5 message-digest typed-records directory-utils stack +;; matchable regex posix (srfi 18) extras ;; tcp +;; (prefix nanomsg nmsg:) +;; (prefix sqlite3 sqlite3:) +;; pkts (prefix dbi dbi:) +;; ) +;; +;; (declare (unit common)) +;; ;; (declare (uses commonmod)) +;; ;; (import commonmod) +;; +;; (include "common_records.scm") ;; (require-library margs) ;; (include "margs.scm") @@ -130,11 +130,11 @@ (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar ;; (define *alt-log-file* #f) ;; used by -log (define *common:denoise* (make-hash-table)) ;; for low noise printing -(define *default-log-port* (current-error-port)) +;; (define *default-log-port* (current-error-port)) (define *time-zero* (current-seconds)) ;; for the watchdog (define *default-area-tag* "local") ;; DATABASE (define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this. @@ -175,10 +175,11 @@ ;; (define *total-non-write-delay* 0) (define *heartbeat-mutex* (make-mutex)) (define *api-process-request-count* 0) (define *max-api-process-requests* 0) (define *server-overloaded* #f) +(define *writes-total-delay* 0) ;; client (define *rmt-mutex* (make-mutex)) ;; remote access calls mutex ;; RPC transport @@ -199,26 +200,31 @@ ;; Miscellaneous (define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers (define *numcpus-cache* (make-hash-table)) -(use posix-extras pathname-expand files) +;; (use posix-extras pathname-expand files) ;; this plugs a hole in posix-extras in recent chicken versions > 4.9) -(let-values (( (chicken-release-number chicken-major-version) - (apply values - (map string->number - (take - (string-split (chicken-version) ".") - 2))))) - (let ((resolve-pathname-broken? - (or (> chicken-release-number 4) - (and (eq? 4 chicken-release-number) (> chicken-major-version 9))))) - (if resolve-pathname-broken? - (define ##sys#expand-home-path pathname-expand)))) - -(define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) )) +;; (let-values (( (chicken-release-number chicken-major-version) +;; (apply values +;; (map string->number +;; (take +;; (string-split (chicken-version) ".") +;; 2))))) +;; (let ((resolve-pathname-broken? +;; (or (> chicken-release-number 4) +;; (and (eq? 4 chicken-release-number) (> chicken-major-version 9))))) +;; (if resolve-pathname-broken? +;; (define ##sys#expand-home-path pathname-expand)))) + +;; (define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) )) +;; (define (realpath x)(pathname-expand (or x "/dev/null")) ) +(define (realpath x) + (with-input-from-pipe + (string-append "readlink -f \""x"\"") + read-line)) (define (common:get-this-exe-fullpath #!key (argv (argv))) (let* ((this-script (cond ((and (> (length argv) 2) @@ -592,11 +598,11 @@ (define (common:exit-on-version-changed) (if (common:on-homehost?) (if (common:api-changed?) (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")) (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db")) - (read-only (not (file-write-access? dbfile))) + (read-only (not (file-writable? dbfile))) (dbstruct (db:setup #t))) (debug:print 0 *default-log-port* "WARNING: Version mismatch!\n" " expected: " (common:version-signature) "\n" " got: " (common:get-last-run-version)) @@ -724,55 +730,10 @@ (print-call-chain (current-error-port)) #f) (read (open-input-string (base64:base64-decode instr)))) (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) -;; dot-locking egg seems not to work, using this for now -;; if lock is older than expire-time then remove it and try again -;; to get the lock -;; -(define (common:simple-file-lock fname #!key (expire-time 300)) - (let ((fmod-time (handle-exceptions - ext - (current-seconds) - (file-modification-time fname)))) - (if (common:file-exists? fname) - (if (> (- (current-seconds) fmod-time) expire-time) - (begin - (handle-exceptions exn #f (delete-file* fname)) - (common:simple-file-lock fname expire-time: expire-time)) - #f) - (let ((key-string (conc (get-host-name) "-" (current-process-id)))) - (with-output-to-file fname - (lambda () - (print key-string))) - (thread-sleep! 0.25) - (if (common:file-exists? fname) - (handle-exceptions exn - #f - (with-input-from-file fname - (lambda () - (equal? key-string (read-line))))) - #f))))) - -(define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) - (let ((end-time (+ expire-time (current-seconds)))) - (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) - (if got-lock - #t - (if (> end-time (current-seconds)) - (begin - (thread-sleep! 3) - (loop (common:simple-file-lock fname expire-time: expire-time))) - #f))))) - -(define (common:simple-file-release-lock fname) - (handle-exceptions - exn - #f ;; I don't really care why this failed (at least for now) - (delete-file* fname))) - ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== ;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls @@ -1004,11 +965,12 @@ ;;====================================================================== ;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp ;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server) ;; (define (common:readonly-watchdog dbstruct) - (thread-sleep! 0.05) ;; delay for startup + (let ((just-testing 0.0501)) + (thread-sleep! just-testing)) ;; (/ 1 20)) ;; 0.051) ;; delay for startup (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.") ;; sync megatest.db to /tmp/.../megatst.db (let* ((sync-cool-off-duration 3) (golden-mtdb (dbr:dbstruct-mtdb dbstruct)) (golden-mtpath (db:dbdat-get-path golden-mtdb)) @@ -1082,11 +1044,11 @@ (begin (sqlite3:interrupt! db) (sqlite3:finalize! db #t) ;; (vector-set! *task-db* 0 #f) (set! *task-db* #f))))) - (http-client#close-all-connections!) + (http-client#close-idle-connections!) ;; (if (and *runremote* ;; (remote-conndat *runremote*)) ;; (begin ;; (http-client#close-all-connections!))) ;; for http-client (if (not (eq? *default-log-port* (current-error-port))) @@ -1205,11 +1167,11 @@ (if (null? dirs) #f (let loop ((hed (car dirs)) (tal (cdr dirs))) (let ((res (or (and (directory? hed) - (file-write-access? hed) + (file-writable? hed) hed) (handle-exceptions exn (begin (debug:print-info 0 *default-log-port* "could not create " hed @@ -1362,11 +1324,11 @@ exn (begin (debug:print 0 *default-log-port* "Failed to identify access to " path-string ", exn=" exn) #f) (if (and (directory-exists? path-string) - (file-write-access? path-string)) + (file-writable? path-string)) path-string #f))) (define (common:get-linktree) (or (getenv "MT_LINKTREE") @@ -1469,11 +1431,11 @@ ((condition-property-accessor 'exn 'message) exn)) (exit 1))) (let ((hhf (conc *toppath* "/.homehost"))) (if (common:file-exists? hhf) (with-input-from-file hhf read-line) - (if (file-write-access? *toppath*) + (if (file-writable? *toppath*) (begin (with-output-to-file hhf (lambda () (print bestadrs))) (begin @@ -1856,11 +1818,11 @@ (delfile (lambda (exn) (debug:print-info 1 *default-log-port* " removing bad file " fullpath ", exn=" exn) (delete-file* fullpath) #f))) (if (and (file-exists? fullpath) - (file-read-access? fullpath)) + (file-readable? fullpath)) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "failed to get cached info from " fullpath ", exn=" exn) #f) @@ -2162,11 +2124,11 @@ (define (common:get-num-cpus remote-host) (let* ((actual-host (or remote-host (get-host-name)))) ;; hosts had better not be changing the number of cpus too often! (or (hash-table-ref/default *numcpus-cache* actual-host #f) - (let* ((numcpus (or (common:get-cached-info actual-host "num-cpus" age: (+ 2592000 (random 3600))) + (let* ((numcpus (or (common:get-cached-info actual-host "num-cpus" age: (+ 2592000 (pseudo-random-integer 3600))) (let* ((proc (lambda () (let loop ((numcpu 0) (inl (read-line))) (if (eof-object? inl) (if (> numcpu 0) @@ -2194,11 +2156,11 @@ (define (common:wait-for-normalized-load maxnormload msg remote-host #!optional (rem-tries 5)) (let ((num-cpus (common:get-num-cpus remote-host))) (if num-cpus (common:wait-for-cpuload maxnormload num-cpus 15 msg: msg remote-host: remote-host) (begin - (thread-sleep! (random 60)) ;; we failed to get num cpus. wait a bit and try again + (thread-sleep! (pseudo-random-integer 60)) ;; we failed to get num cpus. wait a bit and try again (if (> rem-tries 0) (common:wait-for-normalized-load maxnormload msg remote-host (- rem-tries 1)) #f))))) ;;====================================================================== @@ -2273,11 +2235,11 @@ ;; overloaded and count expired (i.e. went to zero) (else (if (> num-tries 0) ;; should be "num-tries-left". (if (common:low-noise-print 30 (conc (round effective-load) "-load-acceptable-" effective-host)) (debug:print 0 *default-log-port* "Load on " effective-host " is acceptable at effective normalized load of " - effective-normalized-load " continuing.")) + normalized-effective-load " continuing.")) (debug:print 0 *default-log-port* "Load on " effective-host ", " first" could not be retrieved. Giving up and continuing.")))))) ;;====================================================================== ;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load @@ -2303,11 +2265,11 @@ ;; 0 ;; next))) ;; we will force a conservative calculation any time next is large. ;; (first-next-avg (/ (+ first next) 2)) ;; ;; add some randomness to the time to break any alignment ;; ;; where netbatch dumps many jobs to machines simultaneously -;; (adjwait (min (+ 300 (random 10)) (abs (* (+ (random 10) +;; (adjwait (min (+ 300 (pseudo-random-integer 10)) (abs (* (+ (pseudo-random-integer 10) ;; (/ (- 1000 count) 10) ;; waitdelay) ;; (- first adjmaxload) )))) ;; (load-jump-limit (configf:lookup-number *configdat* "setup" "load-jump-limit")) ;; ;; effective load accounts for load jumps, this should elminate all the first-next-avg, adjwait, load-jump-limit @@ -2317,11 +2279,11 @@ ;; (normalized-effective-load (/ effective-load numcpus)) ;; (will-wait (> normalized-effective-load maxload))) ;; ;; ;; let's let the user know once in a long while that load checking ;; ;; is happening but not constantly report it -;; #;(if (common:low-noise-print 30 (conc "cpuload" (or remote-host "localhost"))) ;; (> (random 100) 75) ;; about 25% of the time +;; #;(if (common:low-noise-print 30 (conc "cpuload" (or remote-host "localhost"))) ;; (> (pseudo-random-integer 100) 75) ;; about 25% of the time ;; (debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload ;; ", load: " first ", adjmaxload: " adjmaxload ", loadjmp: " loadjmp)) ;; ;; (debug:print-info 1 *default-log-port* ;; "On host: " effective-host @@ -2505,11 +2467,11 @@ (freespc (cond ((not (directory? dirpath)) (if (common:low-noise-print 300 "disks not a dir " disk-num) (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) -1) - ((not (file-write-access? dirpath)) + ((not (file-writable? dirpath)) (if (common:low-noise-print 300 "disks not writeable " disk-num) (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) -1) ((not (eq? (string-ref dirpath 0) #\/)) (if (common:low-noise-print 300 "disks not a proper path " disk-num) @@ -2520,11 +2482,11 @@ (free-inodes (cond ((not (directory? dirpath)) (if (common:low-noise-print 300 "disks not a dir " disk-num) (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) -1) - ((not (file-write-access? dirpath)) + ((not (file-writable? dirpath)) (if (common:low-noise-print 300 "disks not writeable " disk-num) (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) -1) ((not (eq? (string-ref dirpath 0) #\/)) (if (common:low-noise-print 300 "disks not a proper path " disk-num) @@ -3496,11 +3458,11 @@ (cond ((not (common:file-exists? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory " pktsdir " does not exist.")) ((not (directory? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not a directory.")) - ((not (file-read-access? pktsdir)) + ((not (file-readable? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not readable.")) (else (debug:print-info 0 *default-log-port* "Loading packets found in " pktsdir) (let ((pkts (glob (conc pktsdir "/*.pkt")))) (for-each @@ -3611,10 +3573,28 @@ #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception (thread-join! thread)) ))) (hash-table-keys *common:thread-punchlist*))) +(define (dtests:get-pre-command #!key (default-override #f)) + (let* ((orig-pre-command "export CMD='") + (viewscreen-pre-command "viewscreen ") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) + (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \"")) + + +(define (dtests:get-post-command #!key (default-override #f)) + (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" + "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) + (viewscreen-post-command "") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) + (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;;====================================================================== ;; (define *common:telemetry-log-state* 'startup) ;; (define *common:telemetry-log-socket* #f) ;; ;; (define (common:telemetry-log-open) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -68,187 +68,179 @@ (print ((condition-property-accessor 'exn 'message) exn)) (print "Callback error in " procname) (print "Full condition info:\n" (condition->list exn))))) (proc))) -;; Need a mutex protected way to get and set values -;; or use (define-simple-syntax ?? -;; -(define-inline (with-mutex mtx accessor record . val) - (mutex-lock! mtx) - (let ((res (apply accessor record val))) - (mutex-unlock! mtx) - res)) - -;; this was cached based on results from profiling but it turned out the profiling -;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching -;; in for now but can probably take it out later. -;; -(define (debug:calc-verbosity vstr) - (or (hash-table-ref/default *verbosity-cache* vstr #f) - (let ((res (cond - ((number? vstr) vstr) - ((not (string? vstr)) 1) - ;; ((string-match "^\\s*$" vstr) 1) - (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) - (cond - ((> (length debugvals) 1) debugvals) - ((> (length debugvals) 0)(car debugvals)) - (else 1)))) - ((args:get-arg "-v") 2) - ((args:get-arg "-q") 0) - (else 1)))) - (hash-table-set! *verbosity-cache* vstr res) - res))) - -;; check verbosity, #t is ok -(define (debug:check-verbosity verbosity vstr) - (if (not (or (number? verbosity) - (list? verbosity))) - (begin - (print "ERROR: Invalid debug value \"" vstr "\"") - #f) - #t)) - -(define (debug:debug-mode n) - (cond - ((and (number? *verbosity*) ;; number number - (number? n)) - (<= n *verbosity*)) - ((and (list? *verbosity*) ;; list number - (number? n)) - (member n *verbosity*)) - ((and (list? *verbosity*) ;; list list - (list? n)) - (not (null? (lset-intersection! eq? *verbosity* n)))) - ((and (number? *verbosity*) - (list? n)) - (member *verbosity* n)))) - -(define (debug:setup) - (let ((debugstr (or (args:get-arg "-debug") - (args:get-arg "-debug-noprop") - (getenv "MT_DEBUG_MODE")))) - (set! *verbosity* (debug:calc-verbosity debugstr)) - (debug:check-verbosity *verbosity* debugstr) - ;; if we were handed a bad verbosity rule then we will override it with 1 and continue - (if (not *verbosity*)(set! *verbosity* 1)) - (if (and (not (args:get-arg "-debug-noprop")) - (or (args:get-arg "-debug") - (not (getenv "MT_DEBUG_MODE")))) - (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) - (string-intersperse (map conc *verbosity*) ",") - (conc *verbosity*)))))) - -(define (debug:print n e . params) - (if (debug:debug-mode n) - (with-output-to-port (or e (current-error-port)) - (lambda () - (if *logging* - (db:log-event (apply conc params)) - (apply print params) - ))))) - -;; Brandon's debug printer shortcut (indulge me :) -(define *BB-process-starttime* (current-milliseconds)) -(define (BB> . in-args) - (let* ((stack (get-call-chain)) - (location "??")) - (for-each - (lambda (frame) - (let* ((this-loc (vector-ref frame 0)) - (temp (string-split (->string this-loc) " ")) - (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???"))) - (if (equal? this-func "BB>") - (set! location this-loc)))) - stack) - (let* ((color-on "\x1b[1m") - (color-off "\x1b[0m") - (dp-args - (append - (list 0 *default-log-port* - (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") ) - in-args))) - (apply debug:print dp-args)))) - -(define *BBpp_custom_expanders_list* (make-hash-table)) - - - -;; register hash tables with BBpp. -(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE: - (cons hash-table? hash-table->alist)) - -;; test name converter -(define (BBpp_custom_converter arg) - (let ((res #f)) - (for-each - (lambda (custom-type-name) - (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name)) - (custom-type-test (car custom-type-info)) - (custom-type-converter (cdr custom-type-info))) - (when (and (not res) (custom-type-test arg)) - (set! res (custom-type-converter arg))))) - (hash-table-keys *BBpp_custom_expanders_list*)) - (if res (BBpp_ res) arg))) - -(define (BBpp_ arg) - (cond - ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg))) - ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg))) - ((hash-table? arg) - (let ((al (hash-table->alist arg))) - (BBpp_ (cons HASH_TABLE: al)))) - ((null? arg) '()) - ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) - ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) - (else (BBpp_custom_converter arg)))) - -;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp -(define (BBpp arg) - (pp (BBpp_ arg))) - -;(use 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)))) - ;; ) - ] - [(_ x y ...) (begin (inspect x) (inspect y ...))])) - -(define (debug:print-error n e . params) - ;; normal print - (if (debug:debug-mode n) - (with-output-to-port (if (port? e) e (current-error-port)) - (lambda () - (if *logging* - (db:log-event (apply conc params)) - ;; (apply print "pid:" (current-process-id) " " params) - (apply print "ERROR: " params) - )))) - ;; pass important messages to stderr - (if (and (eq? n 0)(not (eq? e (current-error-port)))) - (with-output-to-port (current-error-port) - (lambda () - (apply print "ERROR: " params) - )))) - -(define (debug:print-info n e . params) - (if (debug:debug-mode n) - (with-output-to-port (if (port? e) e (current-error-port)) - (lambda () - (if *logging* - (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) - (db:log-event res)) - ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) - (apply print "INFO: (" n ") " params) ;; res) - ))))) - - - -;; if a value is printable (i.e. string or number) return the value -;; else return an empty string -(define-inline (printable val) - (if (or (number? val)(string? val)) val "")) - +;; ;; this was cached based on results from profiling but it turned out the profiling +;; ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching +;; ;; in for now but can probably take it out later. +;; ;; +;; (define (debug:calc-verbosity vstr) +;; (or (hash-table-ref/default *verbosity-cache* vstr #f) +;; (let ((res (cond +;; ((number? vstr) vstr) +;; ((not (string? vstr)) 1) +;; ;; ((string-match "^\\s*$" vstr) 1) +;; (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) +;; (cond +;; ((> (length debugvals) 1) debugvals) +;; ((> (length debugvals) 0)(car debugvals)) +;; (else 1)))) +;; ((args:get-arg "-v") 2) +;; ((args:get-arg "-q") 0) +;; (else 1)))) +;; (hash-table-set! *verbosity-cache* vstr res) +;; res))) +;; +;; ;; check verbosity, #t is ok +;; (define (debug:check-verbosity verbosity vstr) +;; (if (not (or (number? verbosity) +;; (list? verbosity))) +;; (begin +;; (print "ERROR: Invalid debug value \"" vstr "\"") +;; #f) +;; #t)) +;; +;; (define (debug:debug-mode n) +;; (cond +;; ((and (number? *verbosity*) ;; number number +;; (number? n)) +;; (<= n *verbosity*)) +;; ((and (list? *verbosity*) ;; list number +;; (number? n)) +;; (member n *verbosity*)) +;; ((and (list? *verbosity*) ;; list list +;; (list? n)) +;; (not (null? (lset-intersection! eq? *verbosity* n)))) +;; ((and (number? *verbosity*) +;; (list? n)) +;; (member *verbosity* n)))) +;; +;; (define (debug:setup) +;; (let ((debugstr (or (args:get-arg "-debug") +;; (args:get-arg "-debug-noprop") +;; (getenv "MT_DEBUG_MODE")))) +;; (set! *verbosity* (debug:calc-verbosity debugstr)) +;; (debug:check-verbosity *verbosity* debugstr) +;; ;; if we were handed a bad verbosity rule then we will override it with 1 and continue +;; (if (not *verbosity*)(set! *verbosity* 1)) +;; (if (and (not (args:get-arg "-debug-noprop")) +;; (or (args:get-arg "-debug") +;; (not (getenv "MT_DEBUG_MODE")))) +;; (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) +;; (string-intersperse (map conc *verbosity*) ",") +;; (conc *verbosity*)))))) +;; +;; (define (debug:print n e . params) +;; (if (debug:debug-mode n) +;; (with-output-to-port (or e (current-error-port)) +;; (lambda () +;; (if *logging* +;; (db:log-event (apply conc params)) +;; (apply print params) +;; ))))) +;; +;; ;; Brandon's debug printer shortcut (indulge me :) +;; (define *BB-process-starttime* (current-milliseconds)) +;; (define (BB> . in-args) +;; (let* ((stack (get-call-chain)) +;; (location "??")) +;; (for-each +;; (lambda (frame) +;; (let* ((this-loc (vector-ref frame 0)) +;; (temp (string-split (->string this-loc) " ")) +;; (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???"))) +;; (if (equal? this-func "BB>") +;; (set! location this-loc)))) +;; stack) +;; (let* ((color-on "\x1b[1m") +;; (color-off "\x1b[0m") +;; (dp-args +;; (append +;; (list 0 *default-log-port* +;; (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") ) +;; in-args))) +;; (apply debug:print dp-args)))) +;; +;; (define *BBpp_custom_expanders_list* (make-hash-table)) +;; +;; +;; +;; ;; register hash tables with BBpp. +;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE: +;; (cons hash-table? hash-table->alist)) +;; +;; ;; test name converter +;; (define (BBpp_custom_converter arg) +;; (let ((res #f)) +;; (for-each +;; (lambda (custom-type-name) +;; (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name)) +;; (custom-type-test (car custom-type-info)) +;; (custom-type-converter (cdr custom-type-info))) +;; (when (and (not res) (custom-type-test arg)) +;; (set! res (custom-type-converter arg))))) +;; (hash-table-keys *BBpp_custom_expanders_list*)) +;; (if res (BBpp_ res) arg))) +;; +;; (define (BBpp_ arg) +;; (cond +;; ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg))) +;; ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg))) +;; ((hash-table? arg) +;; (let ((al (hash-table->alist arg))) +;; (BBpp_ (cons HASH_TABLE: al)))) +;; ((null? arg) '()) +;; ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) +;; ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) +;; (else (BBpp_custom_converter arg)))) +;; +;; ;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp +;; (define (BBpp arg) +;; (pp (BBpp_ arg))) +;; +;; ;(use 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)))) +;; ;; ) +;; ] +;; [(_ x y ...) (begin (inspect x) (inspect y ...))])) +;; +;; (define (debug:print-error n e . params) +;; ;; normal print +;; (if (debug:debug-mode n) +;; (with-output-to-port (if (port? e) e (current-error-port)) +;; (lambda () +;; (if *logging* +;; (db:log-event (apply conc params)) +;; ;; (apply print "pid:" (current-process-id) " " params) +;; (apply print "ERROR: " params) +;; )))) +;; ;; pass important messages to stderr +;; (if (and (eq? n 0)(not (eq? e (current-error-port)))) +;; (with-output-to-port (current-error-port) +;; (lambda () +;; (apply print "ERROR: " params) +;; )))) +;; +;; (define (debug:print-info n e . params) +;; (if (debug:debug-mode n) +;; (with-output-to-port (if (port? e) e (current-error-port)) +;; (lambda () +;; (if *logging* +;; (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) +;; (db:log-event res)) +;; ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) +;; (apply print "INFO: (" n ") " params) ;; res) +;; ))))) +;; +;; +;; +;; ;; if a value is printable (i.e. string or number) return the value +;; ;; else return an empty string +;; (define-inline (printable val) +;; (if (or (number? val)(string? val)) val "")) +;; +;; Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -17,18 +17,38 @@ ;; along with Megatest. If not, see . ;;====================================================================== (declare (unit commonmod)) +(declare (uses mtver)) (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.time + chicken.file.posix + chicken.process-context.posix + chicken.io + chicken.string + + (prefix sqlite3 sqlite3:) + + system-information + typed-records + md5 + message-digest + regex + srfi-1 + srfi-18 + srfi-69 + + mtver + ) ;;====================================================================== ;; CONTENTS ;; ;; config file utils @@ -35,128 +55,58 @@ ;; misc conversion, data manipulation functions ;; testsuite and area utilites ;; ;;====================================================================== -(include "megatest-version.scm") (include "megatest-fossil-hash.scm") -(define (get-full-version) - (conc megatest-version "-" megatest-fossil-hash)) - -(define (version-signature) - (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) - - -;;====================================================================== -;; config file utils -;;====================================================================== - -(define (lookup cfgdat section var) - (if (hash-table? cfgdat) - (let ((sectdat (hash-table-ref/default cfgdat section '()))) - (if (null? sectdat) - #f - (let ((match (assoc var sectdat))) - (if match ;; (and match (list? match)(> (length match) 1)) - (cadr match) - #f)) - )) - #f)) - -;; returns var key1=val1; key2=val2 ... as alist -(define (get-key-list cfgdat section var) - ;; convert string a=1; b=2; c=a silly thing; d= - (let ((valstr (lookup cfgdat section var))) - (if valstr - (val->alist valstr) - '()))) ;; should it return empty list or #f to indicate not set? - - -(define (get-section cfgdat section) - (hash-table-ref/default cfgdat section '())) - -;;====================================================================== -;; misc conversion, data manipulation functions -;;====================================================================== - -;; if it looks like a number -> convert it to a number, else return it -;; -(define (lazy-convert inval) - (let* ((as-num (if (string? inval)(string->number inval) #f))) - (or as-num inval))) - -;; to '((a . 1)(b . 2)(c . "a silly thing")(d . "")) -;; -(define (val->alist val #!key (convert #f)) - (let ((val-list (string-split-fields ";\\s*" val #:infix))) - (if val-list - (map (lambda (x) - (let ((f (string-split-fields "\\s*=\\s*" x #:infix))) - (case (length f) - ((0) `(,#f)) ;; null string case - ((1) `(,(string->symbol (car f)))) - ((2) `(,(string->symbol (car f)) . - ,(let ((inval (cadr f))) - (if convert (lazy-convert inval) inval)))) - (else f)))) - (filter (lambda (x) - (not (string-match "^\\s*" x))) - val-list)) - '()))) - -;;====================================================================== -;; testsuite and area utilites -;;====================================================================== - -(define (get-testsuite-name toppath configdat) - (or (lookup configdat "setup" "area-name") - (lookup configdat "setup" "testsuite") - (get-environment-variable "MT_TESTSUITE_NAME") - (if (string? toppath) - (pathname-file toppath) - #f))) - -(define (get-area-path-signature toppath #!optional (short #f)) - (let ((res (message-digest-string (md5-primitive) toppath))) - (if short - (substring res 0 4) - res))) - -(define (get-area-name configdat toppath #!optional (short #f)) - ;; look up my area name in areas table (future) - ;; generate auto name - (conc (get-area-path-signature toppath short) - "-" - (get-testsuite-name toppath configdat))) - -;; need generic find-record-with-var-nmatching-val -;; -(define (path->area-record cfgdat path) - (let* ((areadat (get-cfg-areas cfgdat)) - (all (filter (lambda (x) - (let* ((keyvals (cdr x)) - (pth (alist-ref 'path keyvals))) - (equal? path pth))) - areadat))) - (if (null? all) - #f - (car all)))) ;; return first match - -;; given a config return an alist of alists -;; area-name => data -;; -(define (get-cfg-areas cfgdat) - (let ((adat (get-section cfgdat "areas"))) - (map (lambda (entry) - `(,(car entry) . - ,(val->alist (cadr entry)))) - adat))) - -;; (define (debug:print . params) #f) -;; (define (debug:print-info . params) #f) -;; -;; (define (set-functions dbgp dbgpinfo) -;; (set! debug:print dbgp) -;; (set! debug:print-info dbgpinfo)) +;; Globals +;; +(define *server-loop-heart-beat* (current-seconds)) + +;; dot-locking egg seems not to work, using this for now +;; if lock is older than expire-time then remove it and try again +;; to get the lock +;; +(define (common:simple-file-lock fname #!key (expire-time 300)) + (let ((fmod-time (handle-exceptions + ext + (current-seconds) + (file-modification-time fname)))) + (if (file-exists? fname) + (if (> (- (current-seconds) fmod-time) expire-time) + (begin + (handle-exceptions exn #f (delete-file* fname)) + (common:simple-file-lock fname expire-time: expire-time)) + #f) + (let ((key-string (conc (get-host-name) "-" (current-process-id)))) + (with-output-to-file fname + (lambda () + (print key-string))) + (thread-sleep! 0.251) + (if (file-exists? fname) + (handle-exceptions exn + #f + (with-input-from-file fname + (lambda () + (equal? key-string (read-line))))) + #f))))) + +(define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) + (let ((end-time (+ expire-time (current-seconds)))) + (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) + (if got-lock + #t + (if (> end-time (current-seconds)) + (begin + (thread-sleep! 3) + (loop (common:simple-file-lock fname expire-time: expire-time))) + #f))))) + +(define (common:simple-file-release-lock fname) + (handle-exceptions + exn + #f ;; I don't really care why this failed (at least for now) + (delete-file* fname))) + ) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -20,17 +20,17 @@ ;;====================================================================== ;; Config file handling ;;====================================================================== -(use regex regex-case matchable) ;; directory-utils) -(declare (unit configf)) -(declare (uses process)) -(declare (uses env)) -(declare (uses keys)) - -(include "common_records.scm") +;; (use regex regex-case matchable) ;; directory-utils) +;; (declare (unit configf)) +;; (declare (uses process)) +;; (declare (uses env)) +;; (declare (uses keys)) +;; +;; (include "common_records.scm") ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) (if toppath (let ((cfname (conc toppath "/" configname))) @@ -358,11 +358,11 @@ (configf:script-rx ( x include-script params);; handle-exceptions ;; exn ;; (begin ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (if (and (common:file-exists? include-script)(file-execute-access? include-script)) + (if (and (common:file-exists? include-script)(file-executable? include-script)) (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections)) (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system)) (new-inp-port (common:with-env-vars env-delta @@ -717,11 +717,11 @@ ;; returns (list dat msg) (define (configf:read-refdb refdb-path) (let ((sheets-file (conc refdb-path "/sheet-names.cfg"))) (if (not (common:file-exists? sheets-file)) (list #f (conc "ERROR: no refdb found at " refdb-path)) - (if (not (file-read-access? sheets-file)) + (if (not (file-readable? sheets-file)) (list #f (conc "ERROR: refdb file not readable at " refdb-path)) (let* ((sheets (with-input-from-file sheets-file (lambda () (let loop ((inl (read-line)) (res '())) ADDED configfmod.scm Index: configfmod.scm ================================================================== --- /dev/null +++ configfmod.scm @@ -0,0 +1,1039 @@ +;;====================================================================== +;; Copyright 2017, 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 configfmod)) +(declare (uses mtargs)) +(declare (uses debugprint)) + +(module configfmod + * + +(import scheme + + chicken.base + chicken.condition + chicken.file + chicken.io + chicken.pathname + chicken.port + chicken.pretty-print + chicken.process + chicken.process-context + chicken.sort + chicken.string + chicken.time + + debugprint + mtargs + pkts + + (prefix base64 base64:) + (prefix dbi dbi:) + (prefix sqlite3 sqlite3:) + (srfi 18) + directory-utils + format + matchable + md5 + message-digest + regex + regex-case + sparse-vectors + srfi-1 + srfi-13 + srfi-69 + stack + typed-records + z3 + + ) + +(define getenv get-environment-variable) +(define setenv set-environment-variable!) +(define unsetenv unset-environment-variable!) + +;;====================================================================== +;; move debug stuff to separate module then put these back where they belong +;;====================================================================== +;;====================================================================== +;; lookup routines - replicated from configf +;;====================================================================== + +(define (configf:lookup cfgdat section var) + (if (hash-table? cfgdat) + (let ((sectdat (hash-table-ref/default cfgdat section '()))) + (if (null? sectdat) + #f + (let ((match (assoc var sectdat))) + (if match ;; (and match (list? match)(> (length match) 1)) + (cadr match) + #f)) + )) + #f)) + +(define (configf:assoc-safe-add alist key val #!key (metadata #f)) + (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) + (append newalist (list (if metadata + (list key val metadata) + (list key val)))))) + +(define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f)) + (hash-table-set! cfgdat section-name + (configf:assoc-safe-add + (hash-table-ref/default cfgdat section-name '()) + var value metadata: metadata))) + +;; use to have definitive setting: +;; [foo] +;; var yes +;; +;; (configf:var-is? cfgdat "foo" "var" "yes") => #t +;; +(define (configf:var-is? cfgdat section var expected-val) + (equal? (configf:lookup cfgdat section var) expected-val)) + +;; redefines +(define config-lookup configf:lookup) + +;; safely look up a value that is expected to be a number, return +;; a default (#f unless provided) +;; +(define (configf:lookup-number cfdat section varname #!key (default #f)) + (let* ((val (configf:lookup cfdat section varname)) + (res (if val + (string->number (string-substitute "\\s+" "" val #t)) + #f))) + (cond + (res res) + (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val)) + (else default)))) + +(define (configf:section-vars cfgdat section) + (let ((sectdat (hash-table-ref/default cfgdat section '()))) + (if (null? sectdat) + '() + (map car sectdat)))) + +(define (configf:get-section cfgdat section) + (hash-table-ref/default cfgdat section '())) + +(define (configf:set-section-var cfgdat section var val) + (let ((sectdat (configf:get-section cfgdat section))) + (hash-table-set! cfgdat section + (configf:assoc-safe-add sectdat var val)))) + +;;======================================================================the end + +;; return list (path fullpath configname) +(define (find-config configname #!key (toppath #f)) + (if toppath + (let ((cfname (conc toppath "/" configname))) + (if (file-exists? cfname) + (list toppath cfname configname) + (list #f #f #f))) + (let* ((cwd (string-split (current-directory) "/"))) + (let loop ((dir cwd)) + (let* ((path (conc "/" (string-intersperse dir "/"))) + (fullpath (conc path "/" configname))) + (if (file-exists? fullpath) + (list path fullpath configname) + (let ((remcwd (take dir (- (length dir) 1)))) + (if (null? remcwd) + (list #f #f #f) ;; #f #f) + (loop remcwd))))))))) + +(define (configf:eval-string-in-environment str) + ;; (if (or (string-null? str) + ;; (equal? "!" (substring str 0 1))) ;; null string or starts with ! are preserved but NOT set in the environment + str + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment, exn=" exn) + #f) + (let ((cmdres (process:cmd-run->list (conc "echo " str)))) + (if (null? cmdres) "" + (caar cmdres))))) ;; ) + +;;====================================================================== +;; Make the regexp's needed globally available +;;====================================================================== + +(define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) +(define configf:script-rx (regexp "^\\[scriptinc\\s+(\\S+)([^\\]]*)\\]\\s*$")) ;; include output from a script +(define configf:section-rx (regexp "^\\[(.*)\\]\\s*$")) +(define configf:blank-l-rx (regexp "^\\s*$")) +(define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) +(define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$")) +(define configf:key-no-val (regexp "^(\\S+)(\\s*)$")) +(define configf:comment-rx (regexp "^\\s*#.*")) +(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")) +(define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$")) + +;; read a line and process any #{ ... } constructs + +(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)")) + +(define (configf:system ht cmd) + (system cmd) + ) + +(define (configf:process-line l ht allow-system #!key (linenum #f)) + (let loop ((res l)) + (if (string? res) + (let ((matchdat (string-search configf:var-expand-regex res))) + (if matchdat + (let* ((prestr (list-ref matchdat 1)) + (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv + (cmd (list-ref matchdat 3)) + (poststr (list-ref matchdat 4)) + (result #f) + (start-time (current-seconds)) + (cmdsym (string->symbol cmdtype)) + (fullcmd (case cmdsym + ((scheme scm) (conc "(lambda (ht)" cmd ")")) + ((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))")) + ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))")) + ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))")) + ((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))")) + ((mtrah) (conc "(lambda (ht)" + " (let ((extra \"" cmd "\"))" + " (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))" + " (if (string-null? extra) \"\" \"/\")" + " extra)))")) + ((get g) + (match (string-split cmd) + ((sect var)(conc "(lambda (ht)(configfmod#configf:lookup ht \"" sect "\" \"" var "\"))")) + (else + (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.") + "(lambda (ht) #f)"))) + ((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) + ;; ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) + (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) + ;; (print "fullcmd=" fullcmd) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + ;; (print "exn=" (condition->list exn)) + (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd))) + (if (or allow-system + (not (member cmdtype '("system" "shell" "sh")))) + (with-input-from-string fullcmd + (lambda () + (set! result ((eval (read)) ht)))) + (set! result (conc "#{(" cmdtype ") " cmd "}")))) + (case cmdsym + ((system shell scheme) + (let ((delta (- (current-seconds) start-time))) + (if (> delta 2) + (debug:print-info 0 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result) + (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result))))) + (loop (conc prestr result poststr))) + res)) + res))) + +;; Run a shell command and return the output as a string +(define (shell cmd) + (let* ((output (process:cmd-run->list cmd)) + (res (car output)) + (status (cadr output))) + (if (equal? status 0) + (let ((outres (string-intersperse + res + "\n"))) + (debug:print-info 4 *default-log-port* "shell result:\n" outres) + outres) + (begin + (with-output-to-port (current-error-port) + (lambda () + (print "ERROR: " cmd " returned bad exit code " status))) + "")))) + +;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ... +;; +(define (configf:read-line p ht allow-processing settings) + (let loop ((inl (read-line p))) + (let ((cont-line (and (string? inl) + (not (string-null? inl)) + (equal? "\\" (string-take-right inl 1))))) + (if cont-line ;; last character is \ + (let ((nextl (read-line p))) + (if (not (eof-object? nextl)) + (loop (string-append (if cont-line + (string-take inl (- (string-length inl) 1)) + inl) + nextl)))) + (let ((res (case allow-processing ;; if (and allow-processing + ;; (not (eq? allow-processing 'return-string))) + ((#t #f) + (configf:process-line inl ht allow-processing)) + ((return-string) + inl) + (else + (configf:process-line inl ht allow-processing))))) + (if (and (string? res) ;; must set to "no" to force NOT trimming trailing spaces + (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "yes") "no"))) + (string-substitute "\\s+$" "" res) + res)))))) + +(define (configf:cfgdat->env-alist section cfgdat-ht allow-system) + (filter + (lambda (pair) + (let* ((var (car pair)) + (val (cdr pair))) + (cons var + (cond + ((and allow-system (procedure? val)) ;; if we decided to use something other than #t or #f for allow-system ('return-procs or 'return-string) , this may become problematic + (val)) + ((procedure? val) #f) + ((string? val) val) + (else "#f"))))) + (append + (hash-table-ref/default cfgdat-ht "default" '()) + (if (equal? section "default") '() (hash-table-ref/default cfgdat-ht section '()))))) + +(define (calc-allow-system allow-system section sections) + (if sections + (and (or (equal? "default" section) + (member section sections)) + allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings + allow-system)) + +;; given a config hash and a section name, apply that section to all matching sections (using wildcard % or regex if /..../) +;; remove the section when done so that there is no downstream clobbering +;; +(define (configf:apply-wildcards ht section-name) + (if (hash-table-exists? ht section-name) + (let* ((vars (hash-table-ref ht section-name)) + (rxstr (if (string-contains section-name "%") + (string-substitute (regexp "%") ".*" section-name) + (string-substitute (regexp "^/(.*)/$") "\\1" section-name))) + (rx (regexp rxstr))) + ;; (print "\nsection-name: " section-name " rxstr: " rxstr) + (for-each + (lambda (section) + (if section + (let ((same-section (string=? section-name section)) + (rx-match (string-match rx section))) + ;; (print "section: " section " vars: " vars " same-section: " same-section " rx-match: " rx-match) + (if (and (not same-section) rx-match) + (for-each + (lambda (bundle) + ;; (print "bundle: " bundle) + (let ((key (car bundle)) + (val (cadr bundle)) + (meta (if (> (length bundle) 2)(caddr bundle) #f))) + (hash-table-set! ht section (configf:assoc-safe-add (hash-table-ref ht section) key val metadata: meta)))) + vars))))) + (hash-table-keys ht)))) + ht) + +;; read a config file, returns hash table of alists + +;; read a config file, returns hash table of alists +;; adds to ht if given (must be #f otherwise) +;; allow-system: +;; #f - do not evaluate [system +;; #t - immediately evaluate [system and store result as string +;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time +;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time +;; envion-patt is a regex spec that identifies sections that will be eval'd +;; in the environment on the fly +;; sections: #f => get all, else list of sections to gather +;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path) +;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections +;; +(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f) + (sections #f) (settings (make-hash-table)) (keep-filenames #f) + (post-section-procs '()) (apply-wildcards #t) ) + (debug:print 9 *default-log-port* "START: " path) +;; (if *configdat* +;; (common:save-pkt `((action . read-config) +;; (f . ,(cond ((string? path) path) +;; ((port? path) "port") +;; (else (conc path)))) +;; (T . configf)) +;; *configdat* #t add-only: #t)) + (if (and (not (port? path)) + (not (file-exists? path))) ;; for case where we are handed a port + (begin + (debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory)) + ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read? + #f) ;; (if (not ht)(make-hash-table) ht)) + (let ((inp (if (string? path) + (open-input-file path) + path)) ;; we can be handed a port + (res (if (not ht)(make-hash-table) ht)) + (metapath (if (or (debug:debug-mode 9) + keep-filenames) + path #f)) + (process-wildcards (lambda (res curr-section-name) + (if (and apply-wildcards + (or (string-contains curr-section-name "%") ;; wildcard + (string-match "/.*/" curr-section-name))) ;; regex + (begin + (configf:apply-wildcards res curr-section-name) + (hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res + (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp)) + (curr-section-name (if curr-section curr-section "default")) + (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere + (lead #f)) + (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") + (if (eof-object? inl) + (begin + ;; process last section for wildcards + (process-wildcards res curr-section-name) + (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it. + (close-input-port inp)) + (if (list? sections) ;; delete all sections except given when sections is provided + (for-each + (lambda (section) + (if (not (member section sections)) + (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht + (hash-table-keys res))) + (debug:print 9 *default-log-port* "END: " path) + res + ) ;; retval + (regex-case + inl + (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f)) + + (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f)) + (configf:settings ( x setting val ) + (begin + (hash-table-set! settings setting val) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f))) + + (configf:include-rx ( x include-file ) + (let* ((curr-conf-dir (pathname-directory path)) + (full-conf (if (and (absolute-pathname? include-file) (file-exists? include-file)) + include-file + (common:nice-path + (conc (if curr-conf-dir + curr-conf-dir + ".") + "/" include-file))))) + (let ((all-matches (sort (handle-exceptions exn + (begin + (debug:print '(2 9) *default-log-port* "glob of " full-conf " gave no match. , exn=" exn) + (list)) + (glob full-conf)) string<=?))) + (if (null? all-matches) + (begin + (debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")") + (debug:print 2 *default-log-port* " " full-conf)) + (for-each + (lambda (fpath) + ;; (push-directory conf-dir) + (debug:print 9 *default-log-port* "Including: " full-conf) + (read-config fpath res allow-system environ-patt: environ-patt + curr-section: curr-section-name sections: sections settings: settings + keep-filenames: keep-filenames)) + all-matches)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name #f #f)))) + (configf:script-rx ( x include-script params);; handle-exceptions + ;; exn + ;; (begin + ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") + ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (if (and (file-exists? include-script)(file-executable? include-script)) + (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections)) + (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system)) + (new-inp-port + (common:with-env-vars + env-delta + (lambda () + (open-input-pipe (conc include-script " " params)))))) + (debug:print '(2 9) *default-log-port* "Including from script output: " include-script) + ;; (print "We got here, calling read-config next. Port is: " new-inp-port) + (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) + (close-input-port new-inp-port) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (begin + (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) + ) ;; ) + (configf:section-rx ( x section-name ) + (begin + ;; call post-section-procs + (for-each + (lambda (dat) + (let ((patt (car dat)) + (proc (cdr dat))) + (if (string-match patt curr-section-name) + (proc curr-section-name section-name res path)))) + post-section-procs) + ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards + ;; NOTE: we are processing the curr-section-name, NOT section-name. + (process-wildcards res curr-section-name) + (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) + ;; if we have the sections list then force all settings into "" and delete it later? + ;; (if (or (not sections) + ;; (member section-name sections)) + ;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later. + section-name + #f #f))) + (configf:key-sys-pr ( x key cmd ) + (if (calc-allow-system allow-system curr-section-name sections) + (let ((alist (hash-table-ref/default res curr-section-name '())) + (val-proc (lambda () + (let* ((start-time (current-seconds)) + (local-allow-system (calc-allow-system allow-system curr-section-name sections)) + (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system)) + (cmdres (process:cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars! + (delta (- (current-seconds) start-time)) + (status (cadr cmdres)) + (res (car cmdres))) + (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n")) + (if (not (eq? status 0)) + (begin + (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status + " output: " cmdres))) + (if (> delta 2) + (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) + (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) + (if (null? res) + "" + (string-intersperse res " ")))))) + (hash-table-set! res curr-section-name + (configf:assoc-safe-add alist + key + (case (calc-allow-system allow-system curr-section-name sections) + ((return-procs) val-proc) + ((return-string) cmd) + (else (val-proc))) + metadata: metapath)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) + settings) + curr-section-name #f #f))) + + (configf:key-no-val ( x key val) + (let* ((alist (hash-table-ref/default res curr-section-name '())) + (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) + (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t") + (safe-setenv key fval) + (hash-table-set! res curr-section-name + (configf:assoc-safe-add alist key fval metadata: metapath)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) + settings) + curr-section-name key #f))) + + (configf:key-val-pr ( x key unk1 val unk2 ) + (let* ((alist (hash-table-ref/default res curr-section-name '())) + (envar (and environ-patt + (string-search (regexp environ-patt) curr-section-name) ;; does the section match the envionpatt? + (and (not (string-null? key)) + (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment + ;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs + )) + (realval (if envar + (configf:eval-string-in-environment val) + val))) + (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) + (if envar (safe-setenv key realval)) + (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val) + (hash-table-set! res curr-section-name + (configf:assoc-safe-add alist key realval metadata: metapath)) + (loop (configf:read-line inp res + (calc-allow-system allow-system curr-section-name sections) settings) + curr-section-name key #f))) + ;; if a continued line + (configf:cont-ln-rx ( x whsp val ) + (let ((alist (hash-table-ref/default res curr-section-name '()))) + (if var-flag ;; if set to a string then we have a continued var + (let ((newval (conc + (configf:lookup res curr-section-name var-flag) "\n" + ;; trim lead from the incoming whsp to support some indenting. + (if lead + (string-substitute (regexp lead) "" whsp) + "") + val))) + ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) + (hash-table-set! res curr-section-name + (configf:assoc-safe-add alist var-flag newval metadata: metapath)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) + (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"") + (set! var-flag #f) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) + ) ;; end loop + ))) + +;;====================================================================== +;; lookup and manipulation routines +;;====================================================================== + +;; (define (configf:assoc-safe-add alist key val #!key (metadata #f)) +;; (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) +;; (append newalist (list (if metadata +;; (list key val metadata) +;; (list key val)))))) +;; +;; (define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f)) +;; (hash-table-set! cfgdat section-name +;; (configf:assoc-safe-add +;; (hash-table-ref/default cfgdat section-name '()) +;; var value metadata: metadata))) +;; +;; (define (configf:lookup cfgdat section var) +;; (if (hash-table? cfgdat) +;; (let ((sectdat (hash-table-ref/default cfgdat section '()))) +;; (if (null? sectdat) +;; #f +;; (let ((match (assoc var sectdat))) +;; (if match ;; (and match (list? match)(> (length match) 1)) +;; (cadr match) +;; #f)) +;; )) +;; #f)) +;; +;; ;; use to have definitive setting: +;; ;; [foo] +;; ;; var yes +;; ;; +;; ;; (configf:var-is? cfgdat "foo" "var" "yes") => #t +;; ;; +;; (define (configf:var-is? cfgdat section var expected-val) +;; (equal? (configf:lookup cfgdat section var) expected-val)) +;; +;; (define config-lookup configf:lookup) +(define configf:read-file read-config) + +;; ;; safely look up a value that is expected to be a number, return +;; ;; a default (#f unless provided) +;; ;; +;; (define (configf:lookup-number cfdat section varname #!key (default #f)) +;; (let* ((val (configf:lookup *configdat* section varname)) +;; (res (if val +;; (string->number (string-substitute "\\s+" "" val #t)) +;; #f))) +;; (cond +;; (res res) +;; (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val)) +;; (else default)))) +;; +;; (define (configf:section-vars cfgdat section) +;; (let ((sectdat (hash-table-ref/default cfgdat section '()))) +;; (if (null? sectdat) +;; '() +;; (map car sectdat)))) +;; +;; (define (configf:get-section cfgdat section) +;; (hash-table-ref/default cfgdat section '())) +;; +;; (define (configf:set-section-var cfgdat section var val) +;; (let ((sectdat (configf:get-section cfgdat section))) +;; (hash-table-set! cfgdat section +;; (configf:assoc-safe-add sectdat var val)))) +;; +;; ;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat) +;; ;; (list var val)))) +;; +;;====================================================================== +;; setup +;;====================================================================== +;;====================================================================== + +(define (setup) + (let* ((configf (find-config "megatest.config")) + (config (if configf (read-config configf #f #t) #f))) + (if config + (setenv "RUN_AREA_HOME" (pathname-directory configf))) + config)) + +(define getenv get-environment-variable) +(define (safe-setenv key val) + (if (or (substring-index "!" key) + (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables. + (substring-index "." key)) ;; periods are not allowed in environment variables + (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"") + (if (and (string? val) + (string? key)) + (handle-exceptions + exn + (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val ", exn=" exn) + (setenv key val)) + (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)))) + +;;====================================================================== +;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) +;; execute thunk in context of environment modified as per this list +;; restore env to prior state then return value of eval'd thunk. +;; ** this is not thread safe ** +(define (common:with-env-vars delta-env-alist-or-hash-table thunk) + (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table) + (hash-table->alist delta-env-alist-or-hash-table) + delta-env-alist-or-hash-table)) + (restore-thunks + (filter + identity + (map (lambda (env-pair) + (let* ((env-var (car env-pair)) + (new-val (let ((tmp (cdr env-pair))) + (if (list? tmp) (car tmp) tmp))) + (current-val (get-environment-variable env-var)) + (restore-thunk + (cond + ((not current-val) (lambda () (unsetenv env-var))) + ((not (string? new-val)) #f) + ((eq? current-val new-val) #f) + (else + (lambda () (setenv env-var current-val)))))) + ;;(when (not (string? new-val)) + ;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist) + ;; (pp delta-env-alist) + ;; (exit 1)) + + + (cond + ((not new-val) ;; modify env here + (unsetenv env-var)) + ((string? new-val) + (setenv env-var new-val))) + restore-thunk)) + delta-env-alist)))) + (let ((rv (thunk))) + (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state + rv))) + +;; return a nice clean pathname made absolute +(define (common:nice-path dir) + (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) + (if match ;; using ~ for home? + (common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match))) + (normalize-pathname (if (absolute-pathname? dir) + dir + (conc (current-directory) "/" dir)))))) + +;; make "nice-path" available in config files and the repl +(define nice-path common:nice-path) + +(define (common:read-link-f path) + (handle-exceptions + exn + (begin + (debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed. exn=" exn) + path) ;; just give up + (with-input-from-pipe + (conc "/bin/readlink -f " path) + (lambda () + (read-line))))) + + +;;====================================================================== +;; Non destructive writing of config file +;;====================================================================== + +(define (configf:compress-multi-lines fdat) + ;; step 1.5 - compress any continued lines + (if (null? fdat) fdat + (let loop ((hed (car fdat)) + (tal (cdr fdat)) + (cur "") + (led #f) + (res '())) + ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!! + ;; 1. remove led whitespace + ;; 2. tack on to hed with "\n" + (let ((match (string-match configf:cont-ln-rx hed))) + (if match ;; blast! have to deal with a multiline + (let* ((lead (cadr match)) + (lval (caddr match)) + (newl (conc cur "\n" lval))) + (if (not led)(set! led lead)) + (if (null? tal) + (set! fdat (append fdat (list newl))) + (loop (car tal)(cdr tal) newl led res))) ;; NB// not tacking newl onto res + (let ((newres (if led + (append res (list cur hed)) + (append res (list hed))))) + ;; prev was a multiline + (if (null? tal) + newres + (loop (car tal)(cdr tal) "" #f newres)))))))) + +;; note: I'm cheating a little here. I merely replace "\n" with "\n " +(define (configf:expand-multi-lines fdat) + ;; step 1.5 - compress any continued lines + (if (null? fdat) fdat + (let loop ((hed (car fdat)) + (tal (cdr fdat)) + (res '())) + (let ((newres (append res (list (string-substitute (regexp "\n") "\n " hed #t))))) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres)))))) + +(define (configf:file->list fname) + (if (file-exists? fname) + (let ((inp (open-input-file fname))) + (let loop ((inl (read-line inp)) + (res '())) + (if (eof-object? inl) + (begin + (close-input-port inp) + (reverse res)) + (loop (read-line inp)(cons inl res))))) + '())) + +;;====================================================================== +;; Write a config +;; 0. Given a refererence data structure "indat" +;; 1. Open the output file and read it into a list +;; 2. Flatten any multiline entries +;; 3. Modify values per contents of "indat" and remove absent values +;; 4. Append new values to the section (immediately after last legit entry) +;; 5. Write out the new list +;;====================================================================== + +(define (configf:write-config indat fname #!key (required-sections '())) + (let* (;; step 1: Open the output file and read it into a list + (fdat (configf:file->list fname)) + (refdat (make-hash-table)) + (sechash (make-hash-table)) ;; current section hash, init with hash for "default" section + (new #f) ;; put the line to be used in new, if it is to be deleted the set new to #f + (secname #f)) + + ;; step 2: Flatten multiline entries + (if (not (null? fdat))(set! fdat (configf:compress-multi-lines fdat))) + + ;; step 3: Modify values per contents of "indat" and remove absent values + (if (not (null? fdat)) + (let loop ((hed (car fdat)) + (tal (cadr fdat)) + (res '()) + (lnum 0)) + (regex-case + hed + (configf:comment-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f)) + (configf:blank-l-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f)) + (configf:section-rx ( x section-name ) (let ((section-hash (hash-table-ref/default refdat section-name #f))) + (if (not section-hash) + (let ((newhash (make-hash-table))) + (hash-table-set! refdat section-name newhash) ;; was refhash - not sure that refdat is correct here + (set! sechash newhash)) + (set! sechash section-hash)) + (set! new hed) ;; will append this at the bottom of the loop + (set! secname section-name) + )) + ;; No need to process key cmd, let it fall though to key val + (configf:key-val-pr ( x key val ) + (let ((newval (configf:lookup indat secname key))) ;; was sec, bug or correct? + ;; can handle newval == #f here => that means key is removed + (cond + ((equal? newval val) + (set! res (append res (list hed)))) + ((not newval) ;; key has been removed + (set! new #f)) + ((not (equal? newval val)) + (hash-table-set! sechash key newval) + (set! new (conc key " " newval))) + (else + (debug:print-error 0 *default-log-port* "problem parsing line number " lnum "\"" hed "\""))))) + (else + (debug:print-error 0 *default-log-port* "Problem parsing line num " lnum " :\n " hed ))) + (if (not (null? tal)) + (loop (car tal)(cdr tal)(if new (append res (list new)) res)(+ lnum 1))) + ;; drop to here when done processing, res contains modified list of lines + (set! fdat res))) + + ;; step 4: Append new values to the section + (for-each + (lambda (section) + (let ((sdat '()) ;; append needed bits here + (svars (configf:section-vars indat section))) + (for-each + (lambda (var) + (let ((val (configf:lookup refdat section var))) + (if (not val) ;; this one is new + (begin + (if (null? sdat)(set! sdat (list (conc "[" section "]")))) + (set! sdat (append sdat (list (conc var " " val)))))))) + svars) + (set! fdat (append fdat sdat)))) + (delete-duplicates (append required-sections (hash-table-keys indat)))) + + ;; step 5: Write out new file + (with-output-to-file fname + (lambda () + (for-each + (lambda (line) + (print line)) + (configf:expand-multi-lines fdat)))))) + +(define (process:cmd-run->list cmd #!key (delta-env-alist-or-hash-table '())) + (common:with-env-vars + delta-env-alist-or-hash-table + (lambda () + (let* ((fh (open-input-pipe cmd)) + (res (port->list fh)) + (status (close-input-pipe fh))) + (list res status))))) + +(define (port->list fh) + (if (eof-object? fh) #f + (let loop ((curr (read-line fh)) + (result '())) + (if (not (eof-object? curr)) + (loop (read-line fh) + (append result (list curr))) + result)))) + +;;====================================================================== +;; refdb +;;====================================================================== + +;; reads a refdb into an assoc array of assoc arrays +;; returns (list dat msg) +(define (configf:read-refdb refdb-path) + (let ((sheets-file (conc refdb-path "/sheet-names.cfg"))) + (if (not (file-exists? sheets-file)) + (list #f (conc "ERROR: no refdb found at " refdb-path)) + (if (not (file-readable? sheets-file)) + (list #f (conc "ERROR: refdb file not readable at " refdb-path)) + (let* ((sheets (with-input-from-file sheets-file + (lambda () + (let loop ((inl (read-line)) + (res '())) + (if (eof-object? inl) + (reverse res) + (loop (read-line)(cons inl res))))))) + (data '())) + (for-each + (lambda (sheet-name) + (let* ((dat-path (conc refdb-path "/" sheet-name ".dat")) + (ref-dat (configf:read-file dat-path #f #t)) + (ref-assoc (map (lambda (key) + (list key (hash-table-ref ref-dat key))) + (hash-table-keys ref-dat)))) + ;; (hash-table->alist ref-dat))) + ;; (set! data (append data (list (list sheet-name ref-assoc)))))) + (set! data (cons (list sheet-name ref-assoc) data)))) + sheets) + (list data "NO ERRORS")))))) + +;; map over all pairs in a three level hierarchial alist and apply a function to the keys/val +;; +(define (configf:map-all-hier-alist data proc #!key (initproc1 #f)(initproc2 #f)(initproc3 #f)) + (for-each + (lambda (sheetname) + (let* ((sheettmp (assoc sheetname data)) + (sheetdat (if sheettmp (cadr sheettmp) '()))) + (if initproc1 (initproc1 sheetname)) + (for-each + (lambda (sectionname) + (let* ((sectiontmp (assoc sectionname sheetdat)) + (sectiondat (if sectiontmp (cadr sectiontmp) '()))) + (if initproc2 (initproc2 sheetname sectionname)) + (for-each + (lambda (varname) + (let* ((valtmp (assoc varname sectiondat)) + (val (if valtmp (cadr valtmp) ""))) + (proc sheetname sectionname varname val))) + (map car sectiondat)))) + (map car sheetdat)))) + (map car data)) + data) + +;;====================================================================== +;; C O N F I G T O / F R O M A L I S T +;;====================================================================== + +(define (configf:config->alist cfgdat) + (hash-table->alist cfgdat)) + +(define (configf:alist->config adat) + (let ((ht (make-hash-table))) + (for-each + (lambda (section) + (hash-table-set! ht (car section)(cdr section))) + adat) + ht)) + +;; convert hierarchial list to ini format +;; +(define (configf:config->ini data) + (map + (lambda (section) + (let ((section-name (car section)) + (section-dat (cdr section))) + (print "\n[" section-name "]") + (map (lambda (dat-pair) + (let* ((var (car dat-pair)) + (val (cadr dat-pair)) + (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f))) + (if fname (print "# " var "=>" fname)) + (print var " " val))) + section-dat))) ;; (print "section-dat: " section-dat)) + (hash-table->alist data))) + + +;; if +(define (configf:read-alist fname) + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "read of alist " fname " failed. exn=" exn) + #f) + (configf:alist->config + (with-input-from-file fname read)))) + +;;====================================================================== +;; DO THE LOCKING AROUND THE CALL +;;====================================================================== +;; +(define (configf:write-alist cdat fname) + #;(if (not (common:faux-lock fname)) + (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname)) + (let* ((dat (configf:config->alist cdat)) + (res + (begin + (with-output-to-file fname ;; first write out the file + (lambda () + (pp dat))) + + (if (file-exists? fname) ;; now verify it is readable + (if (configf:read-alist fname) + #t ;; data is good. + (begin + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn) + #f) + (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.") + (delete-file fname)) + #f)) + #f)))) + ;; (common:faux-unlock fname) + res)) + + +) ADDED csv-xml.scm Index: csv-xml.scm ================================================================== --- /dev/null +++ csv-xml.scm @@ -0,0 +1,24 @@ +;; Copyright 2006-2017, 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 . + +;; Always use two or four digit decimal +;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. + +(declare (unit csv-xml)) + +(include "csv-xml/csv-xml.scm") + ADDED csv-xml/csv-out.impl Index: csv-xml/csv-out.impl ================================================================== --- /dev/null +++ csv-xml/csv-out.impl @@ -0,0 +1,261 @@ +;;;; cvs-out.impl -*- Hen -*- +;;;; Kon Lovett, Jun '17 + +;;;; *** included source file *** + +;;Issues +;; +;;- missing explicit types for exports; too much '*' type + +;; + +(define-constant CRLF-STR "\r\n") +(define-constant LF-STR "\n") +(define-constant CR-STR "\r") ;old MacOS + +(define *system-newline* + (cond-expand + (windows + CRLF-STR ) + (unix + LF-STR ) + (else + LF-STR ) ) ) + +(define-constant +newline-char-default+ #t) ;#t - | #\n | ... +(define-constant +separator-char-default+ #\,) +(define-constant +quote-char-default+ #\") ;#f | #\" | ... +(define-constant +comment-char-default+ #\#) ;#f | #\# | ... +(define-constant +quote-doubling-escapes?-default+ #t) +(define-constant +quote-controls?-default+ #t) +(define-constant +always-quote?-default+ #t) + +#| +(define-constant +sxml-top-symbol+ '|*TOP*|) +(define-constant +sxml-row-element-default+ 'row) +(define-constant +sxml-col-elements-limit-default+ 32) ; arbitrary (see csv.ss) +|# + +;; + +;very loose : newline-char | separator-char | quote-char +;see "csv-xml.scm" +(define csv-writer-spec? alist?) +(define-check+error-type csv-writer-spec) + +(define csv-writer? procedure?) +(define-check+error-type csv-writer) + +;; + +(define *default-writer-spec* (writer-spec-with-defaults '())) + +(define (list->csv ls #!optional (writer-or-out (current-output-port))) + (let ( + (writer + (cond + ((csv-writer? writer-or-out) + writer-or-out ) + ((output-port? writer-or-out) + (make-csv-line-writer 'list->csv writer-or-out *default-writer-spec*) ) + (else + (error 'list->csv "invalid csv-writer or output-port" writer-or-out) ) ) ) ) + (for-each writer ls) ) ) + +#| +;; + +(define (list->sxml ls + #!optional + (row-element (sxml-row-element-default)) + (column-elements (sxml-col-elements-default)) + (writer-spec *default-writer-spec*)) + (append! + `(,(sxml-top-symbol)) + (map (cut list->sxml-element <> row-element column-elements writer-spec) ls)) ) +|# + +;; + +(define (writer-spec + #!key + (newline-char +newline-char-default+) + (separator-char +separator-char-default+) + (quote-char +quote-char-default+) + (comment-char +comment-char-default+) + (quote-doubling-escapes? +quote-doubling-escapes?-default+) + (quote-controls? +quote-controls?-default+) + (always-quote? +always-quote?-default+)) + ;FIXME checking the input types + `((newline-char . ,newline-char) + (separator-char . ,separator-char) + (quote-char . ,quote-char) + (comment-char . ,comment-char) + (quote-doubling-escapes? . ,quote-doubling-escapes?) + (quote-controls? . ,quote-controls?) + (always-quote? . ,always-quote?)) ) + +;; + +(define (make-csv-writer out-or-str #!optional (writer-spec '())) + (let ((make-spec-csv-writer (make-csv-writer-maker writer-spec))) + (make-spec-csv-writer out-or-str) ) ) + +(define (make-csv-writer-maker #!optional (writer-spec '())) + (let ((writer-spec + (writer-spec-with-defaults + (check-csv-writer-spec 'make-csv-writer-maker writer-spec)) ) ) + (lambda (out-or-str) + (let ( + (out + (cond + ((string? out-or-str) + (open-output-file out-or-str) ) + ((output-port? out-or-str) + out-or-str ) + (else + (error + 'csv-writer-maker + "invalid output-port or string" out-or-str) ) ) ) ) + (make-csv-line-writer 'csv-writer-maker out writer-spec) ) ) ) ) + +;; + +(define (make-csv-line-writer loc out writer-spec) + (let ( + (writer-spec + (check-csv-writer-spec loc writer-spec) ) + (newline-obj + (select-newline-object loc (alist-ref 'newline-char writer-spec eq?)) ) + (separator-char + (alist-ref 'separator-char writer-spec eq?) ) + (quote-char + (alist-ref 'quote-char writer-spec eq?) ) + (comment-char + (alist-ref 'comment-char writer-spec eq?) ) + (quote-doubling-escapes? + (alist-ref 'quote-doubling-escapes? writer-spec eq?) ) + (quote-controls? + (alist-ref 'quote-controls? writer-spec eq?) ) + (always-quote? + (alist-ref 'always-quote? writer-spec eq?) ) ) + ; + (let* ( + (quote-char-str (unicode-char->string quote-char) ) + (quote-char-str-2 (string-append quote-char-str quote-char-str)) ) + ; + (define (csv-line-object->string obj) + ; + (define (quote-doubling? str) + (and quote-doubling-escapes? (string-index str quote-char)) ) + ; + (define (quoting? str) + (or + always-quote? + (quote-doubling? str) + (and separator-char (string-index str separator-char)) + (and quote-controls? (string-index str char-set:iso-control))) ) + ; + (type-case obj + ((char) + (csv-line-object->string (unicode-char->string obj)) ) + ((symbol) + (csv-line-object->string (symbol->string obj)) ) + ((string) + (if (and quote-char (quoting? obj)) + (let ( + (str + (if (quote-doubling? obj) + (string-translate* obj `((,quote-char-str . ,quote-char-str-2))) + obj ) ) ) + ; + (conc quote-char str quote-char) ) + obj ) ) + (number + (csv-line-object->string (number->string obj)) ) + (else + (csv-line-object->string (->string obj)) ) ) ) + ; + (lambda (obj) + (let ( + ;build row to output as a string with a line-ending sequence + (lin + ;comment desired? + (if (list? obj) + ;row data + (let ((qstrs (map csv-line-object->string (check-list loc obj)))) + (apply + conc + (append! + (intersperse qstrs separator-char) + `(,newline-obj))) ) + ;are we supposed to do comments? + (if comment-char + (conc comment-char obj newline-obj) + obj + #; + (begin + (warning loc "comments not active" obj writer-spec) + "" ) ) ) ) ) + ; + (display lin out) ) ) ) ) ) + +;; + +(define (select-newline-object loc spec) + (case spec + ((cr) + #\return ) + ((lf) + #\newline ) + ((crlf) + CRLF-STR ) + (else + *system-newline* ) ) ) + +;; + +(define (writer-spec-with-defaults writer-spec) + `((newline-char . ,(alist-ref 'newline-char writer-spec eq? +newline-char-default+)) + (separator-char . ,(alist-ref 'separator-char writer-spec eq? +separator-char-default+)) + (quote-char . ,(alist-ref 'quote-char writer-spec eq? +quote-char-default+)) + (comment-char . ,(alist-ref 'comment-char writer-spec eq? +comment-char-default+)) + (quote-doubling-escapes? . ,(alist-ref 'quote-doubling-escapes? writer-spec eq? +quote-doubling-escapes?-default+)) + (quote-controls? . ,(alist-ref 'quote-controls? writer-spec eq? +quote-controls?-default+)) + (always-quote? . ,(alist-ref 'always-quote? writer-spec eq? +always-quote?-default+))) ) + +#| +;; + +(define (list->sxml-element ls row-element col-elements writer-spec) + (if (list? ls) + ;row data + `(,row-element ,@(map list col-elements (map ->string ls))) + ;are we supposed to do comments? + (if (alist-ref 'comment-char writer-spec eq?) + `(*COMMENT* ,(->string ls)) + ls ) ) ) + +(define (make-sxml-col-symbol n) + (string->symbol (string-append "col-" (number->string n))) ) + +(define +sxml-col-elements-default+ + (map make-sxml-col-symbol (sxml-col-iota)) ) + +(define (sxml-top-symbol) + +sxml-top-symbol+ ) + +(define (sxml-row-element-default) + +sxml-row-element-default+ ) + +(define (sxml-col-elements-default) + +sxml-col-elements-default+ ) + +(define (sxml-col-iota) + (iota +sxml-col-elements-limit-default+) ) +#; +(define (sxml-col-iota) + (do ((i 0 add1) + (ls '() (cons (make-sxml-col-symbol i) ls)) ) + ((= i +sxml-col-elements-limit-default+) ls) ) ) +|# ADDED csv-xml/csv-xml.meta Index: csv-xml/csv-xml.meta ================================================================== --- /dev/null +++ csv-xml/csv-xml.meta @@ -0,0 +1,19 @@ +;;;; csv-xml.meta -*- Hen -*- + +((egg "csv-xml.egg") + (date "2011-07-02") + (category parsing) + (author "Neil van Dyke") + (license "LGPL 3") + (doc-from-wiki) + (synopsis "Parsing comma-separated values") + (depends + (setup-helper "1.5.2") + (check-errors "2.0.2") + (moremacros "1.4.2") + (string-utils "1.5.5")) + (test-depends testeez test) + (files + "csv-xml.meta" "csv-xml.setup" + "csv-xml.scm" "csv-out.impl" "csv.ss" + "test/run.scm" "test/test-csv.ss") ) ADDED csv-xml/csv-xml.scm Index: csv-xml/csv-xml.scm ================================================================== --- /dev/null +++ csv-xml/csv-xml.scm @@ -0,0 +1,118 @@ +;;;; csv-xml.scm -*- Hen -*- +;;;; Kon Lovett, Jun '17 +;;;; Kon Lovett, ??? '?? + +(module csv-xml + +(;export + ; + reader-spec + ; + make-csv-reader + make-csv-reader-maker + ; + csv->list + csv->sxml + csv-for-each + csv-map + ; + csv-reader? check-csv-reader error-csv-reader + csv-reader-spec? check-csv-reader-spec error-csv-reader-spec + ; + writer-spec + ; + make-csv-writer-maker + make-csv-writer + ; + list->csv + #;list->sxml + ; + csv-writer? check-csv-writer error-csv-writer + csv-writer-spec? check-csv-writer-spec error-csv-writer-spec) + +(import scheme + chicken.base + chicken.string + + moremacros + srfi-1 + srfi-13 + srfi-14 + type-checks + unicode-utils + ) + +#;(import (except chicken provide)) +;; (import chicken) + +;;; + +;Need to process `#lang' as well. So just "commented out" the "offending" +;sections in the source. +#;(define-syntax provide (syntax-rules () ((_ ?x0 ...) (begin)))) +(define null '()) + +(include "csv-xml/csv.ss") + +;;; + +;; (import (only data-structures conc intersperse ->string alist-ref string-translate*)) +;; (require-library data-structures) +;; +;; #;(import (only list-utils alist?)) +;; (import (only (srfi 1) every iota append! map)) +;; (require-library (srfi 1)) +;; +;; (import (only (srfi 13) string-index)) +;; (require-library (srfi 13)) +;; +;; (import (only (srfi 14) char-set:iso-control)) +;; (require-library (srfi 14)) +;; +;; (import (only type-checks define-check+error-type check-string check-list)) +;; (require-library type-checks) +;; +;; (import (only unicode-utils unicode-char->string)) +;; (require-library unicode-utils) +;; +;; (require-extension moremacros) + +;(from list-utils egg) +(define (alist? obj) + (if (pair? obj) + (every pair? obj) + (null? obj) ) ) + +;very loose ... +(define csv-reader-spec? alist?) +(define-check+error-type csv-reader-spec) + +(define csv-reader? procedure?) +(define-check+error-type csv-reader) + +(define (reader-spec + #!key + (newline-type 'lax) + (separator-chars '(#\,)) + (quote-char #\") + (quote-doubling-escapes? #t) + (comment-chars '()) + (whitespace-chars '(#\space)) + (strip-leading-whitespace? #f) + (strip-trailing-whitespace? #f) + (newlines-in-quotes? #t)) + `((newline-type . ,newline-type) + (separator-chars . ,separator-chars) + (quote-char . ,quote-char) + (quote-doubling-escapes? . ,quote-doubling-escapes?) + (comment-chars . ,comment-chars) + (whitespace-chars . ,whitespace-chars) + (strip-leading-whitespace? . ,strip-leading-whitespace?) + (strip-trailing-whitespace? . ,strip-trailing-whitespace?) + (newlines-in-quotes? . ,newlines-in-quotes?)) ) + +;;; + +(include "csv-xml/csv-out.impl") + +) ;csv-xml ADDED csv-xml/csv-xml.setup Index: csv-xml/csv-xml.setup ================================================================== --- /dev/null +++ csv-xml/csv-xml.setup @@ -0,0 +1,12 @@ +;;;; csv-xml.setup -*- Hen -*- + +(use setup-helper-mod) + +(verify-extension-name "csv-xml") + +(setup-shared+static-extension-module (extension-name) (extension-version "0.12.1") + #:types? #t + #:inline? #t + #:compile-options '( + -optimize-level 3 -debug-level 2 + -no-procedure-checks-for-toplevel-bindings -no-procedure-checks-for-usual-bindings)) ADDED csv-xml/csv.ss Index: csv-xml/csv.ss ================================================================== --- /dev/null +++ csv-xml/csv.ss @@ -0,0 +1,969 @@ +;;; @Package csv +;;; @Subtitle Comma-Separated Value (CSV) Utilities in Scheme +;;; @HomePage http://www.neilvandyke.org/csv-scheme/ +;;; @Author Neil Van Dyke +;;; @Version 0.10 +;;; @Date 2010-04-13 +;;; @PLaneT neil/csv:1:6 + +;; $Id: csv.ss,v 1.199 2010/04/13 17:56:20 neilpair Exp $ + +;;; @legal +;;; Copyright @copyright{} 2004--2009 Neil Van Dyke. This program is Free +;;; Software; you can redistribute it and/or modify it under the terms of the +;;; GNU Lesser General Public License as published by the Free Software +;;; Foundation; either version 3 of the License (LGPL 3), or (at your option) +;;; any later version. This program 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 +;;; @indicateurl{http://www.gnu.org/licenses/} for details. For other licenses +;;; and consulting, please contact the author. +;;; @end legal + +;#lang scheme/base + +;;; @section Introduction + +;;; The @b{csv} Scheme library provides utilities for reading various kinds of +;;; what are commonly known as ``comma-separated value'' (CSV) files. Since +;;; there is no standard CSV format, this library permits CSV readers to be +;;; constructed from a specification of the peculiarities of a given variant. +;;; A default reader handles the majority of formats. +;;; +;;; One of the main uses of this library is to import data from old crusty +;;; legacy applications into Scheme for data conversion and other processing. +;;; To that end, this library includes various conveniences for iterating over +;;; parsed CSV rows, and for converting CSV input to the +;;; @uref{http://pobox.com/~oleg/ftp/Scheme/SXML.html, SXML 3.0} Scheme XML +;;; format. +;;; +;;; This library requires R5RS, SRFI-6, SRFI-23, and an @code{integer->char} +;;; procedure that accepts ASCII values. +;;; +;;; Other implementations of some kind of CSV reading for Scheme include +;;; Gauche's @code{text.csv} module, and Scsh's @code{record-reader} and +;;; related procedures. This library intends to be portable and more +;;; comprehensive. + +;; TODO: Briefly introduce terms "row", "column", and "field". + +(define-syntax %csv:error + (syntax-rules () ((_ p m o) + (error (string-append p " : " m) o) + ;; Bigloo: (error p m o) + ))) + +(define-syntax %csv:type-error + (syntax-rules () + ((_ proc-str expected-str got-value) + (%csv:error proc-str + (string-append "expected " expected-str ", received:") + got-value)))) + +(define %csv:a2c integer->char) + +(define %csv:cr (%csv:a2c 13)) +(define %csv:lf (%csv:a2c 10)) + +(define-syntax %csv:gosc + (syntax-rules () + ((_ os-stx) + (let* ((os os-stx) + (str (get-output-string os))) + (close-output-port os) + str)))) + +(define (%csv:in-arg proc-name in) + (cond ((input-port? in) in) + ((string? in) (open-input-string in)) + (else (%csv:type-error proc-name "input port or string" in)))) + +(define (%csv:reader-or-in-arg proc-name reader-or-in) + (cond ((procedure? reader-or-in) reader-or-in) + ((input-port? reader-or-in) (make-csv-reader reader-or-in)) + ((string? reader-or-in) (make-csv-reader (open-input-string + reader-or-in))) + (else (%csv:type-error proc-name + "csv reader or input port or string" + reader-or-in)))) + +;;; @section Reader Specs + +;;; CSV readers are constructed using @dfn{reader specs}, which are sets of +;;; attribute-value pairs, represented in Scheme as association lists keyed on +;;; symbols. Each attribute has a default value if not specified otherwise. +;;; The attributes are: + +;;; @table @code +;;; +;;; @item newline-type +;;; Symbol representing the newline, or record-terminator, convention. The +;;; convention can be a fixed character sequence (@code{lf}, @code{crlf}, or +;;; @code{cr}, corresponding to combinations of line-feed and carriage-return), +;;; any string of one or more line-feed and carriage-return characters +;;; (@code{lax}), or adaptive (@code{adapt}). @code{adapt} attempts to detect +;;; the newline convention at the start of the input and assume that convention +;;; for the remainder of the input. Default: @code{lax} +;;; +;;; @item separator-chars +;;; Non-null list of characters that serve as field separators. Normally, this +;;; will be a list of one character. Default: @code{(#\,)} (list of the comma +;;; character) +;;; +;;; @item quote-char +;;; Character that should be treated as the quoted field delimiter character, +;;; or @code{#f} if fields cannot be quoted. Note that there can be only one +;;; quote character. Default: @code{#\"} (double-quote) +;;; +;;; @item quote-doubling-escapes? +;;; Boolean for whether or not a sequence of two @code{quote-char} quote +;;; characters within a quoted field constitute an escape sequence for +;;; including a single @code{quote-char} within the string. Default: @code{#t} +;;; +;;; @item comment-chars +;;; List of characters, possibly null, which comment out the entire line of +;;; input when they appear as the first character in a line. Default: +;;; @code{()} (null list) +;;; +;;; @item whitespace-chars +;;; List of characters, possibly null, that are considered @dfn{whitespace} +;;; constituents for purposes of the @code{strip-leading-whitespace?} and +;;; @code{strip-trailing-whitespace?} attributes described below. +;;; Default: @code{(#\space)} (list of the space character) +;;; +;;; @item strip-leading-whitespace? +;;; Boolean for whether or not leading whitespace in fields should be +;;; stripped. Note that whitespace within a quoted field is never stripped. +;;; Default: @code{#f} +;;; +;;; @item strip-trailing-whitespace? +;;; Boolean for whether or not trailing whitespace in fields should be +;;; stripped. Note that whitespace within a quoted field is never stripped. +;;; Default: @code{#f} +;;; +;;; @item newlines-in-quotes? +;;; Boolean for whether or not newline sequences are permitted within quoted +;;; fields. If true, then the newline characters are included as part of the +;;; field value; if false, then the newline sequence is treated as a premature +;;; record termination. Default: @code{#t} +;;; +;;; @end table + +;; TODO: Do not expose this procedure for now. We expect it to go away and be +;; replaced with two other procedures. +;; +;; @defproc %csv:csv-spec-derive orig-spec changes +;; +;; Yields a new CSV spec that is derived from @var{orig-spec} by applying spec +;; @var{changes} as attribute substitions and additions to the original. For +;; example, given an original CSV reader spec: +;; +;; @lisp +;; (define my-first-csv-spec +;; '((newline-type . lax) +;; (separator-chars . (#\,)) +;; (quote-char . #\") +;; (quote-doubling-escapes? . #t) +;; (whitespace-chars . (#\space)))) +;; @end lisp +;; +;; a derived spec with a different @code{separator-chars} attribute and an +;; added @code{comment-chars} attribute can be created like: +;; +;; @lisp +;; (%csv:csv-spec-derive my-first-csv-spec +;; '((separator-chars . (#\%)) +;; (comment-chars . (#\#)))) +;; @result{} +;; ((separator-chars . (#\%)) +;; (comment-chars . (#\#)) +;; (newline-type . lax) +;; (quote-char . #\") +;; (quote-doubling-escapes? . #t) +;; (whitespace-chars . (#\space))) +;; @end lisp +;; +;; In that the yielded spec might share some structure with @var{orig-spec} +;; and/or @var{changes}. Most applications will not use this procedure +;; directly. + +(define (%csv:csv-spec-derive orig-spec changes) + ;; TODO: Make this not share structure. Error-check and normalize at the + ;; same time we clone. + (let ((new-spec '())) + (let ((add-to-new-spec + (lambda (alist) + (for-each (lambda (cell) + (or (assq (car cell) new-spec) + (set! new-spec (cons cell new-spec)))) + alist)))) + (add-to-new-spec changes) + (add-to-new-spec orig-spec) + (reverse new-spec)))) + +;;; @section Making Reader Makers + +;;; CSV readers are procedures that are constructed dynamically to close over a +;;; particular CSV input and yield a parsed row value each time the procedure +;;; is applied. For efficiency reasons, the reader procedures are themselves +;;; constructed by another procedure, @code{make-csv-reader-maker}, for +;;; particular CSV reader specs. + +(define (%csv:csv-error code extra) + ;; TODO: Maybe make the CSV error handler user-specifiable, or allow user to + ;; specify some errors that should be disregarded. + ;; + ;; TODO: Add position information. Keep track of character position while + ;; reading. + (%csv:error + "[csv-reader]" + (string-append "Erroneous CSV format: " + (case code + ((junk-after-quote-close) + "Junk after close of quoted field:") + (else (string-append "INTERNAL ERROR: Unknown code: " + (symbol->string code))))) + extra)) + +(define (%csv:newline-check-step0 newline-type c port) + ;; (display "*DEBUG* (equal? newline-type 'lax) = ") + ;; (write (equal? newline-type 'lax)) + ;; (newline) + ;; (display "*DEBUG* (eqv? newline-type 'lax) = ") + ;; (write (eqv? newline-type 'lax)) + ;; (newline) + (case newline-type + ((cr) (eqv? c %csv:cr)) + ((lf) (eqv? c %csv:lf)) + ((crlf) (if (eqv? c %csv:cr) + (let ((c2 (peek-char port))) + (cond ((eof-object? c2) + ;; Note: This is a CR-EOF in an input that uses CR-LF + ;; for terminating records. We are discarding the CR, + ;; so it will not be added to the field string. We + ;; might want to signal an error. + #t) + ((eqv? c2 %csv:lf) + (read-char port) + #t) + (else #f))) + #f)) + ((lax detect) (cond ((eqv? c %csv:cr) + (let ((c2 (peek-char port))) + (cond ((eof-object? c2) #t) + ((eqv? c2 %csv:lf) + (read-char port) + 'crlf) + (else 'cr)))) + ((eqv? c %csv:lf) 'lf) + (else #f))) + (else (%csv:error + "%csv:make-portreader/positional" + "unrecognized newline-type" + newline-type)))) + +(define %csv:make-portreader/positional + (letrec-syntax + ((newline-check + (syntax-rules () + ((_ newline-type c port detected-newline-type) + ;; Note: "port" and "detected-newline-type" must be identifiers. + ;; "newline-type" and "c" must be identifiers or self-evals. + (if (eqv? newline-type 'detect) + (begin (set! detected-newline-type + (%csv:newline-check-step0 newline-type c port)) + detected-newline-type) + (%csv:newline-check-step0 newline-type c port))))) + (gosc-cons + ;; Note: This is to ensure the output string is gotten and closed + ;; before consing it with the result of a recursive call. + (syntax-rules () + ((_ os b) (let ((s (%csv:gosc os))) (cons s b)))))) + (lambda (newline-type + separator-chars + quote-char + quote-doubling-escapes? + comment-chars + whitespace-chars + strip-leading-whitespace? + strip-trailing-whitespace? + newlines-in-quotes?) + (lambda (port) + (let ((dnlt #f) + (escape-char #\\)) + (let read-fields-or-eof ((c (read-char port))) + (cond + ((eof-object? c) '()) + ((and strip-leading-whitespace? (memv c whitespace-chars)) + ;; It's leading whitespace char when we're ignoring leading + ;; whitespace in fields, and there might just be whitespace and + ;; then an EOF, which should probably be considered just an EOF + ;; rather than a row with one empty field, so just skip this + ;; whitespace char. + (read-fields-or-eof (read-char port))) + ((and (not (null? comment-chars)) (memv c comment-chars)) + ;; It's a comment char in the first column (or in the first + ;; non-whitespace column, if "strip-leading-whitespace?" is + ;; true), so skip to end of line. + (let ((fake-dnlt #f)) + (let loop ((c (read-char port))) + (cond ((eof-object? c) '()) + ((newline-check newline-type c port fake-dnlt) + (read-fields-or-eof (read-char port))) + (else (loop (read-char port))))))) + (else + ;; It's not going to be just an EOF, so try to read a row. + (let ((row + (let read-fields ((c c)) + (cond + ;; If an EOF or newline in an unquoted field, consider + ;; the field and row finished. (We don't consider EOF + ;; before newline to be an error, although perhaps that + ;; would be a useful check for a freak premature + ;; end-of-input when dealing with "well-formed" CSV). + ((or (eof-object? c) + (newline-check newline-type c port dnlt)) + (list "")) + ;; If a field separator, finish this field and cons + ;; with value of recursive call to get the next field. + ((memv c separator-chars) + (cons "" (read-fields (read-char port)))) + ;; If we're ignoring leading whitespace, and it's a + ;; whitespace-chars character, then recurse to keep + ;; finding the field start. + ((and strip-leading-whitespace? + (memv c whitespace-chars)) + (read-fields (read-char port))) + ;; If a quote, read a quoted field. + ((and quote-char (eqv? c quote-char)) + (let ((os (open-output-string))) + (let loop ((c (read-char port))) + (cond + ((or (eof-object? c) + (and (not newlines-in-quotes?) + (newline-check newline-type + c port dnlt))) + (list (%csv:gosc os))) + ((and escape-char (eqv? c escape-char)) + ;FIXME can become unsynchronized + (write-char (read-char port) os) + (loop (read-char port))) + ((and quote-char (eqv? c quote-char)) + (if quote-doubling-escapes? + (let ((c2 (read-char port))) + (if (eqv? c2 quote-char) + (begin (write-char c2 os) + (loop (read-char port))) + (gosc-cons + os + (let skip-after ((c c2)) + (cond + ((or (eof-object? c) + (newline-check + newline-type c port dnlt)) + '()) + ((memv c separator-chars) + (read-fields (read-char port))) + ((memv c whitespace-chars) + ;; Note: We tolerate + ;; whitespace after field + ;; close quote even if + ;; skip-trailing-whitespace? + ;; is false. + (skip-after (read-char port))) + (else (%csv:csv-error + 'junk-after-quote-close + c))))))) + (gosc-cons os + (read-fields (read-char port))))) + (else (write-char c os) + (loop (read-char port))))))) + ;; It's the start of an unquoted field. + (else + (let ((os (open-output-string))) + (write-char c os) + (let loop ((c (read-char port))) + (cond + ((or (eof-object? c) + (newline-check newline-type c port dnlt)) + (list (get-output-string os))) + ((memv c separator-chars) + (gosc-cons os (read-fields (read-char port)))) + ((and strip-trailing-whitespace? + (memv c whitespace-chars)) + ;; TODO: Maybe optimize to avoid creating a new + ;; output string every time we see whitespace. + ;; We could use a string collector with unwrite. + ;; And/or do lookahead to see whether whitespace + ;; is only one character. Do this after we have + ;; a better regression test suite. + (let ((ws-os (open-output-string))) + (write-char c ws-os) + (let ws-loop ((c (read-char port))) + (cond + ((or (eof-object? c) + (newline-check + newline-type c port dnlt)) + (close-output-port ws-os) + (list (%csv:gosc os))) + ((memv c separator-chars) + (close-output-port ws-os) + (gosc-cons os (read-fields (read-char + port)))) + ((memv c whitespace-chars) + (write-char c ws-os) + (ws-loop (read-char port))) + (else + (display (%csv:gosc ws-os) os) + (write-char c os) + (loop (read-char port))))))) + (else (write-char c os) + (loop (read-char port))))))))))) + (if (null? row) + row + (if (eq? newline-type 'detect) + (cons dnlt row) + row))))))))))) + +(define %csv:make-portreader + ;; TODO: Make a macro for the three times we list the spec attributes. + (letrec ((pb (lambda (x) (if x #t #f))) + (pc (lambda (x) + (cond ((char? x) x) + ((string? x) (case (string-length x) + ((1) (string-ref x 0)) + (else (%csv:type-error + "make-csv-reader-maker" + "character" + x)))) + (else (%csv:type-error "make-csv-reader-maker" + "character" + x))))) + (pc-f (lambda (x) + (cond ((not x) x) + ((char? x) x) + ((string? x) (case (string-length x) + ((0) #f) + ((1) (string-ref x 0)) + (else (%csv:type-error + "make-csv-reader-maker" + "character or #f" + x)))) + (else (%csv:type-error "make-csv-reader-maker" + "character or #f" + x))))) + (pe (lambda (x acceptable) + (if (memq x acceptable) + x + (%csv:type-error + "make-csv-reader-maker" + (let ((os (open-output-string))) + (display "symbol from the set " os) + (write acceptable os) + (%csv:gosc os)) + x)))) + (plc-n (lambda (x) + (or (list? x) + (%csv:type-error "make-csv-reader-maker" + "list of characters" + x)) + (map pc x))) + (plc (lambda (x) + (let ((result (plc-n x))) + (if (null? result) + (%csv:type-error "make-csv-reader-maker" + "non-null list of characters" + x) + result))))) + (lambda (reader-spec) + (let ((newline-type 'lax) + (separator-chars '(#\,)) + (quote-char #\") + (quote-doubling-escapes? #t) + (comment-chars '()) + (whitespace-chars '(#\space)) + (strip-leading-whitespace? #f) + (strip-trailing-whitespace? #f) + (newlines-in-quotes? #t)) + ;; TODO: It's erroneous to have two entries for the same attribute in a + ;; spec. However, it would be nice if we error-detected duplicate + ;; entries, or at least had assq semantics (first, rather than last, + ;; wins). Use csv-spec-derive's descendants for that. + (for-each + (lambda (item) + (let ((v (cdr item))) + (case (car item) + ((newline-type) + (set! newline-type (pe v '(cr crlf detect lax lf)))) + ((separator-chars) + (set! separator-chars (plc v))) + ((quote-char) + (set! quote-char (pc-f v))) + ((quote-doubling-escapes?) + (set! quote-doubling-escapes? (pb v))) + ((comment-chars) + (set! comment-chars (plc-n v))) + ((whitespace-chars) + (set! whitespace-chars (plc-n v))) + ((strip-leading-whitespace?) + (set! strip-leading-whitespace? (pb v))) + ((strip-trailing-whitespace?) + (set! strip-trailing-whitespace? (pb v))) + ((newlines-in-quotes?) + (set! newlines-in-quotes? (pb v)))))) + reader-spec) + (%csv:make-portreader/positional + newline-type + separator-chars + quote-char + quote-doubling-escapes? + comment-chars + whitespace-chars + strip-leading-whitespace? + strip-trailing-whitespace? + newlines-in-quotes?))))) + +;;; @defproc make-csv-reader-maker reader-spec +;;; +;;; Constructs a CSV reader constructor procedure from the @var{reader-spec}, +;;; with unspecified attributes having their default values. +;;; +;;; For example, given the input file @code{fruits.csv} with the content: +;;; +;;; @example +;;; apples | 2 | 0.42 +;;; bananas | 20 | 13.69 +;;; @end example +;;; +;;; a reader for the file's apparent format can be constructed like: +;;; +;;; @lisp +;;; (define make-food-csv-reader +;;; (make-csv-reader-maker +;;; '((separator-chars . (#\|)) +;;; (strip-leading-whitespace? . #t) +;;; (strip-trailing-whitespace? . #t)))) +;;; @end lisp +;;; +;;; The resulting @code{make-food-csv-reader} procedure accepts one argument, +;;; which is either an input port from which to read, or a string from which to +;;; read. Our example input file then can be be read by opening an input port +;;; on a file and using our new procedure to construct a reader on it: +;;; +;;; @lisp +;;; (define next-row +;;; (make-food-csv-reader (open-input-file "fruits.csv"))) +;;; @end lisp +;;; +;;; This reader, @code{next-row}, can then be called repeatedly to yield a +;;; parsed representation of each subsequent row. The parsed format is a list +;;; of strings, one string for each column. The null list is yielded to +;;; indicate that all rows have already been yielded. +;;; +;;; @lisp +;;; (next-row) @result{} ("apples" "2" "0.42") +;;; (next-row) @result{} ("bananas" "20" "13.69") +;;; (next-row) @result{} () +;;; @end lisp + +(define (make-csv-reader-maker reader-spec) + (let ((make-portread + (if (let ((p (assq 'newline-type reader-spec))) (and p (cdr p))) + ;; Newline-adapting portreader-maker. + (letrec + ((detect-portread + (%csv:make-portreader + (%csv:csv-spec-derive reader-spec + '((newline-type . detect))))) + ;; TODO: The set of cr/crlf/lf newline-type portreaders are + ;; constructed optimistically right now for two reasons: + ;; 1. we don't yet sanitize reader-specs of shared structure + ;; that can be mutated behind our backs; 2. eventually, we + ;; want to add a "lots-o-shots?" argument that, when true, + ;; would do this anyway. Consider. + (cr-portread + (%csv:make-portreader + (%csv:csv-spec-derive reader-spec + '((newline-type . cr))))) + (crlf-portread + (%csv:make-portreader + (%csv:csv-spec-derive reader-spec + '((newline-type . crlf))))) + (lf-portread + (%csv:make-portreader + (%csv:csv-spec-derive reader-spec + '((newline-type . lf)))))) + (lambda () + (let ((actual-portread #f)) + (let ((adapt-portread + (lambda (port) + (let ((dnlt-row (detect-portread port))) + (if (null? dnlt-row) + dnlt-row + (begin (set! actual-portread + (case (car dnlt-row) + ((cr) cr-portread) + ((crlf) crlf-portread) + ((lf) lf-portread) + (else actual-portread))) + (cdr dnlt-row))))))) + (set! actual-portread adapt-portread) + (lambda (port) (actual-portread port)))))) + ;; Stateless portreader-maker. + (let ((reusable-portread + (%csv:make-portreader reader-spec))) + (lambda () reusable-portread))))) + (lambda (in) + (let ((port (%csv:in-arg "[csv-reader]" in)) + (portread (make-portread))) + (lambda () (portread port)))))) + +;;; @section Making Readers + +;;; In addition to being constructed from the result of +;;; @code{make-csv-reader-maker}, CSV readers can also be constructed using +;;; @code{make-csv-reader}. + +;;; @defproc make-csv-reader in [reader-spec] +;;; +;;; Construct a CSV reader on the input @var{in}, which is an input port or a +;;; string. If @var{reader-spec} is given, and is not the null list, then a +;;; ``one-shot'' reader constructor is constructed with that spec and used. If +;;; @var{reader-spec} is not given, or is the null list, then the default CSV +;;; reader constructor is used. For example, the reader from the +;;; @code{make-csv-reader-maker} example could alternatively have been +;;; constructed like: +;;; +;;; @lisp +;;; (define next-row +;;; (make-csv-reader +;;; (open-input-file "fruits.csv") +;;; '((separator-chars . (#\|)) +;;; (strip-leading-whitespace? . #t) +;;; (strip-trailing-whitespace? . #t)))) +;;; @end lisp + +(define make-csv-reader + (let ((default-maker (make-csv-reader-maker '()))) + (lambda (in . rest) + (let ((spec (cond ((null? rest) '()) + ((null? (cdr rest)) (car rest)) + (else (%csv:error "make-csv-reader" + "extraneous arguments" + (cdr rest)))))) + ((if (null? spec) + default-maker + (make-csv-reader-maker spec)) + (%csv:in-arg "make-csv-reader" in)))))) + +;;; @section High-Level Conveniences + +;;; Several convenience procedures are provided for iterating over the CSV rows +;;; and for converting the CSV to a list. +;;; +;;; To the dismay of some Scheme purists, each of these procedures accepts a +;;; @var{reader-or-in} argument, which can be a CSV reader, an input port, or a +;;; string. If not a CSV reader, then the default reader constructor is used. +;;; For example, all three of the following are equivalent: +;;; +;;; @lisp +;;; (csv->list STRING ) +;;; @equiv{} +;;; (csv->list (make-csv-reader STRING )) +;;; @equiv{} +;;; (csv->list (make-csv-reader (open-input-string STRING ))) +;;; @end lisp + +;;; @defproc csv-for-each proc reader-or-in +;;; +;;; Similar to Scheme's @code{for-each}, applies @var{proc}, a procedure of one +;;; argument, to each parsed CSV row in series. @var{reader-or-in} is the CSV +;;; reader, input port, or string. The return value is undefined. + +;; TODO: Doc an example for this. + +(define (csv-for-each proc reader-or-in) + (let ((reader (%csv:reader-or-in-arg "csv-for-each" reader-or-in))) + (let loop ((row (reader))) + (or (null? row) + (begin (proc row) + (loop (reader))))))) + +;;; @defproc csv-map proc reader-or-in +;;; +;;; Similar to Scheme's @code{map}, applies @var{proc}, a procedure of one +;;; argument, to each parsed CSV row in series, and yields a list of the values +;;; of each application of @var{proc}, in order. @var{reader-or-in} is the CSV +;;; reader, input port, or string. + +;; TODO: Doc an example for this. + +;; (define (csv-map proc reader-or-in) +;; (let ((reader (%csv:reader-or-in-arg "csv-for-each" reader-or-in))) +;; (let ((head '())) +;; (let ((row (reader))) +;; (if (null? row) +;; head +;; (let ((pair (cons (proc row) '()))) +;; (set! head pair) +;; (let loop ((prior pair)) +;; (let ((row (reader))) +;; (if (null? row) +;; head +;; (let ((pair (cons (proc row) '()))) +;; (set-cdr! prior pair) +;; (loop pair))))))))))) + +(define (csv-map proc reader-or-in) + (let ((reader (%csv:reader-or-in-arg "csv-for-each" reader-or-in))) + (let loop ((row (reader)) (ret null)) + (if (null? row) + (reverse ret) + (let ((ret (cons (proc row) ret))) + (loop (reader) ret)))))) + +;;; @defproc csv->list reader-or-in +;;; +;;; Yields a list of CSV row lists from input @var{reader-or-in}, which is a +;;; CSV reader, input port, or string. + +;; TODO: Doc an example for this. + +;; (define (csv->list reader-or-in) +;; (let ((reader (%csv:reader-or-in-arg "csv->list" reader-or-in))) +;; (let ((head '())) +;; (let ((row (reader))) +;; (if (null? row) +;; head +;; (let ((pair (cons row '()))) +;; (set! head pair) +;; (let loop ((prior pair)) +;; (let ((row (reader))) +;; (if (null? row) +;; head +;; (let ((pair (cons row '()))) +;; (set-cdr! prior pair) +;; (loop pair))))))))))) + +(define (csv->list reader-or-in) + (csv-map values reader-or-in)) + +;;; @section Converting CSV to SXML + +;;; The @code{csv->sxml} procedure can be used to convert CSV to SXML format, +;;; for processing with various XML tools. + +;;; @defproc csv->sxml reader-or-in [row-element [col-elements]] +;;; +;;; Reads CSV from input @var{reader-or-in} (which is a CSV reader, input port, +;;; or string), and yields an SXML representation. If given, @var{row-element} +;;; is a symbol for the XML row element. If @var{row-element} is not given, +;;; the default is the symbol @code{row}. If given @var{col-elements} is a +;;; list of symbols for the XML column elements. If not given, or there are +;;; more columns in a row than given symbols, column element symbols are of the +;;; format @code{col-@var{n}}, where @var{n} is the column number (the first +;;; column being number 0, not 1). +;;; +;;; For example, given a CSV-format file @code{friends.csv} that has the +;;; contents: +;;; +;;; @example +;;; Binoche,Ste. Brune,33-1-2-3 +;;; Posey,Main St.,555-5309 +;;; Ryder,Cellblock 9, +;;; @end example +;;; +;;; with elements not given, the result is: +;;; +;;; @lisp +;;; (csv->sxml (open-input-file "friends.csv")) +;;; @result{} +;;; (*TOP* +;;; (row (col-0 "Binoche") (col-1 "Ste. Brune") (col-2 "33-1-2-3")) +;;; (row (col-0 "Posey") (col-1 "Main St.") (col-2 "555-5309")) +;;; (row (col-0 "Ryder") (col-1 "Cellblock 9") (col-2 ""))) +;;; @end lisp +;;; +;;; With elements given, the result is like: +;;; +;;; @lisp +;;; (csv->sxml (open-input-file "friends.csv") +;;; 'friend +;;; '(name address phone)) +;;; @result{} +;;; (*TOP* (friend (name "Binoche") +;;; (address "Ste. Brune") +;;; (phone "33-1-2-3")) +;;; (friend (name "Posey") +;;; (address "Main St.") +;;; (phone "555-5309")) +;;; (friend (name "Ryder") +;;; (address "Cellblock 9") +;;; (phone ""))) +;;; @end lisp + +(define csv->sxml + (let* ((top-symbol + (string->symbol "*TOP*")) + (make-col-symbol + (lambda (n) + (string->symbol (string-append "col-" (number->string n))))) + (default-col-elements + (let loop ((i 0)) + (if (= i 32) ; arbitrary magic number + '() + (cons (make-col-symbol i) (loop (+ 1 i))))))) + ;; TODO: Have option to error when columns count doesn't match provided + ;; column name list. + (lambda (reader-or-in . rest) + (let ((reader (%csv:reader-or-in-arg "csv->sxml" + reader-or-in)) + (row-element 'row) + (col-elements #f)) + ;; TODO: Maybe use case-lambda. + (or (null? rest) + (begin (set! row-element (car rest)) + (let ((rest (cdr rest))) + (or (null? rest) + (begin (set! col-elements (car rest)) + (let ((rest (cdr rest))) + (or (null? rest) + (%csv:error + "csv->sxml" + "extraneous arguments" + rest)))))))) + ;; TODO: We could clone and grow default-col-elements for the duration + ;; of this procedure. + (cons top-symbol + (csv-map (lambda (row) + (cons row-element + (let loop ((vals row) + (i 0) + (names (or col-elements + default-col-elements))) + (if (null? vals) + '() + (cons (list (if (null? names) + (make-col-symbol i) + (car names)) + (car vals)) + (loop (cdr vals) + (+ 1 i) + (if (null? names) + '() + (cdr names)))))))) + reader)))))) + +;; TODO: Make a define-csv-reader/positional, for great constant-folding. +;; That's part of the reason some things are done the way they are. + +;; TODO: Make a csv-bind, as a newbie convenience for people without advanced +;; match forms, which looks good in examples. This is better than a +;; csv-map/bind and a csv-for-each/bind. +;; +;; (csv-for-each/bind ((column-binding ...) body ...) +;; { (else => closure) | (else body ...) | } +;; input-port +;; [ csv-reader ]) +;; +;; (csv-for-each/bind +;; ((lastname firstname email) +;; ...) +;; (else => (lambda (row) (error "CSV row didn't match pattern" row))) +;; my-input-port +;; my-csv-reader) + +;; TODO: Handle escapes, once we find an actual example or specification of any +;; flavor of escapes in CSV other than quote-doubling inside a quoted field. + +;; TODO: Add a spec attribute for treating adjacent separators as one, or +;; skipping empty fields. This would probably only be used in practice for +;; parsing whitespace-separated input. + +;; TODO: Get access to MS Excel or documentation, and make this correct. +;; +;; (define msexcel-csv-reader-spec +;; '((newline-type . crlf) +;; (separator-chars . (#\,)) +;; (quote-char . #\") +;; (quote-doubling-escapes? . #t) +;; (comment-chars . ()) +;; (whitespace-chars . (#\space)) +;; (strip-leading-whitespace? . #f) +;; (strip-trailing-whitespace? . #f) +;; (newlines-in-quotes? . #t))) + +;; TODO: Maybe put this back in. +;; +;; (define default-csv-reader-spec +;; '((newline-type . lax) +;; (separator-chars . (#\,)) +;; (quote-char . #\") +;; (quote-doubling-escapes? . #t) +;; (comment-chars . ()) +;; (whitespace-chars . (#\space)) +;; (strip-leading-whitespace? . #f) +;; (strip-trailing-whitespace? . #f) +;; (newlines-in-quotes? . #t))) + +;; TODO: Implement CSV writing, after CSV reading is field-tested and polished. + +;; TODO: Call "close-input-port" once eof-object is hit, but make sure we still +;; can return an empty list on subsequent calls to the CSV reader. + +;; TODO: Consider switching back to returning eof-object at the end of input. +;; We originally changed to returning the null list because we might want to +;; synthesize the EOF, and there is no R5RS binding for the eof-object. + +;; TODO: [2005-12-09] In one test, Guile has a stack overflow when parsing a +;; row with 425 columns. Wouldn't hurt to see if we can make things more +;; tail-recursive. + +;;; @unnumberedsec History + +;;; @table @asis +;;; +;;; @item Version 0.10 -- 2010-04-13 -- PLaneT @code{(1 6)} +;;; Documentation fix. +;;; +;;; @item Version 0.9 -- 2009-03-14 -- PLaneT @code{(1 5)} +;;; Documentation fix. +;;; +;;; @item Version 0.8 -- 2009-02-23 -- PLaneT @code{(1 4)} +;;; Documentation changes. +;;; +;;; @item Version 0.7 -- 2009-02-22 -- PLaneT @code{(1 3)} +;;; License is now LGPL 3. Moved to author's new Scheme administration system. +;;; +;;; @item Version 0.6 -- 2008-08-12 -- PLaneT @code{(1 2)} +;;; For PLT 4 compatibility, new versions of @code{csv-map} and +;;; @code{csv->list} that don't use @code{set-cdr!} (courtesy of Doug +;;; Orleans). PLT 4 @code{if} compatibility change. Minor documentation fixes. +;;; +;;; @item Version 0.5 --- 2005-12-09 +;;; Changed a non-R5RS use of @code{letrec} to @code{let*}, caught by Guile and +;;; David Pirotte. +;;; +;;; @item Version 0.4 --- 2005-06-07 +;;; Converted to Testeez. Minor documentation changes. +;;; +;;; @item Version 0.3 --- 2004-07-21 +;;; Minor documentation changes. Test suite now disabled by default. +;;; +;;; @item Version 0.2 --- 2004-06-01 +;;; Work-around for @code{case}-related bug observed in Gauche 0.8 and 0.7.4.2 +;;; that was tickled by @code{csv-internal:make-portreader/positional}. Thanks +;;; to Grzegorz Chrupa@l{}a for reporting. +;;; +;;; @item Version 0.1 --- 2004-05-31 +;;; First release, for testing with real-world input. +;;; +;;; @end table + +#;(provide + csv->list + csv->sxml + csv-for-each + csv-map + make-csv-reader + make-csv-reader-maker) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -55,29 +55,29 @@ (iup:show (iup:dialog (iup:vbox (iup:label msg #:margin "40x40"))))) -(define (dtests:get-pre-command #!key (default-override #f)) - (let* ((orig-pre-command "export CMD='") - (viewscreen-pre-command "viewscreen ") - (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) - (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command)) - (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) - (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \"")) - - -(define (dtests:get-post-command #!key (default-override #f)) - (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" - "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) - (viewscreen-post-command "") - (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) - (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) - (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) - (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) - - +;; (define (dtests:get-pre-command #!key (default-override #f)) +;; (let* ((orig-pre-command "export CMD='") +;; (viewscreen-pre-command "viewscreen ") +;; (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) +;; (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command)) +;; (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) +;; (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \"")) +;; +;; +;; (define (dtests:get-post-command #!key (default-override #f)) +;; (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" +;; "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) +;; (viewscreen-post-command "") +;; (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) +;; (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) +;; (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) +;; (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) +;; +;; (define (test-info-panel testdat store-label widgets) (iup:frame #:title "Test Info" ; #:expand "YES" (iup:hbox ; #:expand "YES" (apply iup:vbox ; #:expand "YES" Index: datashare.scm ================================================================== --- datashare.scm +++ datashare.scm @@ -253,11 +253,11 @@ (print "ERROR: invalid path for storing database: " path)))) (define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn - (let ((sleep-time (random 30)) + (let ((sleep-time (pseudo-random-integer 30)) (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) (case err-status ((busy) (thread-sleep! sleep-time)) (else Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -16,96 +16,10 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;;====================================================================== -;;====================================================================== -;; Database access -;;====================================================================== - -;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc - -(use (srfi 18) extras tcp stack) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable) -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) - -(declare (unit db)) -(declare (uses common)) -(declare (uses keys)) -(declare (uses ods)) -(declare (uses client)) -(declare (uses mt)) - -(include "common_records.scm") -(include "db_records.scm") -(include "key_records.scm") -(include "run_records.scm") - -(define *number-of-writes* 0) -(define *number-non-write-queries* 0) - -;;====================================================================== -;; R E C O R D S -;;====================================================================== - -;; each db entry is a pair ( db . dbfilepath ) -;; I propose this record evolves into the area record -;; -(defstruct dbr:dbstruct - (tmpdb #f) - (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack - (mtdb #f) - (refndb #f) - (homehost #f) ;; not used yet - (on-homehost #f) ;; not used yet - (read-only #f) - (stmt-cache (make-hash-table)) - ) ;; goal is to converge on one struct for an area but for now it is too confusing - - -;; record for keeping state,status and count for doing roll-ups in -;; iterated tests -;; -(defstruct dbr:counts - (state #f) - (status #f) - (count 0)) - -;;====================================================================== -;; alist-of-alists -;;====================================================================== -;; -;; (define (db:aa-set! dat key1 key2 val) -;; (let loop (( - -;;====================================================================== -;; hash of hashs -;;====================================================================== - - -(define (db:hoh-set! dat key1 key2 val) - (let* ((subhash (hash-table-ref/default dat key1 #f))) - (if subhash - (hash-table-set! subhash key2 val) - (begin - (hash-table-set! dat key1 (make-hash-table)) - (db:hoh-set! dat key1 key2 val))))) - -(define (db:hoh-get dat key1 key2) - (let* ((subhash (hash-table-ref/default dat key1 #f))) - (and subhash - (hash-table-ref/default subhash key2 #f)))) - -(define (db:get-cache-stmth dbstruct db stmt) - (let* ((stmt-cache (dbr:dbstruct-stmt-cache dbstruct)) - (stmth (db:hoh-get stmt-cache db stmt))) - (or stmth - (let* ((newstmth (sqlite3:prepare db stmt))) - (db:hoh-set! stmt-cache db stmt newstmth) - newstmth)))) - ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== (define (db:general-sqlite-error-dump exn stmt . params) @@ -246,14 +160,14 @@ ;; (define *db-open-mutex* (make-mutex)) (define (db:lock-create-open fname initproc) (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local (raw-fname (pathname-file fname)) - (dir-writable (file-write-access? parent-dir)) + (dir-writable (file-writable? parent-dir)) (file-exists (common:file-exists? fname)) (file-write (if file-exists - (file-write-access? fname) + (file-writable? fname) dir-writable ))) ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped. (if file-write ;; dir-writable (condition-case (let* ((lockfname (conc fname ".lock")) @@ -332,11 +246,11 @@ (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) (mtdb (db:open-megatest-db)) (mtdbpath (db:dbdat-get-path mtdb)) (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) - (write-access (file-write-access? mtdbpath)) + (write-access (file-writable? mtdbpath)) ;(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) ; moving this before db:open-megatest-db is called. if wal mode is on -WAL and -shm file get created with causing the tmpdbmodtime timestamp always greater than mtdbmodtime ;(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) ;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced ;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f)) ;(fmt (file-modification-time tmpdbfname)) @@ -424,11 +338,11 @@ (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) ;;(db:initialize-run-id-db db) ))) - (write-access (file-write-access? dbpath))) + (write-access (file-writable? dbpath))) (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (cons db dbpath))) @@ -627,11 +541,11 @@ (let* ((dbpath (db:dbdat-get-path dbdat)) (dbdir (pathname-directory dbpath)) (fname (pathname-strip-directory dbpath))) (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.") (cond - ((not (file-write-access? dbdir)) + ((not (file-writable? dbdir)) (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname) #f) ;; handle special cases, megatest.db and monitor.db ;; @@ -715,17 +629,17 @@ -3) ((not (sqlite3:database? (db:dbdat-get-db todb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb) -4) - ((not (file-write-access? (db:dbdat-get-path todb))) + ((not (file-writable? (db:dbdat-get-path todb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb) -5) ((not (null? (let ((readonly-slave-dbs (filter (lambda (dbdat) - (not (file-write-access? (db:dbdat-get-path todb)))) + (not (file-writable? (db:dbdat-get-path todb)))) slave-dbs))) (for-each (lambda (bad-dbdat) (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat)) @@ -1039,11 +953,11 @@ ;; (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db") ;; (exit 1)) ;; (let* ((th1 (make-thread ;; (lambda () ;; (if (and (common:file-exists? megatest-db) -;; (file-write-access? megatest-db)) +;; (file-writable? megatest-db)) ;; (begin ;; (db:sync-to-megatest.db dbstruct 'timestamps) ;; internally mutexes on *db-local-sync* ;; (debug:print-info 2 *default-log-port* "Done syncing to megatest.db")))) ;; "call-with-cached-db sync-to-megatest.db")) ;; (cache-db (db:cache-for-read-only @@ -1099,11 +1013,11 @@ ;; clear out junk records ;; ((dejunk) ;; (db:delay-if-busy mtdb) ;; ok to delay on mtdb - (when (file-write-access? (db:dbdat-get-path mtdb)) (db:clean-up mtdb)) + (when (file-writable? (db:dbdat-get-path mtdb)) (db:clean-up mtdb)) (db:clean-up tmpdb) (db:clean-up refndb)) ;; sync runs, test_meta etc. ;; @@ -1201,11 +1115,11 @@ #f)) #;(define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn - (let ((sleep-time (random 30)) + (let ((sleep-time (pseudo-random-integer 30)) (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) (case err-status ((busy) (thread-sleep! sleep-time)) (else @@ -1772,11 +1686,11 @@ #t))))) (define (db:get-status-from-final-status-file run-dir) (let ((infile (conc run-dir "/.final-status"))) ;; first verify we are able to write the output file - (if (not (file-read-access? infile)) + (if (not (file-readable? infile)) (begin (debug:print 0 *default-log-port* "ERROR: cannot read " infile) (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir) #f ) @@ -4884,11 +4798,11 @@ (numkeys (length keypatt-alist)) (test-ids '()) (dbdat (db:get-db dbstruct)) (db (db:dbdat-get-db dbdat)) (windows (and pathmod (substring-index "\\" pathmod))) - (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id))) + (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (pseudo-random-integer 10000) "_" (current-process-id))) (runsheader (append (list "Run Id" "Runname") ; 0 1 (map car keypatt-alist) ; + N = length keypatt-alist (list "Testname" ; 2 "Item Path" ; 3 "Description" ; 4 ADDED dbi.scm Index: dbi.scm ================================================================== --- /dev/null +++ dbi.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 dbi)) + +(include "dbi/dbi.scm") ADDED dbi/dbi.egg Index: dbi/dbi.egg ================================================================== --- /dev/null +++ dbi/dbi.egg @@ -0,0 +1,5 @@ +((license "BSD") + (category db) + (dependencies autoload sql-null) + (test-dependencies test) + (components (extension dbi))) ADDED dbi/dbi.meta Index: dbi/dbi.meta ================================================================== --- /dev/null +++ dbi/dbi.meta @@ -0,0 +1,21 @@ +;; -*- scheme -*- +( +; Your egg's license: +(license "BSD") + +; Pick one from the list of categories (see below) for your egg and enter it +; here. +(category db) + +; A list of eggs dbi depends on. If none, you can omit this declaration +; altogether. If you are making an egg for chicken 3 and you need to use +; procedures from the `files' unit, be sure to include the `files' egg in the +; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit). +; `depends' is an alias to `needs'. +(needs (autoload "3.0") sql-null) + +; A list of eggs required for TESTING ONLY. See the `Tests' section. +(test-depends test) + +(author "Matt Welland") +(synopsis "An abstract database interface.")) ADDED dbi/dbi.release-info Index: dbi/dbi.release-info ================================================================== --- /dev/null +++ dbi/dbi.release-info @@ -0,0 +1,7 @@ +(repo fossil "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}") +(uri zip "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}/zip/{egg-name}.zip?uuid={egg-release}") +(release "0.5") +(release "0.4") +(release "0.3") +(release "0.2") +(release "0.1") ADDED dbi/dbi.scm Index: dbi/dbi.scm ================================================================== --- /dev/null +++ dbi/dbi.scm @@ -0,0 +1,483 @@ +;;; dbi: Minimal gasket to postgresql, sqlite3 and mysql +;;; +;; Copyright (C) 2007-2018 Matt Welland +;; Copyright (C) 2016 Peter Bex +;; Redistribution and use in source and binary forms, with or without +;; modification, is permitted. +;; +;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;; DAMAGE. + +;; ONLY A LOWEST COMMON DEMOMINATOR IS SUPPORTED! + +;; d = db handle +;; t = statement handle +;; s = statement +;; l = proc +;; p = params +;; +;; sqlite3 postgres dbi +;; prepare: (prepare d s) n/a prepare (sqlite3, pg) +;; for-each (for-each-row l d s . p) (query-for-each l s d) for-each-row +;; for-each (for-each-row l t . p) n/a NOT YET +;; exec (exec d s . p) (query-tuples s d) +;; exec (exec t . p) n/a + +;; set to 'pg or 'sqlite3 +;; (define dbi:type 'sqlite3) ;; or 'pg +;; (dbi:open 'sqlite3 (list (cons 'dbname fullname))) + +;;====================================================================== +;; D B I +;;====================================================================== +(module dbi + (open db-dbtype db-conn for-each-row get-one get-one-row get-rows + exec close escape-string mk-db now database? with-transaction fold-row + prepare map-row convert prepare-exec get-res + + ;; TODO: These don't really belong here. Also, the naming is not + ;; consistent with the usual Scheme conventions. + pgdatetime-get-year pgdatetime-get-month pgdatetime-get-day + pgdatetime-get-hour pgdatetime-get-minute pgdatetime-get-second + pgdatetime-get-microsecond + pgdatetime-set-year! pgdatetime-set-month! pgdatetime-set-day! + pgdatetime-set-hour! pgdatetime-set-minute! pgdatetime-set-second! + pgdatetime-set-microsecond! + + lazy-bool) + +(import (chicken base) (chicken process) (chicken file) (chicken time) (chicken string) (chicken format) (chicken time posix) scheme srfi-1 srfi-13) +(import (chicken condition) autoload sql-null) + +(define-record-type db + (make-db dbtype dbconn) + db? + (dbtype db-dbtype db-dbtype-set!) + (dbconn db-conn db-conn-set!)) + +(define (missing-egg type eggname) + (lambda _ + (error (printf + "Cannot access ~A databases. Please install the ~S egg and try again." type eggname)))) + +;; (define (sqlite3:statement? h) #f) ;; dummy - hope it gets clobbered if sqlite3 gets loaded + +;; TODO: Make a convenience macro for this? +(define sqlite3-missing (missing-egg 'sqlite3 "sqlite3")) +(autoload sqlite3 + (open-database sqlite3:open-database sqlite3-missing) + (for-each-row sqlite3:for-each-row sqlite3-missing) + (execute sqlite3:execute sqlite3-missing) + (with-transaction sqlite3:with-transaction sqlite3-missing) + (finalize! sqlite3:finalize! sqlite3-missing) + (make-busy-timeout sqlite3:make-busy-timeout sqlite3-missing) + (set-busy-handler! sqlite3:set-busy-handler! sqlite3-missing) + (database? sqlite3:database? sqlite3-missing) + (prepare sqlite3:prepare sqlite3-missing) + (fold-row sqlite3:fold-row sqlite3-missing) + (map-row sqlite3:map-row sqlite3-missing) + (statement? sqlite3:statement? sqlite3-missing)) + +(define sql-de-lite-missing (missing-egg 'sql-de-lite "sql-de-lite")) +(autoload sql-de-lite + (open-database sql:open-database sql-de-lite-missing) + (close-database sql:close-database sql-de-lite-missing) + (for-each-row sql:for-each-row sql-de-lite-missing) + (fold-rows sql:fold-rows sql-de-lite-missing) + (exec sql:exec sql-de-lite-missing) + (fetch-value sql:fetch-value sql-de-lite-missing) + (with-transaction sql:with-transaction sql-de-lite-missing) + (finalize! sql:finalize! sql-de-lite-missing) + (make-busy-timeout sql:make-busy-timeout sql-de-lite-missing) + (set-busy-handler! sql:set-busy-handler! sql-de-lite-missing) + (query sql:query sql-de-lite-missing) + (sql sql:sql sql-de-lite-missing)) + +(define pg-missing (missing-egg 'pg "postgresql")) +(autoload postgresql + (connect pg:connect pg-missing) + (row-for-each pg:row-for-each pg-missing) + (with-transaction pg:with-transaction pg-missing) + (query pg:query pg-missing) + ;;(escape-string pg:escape-string pg-missing) + (disconnect pg:disconnect pg-missing) + (connection? pg:connection? pg-missing) + (row-fold pg:row-fold pg-missing) + (row-map pg:row-map pg-missing) + (affected-rows pg:affected-rows pg-missing) + (result? pg:result? pg-missing)) + +(define mysql-missing (missing-egg 'mysql "mysql-client")) +(autoload mysql-client + (make-mysql-connection mysql:make-connection mysql-missing) + (mysql-null? mysql:mysql-null? mysql-missing)) + +(define (open dbtype dbinit) + (make-db + dbtype + (case dbtype + ((sqlite3) (sqlite3:open-database (alist-ref 'dbname dbinit))) + ((sql-de-lite) (sql:open-database (alist-ref 'dbname dbinit))) + ((pg) (pg:connect dbinit)) + ((mysql) (mysql:make-connection (alist-ref 'host dbinit) + (alist-ref 'user dbinit) + (alist-ref 'password dbinit) + (alist-ref 'dbname dbinit) + port: (alist-ref 'port dbinit))) + (else (error "Unsupported dbtype " dbtype))))) + +(define (convert dbh) + (cond + ((database? dbh) dbh) + ((sqlite3:database? dbh) (make-db 'sqlite3 dbh)) + ((pg:connection? dbh) (make-db 'pg dbh)) + ((not mysql:mysql-null?) (make-db 'mysql dbh)) + (else (error "Unsupported database handle " dbh)))) + +(define (for-each-row proc dbh stmt . params) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sqlite3) (sqlite3:for-each-row + (lambda (first . remaining) + (let ((tuple (list->vector (cons first remaining)))) + (proc tuple))) + conn + (apply sqlparam stmt params))) + ((sql-de-lite)(apply sql:query (sql:for-each-row + (lambda (row) + (proc (list->vector row)))) + (sql:sql conn stmt) + params)) + ((pg) (pg:row-for-each + (lambda (tuple) + (proc (list->vector tuple))) + (pg:query conn (apply sqlparam stmt params)))) + ((mysql) (let* ((replaced-sql (apply sqlparam stmt params)) + (fetcher (conn replaced-sql))) + (fetcher (lambda (tuple) + (proc (list->vector tuple)))))) + (else (error "Unsupported dbtype " dbtype))))) + +;; common idiom is to seek a single value, #f if no match +;; NOTE: wish to return first found. Do the set only if not set +(define (get-one dbh stmt . params) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sql-de-lite) + (apply sql:query sql:fetch-value (sql:sql conn stmt) params)) + (else + (let ((res #f)) + (apply for-each-row + (lambda (row) + (if (not res) + (set! res (vector-ref row 0)))) + dbh + stmt + params) + res))))) + +;; common idiom is to seek a single value, #f if no match +;; NOTE: wish to return first found. Do the set only if not set +(define (get-one-row dbh stmt . params) + (let ((res #f)) + (apply for-each-row + (lambda (row) + (if (not res) + (set! res row))) + dbh + stmt + params) + res)) + +;; common idiom is to seek a list of rows, '() if no match +(define (get-rows dbh stmt . params) + (let ((res '())) + (apply for-each-row + (lambda (row) + (set! res (cons row res))) + dbh + stmt + params) + (reverse res))) + +(define (exec dbh stmt . params) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh)) + (junk #f)) + (case dbtype + ((sqlite3) (apply sqlite3:execute conn stmt params)) + ((sql-de-lite)(apply sql:exec (sql:sql conn stmt) params)) + ((pg) (pg:query conn (apply sqlparam stmt params))) + ((mysql) (conn (apply sqlparam stmt params))) + (else (error "Unsupported dbtype " dbtype))))) + +(define (with-transaction dbh proc) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sql-de-lite)(sql:with-transaction conn proc)) + ((sqlite3) (sqlite3:with-transaction + conn + (lambda () (proc)))) + ((pg) (pg:with-transaction + conn (lambda () (proc)))) + ((mysql) + (conn "START TRANSACTION") + (conn proc) + (conn "COMMIT")) + (else (error "Unsupported dbtype " dbtype))))) + +(define (prepare dbh stmt) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sql-de-lite) dbh) ;; nop? + ((sqlite3) (sqlite3:prepare conn stmt)) + ((pg) (exec dbh stmt) (cons (cons dbh (cadr (string-split stmt))) '())) + ((mysql) (print "WIP")) + (else (error "Unsupported dbtype" dbtype))))) + +(define (fold-row proc init dbh stmt . params) ;; expecting (proc init/prev res) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sql-de-lite) (apply sql:query (sql:fold-rows proc init) + (sql:sql conn stmt) params)) + ((sqlite3) (let ((newproc (lambda (prev . rem) + (proc rem prev)))) + (apply sqlite3:fold-row newproc init conn stmt params))) ;; (fold-row PROC INIT DATABASE SQL . PARAMETERS) + ((pg) (pg:row-fold proc init (exec dbh stmt params))) + ((mysql) (fold proc '() (get-rows dbh stmt))) + (else (error "Unsupported dbtype" dbtype))))) + +(define (map-row proc init dbh stmt . params) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sqlite3) (apply sqlite3:map-row proc conn stmt params)) + ((pg) (pg:row-map proc (exec dbh stmt params))) + ((mysql) (map proc (get-rows dbh stmt))) + (else (error "Unsupported dbtype" dbtype))))) + +(define (prepare-exec stmth . params) + (if (sqlite3:statement? stmth) + (apply sqlite3:execute stmth params)) + (if (pair? stmth) + (let* ((dbh (car (car stmth))) + (dbtype (db-dbtype dbh)) + (conn (db-conn dbh)) + (stmth-name (string->symbol (cdr (car stmth))))) + (apply pg:query conn stmth-name params)))) + +(define (get-res handle option) + (if (pg:result? handle) + (case option + ((affected-rows) (pg:affected-rows handle))))) + +(define (close dbh) + (cond + ((database? dbh) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sql-de-lite) (sql:close-database conn)) + ((sqlite3) (sqlite3:finalize! conn)) + ((pg) (pg:disconnect conn)) + ((mysql) (void)) ; The mysql-client egg doesn't support closing... + (else (error "Unsupported dbtype " dbtype))))) + ((pair? dbh) + (let ((stmt (conc "DEALLOCATE " (cdr (car dbh)) ";"))) + (exec (car (car dbh)) stmt))) + ((sqlite3:statement? dbh) ;; do this last so that *IF* it is a proper dbh it will be closed above and the sqlite3:statement? will not be called + (sqlite3:finalize! dbh)) + + )) + +;;====================================================================== +;; D B M I S C +;;====================================================================== + +(define (escape-string str) + (let ((parts (split-string str "'"))) + (string-intersperse parts "''"))) +;; (pg:escape-string val))) + +;; convert values to appropriate strings +;; +(define (sqlparam-val->string val) + (cond + ((list? val)(string-intersperse (map conc val) ",")) ;; (a b c) => a,b,c + ((string? val)(string-append "'" (escape-string val) "'")) + ((sql-null? val) "NULL") + ((number? val)(number->string val)) + ((symbol? val)(sqlparam-val->string (symbol->string val))) + ((boolean? val) + (if val "TRUE" "FALSE")) ;; should this be "TRUE" or 1? + ;; should this be "FALSE" or 0 or NULL? + ((vector? val) ;; 'tis a date NB// 5/29/2011 - this is badly borked BUGGY! + (sqlparam-val->string (time->string (seconds->local-time (current-seconds))))) + (else + (error "sqlparam: unknown type for value: " val) + ""))) + +;; (sqlparam "INSERT INTO foo(name,age) VALUES(?,?);" "bob" 20) +;; NB// 1. values only!! +;; 2. terminating semicolon required (used as part of logic) +;; +;; a=? 1 (number) => a=1 +;; a=? 1 (string) => a='1' +;; a=? #f => a=FALSE +;; a=? a (symbol) => a=a +;; +(define (sqlparam query . args) + (let* ((query-parts (string-split query "?")) + (num-parts (length query-parts)) + (num-args (length args))) + (if (not (= (+ num-args 1) num-parts)) + (error "ERROR, sqlparam: wrong number of arguments or missing semicolon, " num-args " for query " query) + (if (= num-args 0) query + (let loop ((section (car query-parts)) + (tail (cdr query-parts)) + (result "") + (arg (car args)) + (argtail (cdr args))) + (let* ((valstr (sqlparam-val->string arg)) + (newresult (string-append result section valstr))) + (if (null? argtail) ;; we are done + (string-append newresult (car tail)) + (loop + (car tail) + (cdr tail) + newresult + (car argtail) + (cdr argtail))))))))) + +;; a poorly written but non-broken split-string +;; +(define (split-string strng delim) + (if (eq? (string-length strng) 0) (list strng) + (let loop ((head (make-string 1 (car (string->list strng)))) + (tail (cdr (string->list strng))) + (dest '()) + (temp "")) + (cond ((equal? head delim) + (set! dest (append dest (list temp))) + (set! temp "")) + ((null? head) + (set! dest (append dest (list temp)))) + (else (set! temp (string-append temp head)))) ;; end if + (cond ((null? tail) + (set! dest (append dest (list temp))) dest) + (else (loop (make-string 1 (car tail)) (cdr tail) dest temp)))))) + +(define (database? dbh) + (if (db? dbh) + (let ((dbtype (db-dbtype dbh)) + (conn (db-conn dbh))) + (case dbtype + ((sqlite3) (if (sqlite3:database? conn) #t #f)) + ((sql-de-lite) #t) ;; don't know how to test for database + ((pg) (if (pg:connection? conn) #t #f)) + ((mysql) #t) + (else (error "Unsupported dbtype " dbtype)))) #f)) + +;;====================================================================== +;; Convienence routines +;;====================================================================== + +;; make a db from a list of statements or open it if it already exists +(define (mk-db path file stmts) + (let* ((fname (conc path "/" file)) + (dbexists (file-exists? fname)) + (dbh (if dbexists (open 'sqlite3 (list (cons 'dbname fname))) #f))) + (if (not dbexists) + (begin + (system (conc "mkdir -p " path)) ;; create the path + (set! dbh (open 'sqlite3 (list (cons 'dbname fname)))) + (for-each + (lambda (sqry) + (exec dbh sqry)) + stmts))) + (sqlite3:set-busy-handler! + (db-conn dbh) (sqlite3:make-busy-timeout 1000000)) + dbh)) + +(define (now dbh) + (let ((dbtype (db-dbtype dbh))) + (case dbtype + ((sqlite3) "datetime('now')") + ;; Standard SQL + (else "now()")))) + +(define (make-pgdatetime)(make-vector 7)) +(define (pgdatetime-get-year vec) (vector-ref vec 0)) +(define (pgdatetime-get-month vec) (vector-ref vec 1)) +(define (pgdatetime-get-day vec) (vector-ref vec 2)) +(define (pgdatetime-get-hour vec) (vector-ref vec 3)) +(define (pgdatetime-get-minute vec) (vector-ref vec 4)) +(define (pgdatetime-get-second vec) (vector-ref vec 5)) +(define (pgdatetime-get-microsecond vec) (vector-ref vec 6)) +(define (pgdatetime-set-year! vec val)(vector-set! vec 0 val)) +(define (pgdatetime-set-month! vec val)(vector-set! vec 1 val)) +(define (pgdatetime-set-day! vec val)(vector-set! vec 2 val)) +(define (pgdatetime-set-hour! vec val)(vector-set! vec 3 val)) +(define (pgdatetime-set-minute! vec val)(vector-set! vec 4 val)) +(define (pgdatetime-set-second! vec val)(vector-set! vec 5 val)) +(define (pgdatetime-set-microsecond! vec val)(vector-set! vec 6 val)) + +;; takes postgres date or timestamp +(define (pg-date->string pgdate) + (conc (pgdatetime-get-month pgdate) "/" + (pgdatetime-get-day pgdate) "/" + (pgdatetime-get-year pgdate))) + +;; takes postgres date or timestamp +(define (pg-datetime->string pgdate) + (conc (pgdatetime-get-month pgdate) "/" + (pgdatetime-get-day pgdate) "/" + (pgdatetime-get-year pgdate) " " + (pgdatetime-get-hour pgdate) ":" + (pgdatetime-get-minute pgdate)`)) + + + +;; map to 0 or 1 from a range of values +;; #f => 0 +;; #t => 1 +;; "0" => 0 +;; "1" => 1 +;; FALSE => 0 +;; TRUE => 1 +;; anything else => 1 +(define (lazy-bool val) + (case val + ((#f) 0) + ((#t) 1) + ((0) 0) + ((1) 1) + (else + (cond + ((string? val) + (let ((nval (string->number val))) + (if nval + (lazy-bool nval) + (cond + ((string=? val "FALSE") 0) + ((string=? val "TRUE") 1) + (else 1))))) + ((symbol? val) + (lazy-bool (symbol->string val))) + (else 1))))) +) ADDED dbi/dbi.setup Index: dbi/dbi.setup ================================================================== --- /dev/null +++ dbi/dbi.setup @@ -0,0 +1,11 @@ +;; Copyright 2007-2018, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +;;;; dbi.setup +(standard-extension 'dbi "0.5") ADDED dbi/example.scm Index: dbi/example.scm ================================================================== --- /dev/null +++ dbi/example.scm @@ -0,0 +1,69 @@ +;;; dbi: Minimal gasket to postgresql, sqlite3 and mysql +;;; +;; Copyright (C) 2007-2016 Matt Welland +;; Redistribution and use in source and binary forms, with or without +;; modification, is permitted. +;; +;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS +;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +;; DAMAGE. + +;; WARNING: This example is basically useless, I'll rewrite it one of these days .... + +(require-library margs dbi) + +(define help "help me") + +(define remargs (args:get-args + (argv) + (list "-inf") + (list "-h") + args:arg-hash + 0)) + +;; define DBPATH in setup.scm +(include "setup.scm") + +(define (ftf:mk-db) + (let* ((fname (conc DBPATH "/ftfplan.db")) + (dbexists (file-exists? fname)) + (dbh (if dbexists (dbi:open 'sqlite3 (list (cons 'dbname fname))) #f))) + (if (not dbexists) + (begin + ;; (print "fullname: " fullname) + (system (conc "mkdir -p " DBPATH)) ;; create the path + (set! dbh (dbi:open 'sqlite3 (list (cons 'dbname fname)))) + (for-each + (lambda (sqry) + ;; (print sqry) + (dbi:exec dbh sqry)) + ;; types: 0 text, 1 jpg, 2 png, 3 svg, 4 spreadsheet, 5 audio, 6 video :: better specs to come... + (list + "CREATE TABLE pics (id INTEGER PRIMARY KEY,name TEXT,dat_id INTEGER,thumb_dat_id INTEGER,created_on INTEGER,owner_id INTEGER);" + "CREATE TABLE dats (id INTEGER PRIMARY KEY,md5sum TEXT,dat BLOB,type INTEGER);" + ;; on every modification a new tiddlers entry is created. When displaying the tiddlers do: + ;; select where created_on < somedate order by created_on desc limit 1 + "CREATE TABLE tiddlers (id INTEGER PRIMARY KEY,wiki_id INTEGER,name TEXT,rev INTEGER,dat_id INTEGER,created_on INTEGER,owner_id INTEGER);" + ;; rev and tag only utilized when user sets a tag. All results from a select as above for tiddlers are set to the tag + "CREATE TABLE revs (id INTEGER PRIMARY KEY,tag TEXT);" + ;; wikis is here for when postgresql support is added or if a sub wiki is created. + "CREATE TABLE wikis (id INTEGER PRIMARY KEY,key_name TEXT,title TEXT,created_on INTEGER);")) + )) + dbh)) + +(define db (ftf:mk-db)) + +(dbi:exec db "INSERT INTO pics (name,owner_id) VALUES ('bob',1);") +(dbi:for-each-row (lambda (row)(print "Name: " (vector-ref row 0) ", owner_id: " (vector-ref row 1))) + db + "SELECT name,owner_id FROM pics;") + Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -21,19 +21,104 @@ (declare (unit dbmod)) (module dbmod * -(import scheme chicken data-structures extras) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18) - -(define (just-testing) - (print "JUST TESTING")) - -;; (define (debug:print . params) #f) -;; (define (debug:print-info . params) #f) +(import scheme + chicken.base + (prefix sqlite3 sqlite3:) + + typed-records + srfi-18 + srfi-69 + + ) + +;;====================================================================== +;; Database access +;;====================================================================== + +;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc + +;; (use (srfi 18) extras tcp stack) +;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable) +;; (import (prefix sqlite3 sqlite3:)) +;; (import (prefix base64 base64:)) +;; +;; (declare (unit db)) +;; (declare (uses common)) +;; (declare (uses keys)) +;; (declare (uses ods)) +;; (declare (uses client)) +;; (declare (uses mt)) +;; +;; (include "common_records.scm") +;; (include "db_records.scm") +;; (include "key_records.scm") +;; (include "run_records.scm") + +(define *number-of-writes* 0) +(define *number-non-write-queries* 0) + +;;====================================================================== +;; R E C O R D S +;;====================================================================== + +;; each db entry is a pair ( db . dbfilepath ) +;; I propose this record evolves into the area record +;; +(defstruct dbr:dbstruct + (tmpdb #f) + (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack + (mtdb #f) + (refndb #f) + (homehost #f) ;; not used yet + (on-homehost #f) ;; not used yet + (read-only #f) + (stmt-cache (make-hash-table)) + (locdbs (make-hash-table)) ;; legacy junk in db_records + ) ;; goal is to converge on one struct for an area but for now it is too confusing + + +;; record for keeping state,status and count for doing roll-ups in +;; iterated tests +;; +(defstruct dbr:counts + (state #f) + (status #f) + (count 0)) + +;;====================================================================== +;; alist-of-alists +;;====================================================================== ;; -;; (define (set-functions dbgp dbgpinfo) -;; (set! debug:print dbgp) -;; (set! debug:print-info dbgpinfo)) +;; (define (db:aa-set! dat key1 key2 val) +;; (let loop (( + +;;====================================================================== +;; hash of hashs +;;====================================================================== + + +(define (db:hoh-set! dat key1 key2 val) + (let* ((subhash (hash-table-ref/default dat key1 #f))) + (if subhash + (hash-table-set! subhash key2 val) + (begin + (hash-table-set! dat key1 (make-hash-table)) + (db:hoh-set! dat key1 key2 val))))) + +(define (db:hoh-get dat key1 key2) + (let* ((subhash (hash-table-ref/default dat key1 #f))) + (and subhash + (hash-table-ref/default subhash key2 #f)))) + +(define (db:get-cache-stmth dbstruct db stmt) + (let* ((stmt-cache (dbr:dbstruct-stmt-cache dbstruct)) + (stmth (db:hoh-get stmt-cache db stmt))) + (or stmth + (let* ((newstmth (sqlite3:prepare db stmt))) + (db:hoh-set! stmt-cache db stmt newstmth) + newstmth)))) + ) ADDED debugprint.scm Index: debugprint.scm ================================================================== --- /dev/null +++ debugprint.scm @@ -0,0 +1,108 @@ +(declare (unit debugprint)) +(declare (uses mtargs)) + +(module debugprint + * + +;;(import scheme chicken data-structures extras files ports) +(import scheme + chicken.base + chicken.string + chicken.port + mtargs + srfi-1 + ) + +;;====================================================================== +;; debug stuff +;;====================================================================== + +(define verbosity (make-parameter '())) +(define *default-log-port* (current-error-port)) + +;;====================================================================== +;; (define (debug:print . params) #f) +;; (define (debug:print-info . params) #f) +;; +;; (define (set-functions dbgp dbgpinfo) +;; (set! debug:print dbgp) +;; (set! debug:print-info dbgpinfo)) + +;;====================================================================== +;; this was cached based on results from profiling but it turned out the profiling +;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching +;; in for now but can probably take it out later. +;; +(define (debug:calc-verbosity vstr arg) ;; arg is 'v (verbose) or 'q (quiet) + (let* ((res (cond + ((number? vstr) vstr) + ((not (string? vstr)) 1) + ;; ((string-match "^\\s*$" vstr) 1) + (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) + (cond + ((> (length debugvals) 1) debugvals) + ((> (length debugvals) 0)(car debugvals)) + (else 1)))) + ((eq? arg 'v) 2) ;; verbose + ((eq? arg 'q) 0) ;; quiet + (else 1)))) + (verbosity res) + res)) + +;;====================================================================== +;; check verbosity, #t is ok +#;(define (debug-check-verbosity verbosity vstr) + (if (not (or (number? verbosity) + (list? verbosity))) + (begin + (print "ERROR: Invalid debug value \"" vstr "\"") + #f) + #t)) + +(define (debug:debug-mode n) + (let* ((vb (verbosity))) + (cond + ((and (number? vb) ;; number number + (number? n)) + (<= n vb)) + ((and (list? vb) ;; list number + (number? n)) + (member n vb)) + ((and (list? vb) ;; list list + (list? n)) + (not (null? (lset-intersection! eq? vb n)))) + ((and (number? vb) + (list? n)) + (member vb n))))) + +(define (debug:print n e . params) + (if (debug:debug-mode n) + (with-output-to-port (or e (current-error-port)) + (lambda () + ;; (if *logging* + ;; (db:log-event (apply conc params)) + (apply print params) + )))) ;; ) + +(define (debug:print-error n e . params) + ;; normal print + (if (debug:debug-mode n) + (with-output-to-port (if (port? e) e (current-error-port)) + (lambda () + (apply print "ERROR: " params) + ))) + ;; pass important messages to stderr + (if (and (eq? n 0)(not (eq? e (current-error-port)))) + (with-output-to-port (current-error-port) + (lambda () + (apply print "ERROR: " params) + )))) + +(define (debug:print-info n e . params) + (if (debug:debug-mode n) + (with-output-to-port (if (port? e) e (current-error-port)) + (lambda () + (apply print "INFO: (" n ") " params) ;; res) + )))) + +) Index: diff-report.scm ================================================================== --- diff-report.scm +++ diff-report.scm @@ -14,18 +14,19 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; -(declare (unit diff-report)) -(declare (uses common)) -(declare (uses rmt)) - -(include "common_records.scm") -(use matchable) -(use fmt) -(use ducttape-lib) +;; (declare (unit diff-report)) +;; (declare (uses common)) +;; (declare (uses rmt)) +;; +;; (include "common_records.scm") +;; (use matchable) +;; (use fmt) +;; (use ducttape-lib) + (define css "") (define (diff:tests-mindat->hash tests-mindat) (let* ((res (make-hash-table))) (for-each Index: ducttape/ducttape-lib.scm ================================================================== --- ducttape/ducttape-lib.scm +++ ducttape/ducttape-lib.scm @@ -49,19 +49,41 @@ *this-exe-dir* *this-exe-name* *this-exe-fullpath* ) - (import scheme chicken extras ports data-structures ) - (use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339) + (import scheme + chicken.base + chicken.condition + chicken.file + chicken.file.posix + chicken.format + chicken.io + chicken.pathname + chicken.port + chicken.process + chicken.process + chicken.process-context + chicken.process-context.posix + chicken.irregex + chicken.string + chicken.time + chicken.time.posix + ) + + (import regex ansi-escape-sequences test srfi-1 slice srfi-13 rfc3339) ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process* - (use directory-utils uuid-lib filepath srfi-19 ) ; linenoise + ;;(import directory-utils uuid-lib filepath srfi-19 ) ; linenoise + (import directory-utils filepath srfi-19 ) ; linenoise ;; plugs a hole in posix-extras in latter chicken versions - (use posix-extras pathname-expand files) - (define ##sys#expand-home-path pathname-expand) - (define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) )) + ;; (import pathname-expand chicken.file chicken.string) + ;; (define ##sys#expand-home-path pathname-expand) + ;; (define (realpath x) (print "Path: " x) (normalize-pathname (pathname-expand (or x "/dev/null")) )) + ;;(define (realpath x) (pathname-expand (or x "/dev/null"))) + (define (realpath x) + (with-input-from-pipe (conc "readlink -f " x) read-line)) ;; (include "mimetypes.scm") ; provides ext->mimetype ;; (include "workweekdate.scm") ;; gathered from macosx: @@ -841,14 +863,14 @@ ("avi" . "video/x-msvideo") ("movie" . "video/x-sgi-movie") ("smv" . "video/x-smv") ("ice" . "x-conference/x-cooltalk"))) -(use srfi-19) -(use test) +(import srfi-19) +(import test) ;;(use format) -(use regex) +(import regex) ;(declare (unit wwdate)) ;; utility procedures to convert among ;; different ways to express date (wwdate, seconds since epoch, isodate) ;; ;; samples: @@ -1058,11 +1080,11 @@ (if (null? rest-path-items) #f (let* ((this-dir (car rest-path-items)) (next-rest (cdr rest-path-items)) (candidate (conc this-dir "/" exe))) - (if (file-execute-access? candidate) + (if (file-executable? candidate) candidate (loop next-rest))))))) @@ -1247,15 +1269,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 +1382,11 @@ (user (or (get-environment-variable "USER") "nouser")) (host (or (get-environment-variable "HOST") "nohost"))) (if logfile (begin (ducttape-log-file logfile) - (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file)))) + (set-environment-variable! "DUCTTAPE_LOG_FILE" (ducttape-log-file)))) (ducttape-append-logfile 'note (format #f "START - pid=~A ppid=~A argv=(~A) pwd=~A user=~A host=~A" pid ppid argv pwd user host) #t))) ;; log exit code (define (set-ducttape-log-exit-handler) @@ -1522,11 +1544,13 @@ (define (sendmail-proc sendmail-port) (define (wl line-str) (write-line line-str sendmail-port)) (define (get-uuid) - (string-upcase (uuid->string (uuid-generate)))) +(print "ERROR in ducttape lib") + "foo") + ;;(string-upcase (uuid->string (uuid-generate)))) (let ((mailpart-uuid (get-uuid)) (mailpart-body-uuid (get-uuid))) (define (boundary) @@ -1702,40 +1726,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 +1774,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 @@ -16,13 +16,13 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -(declare (unit env)) +;; (declare (unit env)) -(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables) +;; (use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables) (define (env:open-db fname) (let* ((db-exists (common:file-exists? fname)) (db (open-database fname))) (if (not db-exists) Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -17,28 +17,30 @@ ;; 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) - -(declare (unit ezsteps)) -(declare (uses db)) -(declare (uses common)) -(declare (uses items)) -(declare (uses runconfig)) -;; (declare (uses sdb)) -;; (declare (uses filedb)) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") - - +;; (use srfi-1 posix regex srfi-69 directory-utils call-with-environment-variables posix-extras +;; z3 csv typed-records pathname-expand matchable) +;; +;; (declare (unit ezsteps)) +;; (declare (uses db)) +;; (declare (uses common)) +;; (declare (uses items)) +;; (declare (uses runconfig)) +;; ;; (declare (uses sdb)) +;; ;; (declare (uses filedb)) +;; +;; (include "common_records.scm") +;; (include "key_records.scm") +;; (include "db_records.scm") +;; (include "run_records.scm") +;; +;; ;;(rmt:get-test-info-by-id run-id test-id) -> testdat + +(define message-window #f) ;; TODO: deprecate me in favor of ezsteps.scm ;; (define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat) (let* ((stepname (car ezstep)) ;; do stuff to run the step @@ -263,19 +265,21 @@ (debug:print-info 0 *default-log-port* "Running in directory " test-run-dir) (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) - (message-window "ERROR: You can only re-run steps defined via ezsteps") + (if message-window + (message-window "ERROR: You can only re-run steps defined via ezsteps") + (debug:print 0 *default-log-port* "ERROR: You can only re-run steps defined via ezsteps")) (begin (let loop ((ezstep (car ezstepslst)) (tal (cdr ezstepslst)) (status-sym-so-far 'pass) ;;(runflag #f) (saw-start-step-name #f)) ;; flag used to skip steps when not starting at the beginning (if (or (vector-ref exit-info 1) - (equal? (alist-ref 'keep-going prev-step-params) 'yes)) + (equal? (alist-ref 'keep-going the-step-params) 'yes)) (let* ((prev-step-params the-step-params) ;; need to snag this now (stepname (car ezstep)) ;; do stuff to run the step (logpro-used (common:file-exists? (conc test-run-dir "/" stepname ".logpro"))) (stepinfo (cadr ezstep)) (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) DELETED fs-transport.scm Index: fs-transport.scm ================================================================== --- fs-transport.scm +++ /dev/null @@ -1,52 +0,0 @@ - -;; Copyright 2006-2012, 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 . - -(require-extension (srfi 18) extras tcp s11n) - -(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) -(import (prefix sqlite3 sqlite3:)) - -(use spiffy uri-common intarweb http-client spiffy-request-vars) - -(tcp-buffer-size 2048) - -(declare (unit fs-transport)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tests)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. - -(include "common_records.scm") -(include "db_records.scm") - - -;;====================================================================== -;; F S T R A N S P O R T S E R V E R -;;====================================================================== - -;; There is no "server" per se but a convience routine to make it non -;; necessary to be reopening the db over and over again. -;; - -(define (fs:process-queue-item packet) - (if (not *dbstruct-db*) ;; we will require that (setup-for-run) has already been called - (set! *dbstruct-db* (db:setup-db))) - (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet) - (db:process-queue-item *dbstruct-db* packet)) - Index: gen-data-for-graph.scm ================================================================== --- gen-data-for-graph.scm +++ gen-data-for-graph.scm @@ -31,21 +31,21 @@ (lambda () (loop ((for m (up-from (/ one-year-ago 60) (to (/ now 60))))) ;; days of the year (let ((thetime (* m 60)) (thehour (round (/ m 60)))) (let loop ((lastsec -1) - (sec (random 60)) + (sec (pseudo-random-integer 60)) (count 0)) (if (> sec lastsec) (exec (sql db "INSERT INTO alldat (event_time,var,val) VALUES (?,?,?)") (+ thetime sec) ;; (* sec 60)) "stuff" (if (even? thehour) - (random 1000) - (random 6)))) + (pseudo-random-integer 1000) + (pseudo-random-integer 6)))) (if (< count 20) - (loop (max sec lastsec)(random 60)(+ count 1)))))))) + (loop (max sec lastsec)(pseudo-random-integer 60)(+ count 1)))))))) (close-database db) ;; (with-transaction @@ -55,18 +55,18 @@ ;; (print "Day: " d) ;; (loop ((for h (up-from 1 (to 24)))) ;; (loop ((for m (up-from 1 (to 60)))) ;; (let ((thetime (+ beginning-2016 (* 365 24 60 60)(* h 60 60)(* m 60)))) ;; (let loop ((lastsec -1) -;; (sec (random 60)) +;; (sec (pseudo-random-integer 60)) ;; (count 0)) ;; (if (> sec lastsec) ;; (exec (sql db "INSERT INTO alldat (event_time,var,val) VALUES (?,?,?)") ;; (+ thetime sec) ;; (* sec 60)) ;; "stuff" ;; (if (even? h) -;; (random 100) -;; (random 6)))) +;; (pseudo-random-integer 100) +;; (pseudo-random-integer 6)))) ;; (if (< count 20) -;; (loop (max sec lastsec)(random 60)(+ count 1)))))))))) +;; (loop (max sec lastsec)(pseudo-random-integer 60)(+ count 1)))))))))) ;; ;; (close-database db) Index: genexample.scm ================================================================== --- genexample.scm +++ genexample.scm @@ -16,14 +16,14 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -(declare (unit genexample)) -(use posix regex matchable) - -(include "db_records.scm") +;; (declare (unit genexample)) +;; (use posix regex matchable) +;; +;; (include "db_records.scm") (define genexample:example-logpro #<. + +;;====================================================================== + +(declare (unit hostinfo)) + +(include "hostinfo/hostinfo.scm") ADDED hostinfo/hostinfo.h Index: hostinfo/hostinfo.h ================================================================== --- /dev/null +++ hostinfo/hostinfo.h @@ -0,0 +1,61 @@ +#ifdef _WIN32 +# include +# include + +const char *inet_ntop(int af, const void *src, char *dst, socklen_t cnt) +{ + if (af == AF_INET) + { + struct sockaddr_in in; + memset(&in, 0, sizeof(in)); + in.sin_family = AF_INET; + memcpy(&in.sin_addr, src, sizeof(struct in_addr)); + getnameinfo((struct sockaddr *)&in, sizeof(struct +sockaddr_in), dst, cnt, NULL, 0, NI_NUMERICHOST); + return dst; + } + else if (af == AF_INET6) + { + struct sockaddr_in6 in; + memset(&in, 0, sizeof(in)); + in.sin6_family = AF_INET6; + memcpy(&in.sin6_addr, src, sizeof(struct in_addr6)); + getnameinfo((struct sockaddr *)&in, sizeof(struct +sockaddr_in6), dst, cnt, NULL, 0, NI_NUMERICHOST); + return dst; + } + return NULL; +} + +int inet_pton(int af, const char *src, void *dst) +{ + struct addrinfo hints, *res, *ressave; + + memset(&hints, 0, sizeof(struct addrinfo)); + hints.ai_family = af; + + if (getaddrinfo(src, NULL, &hints, &res) != 0) + { + return -1; + } + + ressave = res; + + while (res) + { + memcpy(dst, res->ai_addr, res->ai_addrlen); + res = res->ai_next; + } + + freeaddrinfo(ressave); + return 0; +} + +#else + # include + # include + # include /* in_addr */ +# include /* inet_ntop, ... */ +# include /* hostent, gethostby* */ +# include +#endif ADDED hostinfo/hostinfo.meta Index: hostinfo/hostinfo.meta ================================================================== --- /dev/null +++ hostinfo/hostinfo.meta @@ -0,0 +1,9 @@ +;;; hostinfo.meta -*- Hen -*- +((synopsis "Look up host, protocol, and service information") + (author "Jim Ursetto") + (needs vector-lib foreigners) + (egg "hostinfo.egg") + (files "hostinfo.h" "hostinfo.meta" "hostinfo.scm" "hostinfo.setup") + (license "BSD") + (doc-from-wiki) + (category net)) ADDED hostinfo/hostinfo.scm Index: hostinfo/hostinfo.scm ================================================================== --- /dev/null +++ hostinfo/hostinfo.scm @@ -0,0 +1,489 @@ +;;; hostinfo extension to Chicken Scheme +;;; Description: Look up host, service, and protocol information + +;; Copyright (c) 2005-2008, Jim Ursetto. All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are met: +;; +;; Redistributions of source code must retain the above copyright notice, +;; this list of conditions and the following disclaimer. Redistributions in +;; binary form must reproduce the above copyright notice, this list of +;; conditions and the following disclaimer in the documentation and/or +;; other materials provided with the distribution. Neither the name of the +;; author nor the names of its contributors may be used to endorse or +;; promote products derived from this software without specific prior +;; written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, +;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR +;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; + +;; This extension performs host, protocol and service information lookups +;; via underlying calls to gethostbyname(3), getprotobyname(3), and +;; getservbyname(3). Depending on your system, this may consult DNS, +;; NIS, /etc/hosts, /etc/services, /etc/protocols, and so on. + +;; A simple interface is provided for the most commmon queries. Also +;; provided is a more comprehensive interface using records, which +;; contain all data available in a lookup. + +;; IP addresses are represented by 4 (IPv4) or 16 (IPv6) byte +;; u8vectors. The interface requires, and returns, addresses in this +;; format; functions are provided to convert between the string and +;; u8vector representations. However, the "do what I want" procedures +;; (e.g. host-information) will do the conversion for you. + +;; Caveats: +;; - IPv6 addresses can be converted to and from strings, and the underlying structure +;; supports IPv6, but lookup of IPv6 addresses and records is not currently implemented. +;; - array0->string-vector and array0->bytevector-vector contain redundant code. +;; - host, services, and protocol-information check their argument types, even +;; though the underlying code already does it. + +(declare + (fixnum)) + +(cond-expand [paranoia] + [else + (declare (no-bound-checks))]) + +#> #include "../hostinfo/hostinfo.h" <# + +;; (require-extension srfi-4 lolevel posix) + +(module hostinfo +;;; Short and sweet lookups + (current-hostname + hostname->ip ip->hostname + protocol-name->number protocol-number->name + service-port->name service-name->port +;;; Entire host, protocol or service record lookup + hostname->hostinfo ip->hostinfo + protocol-name->protoinfo protocol-number->protoinfo + service-port->servinfo service-name->servinfo +;;; Record accessors and predicates + hostinfo? hostinfo-name hostinfo-aliases hostinfo-addresses + hostinfo-address hostinfo-type hostinfo-length + protoinfo? protoinfo-name protoinfo-aliases protoinfo-number + servinfo? servinfo-name servinfo-aliases servinfo-port servinfo-protocol +;;; One-stop shops -- does what you want + host-information protocol-information service-information +;;; Utilities + string->ip ip->string) + + (import chicken.fixnum chicken.string chicken.blob srfi-2 scheme + typed-records srfi-9 chicken.foreign srfi-4 chicken.base + foreigners system-information + chicken.format) + + (define (vector-map p v0) ; to avoid linking in vector-lib + (let* ((len (vector-length v0)) + (v (make-vector len))) + (do ((i 0 (+ i 1))) + ((>= i len) v) + (vector-set! v i + (p i (vector-ref v0 i)))))) + + (cond-expand [unsafe + (eval-when (compile) + (define-inline (##sys#check-string . r) + (##core#undefined))) ] + [else]) + +;;; C data structure conversions + + (define (c-pointer->blob ptr len) + (let ((bv (make-blob len)) + (memcpy (foreign-lambda bool "C_memcpy" blob c-pointer integer))) + (memcpy bv ptr len) + bv)) + +;; Convert from null-terminated array of c-strings to vector of strings. +;; These functions use C_alloc and so are not suitable for large datasets. +;; Note: get_argv_2 of runtime.c shows how to build a list instead of a vector (in reverse). + (define array0->string-vector + (foreign-primitive scheme-object (((c-pointer "char *") list)) " + char **p; int len = 0; + C_word *a, vec, *elt; + + for (p = list; *p; ++p, ++len); + + a = C_alloc(C_SIZEOF_VECTOR(len)); + vec = (C_word)a; + *a++ = C_make_header(C_VECTOR_TYPE, len); + + for (p = list; *p; ++p) { + len = strlen(*p); + elt = C_alloc(C_SIZEOF_STRING(len)); + /* Both C_mutate and *a++ = seem to work fine here. */ + C_mutate(a++, C_string(&elt, len, *p)); + } + return(vec);" + )) + + ;; Convert from null-terminated array of IP addresses to vector of strings. + (define array0->bytevector-vector + (foreign-primitive scheme-object (((c-pointer "char *") list) (integer addrlen)) " + char **p; int len = 0; + C_word *a, vec, *elt; + + for (p = list; *p; ++p, ++len); + + a = C_alloc(C_SIZEOF_VECTOR(len)); + vec = (C_word)a; + *a++ = C_make_header(C_VECTOR_TYPE, len); + + for (p = list; *p; ++p) { + elt = C_alloc(C_SIZEOF_STRING(addrlen)); + C_mutate(a++, C_bytevector(&elt, addrlen, *p)); + } + return(vec);" + )) + + ;; Not currently used. Could make the array0-> stuff somewhat cleaner. + ;; (define array0-length + ;; (foreign-lambda* integer (((pointer "void *") list)) #<ip conversion + + ;; inet_pton does not like "127.1", nor "0", nor any other non-standard + ;; representation of IP addresses. This is specified by RFC2553. + ;; inet_aton resolves these addresses. We use inet_pton here. + + (define-foreign-variable inet4-addrstrlen integer "INET_ADDRSTRLEN") + (define-foreign-variable inet6-addrstrlen integer "INET6_ADDRSTRLEN") + (define-foreign-variable af-inet integer "AF_INET") + (define-foreign-variable af-inet6 integer "AF_INET6") + + (define inet-ntop (foreign-lambda c-string "inet_ntop" integer u8vector c-string integer)) + (define inet-pton (foreign-lambda* bool ((integer type) (c-string src) (blob dest)) + "return(inet_pton(type, src, dest) == 1);")) + + (define (string->ip4 str) + (##sys#check-string str 'string->ip4) + (let ((bv (make-blob 4))) + (and (inet-pton af-inet str bv) + (blob->u8vector bv)))) + + (define (string->ip6 str) + (##sys#check-string str 'string->ip6) + (let ((bv (make-blob 16))) + (and (inet-pton af-inet6 str bv) + (blob->u8vector bv)))) + + (define (string->ip str) + (or (string->ip4 str) + (string->ip6 str))) + +;;; ip->string conversion + + (define (ip4->string addr) + (let ((len inet4-addrstrlen)) + (inet-ntop af-inet addr (make-string len) len))) + + (define (ip6->string addr) + (let ((len inet6-addrstrlen)) + (inet-ntop af-inet6 addr (make-string len) len))) + + ;; Take an IPv4 or IPv6 u8vector and convert it into the + ;; appropriate string representation, via inet_ntop. + (define (ip->string addr) + (let ((len (u8vector-length addr))) + (cond ((fx= len 4) (ip4->string addr)) + ((fx= len 16) (ip6->string addr)) + (else + (error "Invalid IP address length" addr))))) + +;;; hostent raw structure + + (define-foreign-record-type (hostent "struct hostent") + (c-string h_name hostent-name) + (c-pointer h_aliases hostent-h_aliases) + (integer h_addrtype hostent-addrtype) + (integer h_length hostent-length) + (c-pointer h_addr_list hostent-addr-list)) + + ;; Some convenient accessors for the raw hostent structure--with raw c pointers + ;; converted to the appropriate scheme objects. We only use these once or twice + ;; below, so their main advantage is clarity. + (define (hostent-aliases h) + (array0->string-vector (hostent-h_aliases h))) + (define (hostent-address h) + (let* ((get-addr (foreign-lambda* c-pointer ((hostent h)) "return(h->h_addr_list[0]);")) + (addr (get-addr h))) + (blob->u8vector + (c-pointer->blob addr (hostent-length h))))) + (define (hostent-addresses h) + (vector-map (lambda (i x) (blob->u8vector x)) + (array0->bytevector-vector (hostent-addr-list h) + (hostent-length h)))) + ;; The IPv6 equivalents of these are getipnodebyname and + ;; getipnodebyaddr. + (define gethostent/name (foreign-lambda hostent "gethostbyname" c-string)) + + (define (gethostent/addr addr) + (if (fx= (u8vector-length addr) 4) + (gethostent/addr/bv (u8vector->blob addr)) + (error "invalid IP address length; only IPv4 supported" addr))) + + ;; Warning: handle IPv6!! + (define gethostent/addr/bv (foreign-lambda* hostent ((blob addr)) + "return(gethostbyaddr((const char *)addr, 4, AF_INET));")) + + ;; This was originally made a macro so we could easily return multiple + ;; values -- but we're now returning a hostinfo structure. Eh. + (define (hostent->hostinfo h) + (make-hostinfo (hostent-name h) + (hostent-addresses h) + (hostent-aliases h))) + +;;; hostinfo and host information + + ;; The standard host name for the current processor. + ;; Gets & Sets, error otherwise. + + (define set-host-name! + (foreign-lambda* int ((c-string name)) + "return(sethostname(name, strlen(name)));")) + + (define (current-hostname . args) + (if (null? args) + (get-host-name) + (and (zero? (set-host-name! (->string (car args)))) + (error 'current-hostname "cannot set hostname")))) + + ;; Structure accessors created by define-foreign-record do not intercept + ;; NULL pointer input, including #f. + (define (hostname->ip host) + (and-let* ((h (gethostent/name host))) + (hostent-address h))) + + (define (hostname->hostinfo host) + (and-let* ((h (gethostent/name host))) + (hostent->hostinfo h))) + + (define (ip->hostname addr) + (and-let* ((h (gethostent/addr addr))) + (hostent-name h))) + + (define (ip->hostinfo addr) + (and-let* ((h (gethostent/addr addr))) + (hostent->hostinfo h))) + + ;; A simple hostinfo structure. + (define-record-type hostinfo + (make-hostinfo name addresses aliases) + hostinfo? + (name hostinfo-name) + (addresses hostinfo-addresses) + (aliases hostinfo-aliases)) + + ;; "Accessors" for phantom fields. + ;; We don't need to store length or type, as these are artifacts + ;; of the C implementation, and can be derived from the address itself. + (define (hostinfo-address h) (vector-ref (hostinfo-addresses h) 0)) + (define (hostinfo-length h) (u8vector-length (hostinfo-address h))) + (define (hostinfo-type h) + (let ((len (u8vector-length (hostinfo-address h)))) + (cond ((fx= len 4) 'AF_INET) ;; Kind of a dummy implementation-- + ((fx= len 16) 'AF_INET6) ;; not sure what value would be appropriate + (else + (error "Invalid IP address length" (hostinfo-address h)))))) + + ;; Format the structure for easy interactive viewing--should be possible to + ;; add a ctor for this representation, though it's not clear why you'd want to. + (define-record-printer (hostinfo h port) + (fprintf port "#,(hostinfo name: ~S addresses: ~S aliases: ~S)" + (hostinfo-name h) (hostinfo-addresses h) (hostinfo-aliases h))) + + ;; Warning: lookup of an IP address which is invalid yet numeric will + ;; return a false positive. Bug in gethostbyname? + ;; E.g. (hostname->hostinfo "1") => #,(hostinfo name: "1" addresses: (#u8(0 0 0 1))) + ;; ** If we used inet_aton for string->ip, then these cases would + ;; be transformed into u8vector IPs, and the lookup would correctly fail. + + ;; Return a hostinfo record. HOST is a u8vector IP address, a string + ;; hostname, or a string numeric IP address. + (define (host-information host) + (if (u8vector? host) + (ip->hostinfo host) + (begin + (##sys#check-string host 'host-information) + (cond ((string->ip host) => ip->hostinfo) + (else (hostname->hostinfo host)))))) + +;;; protocols + + (define-foreign-record-type (protoent "struct protoent") + (c-string p_name protoent-name) + (c-pointer p_aliases protoent-p_aliases) + (integer p_proto protoent-proto)) + + (define getprotoent/name (foreign-lambda protoent "getprotobyname" c-string)) + (define getprotoent/number (foreign-lambda protoent "getprotobynumber" integer)) + + ;; Raw structure -> scheme-object accessors + (define (protoent-aliases p) + (array0->string-vector (protoent-p_aliases p))) + + (define-record-type protoinfo + (make-protoinfo name number aliases) + protoinfo? + (name protoinfo-name) + (number protoinfo-number) + (aliases protoinfo-aliases)) + + (define-record-printer (protoinfo p port) + (fprintf port "#,(protoinfo name: ~S number: ~S aliases: ~S)" + (protoinfo-name p) (protoinfo-number p) (protoinfo-aliases p))) + + (define (protocol-name->number name) + (and-let* ((p (getprotoent/name name))) + (protoent-proto p))) + (define (protocol-number->name nr) + (and-let* ((p (getprotoent/number nr))) + (protoent-name p))) + + (define (protoent->protoinfo p) + (make-protoinfo (protoent-name p) + (protoent-proto p) + (protoent-aliases p))) + + (define (protocol-name->protoinfo name) + (and-let* ((p (getprotoent/name name))) + (protoent->protoinfo p))) + (define (protocol-number->protoinfo nr) + (and-let* ((p (getprotoent/number nr))) + (protoent->protoinfo p))) + + (define (protocol-information proto) + (if (fixnum? proto) + (protocol-number->protoinfo proto) + (begin + (##sys#check-string proto 'protocol-information) + (protocol-name->protoinfo proto)))) + +;;; services + + (define-foreign-type port-number int + (foreign-lambda int "htons" int) + (foreign-lambda int "ntohs" int) ) + + (define-foreign-record-type (servent "struct servent") + (c-string s_name servent-name) + (c-pointer s_aliases servent-s_aliases) + (port-number s_port servent-port) + (c-string s_proto servent-proto)) + + (define (servent->servinfo s) + (make-servinfo (servent-name s) + (servent-port s) + (array0->string-vector + (servent-s_aliases s)) + (servent-proto s))) + + (define getservent/name (foreign-lambda servent "getservbyname" c-string c-string)) + (define getservent/port (foreign-lambda servent "getservbyport" port-number c-string)) + + (define-record-type servinfo + (make-servinfo name port aliases protocol) + servinfo? + (name servinfo-name) + (port servinfo-port) + (aliases servinfo-aliases) + (protocol servinfo-protocol)) + + (define-record-printer (servinfo s port) + (fprintf port "#,(servinfo name: ~S port: ~S aliases: ~S protocol: ~S)" + (servinfo-name s) (servinfo-port s) (servinfo-aliases s) (servinfo-protocol s))) + + ;; If provided with the optional protocol argument (a string), these will + ;; restrict their search to that protocol. + (define (service-name->port name . pr) + (let-optionals pr ((proto #f)) + (and-let* ((s (getservent/name name proto))) + (servent-port s)))) + (define (service-port->name port . pr) + (let-optionals pr ((proto #f)) + (and-let* ((s (getservent/port port proto))) + (servent-name s)))) + (define (service-name->servinfo name . pr) + (let-optionals pr ((proto #f)) + (and-let* ((s (getservent/name name proto))) + (servent->servinfo s)))) + (define (service-port->servinfo port . pr) + (let-optionals pr ((proto #f)) + (and-let* ((s (getservent/port port proto))) + (servent->servinfo s)))) + + ;; Return service information given a service name or port, and an + ;; optional protocol name or number to restrict the search to. + ;; Note: if the protocol-number->name lookup fails, + ;; an error is thrown, as this was probably not intended. + (define (service-information service . pr) + (let-optionals pr ((proto #f)) + (let ((proto (if (fixnum? proto) + (or (protocol-number->name proto) + (error 'service-information "illegal protocol number" proto)) + proto))) + (if (fixnum? service) + (service-port->servinfo service proto) + (begin + (##sys#check-string service 'service-information) + (service-name->servinfo service proto)))))) +) ; end module + +;;; Tests +(cond-expand + [testing + (import hostinfo) + (current-hostname) + (host-information "www.call-with-current-continuation.org") + (host-information '#u8(194 97 107 133)) + (host-information "194.97.107.133") + ; => #,(hostinfo name: "www003.lifemedien.de" addresses: #(#u8(194 97 107 133)) + ; aliases: #("www.call-with-current-continuation.org")) + (ip->hostname '#u8(194 97 107 133)) ; "www003.lifemedien.de" + (string->ip "0708::0901") ; #u8(7 8 0 0 0 0 0 0 0 0 0 0 0 0 9 1) + (ip->string '#u8(127 0 0 1)) ; "127.0.0.1" + (hostinfo-aliases + (hostname->hostinfo + (ip->hostname (hostname->ip + (hostinfo-name + (host-information "www.call-with-current-continuation.org")))))) + ; => #("www.call-with-current-continuation.org") + + (protocol-information 17) ; => #,(protoinfo name: "udp" number: 17 aliases: #("UDP")) + (protoinfo-name (protocol-information 2)) ; => "igmp" + (protoinfo-aliases (protocol-name->protoinfo + (protocol-number->name + (protoinfo-number + (protocol-information "ospf"))))) ; => #("OSPFIGP") + (protocol-name->number "OSPFIGP") ; 89 (you can look up aliases, too) + + (servinfo-protocol (service-name->servinfo + (service-port->name + (servinfo-port (service-information "ssh"))))) ; => "udp" (yes, really) + (service-information "ssh" "tcp") ; => #,(servinfo name: "ssh" port: 22 aliases: #() protocol: "tcp") + (service-information "ssh" "tco") ; => #f + (service-information 512 "tcp") ; #,(servinfo name: "exec" port: 512 aliases: #() protocol: "tcp") + (service-information 512 "udp") ; #,(servinfo name: "comsat" port: 512 aliases: #("biff") protocol: "udp") + (service-information 512 17) ; same as previous + (service-information 512 170000) ; Error: (service-information) illegal protocol number: 170000 + ] [else]) ADDED hostinfo/hostinfo.setup Index: hostinfo/hostinfo.setup ================================================================== --- /dev/null +++ hostinfo/hostinfo.setup @@ -0,0 +1,11 @@ +(define libs + (if (eq? (build-platform) 'msvc) + "-lws2_32" + "") ) + +(compile -s -O2 -d2 hostinfo.scm ,libs -j hostinfo) +(compile -s -O2 -d0 hostinfo.import.scm) +(install-extension + 'hostinfo + '("hostinfo.so" "hostinfo.import.so") + '((version "1.4.1"))) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -14,44 +14,42 @@ ;; 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 . -(require-extension (srfi 18) extras tcp s11n) - - -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) - -(use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing) - +;; (require-extension (srfi 18) extras tcp s11n) +;; +;; +;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) +;; +;; (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing) +;; ;; Configurations for server (tcp-buffer-size 2048) (max-connections 2048) -(declare (unit http-transport)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tests)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. -(declare (uses server)) -;; (declare (uses daemon)) -(declare (uses portlogger)) -(declare (uses rmt)) - -(include "common_records.scm") -(include "db_records.scm") -(include "js-path.scm") - -(require-library stml) +;; (declare (unit http-transport)) +;; +;; (declare (uses common)) +;; (declare (uses db)) +;; (declare (uses tests)) +;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. +;; (declare (uses server)) +;; ;; (declare (uses daemon)) +;; (declare (uses portlogger)) +;; (declare (uses rmt)) +;; +;; (include "common_records.scm") +;; (include "db_records.scm") +;; (include "js-path.scm") + +;; (require-library stml) (define (http-transport:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) -(define *server-loop-heart-beat* (current-seconds)) - ;;====================================================================== ;; S E R V E R ;; ====================================================================== ;; Call this to start the actual server @@ -224,14 +222,14 @@ (set! *http-requests-in-progress* (- *http-requests-in-progress* 1)) (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds (if (> *http-requests-in-progress* 0) (if (> etime (current-seconds)) (begin - (thread-sleep! 0.05) + (thread-sleep! 0.052) (loop etime)) (debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) - (close-all-connections!))) + (close-idle-connections!))) (set! *http-connections-next-cleanup* (+ (current-seconds) 10)) (mutex-unlock! *http-mutex*)) (define (http-transport:inc-requests-and-prep-to-close-all-connections) (mutex-lock! *http-mutex*) @@ -299,11 +297,11 @@ (cons 'params sparams)) read-string)) transport: 'http) 0)) ;; added this speculatively ;; Shouldn't this be a call to the managed call-all-connections stuff above? - (close-all-connections!) + (close-idle-connections!) (mutex-unlock! *http-mutex*) )) (time-out (lambda () (thread-sleep! 45) (debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!") @@ -522,11 +520,11 @@ (let ((curr-time (current-seconds))) (handle-exceptions exn (debug:print 0 *default-log-port* "ERROR: Failed to change timestamp on log file " server-log-file ". Are you out of space on that disk? exn=" exn) (if (not *server-overloaded*) - (change-file-times server-log-file curr-time curr-time))))) + (set-file-times! server-log-file curr-time curr-time))))) (loop 0 server-state bad-sync-count (current-milliseconds))) (else (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access)) (http-transport:server-shutdown port))))))) @@ -612,11 +610,11 @@ (th3 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server monitor thread started") (http-transport:keep-running) "Keep running")))) (thread-start! th2) - (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor. + (thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor. (thread-start! th3) (set! *didsomething* #t) (thread-join! th2) (exit)))) Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -19,14 +19,14 @@ ;; (define itemdat '((ripeness "green ripe overripe") ;; (temperature "cool medium hot") ;; (season "summer winter fall spring"))) -(declare (unit items)) -(declare (uses common)) - -(include "common_records.scm") +;; (declare (unit items)) +;; (declare (uses common)) +;; +;; (include "common_records.scm") ;; Puts out all combinations (define (process-itemlist hierdepth curritemkey itemlist) (let ((res '())) (if (not hierdepth) Index: keys.scm ================================================================== --- keys.scm +++ keys.scm @@ -19,18 +19,18 @@ ;;====================================================================== ;; Run keys, these are used to hierarchially organise tests and run areas ;;====================================================================== -(use sqlite3 srfi-1 posix regex regex-case srfi-69) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit keys)) -(declare (uses common)) - -(include "key_records.scm") -(include "common_records.scm") +;; (use sqlite3 srfi-1 posix regex regex-case srfi-69) +;; (import (prefix sqlite3 sqlite3:)) +;; +;; (declare (unit keys)) +;; (declare (uses common)) +;; +;; (include "key_records.scm") +;; (include "common_records.scm") (define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... (string-intersperse keys ",")) (define (args:usage . a) #f) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -19,28 +19,28 @@ ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== -(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 - call-with-environment-variables csv) -(use typed-records pathname-expand matchable) - -(import (prefix base64 base64:)) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit launch)) -(declare (uses subrun)) -(declare (uses common)) -(declare (uses configf)) -(declare (uses db)) -(declare (uses ezsteps)) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "megatest-fossil-hash.scm") +;; (use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 +;; call-with-environment-variables csv) +;; (use typed-records pathname-expand matchable) +;; +;; (import (prefix base64 base64:)) +;; (import (prefix sqlite3 sqlite3:)) +;; +;; (declare (unit launch)) +;; (declare (uses subrun)) +;; (declare (uses common)) +;; (declare (uses configf)) +;; (declare (uses db)) +;; (declare (uses ezsteps)) +;; +;; (include "common_records.scm") +;; (include "key_records.scm") +;; (include "db_records.scm") +;; (include "megatest-fossil-hash.scm") ;;====================================================================== ;; ezsteps ;;====================================================================== @@ -307,11 +307,11 @@ ;; no point in sticking around. Exit now. But run end of run before exiting? (launch:end-of-run-check run-id) (exit))) (if (hash-table-ref/default misc-flags 'keep-going #f) (begin - (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses + (thread-sleep! 3) ;; (+ 3 (pseudo-random-integer 6))) ;; add some jitter to the call home time to spread out the db accesses (if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free) (if do-sync (current-seconds) last-sync))))))) @@ -357,11 +357,11 @@ #f (if (substring-index "/" runscript) runscript ;; use unadultered if contains slashes (let ((fulln (conc work-area "/" runscript))) (if (and (common:file-exists? fulln) - (file-execute-access? fulln)) + (file-executable? fulln)) fulln runscript))))) ;; assume it is on the path (check-work-area (lambda () ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) @@ -614,11 +614,11 @@ (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (common:file-exists? fullrunscript) - (not (file-execute-access? fullrunscript))) + (not (file-executable? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) ;; We are about to actually kick off the test ;; so this is a good place to remove the records for ;; any previous runs @@ -628,11 +628,11 @@ (tconfig-tmpfile (conc tconfig-fname ".tmp")) (tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs))) (scripts (configf:get-section tconfig "scripts"))) ;; create .testconfig file (configf:write-alist tconfig tconfig-tmpfile) - (file-move tconfig-tmpfile tconfig-fname #t) + (move-file tconfig-tmpfile tconfig-fname #t) (delete-file* ".final-status") ;; extract scripts from testconfig and write them to files in test run dir (for-each (lambda (scriptdat) @@ -639,11 +639,11 @@ (match scriptdat ((name content) (with-output-to-file name (lambda () (print content) - (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu))))) + (set-file-permissions! name (bitwise-ior perm/irwxg perm/irwxu))))) (else (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\"")))) scripts)) ;; (let* ((m (make-mutex)) @@ -913,11 +913,11 @@ #f (car cachefiles))) ;; (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) (rccachef (if (null? cachefiles) #f (cdr cachefiles)))) ;; (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) - ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-write-access? cachedir) (not (common:in-running-test?))))) + ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-writable? cachedir) (not (common:in-running-test?))))) (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource ;;(BB> "launch:setup-body -- cachefiles="cachefiles) (cond ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME ((and (not force-reread) @@ -1094,11 +1094,11 @@ (set! *configstatus* 'fulldata))) ;; if have -append-config then read and append here (let ((cfname (args:get-arg "-append-config"))) (if (and cfname - (file-read-access? cfname)) + (file-readable? cfname)) (read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special. *toppath*))) (define (get-best-disk confdat testconfig) Index: margs.scm ================================================================== --- margs.scm +++ margs.scm @@ -14,11 +14,11 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . -(declare (unit margs)) +;; (declare (unit margs)) ;; (declare (uses common)) (define args:arg-hash (make-hash-table)) (define (args:get-arg arg . default) DELETED megatest-version.scm Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ /dev/null @@ -1,23 +0,0 @@ -;; Copyright 2006-2017, 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 . - -;; Always use two or four digit decimal -;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. - -;; (declare (unit megatest-version)) - -(define megatest-version 1.6584) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -14,56 +14,244 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; -;; (include "common.scm") -(include "megatest-version.scm") +;; megatest.scm mofiles/autoload.o mofiles/dbi.o mofiles/ducttape-lib.o +;; mofiles/pkts.o mofiles/stml2.o mofiles/cookie.o mofiles/mutils.o +;; mofiles/mtargs.o + +;; (include "mutils/mutils.scm") +;; (include "autoload/autoload.scm") +;; (include "dbi/dbi.scm") +;; (include "stml2/cookie.scm") +;; (include "stml2/stml2.scm") +;; (include "pkts/pkts.scm") +;; (include "csv-xml/csv-xml.scm") +;; (include "ducttape/ducttape-lib.scm") +;; (include "hostinfo/hostinfo.scm") +;; (include "adjutant.scm") + +(declare (uses autoload)) +(declare (uses pkts)) +(declare (uses stml2)) +(declare (uses cookie)) +(declare (uses csv-xml)) +(declare (uses hostinfo)) + +(declare (uses mutils)) +(declare (uses ducttape-lib)) +(declare (uses mtargs)) +(declare (uses commonmod)) +(declare (uses apimod)) +(declare (uses dbmod)) +(declare (uses rmtmod)) +(declare (uses servermod)) +(declare (uses mtver)) +(declare (uses adjutant)) + +;; (include "call-with-environment-variables/call-with-environment-variables.scm") + +(module megatest-main + * + + (import scheme + chicken.base + chicken.bitwise + chicken.condition + chicken.file + chicken.file.posix + chicken.format + chicken.io + chicken.irregex + chicken.pathname + chicken.port + chicken.pretty-print + chicken.process + chicken.process-context + chicken.process-context.posix + chicken.process.signal + chicken.random + chicken.repl + chicken.sort + chicken.string + chicken.tcp + chicken.time + chicken.time.posix + + (prefix sqlite3 sqlite3:) + (prefix base64 base64:) + address-info + csv-abnf + directory-utils + fmt + json + matchable + md5 + message-digest + queues + regex + regex-case + sql-de-lite + stack + typed-records + s11n + sparse-vectors + sxml-serializer + sxml-modifications + (prefix sxml-modifications sxml-) + sxml-transforms + system-information + z3 + spiffy + uri-common + intarweb + http-client + spiffy-request-vars + intarweb + spiffy-directory-listing + + srfi-1 + srfi-4 + srfi-18 + srfi-13 + srfi-98 + srfi-69 + + ;; local modules + adjutant + csv-xml + ducttape-lib + hostinfo + mtver + mutils + autoload + cookie + csv-xml + ducttape-lib + mtargs + pkts + stml2 + (prefix dbi dbi:) + apimod + commonmod + dbmod + rmtmod + servermod + debugprint + + ) + ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) - -(declare (uses common)) -;; (declare (uses megatest-version)) -(declare (uses margs)) -(declare (uses runs)) -(declare (uses launch)) -(declare (uses server)) -(declare (uses client)) -(declare (uses tests)) -(declare (uses genexample)) -;; (declare (uses daemon)) -(declare (uses db)) -;; (declare (uses dcommon)) - -(declare (uses tdb)) -(declare (uses mt)) -(declare (uses api)) -(declare (uses tasks)) ;; only used for debugging. -(declare (uses env)) -(declare (uses diff-report)) +(define setenv set-environment-variable!) +(define unsetenv unset-environment-variable!) + +;; (declare (uses common)) +;; ;; (declare (uses megatest-version)) +;; (declare (uses margs)) +;; (declare (uses runs)) +;; (declare (uses launch)) +;; (declare (uses server)) +;; (declare (uses client)) +;; (declare (uses tests)) +;; (declare (uses genexample)) +;; ;; (declare (uses daemon)) +;; (declare (uses db)) +;; ;; (declare (uses dcommon)) +;; +;; (declare (uses tdb)) +;; (declare (uses mt)) +;; (declare (uses api)) +;; (declare (uses tasks)) ;; only used for debugging. +;; (declare (uses env)) +;; (declare (uses diff-report)) ;; (declare (uses ftail)) ;; (import ftail) + +;; (define (blahblah)(thread-sleep! 1.234)) (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") +(include "test_records.scm") + +(include "common.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) +(include "configf.scm") +(include "margs.scm") +(include "process.scm") +(include "keys.scm") +(include "portlogger.scm") +(include "db.scm") +(include "rmt.scm") +(include "runs.scm") +(include "launch.scm") +(include "server.scm") +(include "client.scm") +(include "tests.scm") +(include "items.scm") +(include "subrun.scm") +(include "genexample.scm") +(include "tdb.scm") +(include "mt.scm") +(include "api.scm") +(include "tasks.scm") +(include "ezsteps.scm") +(include "env.scm") +(include "diff-report.scm") +(include "cgisetup/models/pgdb.scm") +(include "runconfig.scm") +(include "archive.scm") +(include "ods.scm") +(include "http-transport.scm") -;; Added for csv stuff - will be removed +;;; ;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:) +;;; ;; readline apropos json http-client directory-utils typed-records +;;; ;; http-client srfi-18 extras format) +;;; +;;; ;; Added for csv stuff - will be removed +;;; ;; +;;; ;; (use sparse-vectors) +;;; ;; +;;; ;; (require-library mutils) +;;; +;; copied from egg call-with-environment-variables ;; -(use sparse-vectors) - -(require-library mutils) +(define (call-with-environment-variables variables thunk) + ;; @("Sets up environment variable via dynamic-wind which are taken down after thunk." + ;; (variables "An alist of the form {{'((\"var\" . \"value\") ...)}}") + ;; (thunk "The thunk to execute with a modified environment")) + (let ((pre-existing-variables + (map (lambda (var-value) + (let ((var (car var-value))) + (cons var (get-environment-variable var)))) + variables))) + (dynamic-wind + (lambda () (void)) + (lambda () +;; (use posix) + (for-each (lambda (var-value) + (setenv (car var-value) (cdr var-value))) + variables) + (thunk)) + (lambda () + (for-each (lambda (var-value) + (let ((var (car var-value)) + (value (cdr var-value))) + (if value + (setenv var value) + (unsetenv var)))) + pre-existing-variables))))) + + (define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file ;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file ;; @@ -72,430 +260,469 @@ (load debugcontrolf))) ;; usage logging, careful with this, it is not designed to deal with all real world challenges! ;; (if (and *usage-log-file* - (file-write-access? *usage-log-file*)) + (file-writable? *usage-log-file*)) (with-output-to-file - *usage-log-file* + *usage-log-file* (lambda () - (print - (if *usage-use-seconds* - (current-seconds) - (time->string - (seconds->local-time (current-seconds)) - "%Yww%V.%w %H:%M:%S")) - " " - (current-user-name) " " - (current-directory) " " - "\"" (string-intersperse (argv) " ") "\"")) + (print + (if *usage-use-seconds* + (current-seconds) + (time->string + (seconds->local-time (current-seconds)) + "%Yww%V.%w %H:%M:%S")) + " " + (current-user-name) " " + (current-directory) " " + "\"" (string-intersperse (argv) " ") "\"")) #:append)) ;; Disabled help items ;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s) ;; from prior runs with same keys ;; -daemonize : fork into background and disconnect from stdin/out - + (define help (conc " -Megatest, documentation at http://www.kiatoa.com/fossils/megatest - version " megatest-version " - license GPL, Copyright Matt Welland 2006-2017 - -Usage: megatest [options] - -h : this help - -manual : show the Megatest user manual - -version : print megatest version (currently " megatest-version ") - -Launching and managing runs - -run : run all tests or as specified by -testpatt - -remove-runs : remove the data for a run, requires -runname and -testpatt - Optionally use :state and :status, use -keep-records to remove only - the run data. Use -kill-wait to override the 10 second - per test wait after kill delay (e.g. -kill-wait 0). - -kill-runs : kill existing run(s) (all incomplete tests killed) - -kill-rerun : kill an existing run (all incomplete tests killed and run is rerun) - -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs - -rerun FAIL,WARN... : force re-run for tests with specificed status(s) - -rerun-clean : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a - and then run the specified testpatt with -preclean - -rerun-all : set all tests to NOT_STARTED,n/a and run with -preclean - -lock : lock run specified by target and runname - -unlock : unlock run specified by target and runname - -set-run-status status : sets status for run to status, requires -target and -runname - -get-run-status : gets status for run specified by target and runname - -run-wait : wait on run specified by target and runname - -preclean : remove the existing test directory before running the test - -clean-cache : remove the cached megatest.config and runconfigs.config files - -no-cache : do not use the cached config files. - -one-pass : launch as many tests as you can but do not wait for more to be ready - -remove-keep N : remove all but N most recent runs per target; use '-actions, -age, -precmd' - -age : 120d,3h,20m to apply only to runs older than the - specified age. NB// M=month, m=minute - -actions [,...] : actions to take; print,remove-runs,archive,kill-runs - -precmd : insert a wrapper command in front of the commands run - -Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) - -target key1/key2/... : run for key1, key2, etc. - -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfigs - -testpatt patt1/patt2,patt3/... : % is wildcard - -runname : required, name for this particular test run - -state : Applies to runs, tests or steps depending on context - -status : Applies to runs, tests or steps depending on context - -modepatt key : load testpatt from 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) - -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 - -set-values : update or set values in the testdata table - :category : set the category field (optional) - :variable : set the variable name (optional) - :value : value measured (required) - :expected : value expected (required) - :tol : |value-expect| <= tol (required, can be <, >, >=, <= or number) - :units : name of the units for value, expected_value etc. (optional) - -load-test-data : read test specific data for storage in the test_data table - from standard in. Each line is comma delimited with four - fields category,variable,value,comment - -Queries - -list-runs patt : list runs matching pattern \"patt\", % is the wildcard - -show-keys : show the keys used in this megatest setup - -test-files targpatt : get the most recent test path/file matching targpatt e.g. %/% or '*.log' - returns list sorted by age ascending, see examples below - -test-paths : get the test paths matching target, runname, item and test - patterns. - -list-disks : list the disks available for storing runs - -list-targets : list the targets in runconfigs.config - -list-db-targets : list the target combinations used in the db - -show-config : dump the internal representation of the megatest.config file - -show-runconfig : dump the internal representation of the runconfigs.config file - -dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line) - -show-cmdinfo : dump the command info for a test (run in test environment) - -section sectionName - -var varName : for config and runconfig lookup value for sectionName varName - -since N : get list of runs changed since time N (Unix seconds) - -fields fieldspec : fields to include in json dump; runs:id,runame+tests:testname+steps - -sort fieldname : in -list-runs sort tests by this field - -testdata-csv [categorypatt/]varpatt : dump testdata for given category - -Misc - -start-dir path : switch to this directory before running megatest - -contour cname : add a level of hierarcy to the linktree and run paths - -area-tag tagname : add a tag to an area while syncing to pgdb - -run-tag tagname : add a tag to a run while syncing to pgdb - -rebuild-db : bring the database schema up to date - -cleanup-db : remove any orphan records, vacuum the db - -import-megatest.db : push data from megatest.db to cache db files in /tmp/$USER - -sync-to-megatest.db : pull data from cache files in /tmp/$USER to megatest.db - -sync-to dest : sync to new postgresql central style database - -update-meta : update the tests metadata for all tests - -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are - overwritten by values set in config files. - -server -|hostname : start the server (reduces contention on megatest.db), use - - to automatically figure out hostname - -adjutant C,M : start the server/adjutant with allocated cores C and Mem M (Gig), - use 0,0 to auto use full machine - -transport http|rpc : use http or rpc for transport (default is http) - -log logfile : send stdout and stderr to logfile - -list-servers : list the servers - -kill-servers : kill all servers - -repl : start a repl (useful for extending megatest) - -load file.scm : load and run file.scm - -mark-incompletes : find and mark incomplete tests - -ping run-id|host:port : ping server, exit with 0 if found - -debug N|N,M,O... : enable debug 0-N or N and M and O ... - -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG - -config fname : override the megatest.config file with fname - -append-config fname : append fname to the megatest.config file - -Utilities - -env2file fname : write the environment to fname.csh and fname.sh - -envcap a : save current variables labeled as context 'a' in file envdat.db - -envdelta a-b : output enviroment delta from context a to context b to -o fname - set the output mode with -dumpmode csh, bash or ini - note: ini format will use calls to use curr and minimize path - -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 - -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 - -list-test-time : list time requered to complete each test in a run. It following following arguments - -runname -target -dumpmode - -syscheck : do some very basic checks; write access and space in tmp, home, runs, links and - is $DISPLAY valid - -list-waivers : dump waivers for specified target, runname, testpatt to stdout - -Diff report - -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname - and either -diff-email or -diff-html) - -src-target - -src-runname - -diff-email : comma separated list of email addresses to send diff report - -diff-html : path to html file to generate - -Spreadsheet generation - -extract-ods fname.ods : extract an open document spreadsheet from the database - -pathmod path : insert path, i.e. path/runame/itempath/logfile.html - will clear the field if no rundir/testname/itempath/logfile - if it contains forward slashes the path will be converted - to windows style -Getting started - -create-megatest-area : create a skeleton megatest area. You will be prompted for paths - -create-test testname : create a skeleton megatest test. You will be prompted for info - -Examples - -# Get test path, use '.' to get a single path or a specific path/file pattern -megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt% - -Called as " (string-intersperse (argv) " ") " -Version " megatest-version ", built from " megatest-fossil-hash )) - -;; -gui : start a gui interface -;; -config fname : override the runconfigs file with fname - -;; process args -(define remargs (args:get-args - (argv) - (list "-runtests" ;; run a specific test - "-config" ;; override the config file name - "-append-config" - "-execute" ;; run the command encoded in the base64 parameter - "-step" - "-target" - "-reqtarg" - ":runname" - "-runname" - ":state" - "-state" - ":status" - "-status" - "-list-runs" - "-testdata-csv" - "-testpatt" - "--modepatt" - "-modepatt" - "-tagexpr" - "-itempatt" - "-setlog" - "-set-toplog" - "-runstep" - "-logpro" - "-m" - "-rerun" - - "-days" - "-rename-run" - "-to" - "-dest" - "-source" - "-time-stamp" - ;; values and messages - ":category" - ":variable" - ":value" - ":expected" - ":tol" - ":units" - - ;; misc - "-start-dir" - "-run-patt" - "-target-patt" - "-contour" - "-area-tag" - "-area" - "-run-tag" - "-server" - "-adjutant" - "-transport" - "-port" - "-extract-ods" - "-pathmod" - "-env2file" - "-envcap" - "-envdelta" - "-setvars" - "-set-state-status" - - ;; move runs stuff here - "-remove-keep" - "-set-run-status" - "-age" - - ;; archive - "-archive" - "-actions" - "-precmd" - "-include" - "-exclude-rx" - "-exclude-rx-from" - - "-debug" ;; for *verbosity* > 2 - "-debug-noprop" - "-create-test" - "-override-timeout" - "-test-files" ;; -test-paths is for listing all - "-load" ;; load and exectute a scheme file - "-section" - "-var" - "-dumpmode" - "-run-id" - "-ping" - "-refdb2dat" - "-o" - "-log" - "-sync-log" - "-since" - "-fields" - "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state - "-sort" - "-target-db" - "-source-db" - "-prefix-target" - - "-src-target" - "-src-runname" - "-diff-email" - "-sync-to" - "-pgsync" - "-kill-wait" ;; wait this long before removing test (default is 10 sec) - "-diff-html" - - ;; wizards, area capture, setup new ... - "-extract-skeleton" - ) - (list "-h" "-help" "--help" - "-manual" - "-version" - "-force" - "-xterm" - "-showkeys" - "-show-keys" - "-test-status" - "-set-values" - "-load-test-data" - "-summarize-items" - "-gui" - "-daemonize" - "-preclean" - "-rerun-clean" - "-rerun-all" - "-clean-cache" - "-no-cache" - "-cache-db" - "-cp-eventtime-to-publishtime" - "-use-db-cache" - "-prepend-contour" - - - ;; misc - "-repl" - "-lock" - "-unlock" - "-list-servers" - "-kill-servers" - "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) - "-one-pass" ;; - "-local" ;; run some commands using local db access - "-generate-html" - "-generate-html-structure" - "-list-run-time" - "-list-test-time" - - ;; misc queries - "-list-disks" - "-list-targets" - "-list-db-targets" - "-show-runconfig" - "-show-config" - "-show-cmdinfo" - "-get-run-status" - "-list-waivers" - - ;; queries - "-test-paths" ;; get path(s) to a test, ordered by youngest first - - "-runall" ;; run all tests, respects -testpatt, defaults to % - "-run" ;; alias for -runall - "-remove-runs" - "-kill-runs" - "-kill-rerun" - "-keep-records" ;; use with -remove-runs to remove only the run data - "-rebuild-db" - "-cleanup-db" - "-rollup" - "-update-meta" - "-create-megatest-area" - "-mark-incompletes" - - "-convert-to-norm" - "-convert-to-old" - "-import-megatest.db" - "-sync-to-megatest.db" - "-sync-brute-force" - "-logging" - "-v" ;; verbose 2, more than normal (normal is 1) - "-q" ;; quiet 0, errors/warnings only - - "-diff-rep" - - "-syscheck" - "-obfuscate" - ;; junk placeholder - ;; "-:p" - - ) - args:arg-hash - 0)) - -;; Add args that use remargs here -;; -(if (and (not (null? remargs)) - (not (or - (args:get-arg "-runstep") - (args:get-arg "-envcap") - (args:get-arg "-envdelta") - ) - )) - (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) - -;; before doing anything else change to the start-dir if provided -;; -(if (args:get-arg "-start-dir") - (if (common:file-exists? (args:get-arg "-start-dir")) - (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) - (setenv "PWD" fullpath) - (change-directory fullpath)) - (begin - (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") - (exit 1)))) - -;; immediately set MT_TARGET if -reqtarg or -target are available -;; -(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) - (if targ (setenv "MT_TARGET" targ))) - -;; The watchdog is to keep an eye on things like db sync etc. -;; + Megatest, documentation at http://www.kiatoa.com/fossils/megatest + version " megatest-version " + license GPL, Copyright Matt Welland 2006-2017 + + Usage: megatest [options] + -h : this help + -manual : show the Megatest user manual + -version : print megatest version (currently " megatest-version ") + + Launching and managing runs + -run : run all tests or as specified by -testpatt + -remove-runs : remove the data for a run, requires -runname and -testpatt + Optionally use :state and :status, use -keep-records to remove only + the run data. Use -kill-wait to override the 10 second + per test wait after kill delay (e.g. -kill-wait 0). + -kill-runs : kill existing run(s) (all incomplete tests killed) + -kill-rerun : kill an existing run (all incomplete tests killed and run is rerun) + -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs + -rerun FAIL,WARN... : force re-run for tests with specificed status(s) + -rerun-clean : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a + and then run the specified testpatt with -preclean + -rerun-all : set all tests to NOT_STARTED,n/a and run with -preclean + -lock : lock run specified by target and runname + -unlock : unlock run specified by target and runname + -set-run-status status : sets status for run to status, requires -target and -runname + -get-run-status : gets status for run specified by target and runname + -run-wait : wait on run specified by target and runname + -preclean : remove the existing test directory before running the test + -clean-cache : remove the cached megatest.config and runconfigs.config files + -no-cache : do not use the cached config files. + -one-pass : launch as many tests as you can but do not wait for more to be ready + -remove-keep N : remove all but N most recent runs per target; use '-actions, -age, -precmd' + -age : 120d,3h,20m to apply only to runs older than the + specified age. NB// M=month, m=minute + -actions [,...] : actions to take; print,remove-runs,archive,kill-runs + -precmd : insert a wrapper command in front of the commands run + + Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) + -target key1/key2/... : run for key1, key2, etc. + -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfigs + -testpatt patt1/patt2,patt3/... : % is wildcard + -runname : required, name for this particular test run + -state : Applies to runs, tests or steps depending on context + -status : Applies to runs, tests or steps depending on context + -modepatt key : load testpatt from 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) + -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 + -set-values : update or set values in the testdata table + :category : set the category field (optional) + :variable : set the variable name (optional) + :value : value measured (required) + :expected : value expected (required) + :tol : |value-expect| <= tol (required, can be <, >, >=, <= or number) + :units : name of the units for value, expected_value etc. (optional) + -load-test-data : read test specific data for storage in the test_data table + from standard in. Each line is comma delimited with four + fields category,variable,value,comment + + Queries + -list-runs patt : list runs matching pattern \"patt\", % is the wildcard + -show-keys : show the keys used in this megatest setup + -test-files targpatt : get the most recent test path/file matching targpatt e.g. %/% or '*.log' + returns list sorted by age ascending, see examples below + -test-paths : get the test paths matching target, runname, item and test + patterns. + -list-disks : list the disks available for storing runs + -list-targets : list the targets in runconfigs.config + -list-db-targets : list the target combinations used in the db + -show-config : dump the internal representation of the megatest.config file + -show-runconfig : dump the internal representation of the runconfigs.config file + -dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line) + -show-cmdinfo : dump the command info for a test (run in test environment) + -section sectionName + -var varName : for config and runconfig lookup value for sectionName varName + -since N : get list of runs changed since time N (Unix seconds) + -fields fieldspec : fields to include in json dump; runs:id,runame+tests:testname+steps + -sort fieldname : in -list-runs sort tests by this field + -testdata-csv [categorypatt/]varpatt : dump testdata for given category + + Misc + -start-dir path : switch to this directory before running megatest + -contour cname : add a level of hierarcy to the linktree and run paths + -area-tag tagname : add a tag to an area while syncing to pgdb + -run-tag tagname : add a tag to a run while syncing to pgdb + -rebuild-db : bring the database schema up to date + -cleanup-db : remove any orphan records, vacuum the db + -import-megatest.db : push data from megatest.db to cache db files in /tmp/$USER + -sync-to-megatest.db : pull data from cache files in /tmp/$USER to megatest.db + -sync-to dest : sync to new postgresql central style database + -update-meta : update the tests metadata for all tests + -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are + overwritten by values set in config files. + -server -|hostname : start the server (reduces contention on megatest.db), use + - to automatically figure out hostname + -adjutant C,M : start the server/adjutant with allocated cores C and Mem M (Gig), + use 0,0 to auto use full machine + -transport http|rpc : use http or rpc for transport (default is http) + -log logfile : send stdout and stderr to logfile + -list-servers : list the servers + -kill-servers : kill all servers + -repl : start a repl (useful for extending megatest) + -load file.scm : load and run file.scm + -mark-incompletes : find and mark incomplete tests + -ping run-id|host:port : ping server, exit with 0 if found + -debug N|N,M,O... : enable debug 0-N or N and M and O ... + -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG + -config fname : override the megatest.config file with fname + -append-config fname : append fname to the megatest.config file + + Utilities + -env2file fname : write the environment to fname.csh and fname.sh + -envcap a : save current variables labeled as context 'a' in file envdat.db + -envdelta a-b : output enviroment delta from context a to context b to -o fname + set the output mode with -dumpmode csh, bash or ini + note: ini format will use calls to use curr and minimize path + -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 + -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 + -list-test-time : list time requered to complete each test in a run. It following following arguments + -runname -target -dumpmode + -syscheck : do some very basic checks; write access and space in tmp, home, runs, links and + is $DISPLAY valid + -list-waivers : dump waivers for specified target, runname, testpatt to stdout + + Diff report + -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname + and either -diff-email or -diff-html) + -src-target + -src-runname + -diff-email : comma separated list of email addresses to send diff report + -diff-html : path to html file to generate + + Spreadsheet generation + -extract-ods fname.ods : extract an open document spreadsheet from the database + -pathmod path : insert path, i.e. path/runame/itempath/logfile.html + will clear the field if no rundir/testname/itempath/logfile + if it contains forward slashes the path will be converted + to windows style + Getting started + -create-megatest-area : create a skeleton megatest area. You will be prompted for paths + -create-test testname : create a skeleton megatest test. You will be prompted for info + + Examples + + # Get test path, use '.' to get a single path or a specific path/file pattern + megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt% + + Called as " (string-intersperse (argv) " ") " + Version " megatest-version ", built from " megatest-fossil-hash )) + + ;; -gui : start a gui interface + ;; -config fname : override the runconfigs file with fname + + ;; process args + (define remargs (args:get-args + (argv) + (list "-runtests" ;; run a specific test + "-config" ;; override the config file name + "-append-config" + "-execute" ;; run the command encoded in the base64 parameter + "-step" + "-target" + "-reqtarg" + ":runname" + "-runname" + ":state" + "-state" + ":status" + "-status" + "-list-runs" + "-testdata-csv" + "-testpatt" + "--modepatt" + "-modepatt" + "-tagexpr" + "-itempatt" + "-setlog" + "-set-toplog" + "-runstep" + "-logpro" + "-m" + "-rerun" + + "-days" + "-rename-run" + "-to" + "-dest" + "-source" + "-time-stamp" + ;; values and messages + ":category" + ":variable" + ":value" + ":expected" + ":tol" + ":units" + + ;; misc + "-start-dir" + "-run-patt" + "-target-patt" + "-contour" + "-area-tag" + "-area" + "-run-tag" + "-server" + "-adjutant" + "-transport" + "-port" + "-extract-ods" + "-pathmod" + "-env2file" + "-envcap" + "-envdelta" + "-setvars" + "-set-state-status" + + ;; move runs stuff here + "-remove-keep" + "-set-run-status" + "-age" + + ;; archive + "-archive" + "-actions" + "-precmd" + "-include" + "-exclude-rx" + "-exclude-rx-from" + + "-debug" ;; for *verbosity* > 2 + "-debug-noprop" + "-create-test" + "-override-timeout" + "-test-files" ;; -test-paths is for listing all + "-load" ;; load and exectute a scheme file + "-section" + "-var" + "-dumpmode" + "-run-id" + "-ping" + "-refdb2dat" + "-o" + "-log" + "-sync-log" + "-since" + "-fields" + "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state + "-sort" + "-target-db" + "-source-db" + "-prefix-target" + + "-src-target" + "-src-runname" + "-diff-email" + "-sync-to" + "-pgsync" + "-kill-wait" ;; wait this long before removing test (default is 10 sec) + "-diff-html" + + ;; wizards, area capture, setup new ... + "-extract-skeleton" + ) + (list "-h" "-help" "--help" + "-manual" + "-version" + "-force" + "-xterm" + "-showkeys" + "-show-keys" + "-test-status" + "-set-values" + "-load-test-data" + "-summarize-items" + "-gui" + "-daemonize" + "-preclean" + "-rerun-clean" + "-rerun-all" + "-clean-cache" + "-no-cache" + "-cache-db" + "-cp-eventtime-to-publishtime" + "-use-db-cache" + "-prepend-contour" + + + ;; misc + "-repl" + "-lock" + "-unlock" + "-list-servers" + "-kill-servers" + "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) + "-one-pass" ;; + "-local" ;; run some commands using local db access + "-generate-html" + "-generate-html-structure" + "-list-run-time" + "-list-test-time" + + ;; misc queries + "-list-disks" + "-list-targets" + "-list-db-targets" + "-show-runconfig" + "-show-config" + "-show-cmdinfo" + "-get-run-status" + "-list-waivers" + + ;; queries + "-test-paths" ;; get path(s) to a test, ordered by youngest first + + "-runall" ;; run all tests, respects -testpatt, defaults to % + "-run" ;; alias for -runall + "-remove-runs" + "-kill-runs" + "-kill-rerun" + "-keep-records" ;; use with -remove-runs to remove only the run data + "-rebuild-db" + "-cleanup-db" + "-rollup" + "-update-meta" + "-create-megatest-area" + "-mark-incompletes" + + "-convert-to-norm" + "-convert-to-old" + "-import-megatest.db" + "-sync-to-megatest.db" + "-sync-brute-force" + "-logging" + "-v" ;; verbose 2, more than normal (normal is 1) + "-q" ;; quiet 0, errors/warnings only + + "-diff-rep" + + "-syscheck" + "-obfuscate" + ;; junk placeholder + ;; "-:p" + + ) + args:arg-hash + 0)) + + ;; Add args that use remargs here + ;; + (if (and (not (null? remargs)) + (not (or + (args:get-arg "-runstep") + (args:get-arg "-envcap") + (args:get-arg "-envdelta") + ) + )) + (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) + + ;; before doing anything else change to the start-dir if provided + ;; + (if (args:get-arg "-start-dir") + (if (common:file-exists? (args:get-arg "-start-dir")) + (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) + (setenv "PWD" fullpath) + (change-directory fullpath)) + (begin + (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (exit 1)))) + + ;; immediately set MT_TARGET if -reqtarg or -target are available + ;; + (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) + (if targ (setenv "MT_TARGET" targ))) + + ;; The watchdog is to keep an eye on things like db sync etc. + ;; + +(define (debug:setup) + (let ((debugstr (or (args:get-arg "-debug") + (args:get-arg "-debug-noprop") + (getenv "MT_DEBUG_MODE")))) + (set! *verbosity* (debug:calc-verbosity debugstr 'q)) + (debug:check-verbosity *verbosity* debugstr) + ;; if we were handed a bad verbosity rule then we will override it with 1 and continue + (if (not *verbosity*)(set! *verbosity* 1)) + (if (and (not (args:get-arg "-debug-noprop")) + (or (args:get-arg "-debug") + (not (getenv "MT_DEBUG_MODE")))) + (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) + (string-intersperse (map conc *verbosity*) ",") + (conc *verbosity*)))))) + +;; check verbosity, #t is ok +(define (debug:check-verbosity verbosity vstr) + (if (not (or (number? verbosity) + (list? verbosity))) + (begin + (print "ERROR: Invalid debug value \"" vstr "\"") + #f) + #t)) + +;; (define (debug:debug-mode n) +;; (cond +;; ((and (number? *verbosity*) ;; number number +;; (number? n)) +;; (<= n *verbosity*)) +;; ((and (list? *verbosity*) ;; list number +;; (number? n)) +;; (member n *verbosity*)) +;; ((and (list? *verbosity*) ;; list list +;; (list? n)) +;; (not (null? (lset-intersection! eq? *verbosity* n)))) +;; ((and (number? *verbosity*) +;; (list? n)) +;; (member *verbosity* n)))) ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage (define *watchdog* (make-thread (lambda () (handle-exceptions @@ -504,489 +731,490 @@ (print-call-chain) (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) (common:watchdog))) "Watchdog thread")) -;;(if (not (args:get-arg "-server")) -;; (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog -(let* ((no-watchdog-args - '("-list-runs" - "-testdata-csv" - "-list-servers" - "-server" - "-adjutant" - "-list-disks" - "-list-targets" - "-show-runconfig" - ;;"-list-db-targets" - "-show-runconfig" - "-show-config" - "-show-cmdinfo" - "-cleanup-db" - )) - (no-watchdog-argvals (list '("-archive" . "replicate-db"))) - (start-watchdog-specail-arg-val (let loop ((hed (car no-watchdog-argvals)) - (tail (cdr no-watchdog-argvals))) - ;; (print "hed" hed " arg " (args:get-arg (car hed)) " val:" (cdr hed) " eql" (equal? (args:get-arg (car hed)) (cdr hed))) - (if (equal? (args:get-arg (car hed)) (cdr hed)) - #f - (if (null? tail) - #t - (loop (car tail) (cdr tail)))))) - (no-watchdog-args-vals (filter (lambda (x) x) - (map args:get-arg no-watchdog-args))) - (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val))) - ;(print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog) - (if start-watchdog - (thread-start! *watchdog*))) - - -;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions -(define (open-logfile logpath-in) - (condition-case - (let* ((log-dir (or (pathname-directory logpath-in) ".")) - (fname (pathname-strip-directory logpath-in)) - (logpath (if (> (string-length fname) 250) - (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log"))) - (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf) - newlogf) - logpath-in))) - (if (not (directory-exists? log-dir)) - (system (conc "mkdir -p " log-dir))) - (open-output-file logpath)) - (exn () - (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath) - (define *didsomething* #t) - (exit 1)))) - -;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not -;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation -;; where (launch:setup) returns #f? -;; -(if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server - (handle-exceptions - exn - (begin - (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) - ) - (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified - (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name - (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log"))) - (oup (open-logfile logf))) - (if (not (args:get-arg "-log")) - (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log - (debug:print-info 0 *default-log-port* "Sending log output to " logf) - (set! *default-log-port* oup)))) - -(if (or (args:get-arg "-h") - (args:get-arg "-help") - (args:get-arg "--help")) - (begin - (print help) - (exit))) - -(if (args:get-arg "-manual") - (let* ((htmlviewercmd (or (configf:lookup *configdat* "setup" "htmlviewercmd") - (common:which '("firefox" "arora")))) - (install-home (common:get-install-area)) - (manual-html (conc install-home "/share/docs/megatest_manual.html"))) - (if (and install-home - (common:file-exists? manual-html)) - (system (conc "(" htmlviewercmd " " manual-html " ) &")) - (system (conc "(" htmlviewercmd " http://www.kiatoa.com/cgi-bin/fossils/megatest/doc/tip/docs/manual/megatest_manual.html ) &"))) - (exit))) - -(if (args:get-arg "-version") - (begin - (print (common:version-signature)) ;; (print megatest-version) - (exit))) - -(define *didsomething* #f) - -;; Overall exit handling setup immediately -;; -(if (or (args:get-arg "-process-reap")) - ;; (args:get-arg "-runtests") - ;; (args:get-arg "-execute") - ;; (args:get-arg "-remove-runs") - ;; (args:get-arg "-runstep")) - (let ((original-exit (exit-handler))) - (exit-handler (lambda (#!optional (exit-code 0)) - (printf "Preparing to exit with exit code ~A ...\n" exit-code) - (for-each - - (lambda (pid) - (handle-exceptions - exn - (begin - (printf "process reap failed. exn=~A\n" exn) - #t) - (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) - (if (or (eq? pid-val pid) - (eq? pid-val 0)) - (begin - (printf "Sending signal/term to ~A\n" pid) - (process-signal pid signal/term)))))) - (process:children #f)) - (original-exit exit-code))))) - -;; for some switches always print the command to stderr -;; -(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun") - (debug:print 0 *default-log-port* (string-intersperse (argv) " "))) - -;; some switches imply homehost. Exit here if not on homehost -;; -(let ((homehost-required (list "-cleanup-db" "-server"))) - (if (apply args:any? homehost-required) - (if (not (common:on-homehost?)) - (for-each - (lambda (switch) - (if (args:get-arg switch) - (begin - (debug:print 0 *default-log-port* "ERROR: you must be on the homehost to run with " switch - ", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.") - (exit 1)))) - homehost-required)))) - -;;====================================================================== -;; Misc setup stuff -;;====================================================================== - -(debug:setup) - -(if (args:get-arg "-logging")(set! *logging* #t)) - -;;(if (debug:debug-mode 3) ;; we are obviously debugging -;; (set! open-run-close open-run-close-no-exception-handling)) - -(if (args:get-arg "-itempatt") - (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) - (debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) - (hash-table-set! args:arg-hash "-testpatt" newval) - (hash-table-delete! args:arg-hash "-itempatt"))) - -(if (args:get-arg "-runtests") - (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead")) - -(on-exit std-exit-procedure) - -;;====================================================================== -;; Misc general calls -;;====================================================================== - -(if (and (args:get-arg "-cache-db") - (args:get-arg "-source-db")) - (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_"))))) - (target-db (conc temp-dir "/cached.db")) - (source-db (args:get-arg "-source-db"))) - (db:cache-for-read-only source-db target-db) - (set! *didsomething* #t))) - -;; handle a clean-cache request as early as possible -;; -(if (args:get-arg "-clean-cache") - (let ((toppath (launch:setup))) - (set! *didsomething* #t) ;; suppress the help output. - (runs:clean-cache (common:args-get-target) - (args:get-arg "-runname") - toppath))) - -(if (args:get-arg "-env2file") - (begin - (save-environment-as-files (args:get-arg "-env2file")) - (set! *didsomething* #t))) - -(if (args:get-arg "-list-disks") - (let ((toppath (launch:setup))) - (print - (string-intersperse - (map (lambda (x) - (string-intersperse - x - " => ")) - (common:get-disks *configdat*)) - "\n")) - (set! *didsomething* #t))) - -;; csv processing record -(define (make-refdb:csv) - (vector - (make-sparse-array) - (make-hash-table) - (make-hash-table) - 0 - 0)) -(define-inline (refdb:csv-get-svec vec) (vector-ref vec 0)) -(define-inline (refdb:csv-get-rows vec) (vector-ref vec 1)) -(define-inline (refdb:csv-get-cols vec) (vector-ref vec 2)) -(define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3)) -(define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4)) -(define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val)) -(define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val)) -(define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val)) -(define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val)) -(define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val)) - -(define (get-dat results sheetname) - (or (hash-table-ref/default results sheetname #f) - (let ((tmp-vec (make-refdb:csv))) - (hash-table-set! results sheetname tmp-vec) - tmp-vec))) - -(if (args:get-arg "-refdb2dat") - (let* ((input-db (args:get-arg "-refdb2dat")) - (out-file (args:get-arg "-o")) - (out-fmt (or (args:get-arg "-dumpmode") "scheme")) - (out-port (if (and out-file - (not (member out-fmt '("sqlite3" "csv")))) - (open-output-file out-file) - (current-output-port))) - (res-data (configf:read-refdb input-db)) - (data (car res-data)) - (msg (cadr res-data))) - (if (not data) - (debug:print 0 *default-log-port* "Bad input? data=" data) ;; some error occurred - (with-output-to-port out-port - (lambda () - (case (string->symbol out-fmt) - ((scheme)(pp data)) - ((perl) - ;; (print "%hash = (") - ;; key1 => 'value1', - ;; key2 => 'value2', - ;; key3 => 'value3', - ;; ); - (configf:map-all-hier-alist - data - (lambda (sheetname sectionname varname val) - (print "$data{\"" sheetname "\"}{\"" sectionname "\"}{\"" varname "\"} = \"" val "\";")))) - ((python ruby) - (print "data={}") - (configf:map-all-hier-alist - data - (lambda (sheetname sectionname varname val) - (print "data[\"" sheetname "\"][\"" sectionname "\"][\"" varname "\"] = \"" val "\"")) - initproc1: - (lambda (sheetname) - (print "data[\"" sheetname "\"] = {}")) - initproc2: - (lambda (sheetname sectionname) - (print "data[\"" sheetname "\"][\"" sectionname "\"] = {}")))) - ((csv) - (let* ((results (make-hash-table)) ;; (make-sparse-array))) - (row-cols (make-hash-table))) ;; hash of hashes where section => ht { row- => num or col- => num - ;; (print "data=") - ;; (pp data) - (configf:map-all-hier-alist - data - (lambda (sheetname sectionname varname val) - ;; (print "sheetname: " sheetname ", sectionname: " sectionname ", varname: " varname ", val: " val) - (let* ((dat (get-dat results sheetname)) - (vec (refdb:csv-get-svec dat)) - (rownames (refdb:csv-get-rows dat)) - (colnames (refdb:csv-get-cols dat)) - (currrown (hash-table-ref/default rownames varname #f)) - (currcoln (hash-table-ref/default colnames sectionname #f)) - (rown (or currrown - (let* ((lastn (refdb:csv-get-maxrow dat)) - (newrown (+ lastn 1))) - (refdb:csv-set-maxrow! dat newrown) - newrown))) - (coln (or currcoln - (let* ((lastn (refdb:csv-get-maxcol dat)) - (newcoln (+ lastn 1))) - (refdb:csv-set-maxcol! dat newcoln) - newcoln)))) - (if (not (sparse-array-ref vec 0 coln)) ;; (eq? rown 0) - (begin - (sparse-array-set! vec 0 coln sectionname) - ;; (print "sparse-array-ref " 0 "," coln "=" (sparse-array-ref vec 0 coln)) - )) - (if (not (sparse-array-ref vec rown 0)) ;; (eq? coln 0) - (begin - (sparse-array-set! vec rown 0 varname) - ;; (print "sparse-array-ref " rown "," 0 "=" (sparse-array-ref vec rown 0)) - )) - (if (not currrown)(hash-table-set! rownames varname rown)) - (if (not currcoln)(hash-table-set! colnames sectionname coln)) - ;; (print "dat=" dat ", rown=" rown ", coln=" coln) - (sparse-array-set! vec rown coln val) - ;; (print "sparse-array-ref " rown "," coln "=" (sparse-array-ref vec rown coln)) - ))) - (for-each - (lambda (sheetname) - (let* ((sheetdat (get-dat results sheetname)) - (svec (refdb:csv-get-svec sheetdat)) - (maxrow (refdb:csv-get-maxrow sheetdat)) - (maxcol (refdb:csv-get-maxcol sheetdat)) - (fname (if out-file - (string-substitute "%s" sheetname out-file) ;; "/foo/bar/%s.csv") - (conc sheetname ".csv")))) - (with-output-to-file fname - (lambda () - ;; (print "Sheetname: " sheetname) - (let loop ((row 0) - (col 0) - (curr-row '()) - (result '())) - (let* ((val (sparse-array-ref svec row col)) - (disp-val (if val - (conc "\"" val "\"") - ""))) - (if (> col 0)(display ",")) - (display disp-val) - (cond - ((> row maxrow)(display "\n") result) - ((>= col maxcol) - (display "\n") - (loop (+ row 1) 0 '() (append result (list curr-row)))) - (else - (loop row (+ col 1) (append curr-row (list val)) result))))))))) - (hash-table-keys results)))) - ((sqlite3) - (let* ((db-file (or out-file (pathname-file input-db))) - (db-exists (common:file-exists? db-file)) - (db (sqlite3:open-database db-file))) - (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);")) - (configf:map-all-hier-alist - data - (lambda (sheetname sectionname varname val) - (sqlite3:execute db - "INSERT OR REPLACE INTO data (sheet,section,var,val) VALUES (?,?,?,?);" - sheetname sectionname varname val))) - (sqlite3:finalize! db))) - (else - (pp data)))))) - (if out-file (close-output-port out-port)) - (exit) ;; yes, bending the rules here - need to exit since this is a utility - )) - -(if (args:get-arg "-ping") - (let* ((server-id (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":" - (host:port (args:get-arg "-ping"))) - (server:ping (or server-id host:port) #f do-exit: #t))) - -;;====================================================================== -;; Capture, save and manipulate environments -;;====================================================================== - -;; NOTE: Keep these above the section where the server or client code is setup - -(let ((envcap (args:get-arg "-envcap"))) - (if envcap - (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs))))) - (env:save-env-vars db envcap) - (env:close-database db) - (set! *didsomething* #t)))) - -;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b -;; -(let ((envdelta (args:get-arg "-envdelta"))) - (if envdelta - (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta))) - (if (not (null? match)) - (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs)))) - ;; (resctx (cadr match)) - ;; (equn (caddr match)) - (parts match) ;; (string-split equn "-")) - (minuend (car parts)) - (subtraend (cadr parts)) - (added (env:get-added db minuend subtraend)) - (removed (env:get-removed db minuend subtraend)) - (changed (env:get-changed db minuend subtraend))) - ;; (pp (hash-table->alist added)) - ;; (pp (hash-table->alist removed)) - ;; (pp (hash-table->alist changed)) - (if (args:get-arg "-o") - (with-output-to-file - (args:get-arg "-o") - (lambda () - (env:print added removed changed))) - (env:print added removed changed)) - (env:close-database db) - (set! *didsomething* #t)) - (debug:print-error 0 *default-log-port* "Parameter to -envdelta should be new=start-end"))))) - -;;====================================================================== -;; Start the server - can be done in conjunction with -runall or -runtests (one day...) -;; we start the server if not running else start the client thread -;;====================================================================== - -;; Server? Start up here. -;; -(if (args:get-arg "-server") - (let ((tl (launch:setup)) - (transport-type (string->symbol (or (args:get-arg "-transport") "http")))) - (server:launch 0 transport-type) - (set! *didsomething* #t))) - -;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to -;; a specific Megatest area. Detail are being hashed out and this may change. -;; -(if (args:get-arg "-adjutant") - (begin - (adjutant-run) - (set! *didsomething* #t))) - -(if (or (args:get-arg "-list-servers") - (args:get-arg "-kill-servers")) - (let ((tl (launch:setup))) - (if tl ;; all roads from here exit - (let* ((servers (server:get-list *toppath*)) - (fmtstr "~8a~22a~20a~20a~8a\n")) - (format #t fmtstr "pid" "Interface:port" "age (hms)" "Last mod" "State") - (format #t fmtstr "===" "==============" "=========" "========" "=====") - (for-each ;; ( mod-time host port start-time pid ) - (lambda (server) - (let* ((mtm (any->number (car server))) - (mod (if mtm (- (current-seconds) mtm) "unk")) - (age (- (current-seconds)(or (any->number (list-ref server 3)) (current-seconds)))) - (url (conc (cadr server) ":" (caddr server))) - (pid (list-ref server 4)) - (alv (if (number? mod)(< mod 10) #f))) - (format #t - fmtstr - pid - url - (seconds->hr-min-sec age) - (seconds->hr-min-sec mod) - (if alv "alive" "dead")) - (if (and alv - (args:get-arg "-kill-servers")) - (begin - (debug:print-info 0 *default-log-port* "Attempting to kill server with pid " pid) - (server:kill server))))) - (sort servers (lambda (a b) - (let ((ma (or (any->number (car a)) 9e9)) - (mb (or (any->number (car b)) 9e9))) - (> ma mb))))) - ;; (debug:print-info 1 *default-log-port* "Done with listservers") - (set! *didsomething* #t) - (exit)) - (exit)))) - ;; must do, would have to add checks to many/all calls below - -;;====================================================================== -;; Weird special calls that need to run *after* the server has started? -;;====================================================================== - -(if (args:get-arg "-list-targets") - (if (launch:setup) - (let ((targets (common:get-runconfig-targets))) - ;; (debug:print 1 *default-log-port* "Found "(length targets) " targets") - (case (string->symbol (or (args:get-arg "-dumpmode") "alist")) - ((alist) - (for-each (lambda (x) - ;; (print "[" x "]")) - (print x)) - targets)) - ((json) - (json-write targets)) - (else - (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets"))) - (set! *didsomething* #t)))) + ;;(if (not (args:get-arg "-server")) + ;; (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog + (let* ((no-watchdog-args + '("-list-runs" + "-testdata-csv" + "-list-servers" + "-server" + "-adjutant" + "-list-disks" + "-list-targets" + "-show-runconfig" + ;;"-list-db-targets" + "-show-runconfig" + "-show-config" + "-show-cmdinfo" + "-cleanup-db" + )) + (no-watchdog-argvals (list '("-archive" . "replicate-db"))) + (start-watchdog-specail-arg-val (let loop ((hed (car no-watchdog-argvals)) + (tail (cdr no-watchdog-argvals))) + ;; (print "hed" hed " arg " (args:get-arg (car hed)) " val:" (cdr hed) " eql" (equal? (args:get-arg (car hed)) (cdr hed))) + (if (equal? (args:get-arg (car hed)) (cdr hed)) + #f + (if (null? tail) + #t + (loop (car tail) (cdr tail)))))) + (no-watchdog-args-vals (filter (lambda (x) x) + (map args:get-arg no-watchdog-args))) + (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val))) + ;(print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog) + (if start-watchdog + (thread-start! *watchdog*))) + + + ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions + (define (open-logfile logpath-in) + (condition-case + (let* ((log-dir (or (pathname-directory logpath-in) ".")) + (fname (pathname-strip-directory logpath-in)) + (logpath (if (> (string-length fname) 250) + (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log"))) + (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf) + newlogf) + logpath-in))) + (if (not (directory-exists? log-dir)) + (system (conc "mkdir -p " log-dir))) + (open-output-file logpath)) + (exn () + (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in) + (define *didsomething* #t) + (exit 1)))) + + ;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not + ;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation + ;; where (launch:setup) returns #f? + ;; + (if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server + (handle-exceptions + exn + (begin + (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) + ) + (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified + (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name + (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log"))) + (oup (open-logfile logf))) + (if (not (args:get-arg "-log")) + (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log + (debug:print-info 0 *default-log-port* "Sending log output to " logf) + (set! *default-log-port* oup)))) + + (if (or (args:get-arg "-h") + (args:get-arg "-help") + (args:get-arg "--help")) + (begin + (print help) + (exit))) + + (if (args:get-arg "-manual") + (let* ((htmlviewercmd (or (configf:lookup *configdat* "setup" "htmlviewercmd") + (common:which '("firefox" "arora")))) + (install-home (common:get-install-area)) + (manual-html (conc install-home "/share/docs/megatest_manual.html"))) + (if (and install-home + (common:file-exists? manual-html)) + (system (conc "(" htmlviewercmd " " manual-html " ) &")) + (system (conc "(" htmlviewercmd " http://www.kiatoa.com/cgi-bin/fossils/megatest/doc/tip/docs/manual/megatest_manual.html ) &"))) + (exit))) + + (if (args:get-arg "-version") + (begin + (print (common:version-signature)) ;; (print megatest-version) + (exit))) + + (define *didsomething* #f) + + ;; Overall exit handling setup immediately + ;; + (if (or (args:get-arg "-process-reap")) + ;; (args:get-arg "-runtests") + ;; (args:get-arg "-execute") + ;; (args:get-arg "-remove-runs") + ;; (args:get-arg "-runstep")) + (let ((original-exit (exit-handler))) + (exit-handler (lambda (#!optional (exit-code 0)) + (printf "Preparing to exit with exit code ~A ...\n" exit-code) + (for-each + + (lambda (pid) + (handle-exceptions + exn + (begin + (printf "process reap failed. exn=~A\n" exn) + #t) + (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) + (if (or (eq? pid-val pid) + (eq? pid-val 0)) + (begin + (printf "Sending signal/term to ~A\n" pid) + (process-signal pid signal/term)))))) + (process:children #f)) + (original-exit exit-code))))) + + ;; for some switches always print the command to stderr + ;; + (if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun") + (debug:print 0 *default-log-port* (string-intersperse (argv) " "))) + + ;; some switches imply homehost. Exit here if not on homehost + ;; + (let ((homehost-required (list "-cleanup-db" "-server"))) + (if (apply args:any? homehost-required) + (if (not (common:on-homehost?)) + (for-each + (lambda (switch) + (if (args:get-arg switch) + (begin + (debug:print 0 *default-log-port* "ERROR: you must be on the homehost to run with " switch + ", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.") + (exit 1)))) + homehost-required)))) + + ;;====================================================================== + ;; Misc setup stuff + ;;====================================================================== + + (debug:setup) + + (if (args:get-arg "-logging")(set! *logging* #t)) + + ;;(if (debug:debug-mode 3) ;; we are obviously debugging + ;; (set! open-run-close open-run-close-no-exception-handling)) + + (if (args:get-arg "-itempatt") + (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) + (debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) + (hash-table-set! args:arg-hash "-testpatt" newval) + (hash-table-delete! args:arg-hash "-itempatt"))) + + (if (args:get-arg "-runtests") + (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead")) + + (on-exit std-exit-procedure) + + ;;====================================================================== + ;; Misc general calls + ;;====================================================================== + + (if (and (args:get-arg "-cache-db") + (args:get-arg "-source-db")) + (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_"))))) + (target-db (conc temp-dir "/cached.db")) + (source-db (args:get-arg "-source-db"))) + (db:cache-for-read-only source-db target-db) + (set! *didsomething* #t))) + + ;; handle a clean-cache request as early as possible + ;; + (if (args:get-arg "-clean-cache") + (let ((toppath (launch:setup))) + (set! *didsomething* #t) ;; suppress the help output. + (runs:clean-cache (common:args-get-target) + (args:get-arg "-runname") + toppath))) + + (if (args:get-arg "-env2file") + (begin + (save-environment-as-files (args:get-arg "-env2file")) + (set! *didsomething* #t))) + + (if (args:get-arg "-list-disks") + (let ((toppath (launch:setup))) + (print + (string-intersperse + (map (lambda (x) + (string-intersperse + x + " => ")) + (common:get-disks *configdat*)) + "\n")) + (set! *didsomething* #t))) + + ;; csv processing record + (define (make-refdb:csv) + (vector + (make-sparse-array) + (make-hash-table) + (make-hash-table) + 0 + 0)) + (define-inline (refdb:csv-get-svec vec) (vector-ref vec 0)) + (define-inline (refdb:csv-get-rows vec) (vector-ref vec 1)) + (define-inline (refdb:csv-get-cols vec) (vector-ref vec 2)) + (define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3)) + (define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4)) + (define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val)) + (define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val)) + (define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val)) + (define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val)) + (define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val)) + + (define (get-dat results sheetname) + (or (hash-table-ref/default results sheetname #f) + (let ((tmp-vec (make-refdb:csv))) + (hash-table-set! results sheetname tmp-vec) + tmp-vec))) + + (if (args:get-arg "-refdb2dat") + (let* ((input-db (args:get-arg "-refdb2dat")) + (out-file (args:get-arg "-o")) + (out-fmt (or (args:get-arg "-dumpmode") "scheme")) + (out-port (if (and out-file + (not (member out-fmt '("sqlite3" "csv")))) + (open-output-file out-file) + (current-output-port))) + (res-data (configf:read-refdb input-db)) + (data (car res-data)) + (msg (cadr res-data))) + (if (not data) + (debug:print 0 *default-log-port* "Bad input? data=" data) ;; some error occurred + (with-output-to-port out-port + (lambda () + (case (string->symbol out-fmt) + ((scheme)(pp data)) + ((perl) + ;; (print "%hash = (") + ;; key1 => 'value1', + ;; key2 => 'value2', + ;; key3 => 'value3', + ;; ); + (configf:map-all-hier-alist + data + (lambda (sheetname sectionname varname val) + (print "$data{\"" sheetname "\"}{\"" sectionname "\"}{\"" varname "\"} = \"" val "\";")))) + ((python ruby) + (print "data={}") + (configf:map-all-hier-alist + data + (lambda (sheetname sectionname varname val) + (print "data[\"" sheetname "\"][\"" sectionname "\"][\"" varname "\"] = \"" val "\"")) + initproc1: + (lambda (sheetname) + (print "data[\"" sheetname "\"] = {}")) + initproc2: + (lambda (sheetname sectionname) + (print "data[\"" sheetname "\"][\"" sectionname "\"] = {}")))) + ((csv) + (let* ((results (make-hash-table)) ;; (make-sparse-array))) + (row-cols (make-hash-table))) ;; hash of hashes where section => ht { row- => num or col- => num + ;; (print "data=") + ;; (pp data) + (configf:map-all-hier-alist + data + (lambda (sheetname sectionname varname val) + ;; (print "sheetname: " sheetname ", sectionname: " sectionname ", varname: " varname ", val: " val) + (let* ((dat (get-dat results sheetname)) + (vec (refdb:csv-get-svec dat)) + (rownames (refdb:csv-get-rows dat)) + (colnames (refdb:csv-get-cols dat)) + (currrown (hash-table-ref/default rownames varname #f)) + (currcoln (hash-table-ref/default colnames sectionname #f)) + (rown (or currrown + (let* ((lastn (refdb:csv-get-maxrow dat)) + (newrown (+ lastn 1))) + (refdb:csv-set-maxrow! dat newrown) + newrown))) + (coln (or currcoln + (let* ((lastn (refdb:csv-get-maxcol dat)) + (newcoln (+ lastn 1))) + (refdb:csv-set-maxcol! dat newcoln) + newcoln)))) + (if (not (sparse-array-ref vec 0 coln)) ;; (eq? rown 0) + (begin + (sparse-array-set! vec 0 coln sectionname) + ;; (print "sparse-array-ref " 0 "," coln "=" (sparse-array-ref vec 0 coln)) + )) + (if (not (sparse-array-ref vec rown 0)) ;; (eq? coln 0) + (begin + (sparse-array-set! vec rown 0 varname) + ;; (print "sparse-array-ref " rown "," 0 "=" (sparse-array-ref vec rown 0)) + )) + (if (not currrown)(hash-table-set! rownames varname rown)) + (if (not currcoln)(hash-table-set! colnames sectionname coln)) + ;; (print "dat=" dat ", rown=" rown ", coln=" coln) + (sparse-array-set! vec rown coln val) + ;; (print "sparse-array-ref " rown "," coln "=" (sparse-array-ref vec rown coln)) + ))) + (for-each + (lambda (sheetname) + (let* ((sheetdat (get-dat results sheetname)) + (svec (refdb:csv-get-svec sheetdat)) + (maxrow (refdb:csv-get-maxrow sheetdat)) + (maxcol (refdb:csv-get-maxcol sheetdat)) + (fname (if out-file + (string-substitute "%s" sheetname out-file) ;; "/foo/bar/%s.csv") + (conc sheetname ".csv")))) + (with-output-to-file fname + (lambda () + ;; (print "Sheetname: " sheetname) + (let loop ((row 0) + (col 0) + (curr-row '()) + (result '())) + (let* ((val (sparse-array-ref svec row col)) + (disp-val (if val + (conc "\"" val "\"") + ""))) + (if (> col 0)(display ",")) + (display disp-val) + (cond + ((> row maxrow)(display "\n") result) + ((>= col maxcol) + (display "\n") + (loop (+ row 1) 0 '() (append result (list curr-row)))) + (else + (loop row (+ col 1) (append curr-row (list val)) result))))))))) + (hash-table-keys results)))) + ((sqlite3) + (let* ((db-file (or out-file (pathname-file input-db))) + (db-exists (common:file-exists? db-file)) + (db (sqlite3:open-database db-file))) + (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);")) + (configf:map-all-hier-alist + data + (lambda (sheetname sectionname varname val) + (sqlite3:execute db + "INSERT OR REPLACE INTO data (sheet,section,var,val) VALUES (?,?,?,?);" + sheetname sectionname varname val))) + (sqlite3:finalize! db))) + (else + (pp data)))))) + (if out-file (close-output-port out-port)) + (exit) ;; yes, bending the rules here - need to exit since this is a utility + )) + + (if (args:get-arg "-ping") + (let* ((server-id (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":" + (host:port (args:get-arg "-ping"))) + (server:ping (or server-id host:port) #f do-exit: #t))) + + ;;====================================================================== + ;; Capture, save and manipulate environments + ;;====================================================================== + + ;; NOTE: Keep these above the section where the server or client code is setup + + (let ((envcap (args:get-arg "-envcap"))) + (if envcap + (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs))))) + (env:save-env-vars db envcap) + (env:close-database db) + (set! *didsomething* #t)))) + + ;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b + ;; + (let ((envdelta (args:get-arg "-envdelta"))) + (if envdelta + (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta))) + (if (not (null? match)) + (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs)))) + ;; (resctx (cadr match)) + ;; (equn (caddr match)) + (parts match) ;; (string-split equn "-")) + (minuend (car parts)) + (subtraend (cadr parts)) + (added (env:get-added db minuend subtraend)) + (removed (env:get-removed db minuend subtraend)) + (changed (env:get-changed db minuend subtraend))) + ;; (pp (hash-table->alist added)) + ;; (pp (hash-table->alist removed)) + ;; (pp (hash-table->alist changed)) + (if (args:get-arg "-o") + (with-output-to-file + (args:get-arg "-o") + (lambda () + (env:print added removed changed))) + (env:print added removed changed)) + (env:close-database db) + (set! *didsomething* #t)) + (debug:print-error 0 *default-log-port* "Parameter to -envdelta should be new=start-end"))))) + + ;;====================================================================== + ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) + ;; we start the server if not running else start the client thread + ;;====================================================================== + + ;; Server? Start up here. + ;; + (if (args:get-arg "-server") + (let ((tl (launch:setup)) + (transport-type (string->symbol (or (args:get-arg "-transport") "http")))) + (server:launch 0 transport-type) + (set! *didsomething* #t))) + + ;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to + ;; a specific Megatest area. Detail are being hashed out and this may change. + ;; + (if (args:get-arg "-adjutant") + (begin + (adjutant-run) + (set! *didsomething* #t))) + + (if (or (args:get-arg "-list-servers") + (args:get-arg "-kill-servers")) + (let ((tl (launch:setup))) + (if tl ;; all roads from here exit + (let* ((servers (server:get-list *toppath*)) + (fmtstr "~8a~22a~20a~20a~8a\n")) + (format #t fmtstr "pid" "Interface:port" "age (hms)" "Last mod" "State") + (format #t fmtstr "===" "==============" "=========" "========" "=====") + (for-each ;; ( mod-time host port start-time pid ) + (lambda (server) + (let* ((mtm (any->number (car server))) + (mod (if mtm (- (current-seconds) mtm) "unk")) + (age (- (current-seconds)(or (any->number (list-ref server 3)) (current-seconds)))) + (url (conc (cadr server) ":" (caddr server))) + (pid (list-ref server 4)) + (alv (if (number? mod)(< mod 10) #f))) + (format #t + fmtstr + pid + url + (seconds->hr-min-sec age) + (seconds->hr-min-sec mod) + (if alv "alive" "dead")) + (if (and alv + (args:get-arg "-kill-servers")) + (begin + (debug:print-info 0 *default-log-port* "Attempting to kill server with pid " pid) + (server:kill server))))) + (sort servers (lambda (a b) + (let ((ma (or (any->number (car a)) 9e9)) + (mb (or (any->number (car b)) 9e9))) + (> ma mb))))) + ;; (debug:print-info 1 *default-log-port* "Done with listservers") + (set! *didsomething* #t) + (exit)) + (exit)))) + ;; must do, would have to add checks to many/all calls below + + ;;====================================================================== + ;; Weird special calls that need to run *after* the server has started? + ;;====================================================================== + + (if (args:get-arg "-list-targets") + (if (launch:setup) + (let ((targets (common:get-runconfig-targets))) + ;; (debug:print 1 *default-log-port* "Found "(length targets) " targets") + (case (string->symbol (or (args:get-arg "-dumpmode") "alist")) + ((alist) + (for-each (lambda (x) + ;; (print "[" x "]")) + (print x)) + targets)) + ((json) + (json-write targets)) + (else + (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets"))) + (set! *didsomething* #t)))) + ;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig ;; (define (full-runconfigs-read) ;; in the envprocessing branch the below code replaces the further below code @@ -993,18 +1221,17 @@ ;; (if (eq? *configstatus* 'fulldata) ;; *runconfigdat* ;; (begin ;; (launch:setup) ;; *runconfigdat*))) - (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME")) (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")) #f)) (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f))) (if (and cfgf (common:file-exists? cfgf) - (file-write-access? cfgf) + (file-writable? cfgf) (common:use-cache?)) (configf:read-alist cfgf) (let* ((keys (rmt:get-keys)) (target (common:args-get-target)) (key-vals (if target (keys:target->keyval keys target) #f)) @@ -1017,1538 +1244,1545 @@ key-vals)) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) (runconfig:read (conc *toppath* "/runconfigs.config") target #f)))) (if (and rundir ;; have all needed variabless (directory-exists? rundir) - (file-write-access? rundir)) + (file-writable? rundir)) (begin (if (not (common:in-running-test?)) (configf:write-alist data cfgf)) ;; force re-read of megatest.config - this resolves circular references between megatest.config (launch:setup force-reread: #t) ;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW. )) ;; we can safely cache megatest.config since we have a valid runconfig data)))) - -(if (args:get-arg "-show-runconfig") - (let ((tl (launch:setup))) - (push-directory *toppath*) - (let ((data (full-runconfigs-read))) - ;; keep this one local - (cond - ((and (args:get-arg "-section") - (args:get-arg "-var")) - (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")) - (configf:lookup data "default" (args:get-arg "-var"))))) - (if val (print val)))) - ((or (not (args:get-arg "-dumpmode")) - (string=? (args:get-arg "-dumpmode") "ini")) - (configf:config->ini data)) - ((string=? (args:get-arg "-dumpmode") "sexp") - (pp (hash-table->alist data))) - ((string=? (args:get-arg "-dumpmode") "json") - (json-write data)) - (else - (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) - (set! *didsomething* #t)) - (pop-directory))) - -(if (args:get-arg "-show-config") - (let ((tl (launch:setup)) - (data *configdat*)) ;; (read-config "megatest.config" #f #t))) - (push-directory *toppath*) - ;; keep this one local - (cond - ((and (args:get-arg "-section") - (args:get-arg "-var")) - (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")))) - (if val (print val)))) - - ;; print just a section if only -section - - ((equal? (args:get-arg "-dumpmode") "sexp") - (pp (hash-table->alist data))) - ((equal? (args:get-arg "-dumpmode") "json") - (json-write data)) - ((or (not (args:get-arg "-dumpmode")) - (string=? (args:get-arg "-dumpmode") "ini")) - (configf:config->ini data)) - (else - (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) - (set! *didsomething* #t) - (pop-directory) - (set! *time-to-exit* #t))) - -(if (args:get-arg "-show-cmdinfo") - (if (or (args:get-arg ":value")(getenv "MT_CMDINFO")) - (let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO"))))) - (if (equal? (args:get-arg "-dumpmode") "json") - (json-write data) - (pp data)) - (set! *didsomething* #t)) - (debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set"))) - -;;====================================================================== -;; Remove old run(s) -;;====================================================================== - -;; since several actions can be specified on the command line the removal -;; is done first -(define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default" - (let* ((runrec (runs:runrec-make-record)) - (target (or target-in (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target - (runname (or runname-in - (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls - (testpatt (or (args:get-arg "-testpatt") - (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH - (common:get-full-test-name)) - (and (eq? action 'kill-runs) - "%/%") ;; I'm just guessing that this is correct :( - (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt"))) - ))) ;; - (cond - ((not target) - (debug:print-error 0 *default-log-port* "Missing required parameter for " - action ", you must specify -target or -reqtarg") - (exit 1)) - ((not runname) - (debug:print-error 0 *default-log-port* "Missing required parameter for " - action ", you must specify the run name pattern with -runname patt") - (exit 2)) - ((not testpatt) - (debug:print-error 0 *default-log-port* "Missing required parameter for " - action ", you must specify the test pattern with -testpatt") - (exit 3)) - (else - (if (not (car *configinfo*)) - (begin - (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found") - (exit 1)) - ;; put test parameters into convenient variables - (begin - ;; check for correct version, exit with message if not correct - (common:exit-on-version-changed) - (runs:operate-on action - target - runname - testpatt - state: (common:args-get-state) - status: (common:args-get-status) - new-state-status: (args:get-arg "-set-state-status") - mode: mode))) - (set! *didsomething* #t))))) - -(if (args:get-arg "-kill-runs") - (general-run-call - "-kill-runs" - "kill runs" - (lambda (target runname keys keyvals) - (operate-on 'kill-runs mode: #f) - ))) - -(if (args:get-arg "-kill-rerun") - (let* ((target-patt (common:args-get-target)) - (runname-patt (args:get-arg "-runname"))) - (cond ((not target-patt) - (debug:print-error 0 *default-log-port* "Missing target, must specify target for -kill-rerun with -target ") - (exit 1)) - ((not runname-patt) - (debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname ") - (exit 1)) - ((string-search "[ ,%]" target-patt) - (debug:print-error 0 *default-log-port* "Invalid target ["target-patt"], must specify exact target (no wildcards) for -kill-rerun with -target ") - (exit 1)) - ((string-search "[ ,%]" runname-patt) - (debug:print-error 0 *default-log-port* "Invalid runname ["runname-patt"], must specify exact runname (no wildcards) for -kill-rerun with -runname ") - (exit 1)) - (else - (general-run-call - "-kill-runs" - "kill runs" - (lambda (target runname keys keyvals) - (operate-on 'kill-runs mode: #f) - )) - - (thread-sleep! 15)) - ;; fall thru and let "-run" loop fire - ))) - - -(if (args:get-arg "-remove-runs") - (general-run-call - "-remove-runs" - "remove runs" - (lambda (target runname keys keyvals) - (operate-on 'remove-runs mode: (if (args:get-arg "-keep-records") - 'remove-data-only - 'remove-all))))) - -(if (args:get-arg "-remove-keep") - (general-run-call - "-remove-keep" - "remove keep" - (lambda (target runname keys keyvals) - (let ((actions (map string->symbol - (string-split - (or (args:get-arg "-actions") - "print") - ",")))) ;; default to printing the output - (runs:remove-all-but-last-n-runs-per-target target runname - (string->number (args:get-arg "-remove-keep")) - actions: actions))))) - -(if (args:get-arg "-set-state-status") - (general-run-call - "-set-state-status" - "set state and status" - (lambda (target runname keys keyvals) - (operate-on 'set-state-status)))) - -(if (or (args:get-arg "-set-run-status") - (args:get-arg "-get-run-status")) - (general-run-call - "-set-run-status" - "set run status" - (lambda (target runname keys keyvals) - (let* ((runsdat (rmt:get-runs-by-patt keys runname - (common:args-get-target) - #f #f #f #f)) - (header (vector-ref runsdat 0)) - (rows (vector-ref runsdat 1))) - (if (null? rows) - (begin - (debug:print-info 0 *default-log-port* "No matching run found.") - (exit 1)) - (let* ((row (car (vector-ref runsdat 1))) - (run-id (db:get-value-by-header row header "id"))) - (if (args:get-arg "-set-run-status") - (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m")) - (print (rmt:get-run-status run-id)) - ))))))) - -;;====================================================================== -;; Query runs -;;====================================================================== - -;; -fields runs:id,target,runname,comment+tests:id,testname,item_path+steps -;; -;; csi> (extract-fields-constraints "runs:id,target,runname,comment+tests:id,testname,item_path+steps") -;; => (("runs" "id" "target" "runname" "comment") ("tests" "id" "testname" "item_path") ("steps")) -;; -;; NOTE: remember that the cdr will be the list you expect (cdr ("runs" "id" "target" "runname" "comment")) => ("id" "target" "runname" "comment") -;; and so alist-ref will yield what you expect -;; -(define (extract-fields-constraints fields-spec) - (map (lambda (table-spec) ;; runs:id,target,runname - (let ((dat (string-split table-spec ":"))) ;; ("runs" "id,target,runname") - (if (> (length dat) 1) - (cons (car dat)(string-split (cadr dat) ",")) ;; "id,target,runname" - dat))) - (string-split fields-spec "+"))) - -(define (get-value-by-fieldname datavec test-field-index fieldname) - (let ((indx (hash-table-ref/default test-field-index fieldname #f))) - (if indx - (if (>= indx (vector-length datavec)) - #f ;; index too high, should raise an error I suppose - (vector-ref datavec indx)) - #f))) - - - - - -(when (args:get-arg "-testdata-csv") - (if (launch:setup) - (let* ((keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) - (runpatt (or (args:get-arg "-runname") "%")) - (testpatt (common:args-get-testpatt #f)) - (datapatt (args:get-arg "-testdata-csv")) - (match-data (string-match "^([^/]+)/(.*)" (args:get-arg "-testdata-csv"))) - (categorypatt (if match-data (list-ref match-data 1) "%")) - (setvarpatt (if match-data - (list-ref match-data 2) - (args:get-arg "-testdata-csv"))) - (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") - (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) - (header (db:get-header runsdat)) - (access-mode (db:get-access-mode)) - (testpatt (common:args-get-testpatt #f)) - (fields-spec (if (args:get-arg "-fields") - (extract-fields-constraints (args:get-arg "-fields")) - (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count"))) - (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path") - (list "steps" "id" "stepname")))) - (tests-spec (let ((t (alist-ref "tests" fields-spec equal?))) - (if (and t (null? t)) ;; all fields - db:test-record-fields - t))) - (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) - (test-field-index (make-hash-table)) - (runs (db:get-rows runsdat)) - ) - (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec - (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec))) - (if (null? invalid-tests-spec) - ;; generate the lookup map test-field-name => index-number - (let loop ((hed (car adj-tests-spec)) - (tal (cdr adj-tests-spec)) - (idx 0)) - (hash-table-set! test-field-index hed idx) - (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1)))) - (begin - (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) - (exit))))) - (let* ((table-header (string-split "target,run,test,itempath,category,var,value,comment" ",")) - (table-rows - (apply append (map - (lambda (run) - (let* ((target (string-intersperse (map (lambda (x) - (db:get-value-by-header run header x)) - keys) "/")) - (statuses (string-split (or (args:get-arg "-status") "") ",")) - (run-id (db:get-value-by-header run header "id")) - (runname (db:get-value-by-header run header "runname")) - (states (string-split (or (args:get-arg "-state") "") ",")) - (tests (if tests-spec - (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc - ;; use qryvals if test-spec provided - (if tests-spec - (string-intersperse adj-tests-spec ",") - ;; db:test-record-fields - #f) - #f - 'normal) - '()))) - (apply append - (map - (lambda (test) - (let* ( - (test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test)) - (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test)) - (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test)) - (fullname (conc testname - (if (equal? itempath "") - "" - (conc "/" itempath )))) - (testdat-raw (map vector->list (rmt:read-test-data-varpatt run-id test-id categorypatt setvarpatt))) - (testdat (filter - (lambda (x) - (not (equal? "logpro" - (list-ref x 10)))) - testdat-raw))) - (map - (lambda (item) - (receive (id test_id category - variable value expected - tol units comment status type) - (apply values item) - (list target runname testname itempath category variable value comment))) - testdat))) - tests)))) - runs)))) - (print (string-join table-header ",")) - (for-each (lambda(table-row) - (print (string-join (map ->string table-row) ","))) - - - table-rows)))) - (set! *didsomething* #t) - (set! *time-to-exit* #t)) - - - -;; NOTE: list-runs and list-db-targets operate on local db!!! -;; -;; IDEA: megatest list -runname blah% ... -;; -(if (or (args:get-arg "-list-runs") - (args:get-arg "-list-db-targets")) - (if (launch:setup) - (let* (;; (dbstruct (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local"))) - (runpatt (args:get-arg "-list-runs")) - (access-mode (db:get-access-mode)) - (testpatt (common:args-get-testpatt #f)) - ;; (if (args:get-arg "-testpatt") - ;; (args:get-arg "-testpatt") - ;; "%")) - (keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) - ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) - ;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) - ;; #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) - (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") - (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) - (runstmp (db:get-rows runsdat)) - (header (db:get-header runsdat)) - ;; this is "-since" support. This looks at last mod times of .db files - ;; and collects those modified since the -since time. - (runs runstmp) - ;; (if (and (not (null? runstmp)) - ;; (args:get-arg "-since")) - ;; (let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since"))))) - ;; (let loop ((hed (car runstmp)) - ;; (tal (cdr runstmp)) - ;; (res '())) - ;; (let ((new-res (if (member (db:get-value-by-header hed header "id") changed-ids) - ;; (cons hed res) - ;; res))) - ;; (if (null? tal) - ;; (reverse new-res) - ;; (loop (car tal)(cdr tal) new-res))))) - ;; runstmp)) - (db-targets (args:get-arg "-list-db-targets")) - (seen (make-hash-table)) - (dmode (let ((d (args:get-arg "-dumpmode"))) ;; json, sexpr - (if d (string->symbol d) #f))) - (data (make-hash-table)) - (fields-spec (if (args:get-arg "-fields") - (extract-fields-constraints (args:get-arg "-fields")) - (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count"))) - (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path") - (list "steps" "id" "stepname")))) - (runs-spec (let ((r (alist-ref "runs" fields-spec equal?))) ;; the check is now unnecessary - (if (and r (not (null? r))) r (list "id" )))) - (tests-spec (let ((t (alist-ref "tests" fields-spec equal?))) - (if (and t (null? t)) ;; all fields - db:test-record-fields - t))) - (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id")))) - (steps-spec (alist-ref "steps" fields-spec equal?)) - (test-field-index (make-hash-table))) - (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec - (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec))) - (if (null? invalid-tests-spec) - ;; generate the lookup map test-field-name => index-number - (let loop ((hed (car adj-tests-spec)) - (tal (cdr adj-tests-spec)) - (idx 0)) - (hash-table-set! test-field-index hed idx) - (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1)))) - (begin - (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) - (exit))))) - ;; Each run - (for-each - (lambda (run) - (let ((targetstr (string-intersperse (map (lambda (x) - (db:get-value-by-header run header x)) - keys) "/"))) - (if db-targets - (if (not (hash-table-ref/default seen targetstr #f)) - (begin - (hash-table-set! seen targetstr #t) - ;; (print "[" targetstr "]")))) - (if (not dmode) - (print targetstr) - (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '()))) - ))) - (let* ((run-id (db:get-value-by-header run header "id")) - (runname (db:get-value-by-header run header "runname")) - (states (string-split (or (args:get-arg "-state") "") ",")) - (statuses (string-split (or (args:get-arg "-status") "") ",")) - (tests (if tests-spec - (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc - ;; use qryvals if test-spec provided - (if tests-spec - (string-intersperse adj-tests-spec ",") - ;; db:test-record-fields - #f) - #f - 'normal) - '()))) - (case dmode - ((json ods sexpr) - (if runs-spec - (for-each - (lambda (field-name) - (mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name)) - runs-spec))) - ;; (mutils:hierhash-set! data (db:get-value-by-header run header "status") targetstr runname "meta" "status" ) - ;; (mutils:hierhash-set! data (db:get-value-by-header run header "state") targetstr runname "meta" "state" ) - ;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id")) targetstr runname "meta" "id" ) - ;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" ) - ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) - ;; ;; add last entry twice - seems to be a bug in hierhash? - ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) - (else - (if (null? runs-spec) - (print "Run: " targetstr "/" runname - " status: " (db:get-value-by-header run header "state") - " run-id: " run-id ", number tests: " (length tests) - " event_time: " (db:get-value-by-header run header "event_time")) - (begin - (if (not (member "target" runs-spec)) - ;; (display (conc "Target: " targetstr)) - (display (conc "Run: " targetstr "/" runname " "))) - (for-each - (lambda (field-name) - (if (equal? field-name "target") - (display (conc "target: " targetstr " ")) - (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " ")))) - runs-spec) - (newline))))) - - (for-each - (lambda (test) - (common:debug-handle-exceptions #f - exn - (begin - (debug:print-error 0 *default-log-port* "Bad data in test record? " test) - (debug:print-error 5 *default-log-port* "exn=" (condition->list exn)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (print-call-chain (current-error-port))) - (let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test)) - (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test)) - (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test)) - (comment (if (member "comment" tests-spec)(get-value-by-fieldname test test-field-index "comment" ) #f)) ;; (db:test-get-comment test)) - (tstate (if (member "state" tests-spec)(get-value-by-fieldname test test-field-index "state" ) #f)) ;; (db:test-get-state test)) - (tstatus (if (member "status" tests-spec)(get-value-by-fieldname test test-field-index "status" ) #f)) ;; (db:test-get-status test)) - (event-time (if (member "event_time" tests-spec)(get-value-by-fieldname test test-field-index "event_time" ) #f)) ;; (db:test-get-event_time test)) - (rundir (if (member "rundir" tests-spec)(get-value-by-fieldname test test-field-index "rundir" ) #f)) ;; (db:test-get-rundir test)) - (final_logf (if (member "final_logf" tests-spec)(get-value-by-fieldname test test-field-index "final_logf" ) #f)) ;; (db:test-get-final_logf test)) - (run_duration (if (member "run_duration" tests-spec)(get-value-by-fieldname test test-field-index "run_duration") #f)) ;; (db:test-get-run_duration test)) - (fullname (conc testname - (if (equal? itempath "") - "" - (conc "(" itempath ")"))))) - (case dmode - ((json ods sexpr) - (if tests-spec - (for-each - (lambda (field-name) - (mutils:hierhash-set! data (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name)) - tests-spec))) - ;; ;; (mutils:hierhash-set! data fullname targetstr runname "data" (conc test-id) "tname" ) - ;; (mutils:hierhash-set! data testname targetstr runname "data" (conc test-id) "testname" ) - ;; (mutils:hierhash-set! data itempath targetstr runname "data" (conc test-id) "itempath" ) - ;; (mutils:hierhash-set! data comment targetstr runname "data" (conc test-id) "comment" ) - ;; (mutils:hierhash-set! data tstate targetstr runname "data" (conc test-id) "state" ) - ;; (mutils:hierhash-set! data tstatus targetstr runname "data" (conc test-id) "status" ) - ;; (mutils:hierhash-set! data rundir targetstr runname "data" (conc test-id) "rundir" ) - ;; (mutils:hierhash-set! data final_logf targetstr runname "data" (conc test-id) "final_logf") - ;; (mutils:hierhash-set! data run_duration targetstr runname "data" (conc test-id) "run_duration") - ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time") - ;; ;; add last entry twice - seems to be a bug in hierhash? - ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time") - ;; ) - (else - (if (and tstate tstatus event-time) - (format #t - " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" - (if fullname fullname "") - (if tstate tstate "") - (if tstatus tstatus "") - (get-value-by-fieldname test test-field-index "run_duration");;(if test (db:test-get-run_duration test) "") - (if event-time event-time "") - (get-value-by-fieldname test test-field-index "host")) ;;(if test (db:test-get-host test)) "") - (print " Test: " fullname - (if tstate (conc " State: " tstate) "") - (if tstatus (conc " Status: " tstatus) "") - (if (get-value-by-fieldname test test-field-index "run_duration") - (conc " Runtime: " (get-value-by-fieldname test test-field-index "run_duration")) - "") - (if event-time (conc " Time: " event-time) "") - (if (get-value-by-fieldname test test-field-index "host") - (conc " Host: " (get-value-by-fieldname test test-field-index "host")) - ""))) - (if (not (or (equal? (get-value-by-fieldname test test-field-index "status") "PASS") - (equal? (get-value-by-fieldname test test-field-index "status") "WARN") - (equal? (get-value-by-fieldname test test-field-index "state") "NOT_STARTED"))) - (begin - (print (if (get-value-by-fieldname test test-field-index "cpuload") - (conc " cpuload: " (get-value-by-fieldname test test-field-index "cpuload")) - "") ;; (db:test-get-cpuload test) - (if (get-value-by-fieldname test test-field-index "diskfree") - (conc "\n diskfree: " (get-value-by-fieldname test test-field-index "diskfree")) ;; (db:test-get-diskfree test) - "") - (if (get-value-by-fieldname test test-field-index "uname") - (conc "\n uname: " (get-value-by-fieldname test test-field-index "uname")) ;; (db:test-get-uname test) - "") - (if (get-value-by-fieldname test test-field-index "rundir") - (conc "\n rundir: " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test) - "") -;; "\n rundir: " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* -;; (db:test-get-rundir test) ;; ) - ) - ;; Each test - ;; DO NOT remote run - (let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) - (for-each - (lambda (step) - (format #t - " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" - (tdb:step-get-stepname step) - (tdb:step-get-state step) - (tdb:step-get-status step) - (tdb:step-get-event_time step))) - steps))))))))) - (if (args:get-arg "-sort") - (sort tests - (lambda (a-test b-test) - (let* ((key (args:get-arg "-sort")) - (first (get-value-by-fieldname a-test test-field-index key)) - (second (get-value-by-fieldname b-test test-field-index key))) - ((cond - ((and (number? first)(number? second)) <) - ((and (string? first)(string? second)) string<=?) - (else equal?)) - first second)))) - tests)))))) - runs) - (case dmode - ((json) (json-write data)) - ((sexpr) (pp (common:to-alist data)))) - (let* ((metadat-fields (delete-duplicates - (append keys '( "runname" "time" "owner" "pass_count" "fail_count" "state" "status" "comment" "id")))) - (run-fields '( - "testname" - "item_path" - "state" - "status" - "comment" - "event_time" - "host" - "run_id" - "run_duration" - "attemptnum" - "id" - "archived" - "diskfree" - "cpuload" - "final_logf" - "shortdir" - "rundir" - "uname" - ) - ) - (newdat (common:to-alist data)) - (allrundat (if (null? newdat) - '() - (car (map cdr newdat)))) ;; (car (map cdr (car (map cdr newdat))))) - (runs (append - (list "runs" ;; sheetname - metadat-fields) - (map (lambda (run) - ;; (print "run: " run) - (let* ((runname (car run)) - (rundat (cdr run)) - (metadat (let ((tmp (assoc "meta" rundat))) - (if tmp (cdr tmp) #f)))) - ;; (print "runname: " runname "\n\nrundat: " )(pp rundat)(print "\n\nmetadat: ")(pp metadat) - (if metadat - (map (lambda (field) - (let ((tmp (assoc field metadat))) - (if tmp (cdr tmp) ""))) - metadat-fields) - (begin - (debug:print 0 *default-log-port* "WARNING: meta data for run " runname " not found") - '())))) - allrundat))) - ;; '( ( "target" ( "runname" ( "data" ( "runid" ( "id . "37" ) ( ... )))) - (run-pages (map (lambda (targdat) - (let* ((target (car targdat)) - (runsdat (cdr targdat))) - (if runsdat - (map (lambda (rundat) - (let* ((runname (car rundat)) - (rundat (cdr rundat)) - (testsdat (let ((tmp (assoc "data" rundat))) - (if tmp (cdr tmp) #f)))) - (if testsdat - (let ((tests (map (lambda (test) - (let* ((test-id (car test)) - (test-dat (cdr test))) - (map (lambda (field) - (let ((tmp (assoc field test-dat))) - (if tmp (cdr tmp) ""))) - run-fields))) - testsdat))) - ;; (print "Target: " target "/" runname " tests:") - ;; (pp tests) - (cons (conc target "/" runname) - (cons (list (conc target "/" runname)) - (cons '() - (cons run-fields tests))))) - (begin - (debug:print 4 *default-log-port* "WARNING: run " target "/" runname " appears to have no data") - ;; (pp rundat) - '())))) - runsdat) - '()))) - newdat)) ;; we use newdat to get target - (sheets (filter (lambda (x) - (not (null? x))) - (cons runs (map car run-pages))))) - ;; (print "allrundat:") - ;; (pp allrundat) - ;; (print "runs:") - ;; (pp runs) - ;(print "sheets: ") - ;; (pp sheets) - (if (eq? dmode 'ods) - (let* ((tempdir (conc "/tmp/" (current-user-name) "/" (random 10000) "_" (current-process-id))) - (outputfile (or (args:get-arg "-o") "out.ods")) - (ouf (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path? - outputfile - (begin - (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") - (conc (current-directory) "/" outputfile))))) - (create-directory tempdir #t) - (ods:list->ods tempdir ouf sheets)))) - ;; (system (conc "rm -rf " tempdir)) - (set! *didsomething* #t) - (set! *time-to-exit* #t) - ) ;; end if true branch (end of a let) - ) ;; end if - ) ;; end if -list-runs - -;; list-waivers -(if (and (args:get-arg "-list-waivers") - (launch:setup)) - (let* ((runpatt (or (args:get-arg "-runname") "%")) - (testpatt (common:args-get-testpatt #f)) - (keys (rmt:get-keys)) - (runsdat (rmt:get-runs-by-patt - keys runpatt - (common:args-get-target) #f #f - '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) - (runs (db:get-rows runsdat)) - (header (db:get-header runsdat)) - (results (make-hash-table)) ;; [target] ( (testname/itempath . "comment") ... ) - (addtest (lambda (target testname itempath comment) - (hash-table-set! results target (cons (cons (conc testname "/" itempath) comment) - (hash-table-ref/default results target '()))))) - (last-target #f)) - (for-each - (lambda (run) - (let* ((run-id (db:get-value-by-header run header "id")) - (target (rmt:get-target run-id)) - (runname (db:get-value-by-header run header "runname")) - (tests (rmt:get-tests-for-run - run-id testpatt '("COMPLETED") '("WAIVED") #f #f #f 'testname 'asc ;; use qryvals if test-spec provided - #f #f #f))) - (if (not (equal? target last-target)) - (print "[" target "]")) - (set! last-target target) - (print "# " runname) - (for-each - (lambda (testdat) - (let* ((testfullname (conc (db:test-get-testname testdat) - (if (equal? "" (db:test-get-item-path testdat)) - "" - (conc "/" (db:test-get-item-path testdat))) - ))) - (print testfullname " " (db:test-get-comment testdat)))) - tests))) - runs) - (set! *didsomething* #t))) - -;;====================================================================== -;; full run -;;====================================================================== - -(define (handle-run-requests target runname keys keyvals need-clean) - (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct - ;; For rerun-clean do we or do we not support the testpatt? - (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states") - "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED")) - (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses") - "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED"))) - (hash-table-set! args:arg-hash "-preclean" #t) - (runs:operate-on 'set-state-status - target - (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") - (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") - state: states - ;; status: statuses - new-state-status: "NOT_STARTED,n/a") - (runs:clean-cache target runname *toppath*) - (runs:operate-on 'set-state-status - target - (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") - (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") - ;; state: states - status: statuses - new-state-status: "NOT_STARTED,n/a"))) - ;; RERUN ALL - (if (args:get-arg "-rerun-all") ;; first set states/statuses correct - (let* ((rconfig (full-runconfigs-read))) - (hash-table-set! args:arg-hash "-preclean" #t) - (runs:operate-on 'set-state-status - target - (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt") - state: #f - ;; status: statuses - new-state-status: "NOT_STARTED,n/a") - (runs:clean-cache target runname *toppath*) - (runs:operate-on 'set-state-status - target - (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt") - ;; state: states - status: #f - new-state-status: "NOT_STARTED,n/a"))) - (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) - (if x (string->number x) #f))) - (rerun-cnt (if config-reruns - config-reruns - 1))) - - (runs:run-tests target - runname - #f ;; (common:args-get-testpatt #f) - ;; (or (args:get-arg "-testpatt") - ;; "%") - user - args:arg-hash - run-count: rerun-cnt))) - -;; get lock in db for full run for this directory -;; for all tests with deps -;; walk tree of tests to find head tasks -;; add head tasks to task queue -;; add dependant tasks to task queue -;; add remaining tasks to task queue -;; for each task in task queue -;; if have adequate resources -;; launch task -;; else -;; put task in deferred queue -;; if still ok to run tasks -;; process deferred tasks per above steps - -;; run all tests are are Not COMPLETED and PASS or CHECK -(if (or (args:get-arg "-runall") - (args:get-arg "-run") - (args:get-arg "-rerun-clean") - (args:get-arg "-rerun-all") - (args:get-arg "-runtests") - (args:get-arg "-kill-rerun")) - (let ((need-clean (or (args:get-arg "-rerun-clean") - (args:get-arg "-rerun-all"))) - (orig-cmdline (string-intersperse (argv) " "))) - (general-run-call - "-runall" - "run all tests" - (lambda (target runname keys keyvals) - (if (or (string-search "%" target) - (string-search "%" runname)) ;; we are being asked to re-run multiple runs - (let* ((run-specs (rmt:simple-get-runs runname #f #f target #f))) ;; list of simple-run records - (debug:print-info 0 *default-log-port* "Pattern supplied for target or runname with " - (length run-specs) " matches round. Running each in turn.") - (if (null? run-specs) - (debug:print 0 *default-log-port* "WARNING: No runs match target " target " and runname " runname)) - (for-each (lambda (spec) - (let* ((precmd (if (args:get-arg "-precmd")(conc (args:get-arg "-precmd") " ") "")) - (newcmdline (conc - precmd - (string-substitute - (conc "target " target) - (conc "target " (simple-run-target spec)) - (string-substitute - (conc "runname " runname) - (conc "runname " (simple-run-runname spec)) - orig-cmdline))))) - (debug:print 0 *default-log-port* "ORIG: " orig-cmdline) - (debug:print 0 *default-log-port* "NEW: " newcmdline) - (system newcmdline))) - run-specs)) - (handle-run-requests target runname keys keyvals need-clean)))))) - -;;====================================================================== -;; run one test -;;====================================================================== - -;; 1. find the config file -;; 2. change to the test directory -;; 3. update the db with "test started" status, set running host -;; 4. process launch the test -;; - monitor the process, update stats in the db every 2^n minutes -;; 5. as the test proceeds internally it calls megatest as each step is -;; started and completed -;; - step started, timestamp -;; - step completed, exit status, timestamp -;; 6. test phone home -;; - if test run time > allowed run time then kill job -;; - if cannot access db > allowed disconnect time then kill job - -;; == duplicated == (if (or (args:get-arg "-run")(args:get-arg "-runtests")) -;; == duplicated == (general-run-call -;; == duplicated == "-runtests" -;; == duplicated == "run a test" -;; == duplicated == (lambda (target runname keys keyvals) -;; == duplicated == ;; -;; == duplicated == ;; May or may not implement it this way ... -;; == duplicated == ;; -;; == duplicated == ;; Insert this run into the tasks queue -;; == duplicated == ;; (open-run-close tasks:add tasks:open-db -;; == duplicated == ;; "runtests" -;; == duplicated == ;; user -;; == duplicated == ;; target -;; == duplicated == ;; runname -;; == duplicated == ;; (args:get-arg "-runtests") -;; == duplicated == ;; #f)))) -;; == duplicated == (runs:run-tests target -;; == duplicated == runname -;; == duplicated == (common:args-get-testpatt #f) ;; (args:get-arg "-runtests") -;; == duplicated == user -;; == duplicated == args:arg-hash)))) - -;;====================================================================== -;; Rollup into a run -;;====================================================================== - -(if (args:get-arg "-rollup") - (general-run-call - "-rollup" - "rollup tests" - (lambda (target runname keys keyvals) - (runs:rollup-run keys - keyvals - (or (args:get-arg "-runname")(args:get-arg ":runname") ) - user)))) - -;;====================================================================== -;; Lock or unlock a run -;;====================================================================== - -(if (or (args:get-arg "-lock")(args:get-arg "-unlock")) - (general-run-call - (if (args:get-arg "-lock") "-lock" "-unlock") - "lock/unlock tests" - (lambda (target runname keys keyvals) - (runs:handle-locking - target - keys - (or (args:get-arg "-runname")(args:get-arg ":runname") ) - (args:get-arg "-lock") - (args:get-arg "-unlock") - user)))) - -;;====================================================================== -;; Get paths to tests -;;====================================================================== -;; Get test paths matching target, runname, and testpatt -(if (or (args:get-arg "-test-files")(args:get-arg "-test-paths")) - ;; if we are in a test use the MT_CMDINFO data - (if (getenv "MT_CMDINFO") - (let* ((startingdir (current-directory)) - (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) - (transport (assoc/default 'transport cmdinfo)) - (testpath (assoc/default 'testpath cmdinfo)) - (test-name (assoc/default 'test-name cmdinfo)) - (runscript (assoc/default 'runscript cmdinfo)) - (db-host (assoc/default 'db-host cmdinfo)) - (run-id (assoc/default 'run-id cmdinfo)) - (itemdat (assoc/default 'itemdat cmdinfo)) - (state (args:get-arg ":state")) - (status (args:get-arg ":status")) - ;;(target (args:get-arg "-target")) - (target (common:args-get-target)) - (toppath (assoc/default 'toppath cmdinfo))) - (change-directory toppath) - (if (not target) - (begin - (debug:print-error 0 *default-log-port* "-target is required.") - (exit 1))) - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, giving up on -test-paths or -test-files, exiting") - (exit 1))) - (let* ((keys (rmt:get-keys)) - ;; db:test-get-paths must not be run remote - (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) - (set! *didsomething* #t) - (for-each (lambda (path) - (if (common:file-exists? path) - (print path))) - paths))) - ;; else do a general-run-call - (general-run-call - "-test-files" - "Get paths to test" - (lambda (target runname keys keyvals) - (let* ((db #f) - ;; DO NOT run remote - (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) - (for-each (lambda (path) - (print path)) - paths)))))) - -;;====================================================================== -;; Archive tests -;;====================================================================== -;; Archive tests matching target, runname, and testpatt -(if (equal? (args:get-arg "-archive") "replicate-db") - (begin - ;; check if source - ;; check if megatest.db exist - (launch:setup) - (if (not (args:get-arg "-source")) - (begin - (debug:print-info 1 *default-log-port* "Missing required argument -source ") - (exit 1))) - (if (common:file-exists? (conc *toppath* "/megatest.db")) - (begin - (debug:print-info 1 *default-log-port* "File " (conc *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db") - (exit 1))) - (if (and (common:get-db-tmp-area) (> (length (directory (common:get-db-tmp-area) #f)) 0)) - (begin - (debug:print-info 1 *default-log-port* (common:get-db-tmp-area) " not empty. Please remove it before trying to replicate db") - (exit 1))) - ;; check if timestamp - (let* ((source (args:get-arg "-source")) - (src (if (not (equal? (substring source 0 1) "/")) - (conc (current-directory) "/" source) - source)) - (ts (if (args:get-arg "-time-stamp") (args:get-arg "-time-stamp") "latest"))) - (if (common:directory-exists? src) - (begin - (archive:restore-db src ts) - (set! *didsomething* #t)) - (begin - (debug:print-error 1 *default-log-port* "Path " source " not found") - (exit 1)))))) - ;; else do a general-run-call - (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicate-db"))) - (begin - ;; for the archive get we need to preserve the starting dir as part of the target path - (if (and (args:get-arg "-dest") - (not (equal? (substring (args:get-arg "-dest") 0 1) "/"))) - (let ((newpath (conc (current-directory) "/" (args:get-arg "-dest")))) - (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath) - (hash-table-set! args:arg-hash "-dest" newpath))) - (general-run-call - "-archive" - "Archive" - (lambda (target runname keys keyvals) - (operate-on 'archive target-in: target runname-in: runname ))))) - -;;====================================================================== -;; Extract a spreadsheet from the runs database -;;====================================================================== - -(if (args:get-arg "-extract-ods") - (general-run-call - "-extract-ods" - "Make ods spreadsheet" - (lambda (target runname keys keyvals) - (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) - (outputfile (args:get-arg "-extract-ods")) - (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname"))) - (pathmod (args:get-arg "-pathmod"))) - ;; (keyvalalist (keys->alist keys "%"))) - (debug:print 2 *default-log-port* "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) - (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod) - (db:close-all dbstruct) - (set! *didsomething* #t))))) - -;;====================================================================== -;; execute the test -;; - gets called on remote host -;; - receives info from the -execute param -;; - passes info to steps via MT_CMDINFO env var (future is to use a dot file) -;; - gathers host info and -;;====================================================================== - -(if (args:get-arg "-execute") - (begin - (launch:execute (args:get-arg "-execute")) - (set! *didsomething* #t))) - -;;====================================================================== -;; recover from a test where the managing mtest was killed but the underlying -;; process might still be salvageable -;;====================================================================== - -(if (args:get-arg "-recover-test") - (let* ((params (string-split (args:get-arg "-recover-test") ","))) - (if (> (length params) 1) ;; run-id and test-id - (let ((run-id (string->number (car params))) - (test-id (string->number (cadr params)))) - (if (and run-id test-id) - (begin - (launch:recover-test run-id test-id) - (set! *didsomething* #t)) - (begin - (debug:print-error 0 *default-log-port* "bad run-id or test-id, must be integers") - (exit 1))))))) - -;;====================================================================== -;; Test commands (i.e. for use inside tests) -;;====================================================================== - -(define (megatest:step step state status logfile msg) - (if (not (getenv "MT_CMDINFO")) - (begin - (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") - (exit 5)) - (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) - (transport (assoc/default 'transport cmdinfo)) - (testpath (assoc/default 'testpath cmdinfo)) - (test-name (assoc/default 'test-name cmdinfo)) - (runscript (assoc/default 'runscript cmdinfo)) - (db-host (assoc/default 'db-host cmdinfo)) - (run-id (assoc/default 'run-id cmdinfo)) - (test-id (assoc/default 'test-id cmdinfo)) - (itemdat (assoc/default 'itemdat cmdinfo)) - (work-area (assoc/default 'work-area cmdinfo)) - (db #f)) - (change-directory testpath) - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - (exit 1))) - (if (and state status) - (let ((comment (launch:load-logpro-dat run-id test-id step))) - ;; (rmt:test-set-log! run-id test-id (conc stepname ".html")))) - (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile)) - (begin - (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step") - (exit 6)))))) - -(if (args:get-arg "-step") - (begin - (thread-sleep! 1.5) - (megatest:step - (args:get-arg "-step") - (or (args:get-arg "-state")(args:get-arg ":state")) - (or (args:get-arg "-status")(args:get-arg ":status")) - (args:get-arg "-setlog") - (args:get-arg "-m")) - ;; (if db (sqlite3:finalize! db)) - (set! *didsomething* #t) - (thread-sleep! 1.5))) - -(if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status - ;; (not (args:get-arg "-step"))) ;; -setlog may have been processed already in the "-step" previous - ;; NEW POLICY - -setlog sets test overall log on every call. - (args:get-arg "-set-toplog") - (args:get-arg "-test-status") - (args:get-arg "-set-values") - (args:get-arg "-load-test-data") - (args:get-arg "-runstep") - (args:get-arg "-summarize-items")) - (if (not (getenv "MT_CMDINFO")) - (begin - (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") - (exit 5)) - (let* ((startingdir (current-directory)) - (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) - (transport (assoc/default 'transport cmdinfo)) - (testpath (assoc/default 'testpath cmdinfo)) - (test-name (assoc/default 'test-name cmdinfo)) - (runscript (assoc/default 'runscript cmdinfo)) - (db-host (assoc/default 'db-host cmdinfo)) - (run-id (assoc/default 'run-id cmdinfo)) - (test-id (assoc/default 'test-id cmdinfo)) - (itemdat (assoc/default 'itemdat cmdinfo)) - (work-area (assoc/default 'work-area cmdinfo)) - (db #f) ;; (open-db)) - (state (args:get-arg ":state")) - (status (args:get-arg ":status")) - (stepname (args:get-arg "-step"))) - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - (exit 1))) - - (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area)) - (change-directory work-area) - ;; can setup as client for server mode now - ;; (client:setup) - - (if (args:get-arg "-load-test-data") - ;; has sub commands that are rdb: - ;; DO NOT put this one into either rmt: or open-run-close - (tdb:load-test-data run-id test-id)) - (if (args:get-arg "-setlog") - (let ((logfname (args:get-arg "-setlog"))) - (rmt:test-set-log! run-id test-id logfname))) - (if (args:get-arg "-set-toplog") - ;; DO NOT run remote - (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog"))) - (if (args:get-arg "-summarize-items") - ;; DO NOT run remote - (tests:summarize-items run-id test-id test-name #t)) ;; do force here - (if (args:get-arg "-runstep") - (if (null? remargs) - (begin - (debug:print-error 0 *default-log-port* "nothing specified to run!") - (if db (sqlite3:finalize! db)) - (exit 6)) - (let* ((stepname (args:get-arg "-runstep")) - (logprofile (args:get-arg "-logpro")) - (logfile (conc stepname ".log")) - (cmd (if (null? remargs) #f (car remargs))) - (params (if cmd (cdr remargs) '())) - (exitstat #f) - (shell (let ((sh (get-environment-variable "SHELL") )) - (if sh - (last (string-split sh "/")) - "bash"))) - (redir (case (string->symbol shell) - ((tcsh csh ksh) ">&") - ((zsh bash sh ash) "2>&1 >") - (else ">&"))) - (fullcmd (conc "(" (string-intersperse - (cons cmd params) " ") - ") " redir " " logfile))) - ;; mark the start of the test - (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile) - ;; run the test step - (debug:print-info 2 *default-log-port* "Running \"" fullcmd "\" in directory \"" startingdir) - (change-directory startingdir) - (set! exitstat (system fullcmd)) - (set! *globalexitstatus* exitstat) - ;; (change-directory testpath) - ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) - (if logprofile - (let* ((htmllogfile (conc stepname ".html")) - (oldexitstat exitstat) - (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) - (debug:print-info 2 *default-log-port* "running \"" cmd "\"") - (change-directory startingdir) - (set! exitstat (system cmd)) - (set! *globalexitstatus* exitstat) ;; no necessary - (change-directory testpath) - (rmt:test-set-log! run-id test-id htmllogfile))) - (let ((msg (args:get-arg "-m"))) - (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile)) - ))) - (if (or (args:get-arg "-test-status") - (args:get-arg "-set-values")) - (let ((newstatus (cond - ((number? status) (if (equal? status 0) "PASS" "FAIL")) - ((and (string? status) - (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL")) - (else status))) - ;; transfer relevant keys into a hash to be passed to test-set-status! - ;; could use an assoc list I guess. - (otherdata (let ((res (make-hash-table))) - (for-each (lambda (key) - (if (args:get-arg key) - (hash-table-set! res key (args:get-arg key)))) - (list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable")) - res))) - (if (and (args:get-arg "-test-status") - (or (not state) - (not status))) - (begin - (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -test-status\n" help) - (if (sqlite3:database? db)(sqlite3:finalize! db)) - (exit 6))) - (let* ((msg (args:get-arg "-m")) - (numoth (length (hash-table-keys otherdata)))) - ;; Convert to rpc inside the tests:test-set-status! call, not here - (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area)))) - (if (sqlite3:database? db)(sqlite3:finalize! db)) - (set! *didsomething* #t)))) - -;;====================================================================== -;; Various helper commands can go below here -;;====================================================================== - -(if (or (args:get-arg "-showkeys") - (args:get-arg "-show-keys")) - (let ((db #f) - (keys #f)) - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - (exit 1))) - (set! keys (rmt:get-keys)) ;; db)) - (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", ")) - (if (sqlite3:database? db)(sqlite3:finalize! db)) - (set! *didsomething* #t))) - -(if (args:get-arg "-gui") - (begin - (debug:print 0 *default-log-port* "Look at the dashboard for now") - ;; (megatest-gui) - (set! *didsomething* #t))) - -(if (args:get-arg "-create-megatest-area") - (begin - (genexample:mk-megatest.config) - (set! *didsomething* #t))) - -(if (args:get-arg "-create-test") - (let ((testname (args:get-arg "-create-test"))) - (genexample:mk-megatest-test testname) - (set! *didsomething* #t))) - -;;====================================================================== -;; Update the database schema, clean up the db -;;====================================================================== - -(if (args:get-arg "-rebuild-db") - (begin - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - (exit 1))) - ;; keep this one local - ;; (open-run-close patch-db #f) - (let ((dbstruct (db:setup #f areapath: *toppath*))) - (common:cleanup-db dbstruct full: #t)) - (set! *didsomething* #t))) - -(if (args:get-arg "-cleanup-db") - (begin - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - (exit 1))) - (let ((dbstruct (db:setup #f areapath: *toppath*))) - (common:cleanup-db dbstruct)) - (set! *didsomething* #t))) - -(if (args:get-arg "-mark-incompletes") - (begin - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - (exit 1))) - (open-run-close db:find-and-mark-incomplete #f) - (set! *didsomething* #t))) - -;;====================================================================== -;; Update the tests meta data from the testconfig files -;;====================================================================== - -(if (args:get-arg "-update-meta") - (begin - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - (exit 1))) - (runs:update-all-test_meta #f) - (set! *didsomething* #t))) - -;;====================================================================== -;; Start a repl -;;====================================================================== - -;; fakeout readline -(include "readline-fix.scm") - - -(when (args:get-arg "-diff-rep") - (when (and - (not (args:get-arg "-diff-html")) - (not (args:get-arg "-diff-email"))) - (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep") - (set! *didsomething* 1) - (exit 1)) - - (let* ((toppath (launch:setup))) - (do-diff-report - (args:get-arg "-src-target") - (args:get-arg "-src-runname") - (args:get-arg "-target") - (args:get-arg "-runname") - (args:get-arg "-diff-html") - (args:get-arg "-diff-email")) - (set! *didsomething* #t) - (exit 0))) - -(if (or (getenv "MT_RUNSCRIPT") - (args:get-arg "-repl") - (args:get-arg "-load")) - (let* ((toppath (launch:setup)) - (dbstruct (if (and toppath - (common:on-homehost?)) - (db:setup #t) - #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f))) - (if *toppath* - (cond - ((getenv "MT_RUNSCRIPT") - ;; How to run megatest scripts - ;; - ;; #!/bin/bash - ;; - ;; export MT_RUNSCRIPT=yes - ;; megatest << EOF - ;; (print "Hello world") - ;; (exit) - ;; EOF - - (repl)) - (else - (begin - (set! *db* dbstruct) - (import extras) ;; might not be needed - ;; (import csi) - (import readline) - (import apropos) - ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... - - (if *use-new-readline* - (begin - (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) - (current-input-port (make-readline-port "megatest> "))) - (begin - (gnu-history-install-file-manager - (string-append - (or (get-environment-variable "HOME") ".") "/.megatest_history")) - (current-input-port (make-gnu-readline-port "megatest> ")))) - (if (args:get-arg "-repl") - (repl) - (load (args:get-arg "-load"))) - ;; (db:close-all dbstruct) <= taken care of by on-exit call - ) - (exit))) - (set! *didsomething* #t)))) - -;;====================================================================== -;; Wait on a run to complete -;;====================================================================== - -(if (and (args:get-arg "-run-wait") - (not (or (args:get-arg "-run") - (args:get-arg "-runtests")))) ;; run-wait is built into runtests now - (begin - (if (not (launch:setup)) - (begin - (debug:print 0 *default-log-port* "Failed to setup, exiting") - (exit 1))) - (operate-on 'run-wait) - (set! *didsomething* #t))) - -;; ;; ;; redo me ;; Not converted to use dbstruct yet -;; ;; ;; redo me ;; -;; ;; ;; redo me (if (args:get-arg "-convert-to-norm") -;; ;; ;; redo me (let* ((toppath (setup-for-run)) -;; ;; ;; redo me (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t)))) -;; ;; ;; redo me (for-each -;; ;; ;; redo me (lambda (field) -;; ;; ;; redo me (let ((dat '())) -;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Getting data for field " field) -;; ;; ;; redo me (sqlite3:for-each-row -;; ;; ;; redo me (lambda (id val) -;; ;; ;; redo me (set! dat (cons (list id val) dat))) -;; ;; ;; redo me (db:get-db db run-id) -;; ;; ;; redo me (conc "SELECT id," field " FROM tests;")) -;; ;; ;; redo me (debug:print-info 0 *default-log-port* "found " (length dat) " items for field " field) -;; ;; ;; redo me (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;")))) -;; ;; ;; redo me (for-each -;; ;; ;; redo me (lambda (item) -;; ;; ;; redo me (let ((newval ;; (sdb:qry 'getid -;; ;; ;; redo me (cadr item))) ;; ) -;; ;; ;; redo me (if (not (equal? newval (cadr item))) -;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item))) -;; ;; ;; redo me (sqlite3:execute qry newval (car item)))) -;; ;; ;; redo me dat) -;; ;; ;; redo me (sqlite3:finalize! qry)))) -;; ;; ;; redo me (db:close-all dbstruct) -;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment")) -;; ;; ;; redo me (set! *didsomething* #t))) - -(if (args:get-arg "-import-megatest.db") - (begin - (db:multi-db-sync - (db:setup #f) - 'killservers - 'dejunk - 'adj-testids - 'old2new - ;; 'new2old - ) - (set! *didsomething* #t))) - -(when (args:get-arg "-sync-brute-force") - ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t)) - (set! *didsomething* #t)) - -(if (args:get-arg "-sync-to-megatest.db") - (let* ((dbstruct (db:setup #f)) - (tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct))) - (lockfile (conc tmpdbpth ".lock")) - (locked (common:simple-file-lock lockfile)) - (res (if locked - (db:multi-db-sync - dbstruct - 'new2old) - #f))) - (if res - (begin - (common:simple-file-release-lock lockfile) - (print "Synced " res " records to megatest.db")) - (print "Skipping sync, there is a sync in progress.")) - (set! *didsomething* #t))) - -(if (args:get-arg "-sync-to") - (let ((toppath (launch:setup))) - (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to")) - (set! *didsomething* #t))) - -(if (args:get-arg "-list-test-time") - (let* ((toppath (launch:setup))) - (task:get-test-times) - (set! *didsomething* #t))) - -(if (args:get-arg "-list-run-time") - (let* ((toppath (launch:setup))) - (task:get-run-times) - (set! *didsomething* #t))) - -(if (args:get-arg "-generate-html") - (let* ((toppath (launch:setup))) - (if (tests:create-html-tree #f) - (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page0.html") - (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) - (set! *didsomething* #t))) - -(if (args:get-arg "-generate-html-structure") - (let* ((toppath (launch:setup))) - ;(if (tests:create-html-tree #f) - (if (tests:create-html-summary #f) - (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html") - (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) - (set! *didsomething* #t))) - -(if (args:get-arg "-syscheck") - (begin - (mutils:syscheck common:raw-get-remote-host-load - server:get-best-guess-address - read-config) - (set! *didsomething* #t))) - -(if (args:get-arg "-extract-skeleton") - (let* ((toppath (launch:setup))) - (genexample:extract-skeleton-area (args:get-arg "-extract-skeleton")) - (set! *didsomething* #t))) - -;;====================================================================== -;; Exit and clean up -;;====================================================================== - -(if (not *didsomething*) - (debug:print 0 *default-log-port* help) - (set! *time-to-exit* #t) - ) -;;(debug:print-info 13 *default-log-port* "thread-join! watchdog") - -;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state) -;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead) -;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage -(if (thread? *watchdog*) - (case (thread-state *watchdog*) - ((ready running blocked sleeping terminated dead) - (thread-join! *watchdog*)))) - -(set! *time-to-exit* #t) - -(if (not (eq? *globalexitstatus* 0)) - (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall")) - (begin - (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) - (exit 0)) - (case *globalexitstatus* - ((0)(exit 0)) - ((1)(exit 1)) - ((2)(exit 2)) - (else (exit 3))))) + + (if (args:get-arg "-show-runconfig") + (let ((tl (launch:setup))) + (push-directory *toppath*) + (let ((data (full-runconfigs-read))) + ;; keep this one local + (cond + ((and (args:get-arg "-section") + (args:get-arg "-var")) + (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")) + (configf:lookup data "default" (args:get-arg "-var"))))) + (if val (print val)))) + ((or (not (args:get-arg "-dumpmode")) + (string=? (args:get-arg "-dumpmode") "ini")) + (configf:config->ini data)) + ((string=? (args:get-arg "-dumpmode") "sexp") + (pp (hash-table->alist data))) + ((string=? (args:get-arg "-dumpmode") "json") + (json-write data)) + (else + (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) + (set! *didsomething* #t)) + (pop-directory))) + + (if (args:get-arg "-show-config") + (let ((tl (launch:setup)) + (data *configdat*)) ;; (read-config "megatest.config" #f #t))) + (push-directory *toppath*) + ;; keep this one local + (cond + ((and (args:get-arg "-section") + (args:get-arg "-var")) + (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")))) + (if val (print val)))) + + ;; print just a section if only -section + + ((equal? (args:get-arg "-dumpmode") "sexp") + (pp (hash-table->alist data))) + ((equal? (args:get-arg "-dumpmode") "json") + (json-write data)) + ((or (not (args:get-arg "-dumpmode")) + (string=? (args:get-arg "-dumpmode") "ini")) + (configf:config->ini data)) + (else + (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) + (set! *didsomething* #t) + (pop-directory) + (set! *time-to-exit* #t))) + + (if (args:get-arg "-show-cmdinfo") + (if (or (args:get-arg ":value")(getenv "MT_CMDINFO")) + (let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO"))))) + (if (equal? (args:get-arg "-dumpmode") "json") + (json-write data) + (pp data)) + (set! *didsomething* #t)) + (debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set"))) + + ;;====================================================================== + ;; Remove old run(s) + ;;====================================================================== + + ;; since several actions can be specified on the command line the removal + ;; is done first + (define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default" + (let* ((runrec (runs:runrec-make-record)) + (target (or target-in (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target + (runname (or runname-in + (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls + (testpatt (or (args:get-arg "-testpatt") + (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH + (common:get-full-test-name)) + (and (eq? action 'kill-runs) + "%/%") ;; I'm just guessing that this is correct :( + (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt"))) + ))) ;; + (cond + ((not target) + (debug:print-error 0 *default-log-port* "Missing required parameter for " + action ", you must specify -target or -reqtarg") + (exit 1)) + ((not runname) + (debug:print-error 0 *default-log-port* "Missing required parameter for " + action ", you must specify the run name pattern with -runname patt") + (exit 2)) + ((not testpatt) + (debug:print-error 0 *default-log-port* "Missing required parameter for " + action ", you must specify the test pattern with -testpatt") + (exit 3)) + (else + (if (not (car *configinfo*)) + (begin + (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found") + (exit 1)) + ;; put test parameters into convenient variables + (begin + ;; check for correct version, exit with message if not correct + (common:exit-on-version-changed) + (runs:operate-on action + target + runname + testpatt + state: (common:args-get-state) + status: (common:args-get-status) + new-state-status: (args:get-arg "-set-state-status") + mode: mode))) + (set! *didsomething* #t))))) + + (if (args:get-arg "-kill-runs") + (general-run-call + "-kill-runs" + "kill runs" + (lambda (target runname keys keyvals) + (operate-on 'kill-runs mode: #f) + ))) + + (if (args:get-arg "-kill-rerun") + (let* ((target-patt (common:args-get-target)) + (runname-patt (args:get-arg "-runname"))) + (cond ((not target-patt) + (debug:print-error 0 *default-log-port* "Missing target, must specify target for -kill-rerun with -target ") + (exit 1)) + ((not runname-patt) + (debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname ") + (exit 1)) + ((string-search "[ ,%]" target-patt) + (debug:print-error 0 *default-log-port* "Invalid target ["target-patt"], must specify exact target (no wildcards) for -kill-rerun with -target ") + (exit 1)) + ((string-search "[ ,%]" runname-patt) + (debug:print-error 0 *default-log-port* "Invalid runname ["runname-patt"], must specify exact runname (no wildcards) for -kill-rerun with -runname ") + (exit 1)) + (else + (general-run-call + "-kill-runs" + "kill runs" + (lambda (target runname keys keyvals) + (operate-on 'kill-runs mode: #f) + )) + + (thread-sleep! 15)) + ;; fall thru and let "-run" loop fire + ))) + + + (if (args:get-arg "-remove-runs") + (general-run-call + "-remove-runs" + "remove runs" + (lambda (target runname keys keyvals) + (operate-on 'remove-runs mode: (if (args:get-arg "-keep-records") + 'remove-data-only + 'remove-all))))) + + (if (args:get-arg "-remove-keep") + (general-run-call + "-remove-keep" + "remove keep" + (lambda (target runname keys keyvals) + (let ((actions (map string->symbol + (string-split + (or (args:get-arg "-actions") + "print") + ",")))) ;; default to printing the output + (runs:remove-all-but-last-n-runs-per-target target runname + (string->number (args:get-arg "-remove-keep")) + actions: actions))))) + + (if (args:get-arg "-set-state-status") + (general-run-call + "-set-state-status" + "set state and status" + (lambda (target runname keys keyvals) + (operate-on 'set-state-status)))) + + (if (or (args:get-arg "-set-run-status") + (args:get-arg "-get-run-status")) + (general-run-call + "-set-run-status" + "set run status" + (lambda (target runname keys keyvals) + (let* ((runsdat (rmt:get-runs-by-patt keys runname + (common:args-get-target) + #f #f #f #f)) + (header (vector-ref runsdat 0)) + (rows (vector-ref runsdat 1))) + (if (null? rows) + (begin + (debug:print-info 0 *default-log-port* "No matching run found.") + (exit 1)) + (let* ((row (car (vector-ref runsdat 1))) + (run-id (db:get-value-by-header row header "id"))) + (if (args:get-arg "-set-run-status") + (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m")) + (print (rmt:get-run-status run-id)) + ))))))) + + ;;====================================================================== + ;; Query runs + ;;====================================================================== + + ;; -fields runs:id,target,runname,comment+tests:id,testname,item_path+steps + ;; + ;; csi> (extract-fields-constraints "runs:id,target,runname,comment+tests:id,testname,item_path+steps") + ;; => (("runs" "id" "target" "runname" "comment") ("tests" "id" "testname" "item_path") ("steps")) + ;; + ;; NOTE: remember that the cdr will be the list you expect (cdr ("runs" "id" "target" "runname" "comment")) => ("id" "target" "runname" "comment") + ;; and so alist-ref will yield what you expect + ;; + (define (extract-fields-constraints fields-spec) + (map (lambda (table-spec) ;; runs:id,target,runname + (let ((dat (string-split table-spec ":"))) ;; ("runs" "id,target,runname") + (if (> (length dat) 1) + (cons (car dat)(string-split (cadr dat) ",")) ;; "id,target,runname" + dat))) + (string-split fields-spec "+"))) + + (define (get-value-by-fieldname datavec test-field-index fieldname) + (let ((indx (hash-table-ref/default test-field-index fieldname #f))) + (if indx + (if (>= indx (vector-length datavec)) + #f ;; index too high, should raise an error I suppose + (vector-ref datavec indx)) + #f))) + + + + + + (when (args:get-arg "-testdata-csv") + (if (launch:setup) + (let* ((keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) + (runpatt (or (args:get-arg "-runname") "%")) + (testpatt (common:args-get-testpatt #f)) + (datapatt (args:get-arg "-testdata-csv")) + (match-data (string-match "^([^/]+)/(.*)" (args:get-arg "-testdata-csv"))) + (categorypatt (if match-data (list-ref match-data 1) "%")) + (setvarpatt (if match-data + (list-ref match-data 2) + (args:get-arg "-testdata-csv"))) + (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") + (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) + (header (db:get-header runsdat)) + (access-mode (db:get-access-mode)) + (testpatt (common:args-get-testpatt #f)) + (fields-spec (if (args:get-arg "-fields") + (extract-fields-constraints (args:get-arg "-fields")) + (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count"))) + (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path") + (list "steps" "id" "stepname")))) + (tests-spec (let ((t (alist-ref "tests" fields-spec equal?))) + (if (and t (null? t)) ;; all fields + db:test-record-fields + t))) + (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) + (test-field-index (make-hash-table)) + (runs (db:get-rows runsdat)) + ) + (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec + (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec))) + (if (null? invalid-tests-spec) + ;; generate the lookup map test-field-name => index-number + (let loop ((hed (car adj-tests-spec)) + (tal (cdr adj-tests-spec)) + (idx 0)) + (hash-table-set! test-field-index hed idx) + (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1)))) + (begin + (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) + (exit))))) + (let* ((table-header (string-split "target,run,test,itempath,category,var,value,comment" ",")) + (table-rows + (apply append (map + (lambda (run) + (let* ((target (string-intersperse (map (lambda (x) + (db:get-value-by-header run header x)) + keys) "/")) + (statuses (string-split (or (args:get-arg "-status") "") ",")) + (run-id (db:get-value-by-header run header "id")) + (runname (db:get-value-by-header run header "runname")) + (states (string-split (or (args:get-arg "-state") "") ",")) + (tests (if tests-spec + (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc + ;; use qryvals if test-spec provided + (if tests-spec + (string-intersperse adj-tests-spec ",") + ;; db:test-record-fields + #f) + #f + 'normal) + '()))) + (apply append + (map + (lambda (test) + (let* ( + (test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test)) + (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test)) + (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test)) + (fullname (conc testname + (if (equal? itempath "") + "" + (conc "/" itempath )))) + (testdat-raw (map vector->list (rmt:read-test-data-varpatt run-id test-id categorypatt setvarpatt))) + (testdat (filter + (lambda (x) + (not (equal? "logpro" + (list-ref x 10)))) + testdat-raw))) + (map + (lambda (item) + (receive (id test_id category + variable value expected + tol units comment status type) + (apply values item) + (list target runname testname itempath category variable value comment))) + testdat))) + tests)))) + runs)))) + (print (string-join table-header ",")) + (for-each (lambda(table-row) + (print (string-join (map ->string table-row) ","))) + + + table-rows)))) + (set! *didsomething* #t) + (set! *time-to-exit* #t)) + + + + ;; NOTE: list-runs and list-db-targets operate on local db!!! + ;; + ;; IDEA: megatest list -runname blah% ... + ;; + (if (or (args:get-arg "-list-runs") + (args:get-arg "-list-db-targets")) + (if (launch:setup) + (let* (;; (dbstruct (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local"))) + (runpatt (args:get-arg "-list-runs")) + (access-mode (db:get-access-mode)) + (testpatt (common:args-get-testpatt #f)) + ;; (if (args:get-arg "-testpatt") + ;; (args:get-arg "-testpatt") + ;; "%")) + (keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) + ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) + ;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) + ;; #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) + (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") + (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) + (runstmp (db:get-rows runsdat)) + (header (db:get-header runsdat)) + ;; this is "-since" support. This looks at last mod times of .db files + ;; and collects those modified since the -since time. + (runs runstmp) + ;; (if (and (not (null? runstmp)) + ;; (args:get-arg "-since")) + ;; (let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since"))))) + ;; (let loop ((hed (car runstmp)) + ;; (tal (cdr runstmp)) + ;; (res '())) + ;; (let ((new-res (if (member (db:get-value-by-header hed header "id") changed-ids) + ;; (cons hed res) + ;; res))) + ;; (if (null? tal) + ;; (reverse new-res) + ;; (loop (car tal)(cdr tal) new-res))))) + ;; runstmp)) + (db-targets (args:get-arg "-list-db-targets")) + (seen (make-hash-table)) + (dmode (let ((d (args:get-arg "-dumpmode"))) ;; json, sexpr + (if d (string->symbol d) #f))) + (data (make-hash-table)) + (fields-spec (if (args:get-arg "-fields") + (extract-fields-constraints (args:get-arg "-fields")) + (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count"))) + (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path") + (list "steps" "id" "stepname")))) + (runs-spec (let ((r (alist-ref "runs" fields-spec equal?))) ;; the check is now unnecessary + (if (and r (not (null? r))) r (list "id" )))) + (tests-spec (let ((t (alist-ref "tests" fields-spec equal?))) + (if (and t (null? t)) ;; all fields + db:test-record-fields + t))) + (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id")))) + (steps-spec (alist-ref "steps" fields-spec equal?)) + (test-field-index (make-hash-table))) + (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec + (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec))) + (if (null? invalid-tests-spec) + ;; generate the lookup map test-field-name => index-number + (let loop ((hed (car adj-tests-spec)) + (tal (cdr adj-tests-spec)) + (idx 0)) + (hash-table-set! test-field-index hed idx) + (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1)))) + (begin + (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) + (exit))))) + ;; Each run + (for-each + (lambda (run) + (let ((targetstr (string-intersperse (map (lambda (x) + (db:get-value-by-header run header x)) + keys) "/"))) + (if db-targets + (if (not (hash-table-ref/default seen targetstr #f)) + (begin + (hash-table-set! seen targetstr #t) + ;; (print "[" targetstr "]")))) + (if (not dmode) + (print targetstr) + (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '()))) + ))) + (let* ((run-id (db:get-value-by-header run header "id")) + (runname (db:get-value-by-header run header "runname")) + (states (string-split (or (args:get-arg "-state") "") ",")) + (statuses (string-split (or (args:get-arg "-status") "") ",")) + (tests (if tests-spec + (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc + ;; use qryvals if test-spec provided + (if tests-spec + (string-intersperse adj-tests-spec ",") + ;; db:test-record-fields + #f) + #f + 'normal) + '()))) + (case dmode + ((json ods sexpr) + (if runs-spec + (for-each + (lambda (field-name) + (mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name)) + runs-spec))) + ;; (mutils:hierhash-set! data (db:get-value-by-header run header "status") targetstr runname "meta" "status" ) + ;; (mutils:hierhash-set! data (db:get-value-by-header run header "state") targetstr runname "meta" "state" ) + ;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id")) targetstr runname "meta" "id" ) + ;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" ) + ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) + ;; ;; add last entry twice - seems to be a bug in hierhash? + ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) + (else + (if (null? runs-spec) + (print "Run: " targetstr "/" runname + " status: " (db:get-value-by-header run header "state") + " run-id: " run-id ", number tests: " (length tests) + " event_time: " (db:get-value-by-header run header "event_time")) + (begin + (if (not (member "target" runs-spec)) + ;; (display (conc "Target: " targetstr)) + (display (conc "Run: " targetstr "/" runname " "))) + (for-each + (lambda (field-name) + (if (equal? field-name "target") + (display (conc "target: " targetstr " ")) + (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " ")))) + runs-spec) + (newline))))) + + (for-each + (lambda (test) + (common:debug-handle-exceptions #f + exn + (begin + (debug:print-error 0 *default-log-port* "Bad data in test record? " test) + (debug:print-error 5 *default-log-port* "exn=" (condition->list exn)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port))) + (let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test)) + (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test)) + (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test)) + (comment (if (member "comment" tests-spec)(get-value-by-fieldname test test-field-index "comment" ) #f)) ;; (db:test-get-comment test)) + (tstate (if (member "state" tests-spec)(get-value-by-fieldname test test-field-index "state" ) #f)) ;; (db:test-get-state test)) + (tstatus (if (member "status" tests-spec)(get-value-by-fieldname test test-field-index "status" ) #f)) ;; (db:test-get-status test)) + (event-time (if (member "event_time" tests-spec)(get-value-by-fieldname test test-field-index "event_time" ) #f)) ;; (db:test-get-event_time test)) + (rundir (if (member "rundir" tests-spec)(get-value-by-fieldname test test-field-index "rundir" ) #f)) ;; (db:test-get-rundir test)) + (final_logf (if (member "final_logf" tests-spec)(get-value-by-fieldname test test-field-index "final_logf" ) #f)) ;; (db:test-get-final_logf test)) + (run_duration (if (member "run_duration" tests-spec)(get-value-by-fieldname test test-field-index "run_duration") #f)) ;; (db:test-get-run_duration test)) + (fullname (conc testname + (if (equal? itempath "") + "" + (conc "(" itempath ")"))))) + (case dmode + ((json ods sexpr) + (if tests-spec + (for-each + (lambda (field-name) + (mutils:hierhash-set! data (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name)) + tests-spec))) + ;; ;; (mutils:hierhash-set! data fullname targetstr runname "data" (conc test-id) "tname" ) + ;; (mutils:hierhash-set! data testname targetstr runname "data" (conc test-id) "testname" ) + ;; (mutils:hierhash-set! data itempath targetstr runname "data" (conc test-id) "itempath" ) + ;; (mutils:hierhash-set! data comment targetstr runname "data" (conc test-id) "comment" ) + ;; (mutils:hierhash-set! data tstate targetstr runname "data" (conc test-id) "state" ) + ;; (mutils:hierhash-set! data tstatus targetstr runname "data" (conc test-id) "status" ) + ;; (mutils:hierhash-set! data rundir targetstr runname "data" (conc test-id) "rundir" ) + ;; (mutils:hierhash-set! data final_logf targetstr runname "data" (conc test-id) "final_logf") + ;; (mutils:hierhash-set! data run_duration targetstr runname "data" (conc test-id) "run_duration") + ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time") + ;; ;; add last entry twice - seems to be a bug in hierhash? + ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time") + ;; ) + (else + (if (and tstate tstatus event-time) + (format #t + " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" + (if fullname fullname "") + (if tstate tstate "") + (if tstatus tstatus "") + (get-value-by-fieldname test test-field-index "run_duration");;(if test (db:test-get-run_duration test) "") + (if event-time event-time "") + (get-value-by-fieldname test test-field-index "host")) ;;(if test (db:test-get-host test)) "") + (print " Test: " fullname + (if tstate (conc " State: " tstate) "") + (if tstatus (conc " Status: " tstatus) "") + (if (get-value-by-fieldname test test-field-index "run_duration") + (conc " Runtime: " (get-value-by-fieldname test test-field-index "run_duration")) + "") + (if event-time (conc " Time: " event-time) "") + (if (get-value-by-fieldname test test-field-index "host") + (conc " Host: " (get-value-by-fieldname test test-field-index "host")) + ""))) + (if (not (or (equal? (get-value-by-fieldname test test-field-index "status") "PASS") + (equal? (get-value-by-fieldname test test-field-index "status") "WARN") + (equal? (get-value-by-fieldname test test-field-index "state") "NOT_STARTED"))) + (begin + (print (if (get-value-by-fieldname test test-field-index "cpuload") + (conc " cpuload: " (get-value-by-fieldname test test-field-index "cpuload")) + "") ;; (db:test-get-cpuload test) + (if (get-value-by-fieldname test test-field-index "diskfree") + (conc "\n diskfree: " (get-value-by-fieldname test test-field-index "diskfree")) ;; (db:test-get-diskfree test) + "") + (if (get-value-by-fieldname test test-field-index "uname") + (conc "\n uname: " (get-value-by-fieldname test test-field-index "uname")) ;; (db:test-get-uname test) + "") + (if (get-value-by-fieldname test test-field-index "rundir") + (conc "\n rundir: " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test) + "") + ;; "\n rundir: " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* + ;; (db:test-get-rundir test) ;; ) + ) + ;; Each test + ;; DO NOT remote run + (let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) + (for-each + (lambda (step) + (format #t + " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" + (tdb:step-get-stepname step) + (tdb:step-get-state step) + (tdb:step-get-status step) + (tdb:step-get-event_time step))) + steps))))))))) + (if (args:get-arg "-sort") + (sort tests + (lambda (a-test b-test) + (let* ((key (args:get-arg "-sort")) + (first (get-value-by-fieldname a-test test-field-index key)) + (second (get-value-by-fieldname b-test test-field-index key))) + ((cond + ((and (number? first)(number? second)) <) + ((and (string? first)(string? second)) string<=?) + (else equal?)) + first second)))) + tests)))))) + runs) + (case dmode + ((json) (json-write data)) + ((sexpr) (pp (common:to-alist data)))) + (let* ((metadat-fields (delete-duplicates + (append keys '( "runname" "time" "owner" "pass_count" "fail_count" "state" "status" "comment" "id")))) + (run-fields '( + "testname" + "item_path" + "state" + "status" + "comment" + "event_time" + "host" + "run_id" + "run_duration" + "attemptnum" + "id" + "archived" + "diskfree" + "cpuload" + "final_logf" + "shortdir" + "rundir" + "uname" + ) + ) + (newdat (common:to-alist data)) + (allrundat (if (null? newdat) + '() + (car (map cdr newdat)))) ;; (car (map cdr (car (map cdr newdat))))) + (runs (append + (list "runs" ;; sheetname + metadat-fields) + (map (lambda (run) + ;; (print "run: " run) + (let* ((runname (car run)) + (rundat (cdr run)) + (metadat (let ((tmp (assoc "meta" rundat))) + (if tmp (cdr tmp) #f)))) + ;; (print "runname: " runname "\n\nrundat: " )(pp rundat)(print "\n\nmetadat: ")(pp metadat) + (if metadat + (map (lambda (field) + (let ((tmp (assoc field metadat))) + (if tmp (cdr tmp) ""))) + metadat-fields) + (begin + (debug:print 0 *default-log-port* "WARNING: meta data for run " runname " not found") + '())))) + allrundat))) + ;; '( ( "target" ( "runname" ( "data" ( "runid" ( "id . "37" ) ( ... )))) + (run-pages (map (lambda (targdat) + (let* ((target (car targdat)) + (runsdat (cdr targdat))) + (if runsdat + (map (lambda (rundat) + (let* ((runname (car rundat)) + (rundat (cdr rundat)) + (testsdat (let ((tmp (assoc "data" rundat))) + (if tmp (cdr tmp) #f)))) + (if testsdat + (let ((tests (map (lambda (test) + (let* ((test-id (car test)) + (test-dat (cdr test))) + (map (lambda (field) + (let ((tmp (assoc field test-dat))) + (if tmp (cdr tmp) ""))) + run-fields))) + testsdat))) + ;; (print "Target: " target "/" runname " tests:") + ;; (pp tests) + (cons (conc target "/" runname) + (cons (list (conc target "/" runname)) + (cons '() + (cons run-fields tests))))) + (begin + (debug:print 4 *default-log-port* "WARNING: run " target "/" runname " appears to have no data") + ;; (pp rundat) + '())))) + runsdat) + '()))) + newdat)) ;; we use newdat to get target + (sheets (filter (lambda (x) + (not (null? x))) + (cons runs (map car run-pages))))) + ;; (print "allrundat:") + ;; (pp allrundat) + ;; (print "runs:") + ;; (pp runs) + ;(print "sheets: ") + ;; (pp sheets) + (if (eq? dmode 'ods) + (let* ((tempdir (conc "/tmp/" (current-user-name) "/" (pseudo-random-integer 10000) "_" (current-process-id))) + (outputfile (or (args:get-arg "-o") "out.ods")) + (ouf (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path? + outputfile + (begin + (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") + (conc (current-directory) "/" outputfile))))) + (create-directory tempdir #t) + (ods:list->ods tempdir ouf sheets)))) + ;; (system (conc "rm -rf " tempdir)) + (set! *didsomething* #t) + (set! *time-to-exit* #t) + ) ;; end if true branch (end of a let) + ) ;; end if + ) ;; end if -list-runs + + ;; list-waivers + (if (and (args:get-arg "-list-waivers") + (launch:setup)) + (let* ((runpatt (or (args:get-arg "-runname") "%")) + (testpatt (common:args-get-testpatt #f)) + (keys (rmt:get-keys)) + (runsdat (rmt:get-runs-by-patt + keys runpatt + (common:args-get-target) #f #f + '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) + (runs (db:get-rows runsdat)) + (header (db:get-header runsdat)) + (results (make-hash-table)) ;; [target] ( (testname/itempath . "comment") ... ) + (addtest (lambda (target testname itempath comment) + (hash-table-set! results target (cons (cons (conc testname "/" itempath) comment) + (hash-table-ref/default results target '()))))) + (last-target #f)) + (for-each + (lambda (run) + (let* ((run-id (db:get-value-by-header run header "id")) + (target (rmt:get-target run-id)) + (runname (db:get-value-by-header run header "runname")) + (tests (rmt:get-tests-for-run + run-id testpatt '("COMPLETED") '("WAIVED") #f #f #f 'testname 'asc ;; use qryvals if test-spec provided + #f #f #f))) + (if (not (equal? target last-target)) + (print "[" target "]")) + (set! last-target target) + (print "# " runname) + (for-each + (lambda (testdat) + (let* ((testfullname (conc (db:test-get-testname testdat) + (if (equal? "" (db:test-get-item-path testdat)) + "" + (conc "/" (db:test-get-item-path testdat))) + ))) + (print testfullname " " (db:test-get-comment testdat)))) + tests))) + runs) + (set! *didsomething* #t))) + + ;;====================================================================== + ;; full run + ;;====================================================================== + + (define (handle-run-requests target runname keys keyvals need-clean) + (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct + ;; For rerun-clean do we or do we not support the testpatt? + (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states") + "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED")) + (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses") + "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED"))) + (hash-table-set! args:arg-hash "-preclean" #t) + (runs:operate-on 'set-state-status + target + (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) + ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + state: states + ;; status: statuses + new-state-status: "NOT_STARTED,n/a") + (runs:clean-cache target runname *toppath*) + (runs:operate-on 'set-state-status + target + (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) + ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + ;; state: states + status: statuses + new-state-status: "NOT_STARTED,n/a"))) + ;; RERUN ALL + (if (args:get-arg "-rerun-all") ;; first set states/statuses correct + (let* ((rconfig (full-runconfigs-read))) + (hash-table-set! args:arg-hash "-preclean" #t) + (runs:operate-on 'set-state-status + target + (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) + (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt") + state: #f + ;; status: statuses + new-state-status: "NOT_STARTED,n/a") + (runs:clean-cache target runname *toppath*) + (runs:operate-on 'set-state-status + target + (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) + (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt") + ;; state: states + status: #f + new-state-status: "NOT_STARTED,n/a"))) + (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) + (if x (string->number x) #f))) + (rerun-cnt (if config-reruns + config-reruns + 1))) + + (runs:run-tests target + runname + #f ;; (common:args-get-testpatt #f) + ;; (or (args:get-arg "-testpatt") + ;; "%") + user + args:arg-hash + run-count: rerun-cnt))) + + ;; get lock in db for full run for this directory + ;; for all tests with deps + ;; walk tree of tests to find head tasks + ;; add head tasks to task queue + ;; add dependant tasks to task queue + ;; add remaining tasks to task queue + ;; for each task in task queue + ;; if have adequate resources + ;; launch task + ;; else + ;; put task in deferred queue + ;; if still ok to run tasks + ;; process deferred tasks per above steps + + ;; run all tests are are Not COMPLETED and PASS or CHECK + (if (or (args:get-arg "-runall") + (args:get-arg "-run") + (args:get-arg "-rerun-clean") + (args:get-arg "-rerun-all") + (args:get-arg "-runtests") + (args:get-arg "-kill-rerun")) + (let ((need-clean (or (args:get-arg "-rerun-clean") + (args:get-arg "-rerun-all"))) + (orig-cmdline (string-intersperse (argv) " "))) + (general-run-call + "-runall" + "run all tests" + (lambda (target runname keys keyvals) + (if (or (string-search "%" target) + (string-search "%" runname)) ;; we are being asked to re-run multiple runs + (let* ((run-specs (rmt:simple-get-runs runname #f #f target #f))) ;; list of simple-run records + (debug:print-info 0 *default-log-port* "Pattern supplied for target or runname with " + (length run-specs) " matches round. Running each in turn.") + (if (null? run-specs) + (debug:print 0 *default-log-port* "WARNING: No runs match target " target " and runname " runname)) + (for-each (lambda (spec) + (let* ((precmd (if (args:get-arg "-precmd")(conc (args:get-arg "-precmd") " ") "")) + (newcmdline (conc + precmd + (string-substitute + (conc "target " target) + (conc "target " (simple-run-target spec)) + (string-substitute + (conc "runname " runname) + (conc "runname " (simple-run-runname spec)) + orig-cmdline))))) + (debug:print 0 *default-log-port* "ORIG: " orig-cmdline) + (debug:print 0 *default-log-port* "NEW: " newcmdline) + (system newcmdline))) + run-specs)) + (handle-run-requests target runname keys keyvals need-clean)))))) + + ;;====================================================================== + ;; run one test + ;;====================================================================== + + ;; 1. find the config file + ;; 2. change to the test directory + ;; 3. update the db with "test started" status, set running host + ;; 4. process launch the test + ;; - monitor the process, update stats in the db every 2^n minutes + ;; 5. as the test proceeds internally it calls megatest as each step is + ;; started and completed + ;; - step started, timestamp + ;; - step completed, exit status, timestamp + ;; 6. test phone home + ;; - if test run time > allowed run time then kill job + ;; - if cannot access db > allowed disconnect time then kill job + + ;; == duplicated == (if (or (args:get-arg "-run")(args:get-arg "-runtests")) + ;; == duplicated == (general-run-call + ;; == duplicated == "-runtests" + ;; == duplicated == "run a test" + ;; == duplicated == (lambda (target runname keys keyvals) + ;; == duplicated == ;; + ;; == duplicated == ;; May or may not implement it this way ... + ;; == duplicated == ;; + ;; == duplicated == ;; Insert this run into the tasks queue + ;; == duplicated == ;; (open-run-close tasks:add tasks:open-db + ;; == duplicated == ;; "runtests" + ;; == duplicated == ;; user + ;; == duplicated == ;; target + ;; == duplicated == ;; runname + ;; == duplicated == ;; (args:get-arg "-runtests") + ;; == duplicated == ;; #f)))) + ;; == duplicated == (runs:run-tests target + ;; == duplicated == runname + ;; == duplicated == (common:args-get-testpatt #f) ;; (args:get-arg "-runtests") + ;; == duplicated == user + ;; == duplicated == args:arg-hash)))) + + ;;====================================================================== + ;; Rollup into a run + ;;====================================================================== + + ;; (if (args:get-arg "-rollup") + ;; (general-run-call + ;; "-rollup" + ;; "rollup tests" + ;; (lambda (target runname keys keyvals) + ;; (runs:rollup-run keys + ;; keyvals + ;; (or (args:get-arg "-runname")(args:get-arg ":runname") ) + ;; user)))) + + ;;====================================================================== + ;; Lock or unlock a run + ;;====================================================================== + + (if (or (args:get-arg "-lock")(args:get-arg "-unlock")) + (general-run-call + (if (args:get-arg "-lock") "-lock" "-unlock") + "lock/unlock tests" + (lambda (target runname keys keyvals) + (runs:handle-locking + target + keys + (or (args:get-arg "-runname")(args:get-arg ":runname") ) + (args:get-arg "-lock") + (args:get-arg "-unlock") + user)))) + + ;;====================================================================== + ;; Get paths to tests + ;;====================================================================== + ;; Get test paths matching target, runname, and testpatt + (if (or (args:get-arg "-test-files")(args:get-arg "-test-paths")) + ;; if we are in a test use the MT_CMDINFO data + (if (getenv "MT_CMDINFO") + (let* ((startingdir (current-directory)) + (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) + (transport (assoc/default 'transport cmdinfo)) + (testpath (assoc/default 'testpath cmdinfo)) + (test-name (assoc/default 'test-name cmdinfo)) + (runscript (assoc/default 'runscript cmdinfo)) + (db-host (assoc/default 'db-host cmdinfo)) + (run-id (assoc/default 'run-id cmdinfo)) + (itemdat (assoc/default 'itemdat cmdinfo)) + (state (args:get-arg ":state")) + (status (args:get-arg ":status")) + ;;(target (args:get-arg "-target")) + (target (common:args-get-target)) + (toppath (assoc/default 'toppath cmdinfo))) + (change-directory toppath) + (if (not target) + (begin + (debug:print-error 0 *default-log-port* "-target is required.") + (exit 1))) + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, giving up on -test-paths or -test-files, exiting") + (exit 1))) + (let* ((keys (rmt:get-keys)) + ;; db:test-get-paths must not be run remote + (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) + (set! *didsomething* #t) + (for-each (lambda (path) + (if (common:file-exists? path) + (print path))) + paths))) + ;; else do a general-run-call + (general-run-call + "-test-files" + "Get paths to test" + (lambda (target runname keys keyvals) + (let* ((db #f) + ;; DO NOT run remote + (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) + (for-each (lambda (path) + (print path)) + paths)))))) + + ;;====================================================================== + ;; Archive tests + ;;====================================================================== + ;; Archive tests matching target, runname, and testpatt + (if (equal? (args:get-arg "-archive") "replicate-db") + (begin + ;; check if source + ;; check if megatest.db exist + (launch:setup) + (if (not (args:get-arg "-source")) + (begin + (debug:print-info 1 *default-log-port* "Missing required argument -source ") + (exit 1))) + (if (common:file-exists? (conc *toppath* "/megatest.db")) + (begin + (debug:print-info 1 *default-log-port* "File " (conc *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db") + (exit 1))) + (if (and (common:get-db-tmp-area) (> (length (directory (common:get-db-tmp-area) #f)) 0)) + (begin + (debug:print-info 1 *default-log-port* (common:get-db-tmp-area) " not empty. Please remove it before trying to replicate db") + (exit 1))) + ;; check if timestamp + (let* ((source (args:get-arg "-source")) + (src (if (not (equal? (substring source 0 1) "/")) + (conc (current-directory) "/" source) + source)) + (ts (if (args:get-arg "-time-stamp") (args:get-arg "-time-stamp") "latest"))) + (if (common:directory-exists? src) + (begin + (archive:restore-db src ts) + (set! *didsomething* #t)) + (begin + (debug:print-error 1 *default-log-port* "Path " source " not found") + (exit 1)))))) + ;; else do a general-run-call + (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicate-db"))) + (begin + ;; for the archive get we need to preserve the starting dir as part of the target path + (if (and (args:get-arg "-dest") + (not (equal? (substring (args:get-arg "-dest") 0 1) "/"))) + (let ((newpath (conc (current-directory) "/" (args:get-arg "-dest")))) + (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath) + (hash-table-set! args:arg-hash "-dest" newpath))) + (general-run-call + "-archive" + "Archive" + (lambda (target runname keys keyvals) + (operate-on 'archive target-in: target runname-in: runname ))))) + + ;;====================================================================== + ;; Extract a spreadsheet from the runs database + ;;====================================================================== + + (if (args:get-arg "-extract-ods") + (general-run-call + "-extract-ods" + "Make ods spreadsheet" + (lambda (target runname keys keyvals) + (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) + (outputfile (args:get-arg "-extract-ods")) + (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname"))) + (pathmod (args:get-arg "-pathmod"))) + ;; (keyvalalist (keys->alist keys "%"))) + (debug:print 2 *default-log-port* "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) + (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod) + (db:close-all dbstruct) + (set! *didsomething* #t))))) + + ;;====================================================================== + ;; execute the test + ;; - gets called on remote host + ;; - receives info from the -execute param + ;; - passes info to steps via MT_CMDINFO env var (future is to use a dot file) + ;; - gathers host info and + ;;====================================================================== + + (if (args:get-arg "-execute") + (begin + (launch:execute (args:get-arg "-execute")) + (set! *didsomething* #t))) + + ;;====================================================================== + ;; recover from a test where the managing mtest was killed but the underlying + ;; process might still be salvageable + ;;====================================================================== + + (if (args:get-arg "-recover-test") + (let* ((params (string-split (args:get-arg "-recover-test") ","))) + (if (> (length params) 1) ;; run-id and test-id + (let ((run-id (string->number (car params))) + (test-id (string->number (cadr params)))) + (if (and run-id test-id) + (begin + (launch:recover-test run-id test-id) + (set! *didsomething* #t)) + (begin + (debug:print-error 0 *default-log-port* "bad run-id or test-id, must be integers") + (exit 1))))))) + + ;;====================================================================== + ;; Test commands (i.e. for use inside tests) + ;;====================================================================== + + (define (megatest:step step state status logfile msg) + (if (not (getenv "MT_CMDINFO")) + (begin + (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") + (exit 5)) + (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) + (transport (assoc/default 'transport cmdinfo)) + (testpath (assoc/default 'testpath cmdinfo)) + (test-name (assoc/default 'test-name cmdinfo)) + (runscript (assoc/default 'runscript cmdinfo)) + (db-host (assoc/default 'db-host cmdinfo)) + (run-id (assoc/default 'run-id cmdinfo)) + (test-id (assoc/default 'test-id cmdinfo)) + (itemdat (assoc/default 'itemdat cmdinfo)) + (work-area (assoc/default 'work-area cmdinfo)) + (db #f)) + (change-directory testpath) + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + (exit 1))) + (if (and state status) + (let ((comment (launch:load-logpro-dat run-id test-id step))) + ;; (rmt:test-set-log! run-id test-id (conc stepname ".html")))) + (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile)) + (begin + (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step") + (exit 6)))))) + + (define (main) + (if (args:get-arg "-step") + (begin + (thread-sleep! 1.5) + (megatest:step + (args:get-arg "-step") + (or (args:get-arg "-state")(args:get-arg ":state")) + (or (args:get-arg "-status")(args:get-arg ":status")) + (args:get-arg "-setlog") + (args:get-arg "-m")) + ;; (if db (sqlite3:finalize! db)) + (set! *didsomething* #t) + (thread-sleep! 1.5))) + + (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status + ;; (not (args:get-arg "-step"))) ;; -setlog may have been processed already in the "-step" previous + ;; NEW POLICY - -setlog sets test overall log on every call. + (args:get-arg "-set-toplog") + (args:get-arg "-test-status") + (args:get-arg "-set-values") + (args:get-arg "-load-test-data") + (args:get-arg "-runstep") + (args:get-arg "-summarize-items")) + (if (not (getenv "MT_CMDINFO")) + (begin + (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") + (exit 5)) + (let* ((startingdir (current-directory)) + (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) + (transport (assoc/default 'transport cmdinfo)) + (testpath (assoc/default 'testpath cmdinfo)) + (test-name (assoc/default 'test-name cmdinfo)) + (runscript (assoc/default 'runscript cmdinfo)) + (db-host (assoc/default 'db-host cmdinfo)) + (run-id (assoc/default 'run-id cmdinfo)) + (test-id (assoc/default 'test-id cmdinfo)) + (itemdat (assoc/default 'itemdat cmdinfo)) + (work-area (assoc/default 'work-area cmdinfo)) + (db #f) ;; (open-db)) + (state (args:get-arg ":state")) + (status (args:get-arg ":status")) + (stepname (args:get-arg "-step"))) + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + (exit 1))) + + (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area)) + (change-directory work-area) + ;; can setup as client for server mode now + ;; (client:setup) + + (if (args:get-arg "-load-test-data") + ;; has sub commands that are rdb: + ;; DO NOT put this one into either rmt: or open-run-close + (tdb:load-test-data run-id test-id)) + (if (args:get-arg "-setlog") + (let ((logfname (args:get-arg "-setlog"))) + (rmt:test-set-log! run-id test-id logfname))) + (if (args:get-arg "-set-toplog") + ;; DO NOT run remote + (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog"))) + (if (args:get-arg "-summarize-items") + ;; DO NOT run remote + (tests:summarize-items run-id test-id test-name #t)) ;; do force here + (if (args:get-arg "-runstep") + (if (null? remargs) + (begin + (debug:print-error 0 *default-log-port* "nothing specified to run!") + (if db (sqlite3:finalize! db)) + (exit 6)) + (let* ((stepname (args:get-arg "-runstep")) + (logprofile (args:get-arg "-logpro")) + (logfile (conc stepname ".log")) + (cmd (if (null? remargs) #f (car remargs))) + (params (if cmd (cdr remargs) '())) + (exitstat #f) + (shell (let ((sh (get-environment-variable "SHELL") )) + (if sh + (last (string-split sh "/")) + "bash"))) + (redir (case (string->symbol shell) + ((tcsh csh ksh) ">&") + ((zsh bash sh ash) "2>&1 >") + (else ">&"))) + (fullcmd (conc "(" (string-intersperse + (cons cmd params) " ") + ") " redir " " logfile))) + ;; mark the start of the test + (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile) + ;; run the test step + (debug:print-info 2 *default-log-port* "Running \"" fullcmd "\" in directory \"" startingdir) + (change-directory startingdir) + (set! exitstat (system fullcmd)) + (set! *globalexitstatus* exitstat) + ;; (change-directory testpath) + ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) + (if logprofile + (let* ((htmllogfile (conc stepname ".html")) + (oldexitstat exitstat) + (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) + (debug:print-info 2 *default-log-port* "running \"" cmd "\"") + (change-directory startingdir) + (set! exitstat (system cmd)) + (set! *globalexitstatus* exitstat) ;; no necessary + (change-directory testpath) + (rmt:test-set-log! run-id test-id htmllogfile))) + (let ((msg (args:get-arg "-m"))) + (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile)) + ))) + (if (or (args:get-arg "-test-status") + (args:get-arg "-set-values")) + (let ((newstatus (cond + ((number? status) (if (equal? status 0) "PASS" "FAIL")) + ((and (string? status) + (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL")) + (else status))) + ;; transfer relevant keys into a hash to be passed to test-set-status! + ;; could use an assoc list I guess. + (otherdata (let ((res (make-hash-table))) + (for-each (lambda (key) + (if (args:get-arg key) + (hash-table-set! res key (args:get-arg key)))) + (list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable")) + res))) + (if (and (args:get-arg "-test-status") + (or (not state) + (not status))) + (begin + (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -test-status\n" help) + (if (sqlite3:database? db)(sqlite3:finalize! db)) + (exit 6))) + (let* ((msg (args:get-arg "-m")) + (numoth (length (hash-table-keys otherdata)))) + ;; Convert to rpc inside the tests:test-set-status! call, not here + (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area)))) + (if (sqlite3:database? db)(sqlite3:finalize! db)) + (set! *didsomething* #t)))) + + ;;====================================================================== + ;; Various helper commands can go below here + ;;====================================================================== + + (if (or (args:get-arg "-showkeys") + (args:get-arg "-show-keys")) + (let ((db #f) + (keys #f)) + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + (exit 1))) + (set! keys (rmt:get-keys)) ;; db)) + (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", ")) + (if (sqlite3:database? db)(sqlite3:finalize! db)) + (set! *didsomething* #t))) + + (if (args:get-arg "-gui") + (begin + (debug:print 0 *default-log-port* "Look at the dashboard for now") + ;; (megatest-gui) + (set! *didsomething* #t))) + + (if (args:get-arg "-create-megatest-area") + (begin + (genexample:mk-megatest.config) + (set! *didsomething* #t))) + + (if (args:get-arg "-create-test") + (let ((testname (args:get-arg "-create-test"))) + (genexample:mk-megatest-test testname) + (set! *didsomething* #t))) + + ;;====================================================================== + ;; Update the database schema, clean up the db + ;;====================================================================== + + (if (args:get-arg "-rebuild-db") + (begin + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + (exit 1))) + ;; keep this one local + ;; (open-run-close patch-db #f) + (let ((dbstruct (db:setup #f areapath: *toppath*))) + (common:cleanup-db dbstruct full: #t)) + (set! *didsomething* #t))) + + (if (args:get-arg "-cleanup-db") + (begin + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + (exit 1))) + (let ((dbstruct (db:setup #f areapath: *toppath*))) + (common:cleanup-db dbstruct)) + (set! *didsomething* #t))) + + (if (args:get-arg "-mark-incompletes") + (begin + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + (exit 1))) + (rmt:find-and-mark-incomplete #f) + (set! *didsomething* #t))) + + ;;====================================================================== + ;; Update the tests meta data from the testconfig files + ;;====================================================================== + + (if (args:get-arg "-update-meta") + (begin + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + (exit 1))) + (runs:update-all-test_meta #f) + (set! *didsomething* #t))) + + ;;====================================================================== + ;; Start a repl + ;;====================================================================== + + ;; fakeout readline + ;; (include "readline-fix.scm") + + + (when (args:get-arg "-diff-rep") + (when (and + (not (args:get-arg "-diff-html")) + (not (args:get-arg "-diff-email"))) + (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep") + (set! *didsomething* 1) + (exit 1)) + + (let* ((toppath (launch:setup))) + (do-diff-report + (args:get-arg "-src-target") + (args:get-arg "-src-runname") + (args:get-arg "-target") + (args:get-arg "-runname") + (args:get-arg "-diff-html") + (args:get-arg "-diff-email")) + (set! *didsomething* #t) + (exit 0))) + + (if (or (getenv "MT_RUNSCRIPT") + (args:get-arg "-repl") + (args:get-arg "-load")) + (let* ((toppath (launch:setup)) + (dbstruct (if (and toppath + (common:on-homehost?)) + (db:setup #t) + #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f))) + (if *toppath* + (cond + ((getenv "MT_RUNSCRIPT") + ;; How to run megatest scripts + ;; + ;; #!/bin/bash + ;; + ;; export MT_RUNSCRIPT=yes + ;; megatest << EOF + ;; (print "Hello world") + ;; (exit) + ;; EOF + + (repl)) + (else + (begin + (set! *db* dbstruct) + ;; (import extras) ;; might not be needed + ;; (import csi) + ;; (import readline) + (import apropos) + ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... + + ;; (if *use-new-readline* + ;; (begin + ;; (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) + ;; (current-input-port (make-readline-port "megatest> "))) + ;; (begin + ;; (gnu-history-install-file-manager + ;; (string-append + ;; (or (get-environment-variable "HOME") ".") "/.megatest_history")) + ;; (current-input-port (make-gnu-readline-port "megatest> ")))) + (if (args:get-arg "-repl") + (repl) + (load (args:get-arg "-load"))) + ;; (db:close-all dbstruct) <= taken care of by on-exit call + ) + (exit))) + (set! *didsomething* #t)))) + + ;;====================================================================== + ;; Wait on a run to complete + ;;====================================================================== + + (if (and (args:get-arg "-run-wait") + (not (or (args:get-arg "-run") + (args:get-arg "-runtests")))) ;; run-wait is built into runtests now + (begin + (if (not (launch:setup)) + (begin + (debug:print 0 *default-log-port* "Failed to setup, exiting") + (exit 1))) + (operate-on 'run-wait) + (set! *didsomething* #t))) + + ;; ;; ;; redo me ;; Not converted to use dbstruct yet + ;; ;; ;; redo me ;; + ;; ;; ;; redo me (if (args:get-arg "-convert-to-norm") + ;; ;; ;; redo me (let* ((toppath (setup-for-run)) + ;; ;; ;; redo me (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t)))) + ;; ;; ;; redo me (for-each + ;; ;; ;; redo me (lambda (field) + ;; ;; ;; redo me (let ((dat '())) + ;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Getting data for field " field) + ;; ;; ;; redo me (sqlite3:for-each-row + ;; ;; ;; redo me (lambda (id val) + ;; ;; ;; redo me (set! dat (cons (list id val) dat))) + ;; ;; ;; redo me (db:get-db db run-id) + ;; ;; ;; redo me (conc "SELECT id," field " FROM tests;")) + ;; ;; ;; redo me (debug:print-info 0 *default-log-port* "found " (length dat) " items for field " field) + ;; ;; ;; redo me (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;")))) + ;; ;; ;; redo me (for-each + ;; ;; ;; redo me (lambda (item) + ;; ;; ;; redo me (let ((newval ;; (sdb:qry 'getid + ;; ;; ;; redo me (cadr item))) ;; ) + ;; ;; ;; redo me (if (not (equal? newval (cadr item))) + ;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item))) + ;; ;; ;; redo me (sqlite3:execute qry newval (car item)))) + ;; ;; ;; redo me dat) + ;; ;; ;; redo me (sqlite3:finalize! qry)))) + ;; ;; ;; redo me (db:close-all dbstruct) + ;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment")) + ;; ;; ;; redo me (set! *didsomething* #t))) + + (if (args:get-arg "-import-megatest.db") + (begin + (db:multi-db-sync + (db:setup #f) + 'killservers + 'dejunk + 'adj-testids + 'old2new + ;; 'new2old + ) + (set! *didsomething* #t))) + + (when (args:get-arg "-sync-brute-force") + ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t)) + (set! *didsomething* #t)) + + (if (args:get-arg "-sync-to-megatest.db") + (let* ((dbstruct (db:setup #f)) + (tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct))) + (lockfile (conc tmpdbpth ".lock")) + (locked (common:simple-file-lock lockfile)) + (res (if locked + (db:multi-db-sync + dbstruct + 'new2old) + #f))) + (if res + (begin + (common:simple-file-release-lock lockfile) + (print "Synced " res " records to megatest.db")) + (print "Skipping sync, there is a sync in progress.")) + (set! *didsomething* #t))) + + (if (args:get-arg "-sync-to") + (let ((toppath (launch:setup))) + (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to")) + (set! *didsomething* #t))) + + (if (args:get-arg "-list-test-time") + (let* ((toppath (launch:setup))) + (task:get-test-times) + (set! *didsomething* #t))) + + (if (args:get-arg "-list-run-time") + (let* ((toppath (launch:setup))) + (task:get-run-times) + (set! *didsomething* #t))) + + (if (args:get-arg "-generate-html") + (let* ((toppath (launch:setup))) + (if (tests:create-html-tree #f) + (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page0.html") + (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) + (set! *didsomething* #t))) + + (if (args:get-arg "-generate-html-structure") + (let* ((toppath (launch:setup))) + ;(if (tests:create-html-tree #f) + (if (tests:create-html-summary #f) + (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html") + (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) + (set! *didsomething* #t))) + + (if (args:get-arg "-syscheck") + (begin + (mutils:syscheck common:raw-get-remote-host-load + server:get-best-guess-address + read-config) + (set! *didsomething* #t))) + + (if (args:get-arg "-extract-skeleton") + (let* ((toppath (launch:setup))) + (genexample:extract-skeleton-area (args:get-arg "-extract-skeleton")) + (set! *didsomething* #t))) + + ;;====================================================================== + ;; Exit and clean up + ;;====================================================================== + + (if (not *didsomething*) + (debug:print 0 *default-log-port* help) + (set! *time-to-exit* #t) + ) + ;;(debug:print-info 13 *default-log-port* "thread-join! watchdog") + + ;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state) + ;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead) + ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage + (if (thread? *watchdog*) + (case (thread-state *watchdog*) + ((ready running blocked sleeping terminated dead) + (thread-join! *watchdog*)))) + + (set! *time-to-exit* #t) + + (if (not (eq? *globalexitstatus* 0)) + (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall")) + (begin + (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) + (exit 0)) + (case *globalexitstatus* + ((0)(exit 0)) + ((1)(exit 1)) + ((2)(exit 2)) + (else (exit 3))))) + ) + +) + +;; (main) +(print "Got here") Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -15,29 +15,29 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit mt)) -(declare (uses db)) -(declare (uses common)) -(declare (uses items)) -(declare (uses runconfig)) -(declare (uses tests)) -(declare (uses server)) -(declare (uses runs)) -(declare (uses rmt)) -;; (declare (uses filedb)) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "test_records.scm") +;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables) +;; (import (prefix sqlite3 sqlite3:)) +;; +;; (declare (unit mt)) +;; (declare (uses db)) +;; (declare (uses common)) +;; (declare (uses items)) +;; (declare (uses runconfig)) +;; (declare (uses tests)) +;; (declare (uses server)) +;; (declare (uses runs)) +;; (declare (uses rmt)) +;; ;; (declare (uses filedb)) +;; +;; (include "common_records.scm") +;; (include "key_records.scm") +;; (include "db_records.scm") +;; (include "run_records.scm") +;; (include "test_records.scm") ;; This is the Megatest API. All generally "useful" routines will be wrapped or extended ;; here. ;;====================================================================== @@ -155,14 +155,14 @@ event-time )) (prev-nbfake-log (get-environment-variable "NBFAKE_LOG"))) (setenv "NBFAKE_LOG" (conc (cond ((and (directory-exists? test-rundir) - (file-write-access? test-rundir)) + (file-writable? test-rundir)) test-rundir) ((and (directory-exists? *toppath*) - (file-write-access? *toppath*)) + (file-writable? *toppath*)) *toppath*) (else (conc "/tmp/" (current-user-name)))) "/" logname)) (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG")) ;; (call-with-environment-variables @@ -285,11 +285,11 @@ (let loop ((hed (car test-dirs)) (tal (cdr test-dirs))) ;; Setting MT_LINKTREE here is almost certainly unnecessary. (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) (if (and (common:file-exists? tconfig-file) - (file-read-access? tconfig-file)) + (file-readable? tconfig-file)) (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) (old-link-tree (get-environment-variable "MT_LINKTREE"))) (if link-tree-path (setenv "MT_LINKTREE" link-tree-path)) (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...] (hash-table-set! *testconfigs* test-name newtcfg) Index: mtargs/mtargs.scm ================================================================== --- mtargs/mtargs.scm +++ mtargs/mtargs.scm @@ -26,12 +26,11 @@ 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 srfi-69 srfi-1) (define arg-hash (make-hash-table)) (define help "") (define (get-arg arg . default) ADDED mtver.scm Index: mtver.scm ================================================================== --- /dev/null +++ mtver.scm @@ -0,0 +1,29 @@ +;; Copyright 2006-2017, 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 . + +;; Always use two or four digit decimal +;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. + +(declare (unit mtver)) + +(module mtver * + +(import scheme chicken.module) + +(define megatest-version 1.6584) + +) Index: mutils/mutils.scm ================================================================== --- mutils/mutils.scm +++ mutils/mutils.scm @@ -12,22 +12,37 @@ ;; (module mutils * - (import chicken scheme + (import scheme + + chicken.base + chicken.file + chicken.file.posix + chicken.port + chicken.process + chicken.process-context + chicken.random + chicken.condition + chicken.io + chicken.time + chicken.string + ;; data-structures posix srfi-1 ;; srfi-13 srfi-69 - ports - extras + srfi-98 + regex - posix - data-structures matchable + sparse-vectors + system-information + ) + (define (mutils:hierhash-ref hh . keys) (if (null? keys) #f (let loop ((ht hh) @@ -90,12 +105,10 @@ (if (or (string-match comment l) (string-match blank l)) (loop (read-line fh) res) (loop (read-line fh) (cons l res))))))) -(use sparse-vectors) - ;; this is a simple two dimensional sparse array ;; ONLY TWO DIMENSIONS!!! SEE ARRAY-LIB IF YOUR NEEDS ARE GREATER!! ;; (define (mutils:make-sparse-array) @@ -189,12 +202,13 @@ ;;====================================================================== ;; Other utils ;;====================================================================== (define (check-write-create fpath) - (and (file-write-access? fpath) - (let ((fname (conc fpath "/.junk-" (current-seconds) "-" (random 10000)))) + (and (file-writable? fpath) + (let ((fname (conc fpath "/.junk-" (current-seconds) "-" + (pseudo-random-integer 10000)))) ;;(print "trying to create/remove " fname) (handle-exceptions exn #f (begin Index: ods.scm ================================================================== --- ods.scm +++ ods.scm @@ -14,13 +14,13 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; -(use csv-xml regex) -(declare (unit ods)) -(declare (uses common)) +;; (use csv-xml regex) +;; (declare (unit ods)) +;; (declare (uses common)) (define ods:dirs '("Configurations2" "Configurations2/toolpanel" "Configurations2/menubar" Index: pkts/pkts.scm ================================================================== --- pkts/pkts.scm +++ pkts/pkts.scm @@ -162,12 +162,13 @@ ;; utility procs increment-string ;; used to get indexes for strings in ref pkts make-report ;; make a .dot file ) -(import chicken scheme data-structures posix srfi-1 regex srfi-13 srfi-69 ports extras) -(use crypt sha1 message-digest (prefix dbi dbi:) typed-records) +(import (chicken base) scheme (chicken process) (chicken time posix) (chicken io) (chicken file)) +(import chicken.process-context.posix (chicken string) (chicken time) (chicken sort) (chicken file posix) (chicken condition) srfi-1 regex srfi-13 srfi-69 (chicken port) ) +(import crypt sha1 message-digest (prefix dbi dbi:) typed-records) ;;====================================================================== ;; DATA MANIPULATION UTILS ;;====================================================================== @@ -695,11 +696,11 @@ (cond ((not (file-exists? pktsdir)) (print "ERROR: packets directory " pktsdir " does not exist.")) ((not (directory? pktsdir)) (print "ERROR: packets directory path " pktsdir " is not a directory.")) - ((not (file-read-access? pktsdir)) + ((not (file-readable? pktsdir)) (print "ERROR: packets directory path " pktsdir " is not readable.")) (else ;; (print "INFO: Loading packets found in " pktsdir) (let ((pkts (glob (conc pktsdir "/*.pkt")))) (for-each ADDED pktsmod.scm Index: pktsmod.scm ================================================================== --- /dev/null +++ pktsmod.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 pkts)) + +(include "pkts/pkts.scm") Index: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -15,17 +15,17 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; -(require-extension (srfi 18) extras tcp s11n) - -(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit portlogger)) -(declare (uses db)) +;; (require-extension (srfi 18) extras tcp s11n) +;; +;; (use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3) +;; (import (prefix sqlite3 sqlite3:)) +;; +;; (declare (unit portlogger)) +;; (declare (uses db)) ;; lsof -i (define (portlogger:open-db fname) (let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away @@ -34,11 +34,11 @@ (sqlite3:open-database fname) (begin (system (conc "rm -f " fname)) (sqlite3:open-database fname)))) (handler (sqlite3:make-busy-timeout 136000)) - (canwrite (file-write-access? fname))) + (canwrite (file-writable? fname))) ;; (db-init (lambda () ;; (sqlite3:execute ;; db ;; "CREATE TABLE IF NOT EXISTS ports ( ;; port INTEGER PRIMARY KEY, @@ -130,11 +130,11 @@ (string->number val)) (string->number val) 32768))) (portnum (or (portlogger:get-prev-used-port db) (+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range - (random (- 64000 lowport)))))) + (pseudo-random-integer (- 64000 lowport)))))) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -20,12 +20,12 @@ ;;====================================================================== ;; Process convience utils ;;====================================================================== -(use regex directory-utils) -(declare (unit process)) +;; (use regex directory-utils) +;; (declare (unit process)) (define (process:conservative-read port) (let loop ((res "")) (if (not (eof-object? (peek-char port))) (loop (conc res (read-char port))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -16,16 +16,16 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;;====================================================================== -(use format typed-records) ;; RADT => purpose of json format?? - -(declare (unit rmt)) -(declare (uses api)) -(declare (uses http-transport)) -(include "common_records.scm") +;; (use format typed-records) ;; RADT => purpose of json format?? +;; +;; (declare (unit rmt)) +;; (declare (uses api)) +;; (declare (uses http-transport)) +;; (include "common_records.scm") ;; (declare (uses rmtmod)) ;; (import rmtmod) ;; @@ -68,11 +68,11 @@ (if (> attemptnum 2) (debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum)) (cond - ((> attemptnum 2) (thread-sleep! 0.05)) + ((> attemptnum 2) (thread-sleep! 0.053)) ((> attemptnum 10) (thread-sleep! 0.5)) ((> attemptnum 20) (thread-sleep! 1))) (if (and (> attemptnum 5) (= 0 (modulo attemptnum 15))) (begin (server:run *toppath*) (thread-sleep! 3))) @@ -371,11 +371,11 @@ (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) (let* ((qry-is-write (not (member cmd api:read-only-queries))) (db-file-path (db:dbfile-path)) ;; 0)) (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t))) - (read-only (not (file-write-access? db-file-path))) + (read-only (not (file-writable? db-file-path))) (start (current-milliseconds)) (resdat (if (not (and read-only qry-is-write)) (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong.. exn ;; This is an attempt to detect that situation and recover gracefully @@ -395,11 +395,11 @@ (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd)) (if (not success) (if (> remretries 0) (begin (debug:print-error 0 *default-log-port* "local query failed. Trying again.") - (thread-sleep! (/ (random 5000) 1000)) ;; some random delay + (thread-sleep! (/ (pseudo-random-integer 5000) 1000)) ;; some random delay (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1))) (begin (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up") #f)) (begin @@ -614,11 +614,11 @@ (mutex-unlock! multi-run-mutex)) (debug:print-error 0 *default-log-port* "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) (conc "multi-run-thread for run-id " hed))) (newthreads (cons newthread threads))) (thread-start! newthread) - (thread-sleep! 0.05) ;; give that thread some time to start + (thread-sleep! 0.054) ;; give that thread some time to start (if (null? tal) newthreads (loop (car tal)(cdr tal) newthreads)))))) result)) @@ -974,11 +974,11 @@ (define (rmtmod:calc-ro-mode runremote *toppath*) (if (and runremote (remote-ro-mode-checked runremote)) (remote-ro-mode runremote) (let* ((dbfile (conc *toppath* "/megatest.db")) - (ro-mode (not (file-write-access? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future + (ro-mode (not (file-writable? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future (if runremote (begin (remote-ro-mode-set! runremote ro-mode) (remote-ro-mode-checked-set! runremote #t) ro-mode) Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -19,23 +19,23 @@ ;;====================================================================== (declare (unit rmtmod)) (declare (uses commonmod)) (declare (uses apimod)) -;; (declare (uses apimod.import)) -(declare (uses ulex)) - -;; (include "ulex/ulex.scm") (module rmtmod * -(import scheme chicken data-structures extras) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18) -(import (prefix commonmod cmod:)) -(import apimod) -(import (prefix ulex ulex:)) +(import scheme + (prefix sqlite3 sqlite3:) + + typed-records + srfi-18 + commonmod + apimod + + ) (defstruct alldat (areapath #f) (ulexdat #f) ) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -18,16 +18,16 @@ ;;====================================================================== ;; read a config file, loading only the section pertinent ;; to this run field1val/field2val/field3val ... ;;====================================================================== -(use format directory-utils) - -(declare (unit runconfig)) -(declare (uses common)) - -(include "common_records.scm") +;; (use format directory-utils) +;; +;; (declare (unit runconfig)) +;; (declare (uses common)) +;; +;; (include "common_records.scm") (define (runconfig:read fname target environ-patt) (let ((ht (make-hash-table))) (if target (hash-table-set! ht target '())) (read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f)))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -15,31 +15,31 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) - posix-extras directory-utils pathname-expand typed-records format sxml-serializer - sxml-modifications matchable) - -(declare (unit runs)) -(declare (uses db)) -(declare (uses common)) -(declare (uses items)) -(declare (uses runconfig)) -(declare (uses tests)) -(declare (uses server)) -(declare (uses mt)) -(declare (uses archive)) -;; (declare (uses filedb)) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "test_records.scm") - +;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) +;; posix-extras directory-utils pathname-expand typed-records format sxml-serializer +;; sxml-modifications matchable) +;; +;; (declare (unit runs)) +;; (declare (uses db)) +;; (declare (uses common)) +;; (declare (uses items)) +;; (declare (uses runconfig)) +;; (declare (uses tests)) +;; (declare (uses server)) +;; (declare (uses mt)) +;; (declare (uses archive)) +;; ;; (declare (uses filedb)) +;; +;; (include "common_records.scm") +;; (include "key_records.scm") +;; (include "db_records.scm") +;; (include "run_records.scm") +;; (include "test_records.scm") +;; ;; (include "debugger.scm") ;; use this struct to facilitate refactoring ;; @@ -128,11 +128,11 @@ (endt (+ startt duration))) ((or proc runs:parallel-runners-mgmt) rdat) (let loop () (let* ((wstart (current-seconds))) (if (< wstart endt) - (let* ((work-time (random 10))) + (let* ((work-time (pseudo-random-integer 10))) #;(debug:print-info 0 *default-log-port* "working for " work-time " seconds. Total work: " rtime ", elapsed time: " (- wstart startt)) (thread-sleep! work-time) (set! rtime (+ rtime work-time)) ((or proc runs:parallel-runners-mgmt) rdat) @@ -508,11 +508,11 @@ (keyvals (keys:target->keyval keys target)) (run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name))) ;; (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config")) (dbfile (conc *toppath* "/megatest.db")) - (readonly-mode (not (file-write-access? dbfile))) + (readonly-mode (not (file-writable? dbfile))) (test-records (make-hash-table)) ;; need to process runconfigs before generating these lists (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names #f) ;; (hash-table-keys all-tests-registry)) (test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts)) @@ -1268,11 +1268,11 @@ ((not have-resources) ;; simply try again after waiting a second (if (runs:lownoise "no resources" 60) (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ...")) ;; Have gone back and forth on this but db starvation is an issue. ;; wait one second before looking again to run jobs. - (thread-sleep! 0.25) + (thread-sleep! 0.253) ;; could have done hed tal here but doing car/cdr of newtal to rotate tests (list (car newtal)(cdr newtal) reg reruns)) ;; This is the final stage, everything is in place so launch the test ;; @@ -2342,11 +2342,11 @@ (keep-records (args:get-arg "-keep-records")) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode". (test-records '())) ;; for tasks that we wish to operate on all tests in one fell swoop (let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs)) (dbfile (conc *toppath* "/megatest.db")) - (readonly-mode (not (file-write-access? dbfile)))) + (readonly-mode (not (file-writable? dbfile)))) (when (and readonly-mode (member action write-access-actions)) (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .") (exit 1))) @@ -2565,11 +2565,11 @@ (substring-index run-name rundir) (tests:glob-like-match (conc "%/" target "/%") rundir) ) (begin (set! lasttpath (db:test-get-rundir new-test-dat)) ;; remember this path for run removal - (set! lastrealpath (remove-last-path-directory (resolve-pathname lasttpath))) + (set! lastrealpath (remove-last-path-directory (realpath lasttpath))) (hash-table-set! run-paths-hash lastrealpath 1) (runs:remove-test-directory new-test-dat mode) ;; 'remove-all) ) (begin (debug:print 2 *default-log-port* "Not removing directory " rundir " because either it doesn't exist or has a bad name") @@ -2733,11 +2733,11 @@ ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f))) (debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) (if (and real-dir (> (string-length real-dir) 5) (common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. - (let* ((realpath (resolve-pathname run-dir))) + (let* ((realpath (realpath run-dir))) (debug:print-info 1 *default-log-port* "Recursively removing " realpath) (if (common:file-exists? realpath) (runs:safe-delete-test-dir realpath) (debug:print 0 *default-log-port* "WARNING: test dir " realpath " appears to not exist or is not readable"))) (if real-dir @@ -2959,12 +2959,11 @@ '(*TOP* (*PI* xml "version='1.0'") (testsuite))) (define (runs:update-junit-test-reporter-xml run-id) - (let* ( - (junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml")) + (let* ((junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml")) (junit-test-report-dir (configf:lookup *configdat* "runs" "junit-test-report-dir")) (xml-dir (if (and junit-test-reporter (equal? junit-test-reporter "yes" )) (if junit-test-report-dir junit-test-report-dir (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))) @@ -3003,31 +3002,31 @@ (test-state (vector-ref test 3)) (comment (vector-ref test 14)) (test-status (vector-ref test 4)) (exc-msg (conc "No bucket for State " test-state " Status " test-status)) (new-doc (cond - ((member test-state (list "RUNNING" )) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc)) - ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc)) - ((member test-status (list "PASS" "WARN" "WAIVED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc)) - ((member test-status (list "FAIL" "CHECK")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc)) - ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc)) - ((member test-status (list "SKIP")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc)) - (else - (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status)) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc)))) - (new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) - (+ error-cnt 1) - error-cnt)) - (new-fail-cnt (if (member test-status (list "FAIL" "CHECK")) - (+ fail-cnt 1) - fail-cnt))) + ((member test-state (list "RUNNING" )) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc)) + ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED")) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc)) + ((member test-status (list "PASS" "WARN" "WAIVED")) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc)) + ((member test-status (list "FAIL" "CHECK")) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc)) + ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc)) + ((member test-status (list "SKIP")) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc)) + (else + (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status)) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc)))) + (new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) + (+ error-cnt 1) + error-cnt)) + (new-fail-cnt (if (member test-status (list "FAIL" "CHECK")) + (+ fail-cnt 1) + fail-cnt))) (if (null? tail) (let* ((final-doc ((sxml-modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc))) (debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt) (handle-exceptions exn Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -14,37 +14,30 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; -(require-extension (srfi 18) extras tcp s11n) - -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest - directory-utils posix-extras matchable) - -(use spiffy uri-common intarweb http-client spiffy-request-vars) - -(declare (unit server)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. -;; (declare (uses synchash)) -(declare (uses http-transport)) -;;(declare (uses rpc-transport)) -(declare (uses launch)) -;; (declare (uses daemon)) - -(include "common_records.scm") -(include "db_records.scm") - -(define (server:make-server-url hostport) - (if (not hostport) - #f - (conc "http://" (car hostport) ":" (cadr hostport)))) - -(define *server-loop-heart-beat* (current-seconds)) +;; (require-extension (srfi 18) extras tcp s11n) +;; +;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest +;; directory-utils posix-extras matchable) +;; +;; (use spiffy uri-common intarweb http-client spiffy-request-vars) +;; +;; (declare (unit server)) +;; +;; (declare (uses common)) +;; (declare (uses db)) +;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. +;; ;; (declare (uses synchash)) +;; (declare (uses http-transport)) +;; ;;(declare (uses rpc-transport)) +;; (declare (uses launch)) +;; ;; (declare (uses daemon)) +;; +;; (include "common_records.scm") +;; (include "db_records.scm") ;;====================================================================== ;; P K T S S T U F F ;;====================================================================== @@ -154,11 +147,11 @@ (begin (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile) (setenv "TARGETHOST" target-host))) (setenv "TARGETHOST_LOGF" logfile) - (thread-sleep! (/ (random 5000) 1000)) ;; add about a random (up to 5 seconds) initial delay. It seems pretty common that many running tests request a server at the same time + (thread-sleep! (/ (pseudo-random-integer 5000) 1000)) ;; add about a random (up to 5 seconds) initial delay. It seems pretty common that many running tests request a server at the same time ;; (common:wait-for-normalized-load load-limit " delaying server start due to load" target-host) ;; do not try starting servers on an already overloaded machine, just wait forever #;(common:wait-for-homehost-load load-limit (conc " delaying server start due to load on homehost. limit is " load-limit)) (system (conc "nbfake " cmdln)) (unsetenv "TARGETHOST_LOGF") (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) @@ -206,11 +199,11 @@ (debug:print-info 0 *default-log-port* "Server is in dbprep at " (current-seconds)) (thread-sleep! 25) ) (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (current-seconds)) ) - (list #f #f #f #f))))))))) + (list #f #f #f #f))))))))) ;; get a list of servers with all relevant data ;; ( mod-time host port start-time pid ) ;; (define (server:get-list areapath #!key (limit #f)) @@ -219,22 +212,21 @@ ;; if the directory exists continue to get the list ;; otherwise attempt to create the logs dir and then ;; continue (if (if (directory-exists? (conc areapath "/logs")) '() - (if (file-write-access? areapath) + (if (file-writable? areapath) (begin (condition-case (create-directory (conc areapath "/logs") #t) (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs"))) (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn))) (directory-exists? (conc areapath "/logs"))) '())) ;; Get the list of server logs that do not contain "exiting". Ignore logs for servers that have exited. - (let* ((server-logs-cmd (conc "grep -iL exiting " areapath "/logs/server-*-*.log")) - (server-logs (string-split (string-chomp (call-with-input-pipe server-logs-cmd read-all)))) + (let* ((server-logs (server:get-logs-list areapath)) (num-serv-logs (length server-logs))) (if (or (null? server-logs) (= num-serv-logs 0)) (let () (debug:print 1 *default-log-port* "There are no servers running") '() @@ -308,11 +300,11 @@ (< (- now mod-time) 16) ;; still alive - file touched in last 16 seconds (or (not (configf:lookup *configdat* "server" "runtime")) ;; skip if not set (< (- now start-time) (+ (- (string->number (configf:lookup *configdat* "server" "runtime")) 180) - (random 360)))) ;; under one hour running time +/- 180 + (pseudo-random-integer 360)))) ;; under one hour running time +/- 180 )) #f)) srvlst) (lambda (a b) (< (list-ref a 3) @@ -331,11 +323,11 @@ (define (server:get-rand-best areapath) (let ((srvrs (server:get-best (server:get-list areapath)))) (if (and (list? srvrs) (not (null? srvrs))) (let* ((len (length srvrs)) - (idx (random len))) + (idx (pseudo-random-integer len))) (list-ref srvrs idx)) #f))) (define (server:record->id servr) (handle-exceptions @@ -382,11 +374,11 @@ (begin (debug:print-info 0 *default-log-port* "Writing " start-flag) (with-output-to-file start-flag (lambda () (print server-key))) - (thread-sleep! 0.25) + (thread-sleep! 0.254) (let ((res (with-input-from-file start-flag (lambda () (read-line))))) (equal? server-key res)))) #t ;; (system (conc "touch " start-flag)) ;; lazy but safe @@ -410,11 +402,11 @@ (run-delay (+ (case call-num ((0) 0) ((1) 20) ((2) 300) (else 600)) - (random 5))) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously + (pseudo-random-integer 5))) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously (lock-file (conc areapath "/logs/server-start.lock"))) (if (> (- (current-seconds) when-run) run-delay) (let* ((start-flag (conc areapath "/logs/server-start-last"))) (common:simple-file-lock-and-wait lock-file expire-time: 15) (debug:print-info 0 *default-log-port* "server:kind-run: touching " start-flag) @@ -455,11 +447,11 @@ (servers (server:get-best (server:get-list areapath)))) (if (or (and servers (null? servers)) (not servers) (and (list? servers) - (< (length servers) (random ns)))) ;; somewhere between 0 and numservers + (< (length servers) (pseudo-random-integer ns)))) ;; somewhere between 0 and numservers #f (let loop ((hed (car servers)) (tal (cdr servers))) (let ((res (server:check-server hed))) (if res @@ -620,11 +612,11 @@ (calculate-off-time (lambda (work-duration duty-cycle) (* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds))) (off-time min-intersync-delay) ;; adjusted in closure below. (do-a-sync (lambda () - (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync) + ;; (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync) (let* ((finalres (let retry-loop ((num-tries 0)) (if (common:simple-file-lock lockfile) (begin (cond @@ -672,13 +664,13 @@ (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail") (if (file-exists? (conc mtdbfile ".backup")) (system (conc "/bin/cp "mtdbfile ".backup " mtdbfile))) #f)))) (common:simple-file-release-lock lockfile) - (BB> "released lockfile: " lockfile) - (when (common:file-exists? lockfile) - (BB> "DID NOT ACTUALLY RELEASE LOCKFILE")) + ;; (BB> "released lockfile: " lockfile) + ;; (when (common:file-exists? lockfile) + ;; (BB> "DID NOT ACTUALLY RELEASE LOCKFILE")) res2) ;; end let );; end begin ;; else (cond (persist-until-sync @@ -690,11 +682,11 @@ (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.") 'parallel-sync-in-progress)) ) ;; end if got lockfile ) )) - (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres) + ;; (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres) finalres) ) ;; end lambda )) do-a-sync)) @@ -715,11 +707,11 @@ (if (common:low-noise-print 30) (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))) (define (server:writable-watchdog-deltasync dbstruct) - (thread-sleep! 0.05) ;; delay for startup + (thread-sleep! 0.054) ;; delay for startup (let ((legacy-sync (common:run-sync?)) (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds)) (no-sync-db (db:open-no-sync-db)) ADDED servermod.scm Index: servermod.scm ================================================================== --- /dev/null +++ servermod.scm @@ -0,0 +1,51 @@ +;;====================================================================== +;; Copyright 2017, 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 servermod)) + +(module servermod + * + +(import scheme + chicken.base + chicken.string + chicken.process + chicken.io + chicken.time + + (prefix sqlite3 sqlite3:) + + typed-records + srfi-18 + srfi-69 + ) + +(define (server:make-server-url hostport) + (if (not hostport) + #f + (conc "http://" (car hostport) ":" (cadr hostport)))) + +(define (server:get-logs-list area-path) + (let* ((server-logs-cmd (conc "grep -iL exiting " area-path "/logs/server-*-*.log")) + (server-logs (string-split (string-chomp (with-input-from-pipe server-logs-cmd read-string))))) + server-logs)) + + +) Index: stml2.scm ================================================================== --- stml2.scm +++ stml2.scm @@ -19,5 +19,9 @@ ;;====================================================================== (declare (unit stml2)) (include "stml2/stml2.scm") + +(import stml2) + +(write "true") Index: stml2/cookie.scm ================================================================== --- stml2/cookie.scm +++ stml2/cookie.scm @@ -45,11 +45,11 @@ ;; (declare (unit cookie)) (module cookie * -(import chicken scheme data-structures extras srfi-13 ports posix) +(import (chicken base) scheme queues srfi-13 (chicken port) (chicken io)(chicken file) (chicken format) (chicken string) (chicken time posix)) (require-extension srfi-1 srfi-13 srfi-14 regex) ;; (use srfi-1 srfi-13 srfi-14 regex) ;; (declare (export parse-cookie-string construct-cookie-string)) Index: stml2/stml2.scm ================================================================== --- stml2/stml2.scm +++ stml2/stml2.scm @@ -12,17 +12,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: subrun.scm ================================================================== --- subrun.scm +++ subrun.scm @@ -16,30 +16,30 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) - posix-extras directory-utils pathname-expand typed-records format - call-with-environment-variables) -(declare (unit subrun)) -;;(declare (uses runs)) -(declare (uses db)) -(declare (uses common)) -;;(declare (uses items)) -;;(declare (uses runconfig)) -;;(declare (uses tests)) -;;(declare (uses server)) -(declare (uses mt)) -;;(declare (uses archive)) -;; (declare (uses filedb)) - -;(include "common_records.scm") -;;(include "key_records.scm") -(include "db_records.scm") ;; provides db:test-get-id -;;(include "run_records.scm") -;;(include "test_records.scm") +;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) +;; posix-extras directory-utils pathname-expand typed-records format +;; call-with-environment-variables) +;; (declare (unit subrun)) +;; ;;(declare (uses runs)) +;; (declare (uses db)) +;; (declare (uses common)) +;; ;;(declare (uses items)) +;; ;;(declare (uses runconfig)) +;; ;;(declare (uses tests)) +;; ;;(declare (uses server)) +;; (declare (uses mt)) +;; ;;(declare (uses archive)) +;; ;; (declare (uses filedb)) +;; +;; ;(include "common_records.scm") +;; ;;(include "key_records.scm") +;; (include "db_records.scm") ;; provides db:test-get-id +;; ;;(include "run_records.scm") +;; ;;(include "test_records.scm") (define (subrun:subrun-test-initialized? test-run-dir) (if (and (common:file-exists? (conc test-run-dir "/subrun-area") ) (common:file-exists? (conc test-run-dir "/testconfig.subrun") )) #t Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -16,18 +16,18 @@ ;; along with Megatest. If not, see . ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit tasks)) -(declare (uses db)) -(declare (uses rmt)) -(declare (uses common)) -(declare (uses pgdb)) +;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format) +;; (import (prefix sqlite3 sqlite3:)) +;; +;; (declare (unit tasks)) +;; (declare (uses db)) +;; (declare (uses rmt)) +;; (declare (uses common)) +;; (declare (uses pgdb)) ;; (import pgdb) ;; pgdb is a module (include "task_records.scm") (include "db_records.scm") @@ -107,25 +107,25 @@ (debug:print 5 *default-log-port* " exn=" (condition->list exn)))) (let* ((dbpath (db:dbfile-path )) ;; (tasks:get-task-db-path)) (dbfile (conc dbpath "/monitor.db")) (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away (exists (common:file-exists? dbpath)) - (write-access (file-write-access? dbpath)) + (write-access (file-writable? dbpath)) (mdb (cond ;; what the hek is *toppath* doing here? - ((and (string? *toppath*)(file-write-access? *toppath*)) + ((and (string? *toppath*)(file-writable? *toppath*)) (sqlite3:open-database dbfile)) - ((file-read-access? dbpath) (sqlite3:open-database dbfile)) + ((file-readable? dbpath) (sqlite3:open-database dbfile)) (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath)) (handler (sqlite3:make-busy-timeout 36000))) (if (and exists (not write-access)) (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control (sqlite3:set-busy-handler! mdb handler) (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) ;; (if (or (and (not exists) - ;; (file-write-access? *toppath*)) - ;; (not (file-read-access? dbpath))) + ;; (file-writable? *toppath*)) + ;; (not (file-readable? dbpath))) ;; (begin ;; ;; TASKS QUEUE MOVED TO main.db ;; ;; (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -20,27 +20,27 @@ ;;====================================================================== ;; Database access ;;====================================================================== -(require-extension (srfi 18) extras tcp) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) - -(declare (unit tdb)) -(declare (uses common)) -(declare (uses keys)) -(declare (uses ods)) -(declare (uses client)) -(declare (uses mt)) -(declare (uses db)) - -(include "common_records.scm") -(include "db_records.scm") -(include "key_records.scm") -(include "run_records.scm") +;; (require-extension (srfi 18) extras tcp) +;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) +;; (import (prefix sqlite3 sqlite3:)) +;; (import (prefix base64 base64:)) +;; +;; (declare (unit tdb)) +;; (declare (uses common)) +;; (declare (uses keys)) +;; (declare (uses ods)) +;; (declare (uses client)) +;; (declare (uses mt)) +;; (declare (uses db)) +;; +;; (include "common_records.scm") +;; (include "db_records.scm") +;; (include "key_records.scm") +;; (include "run_records.scm") ;;====================================================================== ;; ;; T E S T D A T A B A S E S ;; @@ -57,14 +57,14 @@ ;; (define (open-test-db work-area) (debug:print-info 11 *default-log-port* "open-test-db " work-area) (if (and work-area (directory? work-area) - (file-read-access? work-area)) + (file-readable? work-area)) (let* ((dbpath (conc work-area "/testdat.db")) (dbexists (common:file-exists? dbpath)) - (work-area-writeable (file-write-access? work-area)) + (work-area-writeable (file-writable? work-area)) (db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem exn (begin (print-call-chain (current-error-port)) (debug:print 2 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" @@ -73,12 +73,12 @@ (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access (if (or work-area-writeable dbexists) (sqlite3:open-database dbpath) (sqlite3:open-database ":memory:")))) - (tdb-writeable (and (file-write-access? work-area) - (file-write-access? dbpath))) + (tdb-writeable (and (file-writable? work-area) + (file-writable? dbpath))) (handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) (if (and tdb-writeable Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -20,31 +20,31 @@ ;;====================================================================== ;; Tests ;;====================================================================== -(declare (unit tests)) -(declare (uses lock-queue)) -(declare (uses db)) -(declare (uses tdb)) -(declare (uses common)) -;; (declare (uses dcommon)) ;; needed for the steps processing -(declare (uses items)) -(declare (uses runconfig)) -;; (declare (uses sdb)) -(declare (uses server)) -;;(declare (uses stml2)) - -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) -(import (prefix sqlite3 sqlite3:)) -(require-library stml) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "test_records.scm") +;; (declare (unit tests)) +;; (declare (uses lock-queue)) +;; (declare (uses db)) +;; (declare (uses tdb)) +;; (declare (uses common)) +;; ;; (declare (uses dcommon)) ;; needed for the steps processing +;; (declare (uses items)) +;; (declare (uses runconfig)) +;; ;; (declare (uses sdb)) +;; (declare (uses server)) +;; ;;(declare (uses stml2)) +;; +;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) +;; (import (prefix sqlite3 sqlite3:)) +;; (require-library stml) +;; +;; (include "common_records.scm") +;; (include "key_records.scm") +;; (include "db_records.scm") +;; (include "run_records.scm") +;; (include "test_records.scm") (include "js-path.scm") (define (init-java-script-lib) (set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js")) ) @@ -559,11 +559,11 @@ 0) (file-modification-time lockf))) ;; we started since current re-gen in flight, delay a little and try again (begin (debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it") - (thread-sleep! (+ 5 (random 5))) ;; delay between 5 and 10 seconds + (thread-sleep! (+ 5 (pseudo-random-integer 5))) ;; delay between 5 and 10 seconds (loop (common:simple-file-lock lockf)))))))))) (define (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename) (let ((counts (make-hash-table)) (statecounts (make-hash-table)) @@ -909,11 +909,11 @@ ; (set! page (+ 1 page)) (if (> total-runs (* (+ 1 page) pg-size)) (loop (+ 1 page))))) (common:simple-file-release-lock lockfile)) (begin - (debug-print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f)))) + (debug:print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f)))) (define (tests:readlines filename) (call-with-input-file filename (lambda (p) @@ -1214,11 +1214,11 @@ (let* ((targ-path (string-intersperse p "/")) (full-path (conc linktree "/" targ-path)) (run-name (car (reverse p)))) (if (and (common:file-exists? full-path) (directory? full-path) - (file-write-access? full-path)) + (file-writable? full-path)) (s:a run-name 'href (conc targ-path "/run-summary.html")) (begin (debug:print 0 *default-log-port* "INFO: Can't create " targ-path "/run-summary.html") (conc run-name " (Not able to create summary at " targ-path ")"))))))))))) (close-output-port oup) @@ -1253,11 +1253,11 @@ (tests-htree (common:list->htree tests-tree-dat)) (html-dir (conc linktree "/" (string-intersperse run-dir "/"))) (html-path (conc html-dir "/run-summary.html")) (oup (if (and (common:file-exists? html-dir) (directory? html-dir) - (file-write-access? html-dir)) + (file-writable? html-dir)) (open-output-file html-path) #f))) ;; (print "run-dir: " run-dir ", tests-tree-dat: " tests-tree-dat) (if oup (begin @@ -1285,11 +1285,11 @@ alt-file std-file)) (run-name (car (reverse p)))) (if (and (not (common:file-exists? full-targ)) (directory? full-targ) - (file-write-access? full-targ)) + (file-writable? full-targ)) (tests:summarize-test run-id (rmt:get-test-id run-id test-name item-path))) (if (common:file-exists? full-targ) (s:a run-name 'href html-file) @@ -1418,11 +1418,11 @@ (let* ((test-dat (rmt:get-test-info-by-id run-id test-id)) (out-dir (db:test-get-rundir test-dat)) (status-file (conc out-dir "/.final-status")) ) ;; first verify we are able to write the output file - (if (not (file-write-access? out-dir)) + (if (not (file-writable? out-dir)) (debug:print 0 *default-log-port* "ERROR: cannot write .final-status to " out-dir) (let* ((outp (open-output-file status-file)) (status (db:test-get-status test-dat)) (state (db:test-get-state test-dat))) @@ -1436,11 +1436,11 @@ (define (tests:summarize-test run-id test-id) (let* ((test-dat (rmt:get-test-info-by-id run-id test-id)) (out-dir (db:test-get-rundir test-dat)) (out-file (conc out-dir "/test-summary.html"))) ;; first verify we are able to write the output file - (if (not (file-write-access? out-dir)) + (if (not (file-writable? out-dir)) (debug:print 0 *default-log-port* "ERROR: cannot write test-summary.html to " out-dir) (let* (;; (steps-dat (rmt:get-steps-for-test run-id test-id)) (test-name (db:test-get-testname test-dat)) (item-path (db:test-get-item-path test-dat)) (full-name (db:test-make-full-name test-name item-path)) @@ -1595,11 +1595,11 @@ (conc *toppath* "/tests/" test-name))) (test-configf (conc test-path "/testconfig")) (testexists (let loopa ((tries-left 30)) (cond ( - (and (common:file-exists? test-configf)(file-read-access? test-configf)) + (and (common:file-exists? test-configf)(file-readable? test-configf)) #t) ( (common:file-exists? test-configf) (debug:print 0 *default-log-port* "WARNING: Cannot read testconfig file: "test-configf) #f) @@ -1619,11 +1619,11 @@ #f))) (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data (if tcfg (hash-table-set! *testconfigs* test-full-name tcfg)) (if (and testexists cache-file - (file-write-access? cache-path) + (file-writable? cache-path) allow-write-cache) (let ((tpath (conc cache-path "/.testconfig"))) (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) (if (and tcfg (not (common:in-running-test?))) (configf:write-alist tcfg tpath)))) @@ -1728,11 +1728,11 @@ (let ((res (read-lines))) ;; (delete-file temp-path) res)))))) (define (tests:write-dot-file test-records fname sizex sizey) - (if (file-write-access? (pathname-directory fname)) + (if (file-writable? (pathname-directory fname)) (with-output-to-file fname (lambda () (map print (tests:tests->dot test-records sizex sizey)))))) (define (tests:tests->dot test-records sizex sizey) Index: vg.scm ================================================================== --- vg.scm +++ vg.scm @@ -379,20 +379,20 @@ b)) ;; Obsolete function ;; (define (vg:generate-color) - (vg:rgb->number (random 255) - (random 255) - (random 255))) + (vg:rgb->number (pseudo-random-integer 255) + (pseudo-random-integer 255) + (pseudo-random-integer 255))) ;; Need to return a string of random iup-color for graph ;; (define (vg:generate-color-rgb) - (conc (number->string (random 255)) " " - (number->string (random 255)) " " - (number->string (random 255)))) + (conc (number->string (pseudo-random-integer 255)) " " + (number->string (pseudo-random-integer 255)) " " + (number->string (pseudo-random-integer 255)))) (define (vg:iup-color->number iup-color) (apply vg:rgb->number (map string->number (string-split iup-color)))) ;;====================================================================== ADDED vgmod.scm Index: vgmod.scm ================================================================== --- /dev/null +++ vgmod.scm @@ -0,0 +1,672 @@ +;; +;; Copyright 2016 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 . + +;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') + +(declare (unit vgmod)) + +(module vgmod + * + +(import scheme chicken data-structures extras ports) +(use canvas-draw iup) +(use typed-records srfi-1 srfi-69) +(import canvas-draw-iup) + +(include "vg_records.scm") + +;; ;; structs +;; ;; +;; (defstruct vg:lib comps) +;; (defstruct vg:comp objs name file) +;; ;; extents caches extents calculated on draw +;; ;; proc is called on draw and takes the obj itself as a parameter +;; ;; attrib is an alist of parameters +;; (defstruct vg:obj type pts fill-color text line-color call-back angle font attrib extents proc) +;; (defstruct vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache) +;; (defstruct vg:drawing libs insts scalex scaley xoff yoff cnv cache) ;; libs: hash of name->lib, insts: hash of instname->inst + +;; inits +;; +(define (vg:comp-new) + (make-vg:comp objs: '() name: #f file: #f)) + +(define (vg:lib-new) + (make-vg:lib comps: (make-hash-table))) + +(define (vg:drawing-new) + (make-vg:drawing scalex: 1 + scaley: 1 + xoff: 0 + yoff: 0 + libs: (make-hash-table) + insts: (make-hash-table) + cache: '())) + +;;====================================================================== +;; scaling and offsets +;;====================================================================== + +(define-inline (vg:scale-offset val s o) + (+ o (* val s))) + ;; (* (+ o val) s)) + +;; apply scale and offset to a list of x y values +;; +(define (vg:scale-offset-xy lstxy sx sy ox oy) + (if (> (length lstxy) 1) ;; have at least one xy pair + (let loop ((x (car lstxy)) + (y (cadr lstxy)) + (tal (cddr lstxy)) + (res '())) + (let ((newres (cons (vg:scale-offset y sy oy) + (cons (vg:scale-offset x sx ox) + res)))) + (if (> (length tal) 1) + (loop (car tal)(cadr tal)(cddr tal) newres) + (reverse newres)))) + '())) + +;; apply drawing offset and scaling to the points in lstxy +;; +(define (vg:drawing-apply-scale drawing lstxy) + (vg:scale-offset-xy + lstxy + (vg:drawing-scalex drawing) + (vg:drawing-scaley drawing) + (vg:drawing-xoff drawing) + (vg:drawing-yoff drawing))) + +;; apply instance offset and scaling to the points in lstxy +;; +(define (vg:inst-apply-scale inst lstxy) + (vg:scale-offset-xy + lstxy + (vg:inst-scalex inst) + (vg:inst-scaley inst) + (vg:inst-xoff inst) + (vg:inst-yoff inst))) + +;; apply both drawing and instance scaling to a list of xy points +;; +(define (vg:drawing-inst-apply-scale-offset drawing inst lstxy) + (vg:drawing-apply-scale + drawing + (vg:inst-apply-scale inst lstxy))) + +;;====================================================================== +;; objects +;;====================================================================== + +;; (vg:inst-apply-scale +;; inst +;; (vg:drawing-apply-scale drawing lstxy))) + +;; make a rectangle obj +;; +(define (vg:make-rect-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f)) + (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: extents)) + +;; make a rectangle obj +;; +(define (vg:make-line-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f)) + (make-vg:obj type: 'l pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color extents: extents)) + +;; make a text obj +;; +(define (vg:make-text-obj x1 y1 text #!key (line-color #f)(fill-color #f) + (angle #f)(scale-with-zoom #f)(font #f) + (font-size #f)) + (make-vg:obj type: 't pts: (list x1 y1) text: text + line-color: line-color fill-color: fill-color + angle: angle font: font extents: #f + attributes: (vg:make-attrib 'font-size font-size))) + +;; proc takes startnum and endnum and yields scalef, per-grad and unitname +;; +(define (vg:make-xaxis-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(proc #f)) + (make-vg:obj type: 'x pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: #f proc: proc)) + +;;====================================================================== +;; obj modifiers and queries +;;====================================================================== + +;; get extents, use knowledge of type ... +;; +(define (vg:obj-get-extents drawing obj) + (let ((type (vg:obj-type obj))) + (case type + ((l)(vg:rect-get-extents obj)) + ((r)(vg:rect-get-extents obj)) + ((t)(vg:draw-text drawing obj draw: #f)) + (else #f)))) + +(define (vg:rect-get-extents obj) + (vg:obj-pts obj)) ;; extents are just the points for a rectangle + +(define (vg:grow-rect borderx bordery x1 y1 x2 y2) + (list + (- x1 borderx) + (- y1 bordery) + (+ x2 borderx) + (+ y2 bordery))) + +(define (vg:make-attrib . attrib-list) + #f) + +;;====================================================================== +;; components +;;====================================================================== + +;; add obj to comp +;; +(define (vg:add-objs-to-comp comp . objs) + (vg:comp-objs-set! comp (append (vg:comp-objs comp) objs))) + +(define (vg:add-obj-to-comp comp obj) + (vg:comp-objs-set! comp (cons obj (vg:comp-objs comp)))) + +;; use the struct. leave this here to remind of this! +;; +;; (define (vg:comp-get-objs comp) +;; (vg:comp-objs comp)) + +;; add comp to lib +;; +(define (vg:add-comp-to-lib lib compname comp) + (hash-table-set! (vg:lib-comps lib) compname comp)) + +;; instanciate component in drawing +;; +(define (vg:instantiate drawing libname compname instname xoff yoff #!key (theta 0)(scalex 1)(scaley 1)(mirrx #f)(mirry #f)) + (let ((inst (make-vg:inst libname: libname compname: compname xoff: xoff yoff: yoff theta: theta scalex: scalex scaley: scaley mirrx: mirrx mirry: mirry)) ) + (hash-table-set! (vg:drawing-insts drawing) instname inst))) + +(define (vg:instance-move drawing instname newx newy) + (let ((inst (hash-table-ref (vg:drawing-insts drawing) instname))) + (vg:inst-xoff-set! inst newx) + (vg:inst-yoff-set! inst newy))) + +;; get component from drawing (look in apropriate lib) given libname and compname +(define (vg:get-component drawing libname compname) + (let* ((lib (hash-table-ref (vg:drawing-libs drawing) libname)) + (inst (hash-table-ref (vg:lib-comps lib) compname))) + inst)) + +(define (vg:get-extents-for-objs drawing objs) + (if (or (not objs) + (null? objs)) + #f + (let loop ((hed (car objs)) + (tal (cdr objs)) + (extents (vg:obj-get-extents drawing (car objs)))) + (let ((newextents + (vg:get-extents-for-two-rects + extents + (vg:obj-get-extents drawing hed)))) + (if (null? tal) + extents + (loop (car tal)(cdr tal) newextents)))))) + +;; (let ((extents #f)) +;; (for-each +;; (lambda (obj) +;; (set! extents +;; (vg:get-extents-for-two-rects +;; extents +;; (vg:obj-get-extents drawing obj)))) +;; objs) +;; extents)) + +;; given rectangles r1 and r2, return the box that bounds both +;; +(define (vg:get-extents-for-two-rects r1 r2) + (if (not r1) + r2 + (if (not r2) + r1 ;; #f ;; no extents from #f #f + (list (min (car r1)(car r2)) ;; llx + (min (cadr r1)(cadr r2)) ;; lly + (max (caddr r1)(caddr r2)) ;; ulx + (max (cadddr r1)(cadddr r2)))))) ;; uly + +(define (vg:components-get-extents drawing . comps) + (if (null? comps) + #f + (let loop ((hed (car comps)) + (tal (cdr comps)) + (extents #f)) + (let* ((objs (vg:comp-objs hed)) + (newextents (if extents + (vg:get-extents-for-two-rects + extents + (vg:get-extents-for-objs drawing objs)) + (vg:get-extents-for-objs drawing objs)))) + (if (null? tal) + newextents + (loop (car tal)(cdr tal) newextents)))))) + +;;====================================================================== +;; libraries +;;====================================================================== + +;; register lib with drawing + +;; +(define (vg:add-lib drawing libname lib) + (hash-table-set! (vg:drawing-libs drawing) libname lib)) + +(define (vg:get-lib drawing libname) + (hash-table-ref/default (vg:drawing-libs drawing) libname #f)) + +(define (vg:get/create-lib drawing libname) + (let ((lib (vg:get-lib drawing libname))) + (if lib + lib + (let ((newlib (vg:lib-new))) + (vg:add-lib drawing libname newlib) + newlib)))) + +;;====================================================================== +;; map objects given offset, scale and mirror, resulting obj is displayed +;;====================================================================== + +;; dispatch the drawing of obj off to the correct drawing routine +;; +(define (vg:map-obj drawing inst obj) + (case (vg:obj-type obj) + ((l)(vg:map-line drawing inst obj)) + ((r)(vg:map-rect drawing inst obj)) + ((t)(vg:map-text drawing inst obj)) + ((x)(vg:map-xaxis drawing inst obj)) + (else #f))) + +;; given a drawing and a inst map a rectangle to it screen coordinates +;; +(define (vg:map-rect drawing inst obj) + (let ((res (make-vg:obj type: 'r ;; is there a defstruct copy? + fill-color: (vg:obj-fill-color obj) + text: (vg:obj-text obj) + line-color: (vg:obj-line-color obj) + font: (vg:obj-font obj))) + (pts (vg:obj-pts obj))) + (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts)) + (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) )) + res)) + +;; given a drawing and a inst map a line to it screen coordinates +;; +(define (vg:map-line drawing inst obj) + (let ((res (make-vg:obj type: 'l ;; is there a defstruct copy? + line-color: (vg:obj-line-color obj) + font: (vg:obj-font obj))) + (pts (vg:obj-pts obj))) + (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts)) + (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) )) + res)) + +;; given a drawing and a inst map a text to it screen coordinates +;; +(define (vg:map-text drawing inst obj) + (let ((res (make-vg:obj type: 't + fill-color: (vg:obj-fill-color obj) + text: (vg:obj-text obj) + line-color: (vg:obj-line-color obj) + font: (vg:obj-font obj) + angle: (vg:obj-angle obj) + attrib: (vg:obj-attrib obj))) + (pts (vg:obj-pts obj))) + (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts)) + (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing))) + res)) + +;; given a drawing and a inst map a line to it screen coordinates +;; +(define (vg:map-xaxis drawing inst obj) + (let ((res (make-vg:obj type: 'x ;; is there a defstruct copy? + line-color: (vg:obj-line-color obj) + font: (vg:obj-font obj))) + (pts (vg:obj-pts obj))) + (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts)) + (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) )) + res)) + +;;====================================================================== +;; instances +;;====================================================================== + +(define (vg:instances-get-extents drawing . instance-names) + (let ((xtnt-lst (vg:draw drawing #f))) + (if (null? xtnt-lst) + #f + (let loop ((extents (car xtnt-lst)) + (tal (cdr xtnt-lst)) + (llx #f) + (lly #f) + (ulx #f) + (uly #f)) + (let ((nllx (if llx (min llx (list-ref extents 0))(list-ref extents 0))) + (nlly (if lly (min lly (list-ref extents 1))(list-ref extents 1))) + (nulx (if ulx (max ulx (list-ref extents 2))(list-ref extents 2))) + (nuly (if uly (max uly (list-ref extents 3))(list-ref extents 3)))) + (if (null? tal) + (list llx lly ulx uly) + (loop (car tal)(cdr tal) nllx nlly nulx nuly))))))) + +(define (vg:lib-get-component lib instname) + (hash-table-ref/default (vg:lib-comps lib) instname #f)) + +;;====================================================================== +;; color +;;====================================================================== + +(define (vg:rgb->number r g b #!key (a 0)) + (bitwise-ior + (arithmetic-shift a 24) + (arithmetic-shift r 16) + (arithmetic-shift g 8) + b)) + +;; Obsolete function +;; +(define (vg:generate-color) + (vg:rgb->number (random 255) + (random 255) + (random 255))) + +;; Need to return a string of random iup-color for graph +;; +(define (vg:generate-color-rgb) + (conc (number->string (random 255)) " " + (number->string (random 255)) " " + (number->string (random 255)))) + +(define (vg:iup-color->number iup-color) + (apply vg:rgb->number (map string->number (string-split iup-color)))) + +;;====================================================================== +;; graphing +;;====================================================================== + +(define (vg:make-xaxis drawing component x1 y1 x2 y2 startnum endnum scaleproc) + (let ((obj (vg:make-xaxis-obj x1 y1 x2 y2))) + #f)) + +;;====================================================================== +;; Unravel and draw the objects +;;====================================================================== + +;; with get-extents = #t return the extents +;; with draw = #f don't actually draw the object +;; +(define (vg:draw-obj drawing obj #!key (draw #t)) + ;; (print "obj type: " (vg:obj-type obj)) + (case (vg:obj-type obj) + ((l)(vg:draw-line drawing obj draw: draw)) + ((r)(vg:draw-rect drawing obj draw: draw)) + ((t)(vg:draw-text drawing obj draw: draw)))) + +;; given a rect obj draw it on the canvas applying first the drawing +;; scale and offset +;; +(define (vg:draw-rect drawing obj #!key (draw #t)) + (let* ((cnv (vg:drawing-cnv drawing)) + (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) + (fill-color (vg:obj-fill-color obj)) + (line-color (vg:obj-line-color obj)) + (text (vg:obj-text obj)) + (font (vg:obj-font obj)) + (llx (car pts)) + (lly (cadr pts)) + (ulx (caddr pts)) + (uly (cadddr pts)) + (w (- ulx llx)) + (h (- uly lly)) + (text-xmax #f) + (text-ymax #f)) + (if draw + (let ((prev-background-color (canvas-background cnv)) + (prev-foreground-color (canvas-foreground cnv))) + (if fill-color + (begin + (canvas-foreground-set! cnv fill-color) + (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h) + (if line-color + (canvas-foreground-set! cnv line-color) + (if fill-color + (canvas-foreground-set! cnv prev-foreground-color))) + (canvas-rectangle! cnv llx ulx lly uly) + (canvas-foreground-set! cnv prev-foreground-color) + (if text + (let* ((prev-font (canvas-font cnv)) + (font-changed (and font (not (equal? font prev-font))))) + (if font-changed (canvas-font-set! cnv font)) + (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) + (if (eq? draw 'get-extents) + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (set! text-xmax xmax)(set! text-ymax ymax))) + (if font-changed (canvas-font-set! cnv prev-font)))))) + ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax) + (if (vg:obj-extents obj) + (vg:obj-extents obj) + (if (not text) + pts ;; no text + (if (and text-xmax text-ymax) ;; have text + (let ((xt (list llx lly + (max ulx (+ llx text-xmax)) + (max uly (+ lly text-ymax))))) + (vg:obj-extents-set! obj xt) + xt) + (if cnv + (if (eq? draw 'get-extents) + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (let ((xt (list llx lly + (max ulx (+ llx xmax)) + (max uly (+ lly ymax))))) + (vg:obj-extents-set! obj xt) + xt)) + pts) + pts)))))) ;; return extents + +;; given a rect obj draw it on the canvas applying first the drawing +;; scale and offset +;; +(define (vg:draw-line drawing obj #!key (draw #t)) + (let* ((cnv (vg:drawing-cnv drawing)) + (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) + ;; (fill-color (vg:obj-fill-color obj)) + (line-color (vg:obj-line-color obj)) + (text (vg:obj-text obj)) + (font (vg:obj-font obj)) + (llx (car pts)) + (lly (cadr pts)) + (ulx (caddr pts)) + (uly (cadddr pts)) + (w (- ulx llx)) + (h (- uly lly)) + (text-xmax #f) + (text-ymax #f)) + (if draw + (let ((prev-background-color (canvas-background cnv)) + (prev-foreground-color (canvas-foreground cnv))) + ;; (if fill-color + ;; (begin + ;; (canvas-foreground-set! cnv fill-color) + ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h) + (if line-color + (canvas-foreground-set! cnv line-color)) + ;; (if fill-color + ;; (canvas-foreground-set! cnv prev-foreground-color))) + (canvas-line! cnv llx lly ulx uly) + (canvas-foreground-set! cnv prev-foreground-color) + (if text + (let* ((prev-font (canvas-font cnv)) + (font-changed (and font (not (equal? font prev-font))))) + (if font-changed (canvas-font-set! cnv font)) + (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (set! text-xmax xmax)(set! text-ymax ymax)) + (if font-changed (canvas-font-set! cnv prev-font)))))) + ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax) + (if (vg:obj-extents obj) + (vg:obj-extents obj) + (if (not text) + pts + (if (and text-xmax text-ymax) + (let ((xt (list llx lly + (max ulx (+ llx text-xmax)) + (max uly (+ lly text-ymax))))) + (vg:obj-extents-set! obj xt) + xt) + (if cnv + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (let ((xt (list llx lly + (max ulx (+ llx xmax)) + (max uly (+ lly ymax))))) + (vg:obj-extents-set! obj xt) + xt)) + pts)))))) ;; return extents + +;; given a rect obj draw it on the canvas applying first the drawing +;; scale and offset +;; +(define (vg:draw-xaxis drawing obj #!key (draw #t)) + (let* ((cnv (vg:drawing-cnv drawing)) + (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) + ;; (fill-color (vg:obj-fill-color obj)) + (line-color (vg:obj-line-color obj)) + (text (vg:obj-text obj)) + (font (vg:obj-font obj)) + (llx (car pts)) + (lly (cadr pts)) + (ulx (caddr pts)) + (uly (cadddr pts)) + (w (- ulx llx)) + (h (- uly lly)) + (text-xmax #f) + (text-ymax #f)) + (if draw + (let ((prev-background-color (canvas-background cnv)) + (prev-foreground-color (canvas-foreground cnv))) + ;; (if fill-color + ;; (begin + ;; (canvas-foreground-set! cnv fill-color) + ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h) + (if line-color + (canvas-foreground-set! cnv line-color) + #;(if fill-color + (canvas-foreground-set! cnv prev-foreground-color))) + (canvas-line! cnv llx ulx lly uly) + (canvas-foreground-set! cnv prev-foreground-color) + (if text + (let* ((prev-font (canvas-font cnv)) + (font-changed (and font (not (equal? font prev-font))))) + (if font-changed (canvas-font-set! cnv font)) + (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (set! text-xmax xmax)(set! text-ymax ymax)) + (if font-changed (canvas-font-set! cnv prev-font)))))) + ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax) + (if (vg:obj-extents obj) + (vg:obj-extents obj) + (if (not text) + pts + (if (and text-xmax text-ymax) + (let ((xt (list llx lly + (max ulx (+ llx text-xmax)) + (max uly (+ lly text-ymax))))) + (vg:obj-extents-set! obj xt) + xt) + (if cnv + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (let ((xt (list llx lly + (max ulx (+ llx xmax)) + (max uly (+ lly ymax))))) + (vg:obj-extents-set! obj xt) + xt)) + pts)))))) ;; return extents + +;; given a rect obj draw it on the canvas applying first the drawing +;; scale and offset +;; +(define (vg:draw-text drawing obj #!key (draw #t)) + (let* ((cnv (vg:drawing-cnv drawing)) + (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) + (text (vg:obj-text obj)) + (font (vg:obj-font obj)) + (fill-color (vg:obj-fill-color obj)) + (line-color (vg:obj-line-color obj)) + (llx (car pts)) + (lly (cadr pts))) + (if draw + (let* ((prev-background-color (canvas-background cnv)) + (prev-foreground-color (canvas-foreground cnv)) + (prev-font (canvas-font cnv)) + (font-changed (and font (not (equal? font prev-font))))) + (if line-color + (canvas-foreground-set! cnv line-color) + (if fill-color + (canvas-foreground-set! cnv prev-foreground-color))) + (if font-changed (canvas-font-set! cnv font)) + (canvas-text! cnv llx lly text) + ;; NOTE: we do not set the font back!! + (canvas-foreground-set! cnv prev-foreground-color))) + (if cnv + (if (eq? draw 'get-extents) + (let-values (((xmax ymax)(canvas-text-size cnv text))) + (append pts (list (+ llx xmax)(+ lly ymax)))) ;; will be wrong if text is rotated? + (append pts pts)) + (append pts pts)))) + +(define (vg:draw-inst drawing inst #!key (draw-mode #t)(prev-extents '())) + (let* ((libname (vg:inst-libname inst)) + (compname (vg:inst-compname inst)) + (comp (vg:get-component drawing libname compname)) + (objs (vg:comp-objs comp))) + ;; (print "comp: " comp) + (if (null? objs) + prev-extents + (let loop ((obj (car objs)) + (tal (cdr objs)) + (res prev-extents)) + (let* ((obj-xfrmd (vg:map-obj drawing inst obj)) + (newres (cons (vg:draw-obj drawing obj-xfrmd draw: draw-mode) res))) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres))))))) + +(define (vg:draw drawing draw-mode . instnames) + (let* ((insts (vg:drawing-insts drawing)) + (all-inst-names (hash-table-keys insts)) + (master-list (if (null? instnames) + all-inst-names + instnames))) + (if (null? master-list) + '() + (let loop ((instname (car master-list)) + (tal (cdr master-list)) + (res '())) + (let* ((inst (hash-table-ref/default insts instname #f)) + (newres (if inst + (vg:draw-inst drawing inst draw-mode: draw-mode prev-extents: res) + res))) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres))))))) + +) DELETED widgets.scm Index: widgets.scm ================================================================== --- widgets.scm +++ /dev/null @@ -1,208 +0,0 @@ -;; Copyright 2006-2017, 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 . - -(require-library srfi-4 iup) -(import srfi-4 iup - ;; iup-pplot - iup-glcanvas) ;; iup-web - -(define (popup dlg . args) - (apply show dlg #:modal? 'yes args) - (destroy! dlg)) - -(define (properties ih) - (popup (element-properties-dialog ih)) - 'default) - -(define dlg - (dialog - (vbox - (hbox ; headline - (fill) - (frame (label " Inspect control and dialog classes " - fontsize: 15)) - (fill) - margin: '0x0) - - (label "") - (label "Dialogs" fontsize: 12) - (hbox - (button "dialog" - action: (lambda (self) (properties (dialog (vbox))))) - (button "color-dialog" - action: (lambda (self) (properties (color-dialog)))) - (button "file-dialog" - action: (lambda (self) (properties (file-dialog)))) - (button "font-dialog" - action: (lambda (self) (properties (font-dialog)))) - (button "message-dialog" - action: (lambda (self) (properties (message-dialog)))) - (fill) - margin: '0x0) - (hbox - (button "layout-dialog" - action: (lambda (self) (properties (layout-dialog)))) - (button "element-properties-dialog" - action: (lambda (self) - (properties - (element-properties-dialog (create 'user))))) - (fill) - margin: '0x0) - - (label "") - (label "Composition widgets" fontsize: 12) - (hbox - (button "fill" - action: (lambda (self) (properties (fill)))) - (button "hbox" - action: (lambda (self) (properties (hbox)))) - (button "vbox" - action: (lambda (self) (properties (vbox)))) - (button "zbox" - action: (lambda (self) (properties (zbox)))) - (button "radio" - action: (lambda (self) (properties (radio (vbox))))) - (button "normalizer" - action: (lambda (self) (properties (normalizer)))) - (button "cbox" - action: (lambda (self) (properties (cbox)))) - (button "sbox" - action: (lambda (self) (properties (sbox (vbox))))) - (button "split" - action: (lambda (self) (properties (split (vbox) (vbox))))) - (fill) - margin: '0x0) - - (label "") - (label "Standard widgets" fontsize: 12) - (hbox - (button "button" - action: (lambda (self) (properties (button)))) - (button "canvas" - action: (lambda (self) (properties (canvas)))) - (button "frame" - action: (lambda (self) (properties (frame)))) - (button "label" - action: (lambda (self) (properties (label)))) - (button "listbox" - action: (lambda (self) (properties (listbox)))) - (button "progress-bar" - action: (lambda (self) (properties (progress-bar)))) - (button "spin" - action: (lambda (self) (properties (spin)))) - (fill) - margin: '0x0) - (hbox - (button "tabs" - action: (lambda (self) (properties (tabs)))) - (button "textbox" - action: (lambda (self) (properties (textbox)))) - (button "toggle" - action: (lambda (self) (properties (toggle)))) - (button "treebox" - action: (lambda (self) (properties (treebox)))) - (button "valuator" - action: (lambda (self) (properties (valuator "")))) - (fill) - margin: '0x0) - - (label "") - (label "Additional widgets" fontsize: 12) - (hbox - (button "cells" - action: (lambda (self) (properties (cells)))) - (button "color-bar" - action: (lambda (self) (properties (color-bar)))) - (button "color-browser" - action: (lambda (self) (properties (color-browser)))) - (button "dial" - action: (lambda (self) (properties (dial "")))) - (button "matrix" - action: (lambda (self) (properties (matrix)))) - (fill) - margin: '0x0) - (hbox - #;(button "pplot" - action: (lambda (self) (properties (pplot)))) - (button "glcanvas" - action: (lambda (self) (properties (glcanvas)))) - ;; (button "web-browser" - ;; action: (lambda (self) (properties (web-browser)))) - (fill) - margin: '0x0) - - (label "") - (label "Menu widgets" fontsize: 12) - (hbox - (button "menu" - action: (lambda (self) (properties (menu)))) - (button "menu-item" - action: (lambda (self) (properties (menu-item)))) - (button "menu-separator" - action: (lambda (self) (properties (menu-separator)))) - (fill) - margin: '0x0) - - (label "") - (label "Images" fontsize: 12) - (hbox - (button "image/palette" - action: (lambda (self) - (properties - (image/palette 1 1 (u8vector->blob (u8vector 0)))))) - (button "image/rgb" - action: (lambda (self) - (properties - (image/rgb 1 1 (u8vector->blob (u8vector 0)))))) - (button "image/rgba" - action: (lambda (self) - (properties - (image/rgba 1 1 (u8vector->blob (u8vector 0)))))) - (button "image/file" - action: (lambda (self) - (properties - ;; same attributes as image/palette - (image/palette 1 1 (u8vector->blob (u8vector 0)))))) - ;; needs a file in current directory - ;(image/file "chicken.ico")))) ; ok - ;(image/file "chicken.png")))) ; doesn't work - (fill) - margin: '0x0) - - (label "") - (label "Other widgets" fontsize: 12) - (hbox - (button "clipboard" - action: (lambda (self) (properties (clipboard)))) - (button "timer" - action: (lambda (self) (properties (timer)))) - (button "spinbox" - action: (lambda (self) (properties (spinbox (vbox))))) - (fill) - margin: '0x0) - - (fill) - (button "E&xit" - expand: 'horizontal - action: (lambda (self) 'close)) - ) - margin: '15x15 - title: "Iup inspector")) - -(show dlg) -(main-loop) -(exit 0)