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 + +# 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 @@ -16,16 +16,16 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -(declare (unit adjutant)) +;; (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") @@ -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)) @@ -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: 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,54 @@ ;; 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)) +;; 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/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,21 @@ *this-exe-dir* *this-exe-name* *this-exe-fullpath* ) - (import scheme chicken extras ports data-structures ) - (use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339) + (import scheme chicken.base chicken.port chicken.process chicken.io chicken.pathname chicken.process-context chicken.time chicken.process chicken.condition chicken.time.posix chicken.process-context.posix chicken.format chicken.file.posix) + (import regex ansi-escape-sequences test srfi-1 chicken.irregex slice srfi-13 rfc3339) ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process* - (use directory-utils uuid-lib filepath srfi-19 ) ; linenoise + ;;(import directory-utils uuid-lib filepath srfi-19 ) ; linenoise + (import directory-utils filepath srfi-19 ) ; linenoise ;; plugs a hole in posix-extras in latter chicken versions - (use posix-extras pathname-expand files) + (import pathname-expand chicken.file chicken.string) (define ##sys#expand-home-path pathname-expand) - (define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) )) + (define (realpath x) (print "Path: " x) (normalize-pathname (pathname-expand (or x "/dev/null")) )) + ;;(define (realpath x) (pathname-expand (or x "/dev/null"))) ;; (include "mimetypes.scm") ; provides ext->mimetype ;; (include "workweekdate.scm") ;; gathered from macosx: @@ -841,14 +843,14 @@ ("avi" . "video/x-msvideo") ("movie" . "video/x-sgi-movie") ("smv" . "video/x-smv") ("ice" . "x-conference/x-cooltalk"))) -(use srfi-19) -(use test) +(import srfi-19) +(import test) ;;(use format) -(use regex) +(import regex) ;(declare (unit wwdate)) ;; utility procedures to convert among ;; different ways to express date (wwdate, seconds since epoch, isodate) ;; ;; samples: @@ -1058,11 +1060,11 @@ (if (null? rest-path-items) #f (let* ((this-dir (car rest-path-items)) (next-rest (cdr rest-path-items)) (candidate (conc this-dir "/" exe))) - (if (file-execute-access? candidate) + (if (file-executable? candidate) candidate (loop next-rest))))))) @@ -1247,15 +1249,15 @@ (let ((num-debug-level (runs-ok (string->number raw-debug-level)))) (if (integer? num-debug-level) (begin (let ((new-num-debug-level (- num-debug-level 1))) (if (> new-num-debug-level 0) ;; decrement - (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level)) - (unsetenv "DUCTTAPE_DEBUG_LEVEL"))) + (set-environment-variable! "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level)) + (unset-environment-variable! "DUCTTAPE_DEBUG_LEVEL"))) num-debug-level) ; it was set and > 0, mode is value (begin - (unsetenv "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it + (unset-environment-variable! "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it #f))) ; value was invalid, mode is f #f)))) ; var not set, mode is f (define ducttape-debug-mode (if (ducttape-debug-level) #t #f)) @@ -1360,11 +1362,11 @@ (user (or (get-environment-variable "USER") "nouser")) (host (or (get-environment-variable "HOST") "nohost"))) (if logfile (begin (ducttape-log-file logfile) - (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file)))) + (set-environment-variable! "DUCTTAPE_LOG_FILE" (ducttape-log-file)))) (ducttape-append-logfile 'note (format #f "START - pid=~A ppid=~A argv=(~A) pwd=~A user=~A host=~A" pid ppid argv pwd user host) #t))) ;; log exit code (define (set-ducttape-log-exit-handler) @@ -1522,11 +1524,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 +1706,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 +1754,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)) 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,37 +14,37 @@ ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . -(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)))) @@ -224,14 +224,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 +299,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 +522,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 +612,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,55 +14,239 @@ ;; ;; 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)) + +;; (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 + 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 + + ) + ;; 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 "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") + +;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:) +;; readline apropos json http-client directory-utils typed-records +;; http-client srfi-18 extras format) ;; Added for csv stuff - will be removed ;; -(use sparse-vectors) +;; (use sparse-vectors) +;; +;; (require-library mutils) -(require-library mutils) +;; copied from egg call-with-environment-variables +;; +(define (call-with-environment-variables variables thunk) + ;; @("Sets up environment variable via dynamic-wind which are taken down after thunk." + ;; (variables "An alist of the form {{'((\"var\" . \"value\") ...)}}") + ;; (thunk "The thunk to execute with a modified environment")) + (let ((pre-existing-variables + (map (lambda (var-value) + (let ((var (car var-value))) + (cons var (get-environment-variable var)))) + variables))) + (dynamic-wind + (lambda () (void)) + (lambda () +;; (use posix) + (for-each (lambda (var-value) + (setenv (car var-value) (cdr var-value))) + variables) + (thunk)) + (lambda () + (for-each (lambda (var-value) + (let ((var (car var-value)) + (value (cdr var-value))) + (if value + (setenv var value) + (unsetenv var)))) + pre-existing-variables))))) + + (define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file ;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file @@ -72,11 +256,11 @@ (load debugcontrolf))) ;; usage logging, careful with this, it is not designed to deal with all real world challenges! ;; (if (and *usage-log-file* - (file-write-access? *usage-log-file*)) + (file-writable? *usage-log-file*)) (with-output-to-file *usage-log-file* (lambda () (print (if *usage-use-seconds* @@ -552,11 +736,11 @@ 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) + (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 @@ -1000,11 +1184,11 @@ (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")) #f)) (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f))) (if (and cfgf (common:file-exists? cfgf) - (file-write-access? cfgf) + (file-writable? cfgf) (common:use-cache?)) (configf:read-alist cfgf) (let* ((keys (rmt:get-keys)) (target (common:args-get-target)) (key-vals (if target (keys:target->keyval keys target) #f)) @@ -1017,11 +1201,11 @@ key-vals)) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) (runconfig:read (conc *toppath* "/runconfigs.config") target #f)))) (if (and rundir ;; have all needed variabless (directory-exists? rundir) - (file-write-access? rundir)) + (file-writable? rundir)) (begin (if (not (common:in-running-test?)) (configf:write-alist data cfgf)) ;; force re-read of megatest.config - this resolves circular references between megatest.config (launch:setup force-reread: #t) @@ -1683,11 +1867,11 @@ ;; (print "runs:") ;; (pp runs) ;(print "sheets: ") ;; (pp sheets) (if (eq? dmode 'ods) - (let* ((tempdir (conc "/tmp/" (current-user-name) "/" (random 10000) "_" (current-process-id))) + (let* ((tempdir (conc "/tmp/" (current-user-name) "/" (pseudo-random-integer 10000) "_" (current-process-id))) (outputfile (or (args:get-arg "-o") "out.ods")) (ouf (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path? outputfile (begin (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") @@ -1898,19 +2082,19 @@ ;;====================================================================== ;; 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)))) +;; (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 ;;====================================================================== @@ -2310,11 +2494,11 @@ (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) + (rmt:find-and-mark-incomplete #f) (set! *didsomething* #t))) ;;====================================================================== ;; Update the tests meta data from the testconfig files ;;====================================================================== @@ -2331,11 +2515,11 @@ ;;====================================================================== ;; Start a repl ;;====================================================================== ;; fakeout readline -(include "readline-fix.scm") +;; (include "readline-fix.scm") (when (args:get-arg "-diff-rep") (when (and (not (args:get-arg "-diff-html")) @@ -2378,25 +2562,25 @@ (repl)) (else (begin (set! *db* dbstruct) - (import extras) ;; might not be needed + ;; (import extras) ;; might not be needed ;; (import csi) - (import readline) + ;; (import readline) (import apropos) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... - (if *use-new-readline* - (begin - (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) - (current-input-port (make-readline-port "megatest> "))) - (begin - (gnu-history-install-file-manager - (string-append - (or (get-environment-variable "HOME") ".") "/.megatest_history")) - (current-input-port (make-gnu-readline-port "megatest> ")))) + ;; (if *use-new-readline* + ;; (begin + ;; (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) + ;; (current-input-port (make-readline-port "megatest> "))) + ;; (begin + ;; (gnu-history-install-file-manager + ;; (string-append + ;; (or (get-environment-variable "HOME") ".") "/.megatest_history")) + ;; (current-input-port (make-gnu-readline-port "megatest> ")))) (if (args:get-arg "-repl") (repl) (load (args:get-arg "-load"))) ;; (db:close-all dbstruct) <= taken care of by on-exit call ) @@ -2550,5 +2734,6 @@ (case *globalexitstatus* ((0)(exit 0)) ((1)(exit 1)) ((2)(exit 2)) (else (exit 3))))) +) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -15,29 +15,29 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit mt)) -(declare (uses db)) -(declare (uses common)) -(declare (uses items)) -(declare (uses runconfig)) -(declare (uses tests)) -(declare (uses server)) -(declare (uses runs)) -(declare (uses rmt)) -;; (declare (uses filedb)) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "test_records.scm") +;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables) +;; (import (prefix sqlite3 sqlite3:)) +;; +;; (declare (unit mt)) +;; (declare (uses db)) +;; (declare (uses common)) +;; (declare (uses items)) +;; (declare (uses runconfig)) +;; (declare (uses tests)) +;; (declare (uses server)) +;; (declare (uses runs)) +;; (declare (uses rmt)) +;; ;; (declare (uses filedb)) +;; +;; (include "common_records.scm") +;; (include "key_records.scm") +;; (include "db_records.scm") +;; (include "run_records.scm") +;; (include "test_records.scm") ;; This is the Megatest API. All generally "useful" routines will be wrapped or extended ;; here. ;;====================================================================== @@ -155,14 +155,14 @@ event-time )) (prev-nbfake-log (get-environment-variable "NBFAKE_LOG"))) (setenv "NBFAKE_LOG" (conc (cond ((and (directory-exists? test-rundir) - (file-write-access? test-rundir)) + (file-writable? test-rundir)) test-rundir) ((and (directory-exists? *toppath*) - (file-write-access? *toppath*)) + (file-writable? *toppath*)) *toppath*) (else (conc "/tmp/" (current-user-name)))) "/" logname)) (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG")) ;; (call-with-environment-variables @@ -285,11 +285,11 @@ (let loop ((hed (car test-dirs)) (tal (cdr test-dirs))) ;; Setting MT_LINKTREE here is almost certainly unnecessary. (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) (if (and (common:file-exists? tconfig-file) - (file-read-access? tconfig-file)) + (file-readable? tconfig-file)) (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) (old-link-tree (get-environment-variable "MT_LINKTREE"))) (if link-tree-path (setenv "MT_LINKTREE" link-tree-path)) (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...] (hash-table-set! *testconfigs* test-name newtcfg) Index: 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,33 +3002,33 @@ (test-state (vector-ref test 3)) (comment (vector-ref test 14)) (test-status (vector-ref test 4)) (exc-msg (conc "No bucket for State " test-state " Status " test-status)) (new-doc (cond - ((member test-state (list "RUNNING" )) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc)) - ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc)) - ((member test-status (list "PASS" "WARN" "WAIVED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc)) - ((member test-status (list "FAIL" "CHECK")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc)) - ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc)) - ((member test-status (list "SKIP")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc)) - (else - (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status)) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc)))) - (new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) - (+ error-cnt 1) - error-cnt)) - (new-fail-cnt (if (member test-status (list "FAIL" "CHECK")) - (+ fail-cnt 1) - fail-cnt))) + ((member test-state (list "RUNNING" )) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc)) + ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc)) + ((member test-status (list "PASS" "WARN" "WAIVED")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc)) + ((member test-status (list "FAIL" "CHECK")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc)) + ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc)) + ((member test-status (list "SKIP")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc)) + (else + (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status)) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc)))) + (new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) + (+ error-cnt 1) + error-cnt)) + (new-fail-cnt (if (member test-status (list "FAIL" "CHECK")) + (+ fail-cnt 1) + fail-cnt))) (if (null? tail) - (let* ((final-doc ((sxml-modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc))) + (let* ((final-doc ((modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc))) (debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt) (handle-exceptions exn (let* ((msg ((condition-property-accessor 'exn 'message) exn))) (debug:print 0 *default-log-port* (conc "WARNING: Failed to update file" xml-path". Message:" msg ", exn=" exn))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -14,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 @@ -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,53 @@ +;;====================================================================== +;; 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-loop-heart-beat* (current-seconds)) + +(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)