Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -19,24 +19,28 @@ # 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 + +# 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 @@ -59,10 +63,14 @@ 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 + 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: 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)) @@ -1205,11 +1211,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 +1368,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 +1475,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 +1862,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 +2168,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 +2200,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 +2279,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 +2309,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 +2323,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 +2511,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 +2526,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 +3502,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 +3617,28 @@ #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception (thread-join! thread)) ))) (hash-table-keys *common:thread-punchlist*))) +(define (dtests:get-pre-command #!key (default-override #f)) + (let* ((orig-pre-command "export CMD='") + (viewscreen-pre-command "viewscreen ") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) + (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \"")) + + +(define (dtests:get-post-command #!key (default-override #f)) + (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&" + "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &")) + (viewscreen-post-command "") + (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen")) + (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command)) + (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) + (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) + ;;====================================================================== ;; (define *common:telemetry-log-state* 'startup) ;; (define *common:telemetry-log-socket* #f) ;; ;; (define (common:telemetry-log-open) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -20,17 +20,17 @@ ;;====================================================================== ;; Config file handling ;;====================================================================== -(use regex regex-case matchable) ;; directory-utils) -(declare (unit configf)) -(declare (uses process)) -(declare (uses env)) -(declare (uses keys)) - -(include "common_records.scm") +;; (use regex regex-case matchable) ;; directory-utils) +;; (declare (unit configf)) +;; (declare (uses process)) +;; (declare (uses env)) +;; (declare (uses keys)) +;; +;; (include "common_records.scm") ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) (if toppath (let ((cfname (conc toppath "/" configname))) @@ -358,11 +358,11 @@ (configf:script-rx ( x include-script params);; handle-exceptions ;; exn ;; (begin ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (if (and (common:file-exists? include-script)(file-execute-access? include-script)) + (if (and (common:file-exists? include-script)(file-executable? include-script)) (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections)) (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system)) (new-inp-port (common:with-env-vars env-delta @@ -717,11 +717,11 @@ ;; returns (list dat msg) (define (configf:read-refdb refdb-path) (let ((sheets-file (conc refdb-path "/sheet-names.cfg"))) (if (not (common:file-exists? sheets-file)) (list #f (conc "ERROR: no refdb found at " refdb-path)) - (if (not (file-read-access? sheets-file)) + (if (not (file-readable? sheets-file)) (list #f (conc "ERROR: refdb file not readable at " refdb-path)) (let* ((sheets (with-input-from-file sheets-file (lambda () (let loop ((inl (read-line)) (res '())) 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 @@ -22,26 +22,26 @@ ;; Database access ;;====================================================================== ;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc -(use (srfi 18) extras tcp stack) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable) -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) - -(declare (unit db)) -(declare (uses common)) -(declare (uses keys)) -(declare (uses ods)) -(declare (uses client)) -(declare (uses mt)) - -(include "common_records.scm") -(include "db_records.scm") -(include "key_records.scm") -(include "run_records.scm") +;; (use (srfi 18) extras tcp stack) +;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable) +;; (import (prefix sqlite3 sqlite3:)) +;; (import (prefix base64 base64:)) +;; +;; (declare (unit db)) +;; (declare (uses common)) +;; (declare (uses keys)) +;; (declare (uses ods)) +;; (declare (uses client)) +;; (declare (uses mt)) +;; +;; (include "common_records.scm") +;; (include "db_records.scm") +;; (include "key_records.scm") +;; (include "run_records.scm") (define *number-of-writes* 0) (define *number-non-write-queries* 0) ;;====================================================================== @@ -58,10 +58,11 @@ (refndb #f) (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet (read-only #f) (stmt-cache (make-hash-table)) + (locdbs (make-hash-table)) ;; legacy junk in db_records ) ;; goal is to converge on one struct for an area but for now it is too confusing ;; record for keeping state,status and count for doing roll-ups in ;; iterated tests @@ -246,14 +247,14 @@ ;; (define *db-open-mutex* (make-mutex)) (define (db:lock-create-open fname initproc) (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local (raw-fname (pathname-file fname)) - (dir-writable (file-write-access? parent-dir)) + (dir-writable (file-writable? parent-dir)) (file-exists (common:file-exists? fname)) (file-write (if file-exists - (file-write-access? fname) + (file-writable? fname) dir-writable ))) ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped. (if file-write ;; dir-writable (condition-case (let* ((lockfname (conc fname ".lock")) @@ -332,11 +333,11 @@ (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) (mtdb (db:open-megatest-db)) (mtdbpath (db:dbdat-get-path mtdb)) (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) - (write-access (file-write-access? mtdbpath)) + (write-access (file-writable? mtdbpath)) ;(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) ; moving this before db:open-megatest-db is called. if wal mode is on -WAL and -shm file get created with causing the tmpdbmodtime timestamp always greater than mtdbmodtime ;(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) ;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced ;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f)) ;(fmt (file-modification-time tmpdbfname)) @@ -424,11 +425,11 @@ (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) ;;(db:initialize-run-id-db db) ))) - (write-access (file-write-access? dbpath))) + (write-access (file-writable? dbpath))) (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (cons db dbpath))) @@ -627,11 +628,11 @@ (let* ((dbpath (db:dbdat-get-path dbdat)) (dbdir (pathname-directory dbpath)) (fname (pathname-strip-directory dbpath))) (debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.") (cond - ((not (file-write-access? dbdir)) + ((not (file-writable? dbdir)) (debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname) #f) ;; handle special cases, megatest.db and monitor.db ;; @@ -715,17 +716,17 @@ -3) ((not (sqlite3:database? (db:dbdat-get-db todb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb) -4) - ((not (file-write-access? (db:dbdat-get-path todb))) + ((not (file-writable? (db:dbdat-get-path todb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb) -5) ((not (null? (let ((readonly-slave-dbs (filter (lambda (dbdat) - (not (file-write-access? (db:dbdat-get-path todb)))) + (not (file-writable? (db:dbdat-get-path todb)))) slave-dbs))) (for-each (lambda (bad-dbdat) (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat)) @@ -1039,11 +1040,11 @@ ;; (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db") ;; (exit 1)) ;; (let* ((th1 (make-thread ;; (lambda () ;; (if (and (common:file-exists? megatest-db) -;; (file-write-access? megatest-db)) +;; (file-writable? megatest-db)) ;; (begin ;; (db:sync-to-megatest.db dbstruct 'timestamps) ;; internally mutexes on *db-local-sync* ;; (debug:print-info 2 *default-log-port* "Done syncing to megatest.db")))) ;; "call-with-cached-db sync-to-megatest.db")) ;; (cache-db (db:cache-for-read-only @@ -1099,11 +1100,11 @@ ;; clear out junk records ;; ((dejunk) ;; (db:delay-if-busy mtdb) ;; ok to delay on mtdb - (when (file-write-access? (db:dbdat-get-path mtdb)) (db:clean-up mtdb)) + (when (file-writable? (db:dbdat-get-path mtdb)) (db:clean-up mtdb)) (db:clean-up tmpdb) (db:clean-up refndb)) ;; sync runs, test_meta etc. ;; @@ -1201,11 +1202,11 @@ #f)) #;(define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn - (let ((sleep-time (random 30)) + (let ((sleep-time (pseudo-random-integer 30)) (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) (case err-status ((busy) (thread-sleep! sleep-time)) (else @@ -1772,11 +1773,11 @@ #t))))) (define (db:get-status-from-final-status-file run-dir) (let ((infile (conc run-dir "/.final-status"))) ;; first verify we are able to write the output file - (if (not (file-read-access? infile)) + (if (not (file-readable? infile)) (begin (debug:print 0 *default-log-port* "ERROR: cannot read " infile) (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir) #f ) @@ -4884,11 +4885,11 @@ (numkeys (length keypatt-alist)) (test-ids '()) (dbdat (db:get-db dbstruct)) (db (db:dbdat-get-db dbdat)) (windows (and pathmod (substring-index "\\" pathmod))) - (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id))) + (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (pseudo-random-integer 10000) "_" (current-process-id))) (runsheader (append (list "Run Id" "Runname") ; 0 1 (map car keypatt-alist) ; + N = length keypatt-alist (list "Testname" ; 2 "Item Path" ; 3 "Description" ; 4 ADDED dbi.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: 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 #< +# 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.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)))) @@ -227,11 +227,11 @@ (if (> etime (current-seconds)) (begin (thread-sleep! 0.05) (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))))))) 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) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -14,55 +14,218 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; +;; 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 mutils)) +(declare (uses autoload)) +(declare (uses pkts)) +(declare (uses ducttape-lib)) +(declare (uses stml2)) +(declare (uses cookie)) +(declare (uses mtargs)) + +;; (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 + mutils + csv-xml + ducttape-lib + hostinfo + adjutant + ) + ;; (include "common.scm") (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) - -(declare (uses common)) -;; (declare (uses megatest-version)) -(declare (uses margs)) -(declare (uses runs)) -(declare (uses launch)) -(declare (uses server)) -(declare (uses client)) -(declare (uses tests)) -(declare (uses genexample)) -;; (declare (uses daemon)) -(declare (uses db)) -;; (declare (uses dcommon)) - -(declare (uses tdb)) -(declare (uses mt)) -(declare (uses api)) -(declare (uses tasks)) ;; only used for debugging. -(declare (uses env)) -(declare (uses diff-report)) +(define setenv set-environment-variable!) +(define unsetenv unset-environment-variable!) + +;; (declare (uses common)) +;; ;; (declare (uses megatest-version)) +;; (declare (uses margs)) +;; (declare (uses runs)) +;; (declare (uses launch)) +;; (declare (uses server)) +;; (declare (uses client)) +;; (declare (uses tests)) +;; (declare (uses genexample)) +;; ;; (declare (uses daemon)) +;; (declare (uses db)) +;; ;; (declare (uses dcommon)) +;; +;; (declare (uses tdb)) +;; (declare (uses mt)) +;; (declare (uses api)) +;; (declare (uses tasks)) ;; only used for debugging. +;; (declare (uses env)) +;; (declare (uses diff-report)) ;; (declare (uses ftail)) ;; (import ftail) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") +(include "test_records.scm") (include "megatest-fossil-hash.scm") -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:) - readline apropos json http-client directory-utils typed-records - http-client srfi-18 extras format) +(import (prefix dbi dbi:)) +(import stml2) +(import pkts) + +(include "common.scm") +(include "configf.scm") +(include "margs.scm") +(include "process.scm") +(include "keys.scm") +(include "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 +235,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 +715,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 +1163,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 +1180,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 +1846,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 +2061,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 +2473,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 +2494,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 +2541,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 +2713,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) 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) ;; @@ -371,11 +371,11 @@ (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) (let* ((qry-is-write (not (member cmd api:read-only-queries))) (db-file-path (db:dbfile-path)) ;; 0)) (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t))) - (read-only (not (file-write-access? db-file-path))) + (read-only (not (file-writable? db-file-path))) (start (current-milliseconds)) (resdat (if (not (and read-only qry-is-write)) (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong.. exn ;; This is an attempt to detect that situation and recover gracefully @@ -395,11 +395,11 @@ (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd)) (if (not success) (if (> remretries 0) (begin (debug:print-error 0 *default-log-port* "local query failed. Trying again.") - (thread-sleep! (/ (random 5000) 1000)) ;; some random delay + (thread-sleep! (/ (pseudo-random-integer 5000) 1000)) ;; some random delay (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1))) (begin (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up") #f)) (begin @@ -974,11 +974,11 @@ (define (rmtmod:calc-ro-mode runremote *toppath*) (if (and runremote (remote-ro-mode-checked runremote)) (remote-ro-mode runremote) (let* ((dbfile (conc *toppath* "/megatest.db")) - (ro-mode (not (file-write-access? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future + (ro-mode (not (file-writable? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future (if runremote (begin (remote-ro-mode-set! runremote ro-mode) (remote-ro-mode-checked-set! runremote #t) ro-mode) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -18,16 +18,16 @@ ;;====================================================================== ;; read a config file, loading only the section pertinent ;; to this run field1val/field2val/field3val ... ;;====================================================================== -(use format directory-utils) - -(declare (unit runconfig)) -(declare (uses common)) - -(include "common_records.scm") +;; (use format directory-utils) +;; +;; (declare (unit runconfig)) +;; (declare (uses common)) +;; +;; (include "common_records.scm") (define (runconfig:read fname target environ-patt) (let ((ht (make-hash-table))) (if target (hash-table-set! ht target '())) (read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f)))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -15,31 +15,31 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) - posix-extras directory-utils pathname-expand typed-records format sxml-serializer - sxml-modifications matchable) - -(declare (unit runs)) -(declare (uses db)) -(declare (uses common)) -(declare (uses items)) -(declare (uses runconfig)) -(declare (uses tests)) -(declare (uses server)) -(declare (uses mt)) -(declare (uses archive)) -;; (declare (uses filedb)) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "test_records.scm") - +;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) +;; posix-extras directory-utils pathname-expand typed-records format sxml-serializer +;; sxml-modifications matchable) +;; +;; (declare (unit runs)) +;; (declare (uses db)) +;; (declare (uses common)) +;; (declare (uses items)) +;; (declare (uses runconfig)) +;; (declare (uses tests)) +;; (declare (uses server)) +;; (declare (uses mt)) +;; (declare (uses archive)) +;; ;; (declare (uses filedb)) +;; +;; (include "common_records.scm") +;; (include "key_records.scm") +;; (include "db_records.scm") +;; (include "run_records.scm") +;; (include "test_records.scm") +;; ;; (include "debugger.scm") ;; use this struct to facilitate refactoring ;; @@ -128,11 +128,11 @@ (endt (+ startt duration))) ((or proc runs:parallel-runners-mgmt) rdat) (let loop () (let* ((wstart (current-seconds))) (if (< wstart endt) - (let* ((work-time (random 10))) + (let* ((work-time (pseudo-random-integer 10))) #;(debug:print-info 0 *default-log-port* "working for " work-time " seconds. Total work: " rtime ", elapsed time: " (- wstart startt)) (thread-sleep! work-time) (set! rtime (+ rtime work-time)) ((or proc runs:parallel-runners-mgmt) rdat) @@ -508,11 +508,11 @@ (keyvals (keys:target->keyval keys target)) (run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name))) ;; (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config")) (dbfile (conc *toppath* "/megatest.db")) - (readonly-mode (not (file-write-access? dbfile))) + (readonly-mode (not (file-writable? dbfile))) (test-records (make-hash-table)) ;; need to process runconfigs before generating these lists (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names #f) ;; (hash-table-keys all-tests-registry)) (test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts)) @@ -2342,11 +2342,11 @@ (keep-records (args:get-arg "-keep-records")) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode". (test-records '())) ;; for tasks that we wish to operate on all tests in one fell swoop (let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs)) (dbfile (conc *toppath* "/megatest.db")) - (readonly-mode (not (file-write-access? dbfile)))) + (readonly-mode (not (file-writable? dbfile)))) (when (and readonly-mode (member action write-access-actions)) (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .") (exit 1))) @@ -2565,11 +2565,11 @@ (substring-index run-name rundir) (tests:glob-like-match (conc "%/" target "/%") rundir) ) (begin (set! lasttpath (db:test-get-rundir new-test-dat)) ;; remember this path for run removal - (set! lastrealpath (remove-last-path-directory (resolve-pathname lasttpath))) + (set! lastrealpath (remove-last-path-directory (realpath lasttpath))) (hash-table-set! run-paths-hash lastrealpath 1) (runs:remove-test-directory new-test-dat mode) ;; 'remove-all) ) (begin (debug:print 2 *default-log-port* "Not removing directory " rundir " because either it doesn't exist or has a bad name") @@ -2733,11 +2733,11 @@ ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f))) (debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) (if (and real-dir (> (string-length real-dir) 5) (common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. - (let* ((realpath (resolve-pathname run-dir))) + (let* ((realpath (realpath run-dir))) (debug:print-info 1 *default-log-port* "Recursively removing " realpath) (if (common:file-exists? realpath) (runs:safe-delete-test-dir realpath) (debug:print 0 *default-log-port* "WARNING: test dir " realpath " appears to not exist or is not readable"))) (if real-dir @@ -2959,12 +2959,11 @@ '(*TOP* (*PI* xml "version='1.0'") (testsuite))) (define (runs:update-junit-test-reporter-xml run-id) - (let* ( - (junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml")) + (let* ((junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml")) (junit-test-report-dir (configf:lookup *configdat* "runs" "junit-test-report-dir")) (xml-dir (if (and junit-test-reporter (equal? junit-test-reporter "yes" )) (if junit-test-report-dir junit-test-report-dir (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))) @@ -3003,33 +3002,33 @@ (test-state (vector-ref test 3)) (comment (vector-ref test 14)) (test-status (vector-ref test 4)) (exc-msg (conc "No bucket for State " test-state " Status " test-status)) (new-doc (cond - ((member test-state (list "RUNNING" )) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc)) - ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc)) - ((member test-status (list "PASS" "WARN" "WAIVED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc)) - ((member test-status (list "FAIL" "CHECK")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc)) - ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc)) - ((member test-status (list "SKIP")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc)) - (else - (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status)) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc)))) - (new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) - (+ error-cnt 1) - error-cnt)) - (new-fail-cnt (if (member test-status (list "FAIL" "CHECK")) - (+ fail-cnt 1) - fail-cnt))) + ((member test-state (list "RUNNING" )) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc)) + ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc)) + ((member test-status (list "PASS" "WARN" "WAIVED")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc)) + ((member test-status (list "FAIL" "CHECK")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc)) + ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc)) + ((member test-status (list "SKIP")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc)) + (else + (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status)) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc)))) + (new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) + (+ error-cnt 1) + error-cnt)) + (new-fail-cnt (if (member test-status (list "FAIL" "CHECK")) + (+ fail-cnt 1) + fail-cnt))) (if (null? tail) - (let* ((final-doc ((sxml-modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc))) + (let* ((final-doc ((modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc))) (debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt) (handle-exceptions exn (let* ((msg ((condition-property-accessor 'exn 'message) exn))) (debug:print 0 *default-log-port* (conc "WARNING: Failed to update file" xml-path". Message:" msg ", exn=" exn))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -14,30 +14,30 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; -(require-extension (srfi 18) extras tcp s11n) - -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest - directory-utils posix-extras matchable) - -(use spiffy uri-common intarweb http-client spiffy-request-vars) - -(declare (unit server)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. -;; (declare (uses synchash)) -(declare (uses http-transport)) -;;(declare (uses rpc-transport)) -(declare (uses launch)) -;; (declare (uses daemon)) - -(include "common_records.scm") -(include "db_records.scm") +;; (require-extension (srfi 18) extras tcp s11n) +;; +;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest +;; directory-utils posix-extras matchable) +;; +;; (use spiffy uri-common intarweb http-client spiffy-request-vars) +;; +;; (declare (unit server)) +;; +;; (declare (uses common)) +;; (declare (uses db)) +;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. +;; ;; (declare (uses synchash)) +;; (declare (uses http-transport)) +;; ;;(declare (uses rpc-transport)) +;; (declare (uses launch)) +;; ;; (declare (uses daemon)) +;; +;; (include "common_records.scm") +;; (include "db_records.scm") (define (server:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) @@ -154,11 +154,11 @@ (begin (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile) (setenv "TARGETHOST" target-host))) (setenv "TARGETHOST_LOGF" logfile) - (thread-sleep! (/ (random 5000) 1000)) ;; add about a random (up to 5 seconds) initial delay. It seems pretty common that many running tests request a server at the same time + (thread-sleep! (/ (pseudo-random-integer 5000) 1000)) ;; add about a random (up to 5 seconds) initial delay. It seems pretty common that many running tests request a server at the same time ;; (common:wait-for-normalized-load load-limit " delaying server start due to load" target-host) ;; do not try starting servers on an already overloaded machine, just wait forever #;(common:wait-for-homehost-load load-limit (conc " delaying server start due to load on homehost. limit is " load-limit)) (system (conc "nbfake " cmdln)) (unsetenv "TARGETHOST_LOGF") (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) @@ -219,11 +219,11 @@ ;; if the directory exists continue to get the list ;; otherwise attempt to create the logs dir and then ;; continue (if (if (directory-exists? (conc areapath "/logs")) '() - (if (file-write-access? areapath) + (if (file-writable? areapath) (begin (condition-case (create-directory (conc areapath "/logs") #t) (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs"))) (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn))) @@ -230,11 +230,11 @@ (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)))) + (server-logs (string-split (string-chomp (call-with-input-pipe server-logs-cmd read-string)))) (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 +308,11 @@ (< (- now mod-time) 16) ;; still alive - file touched in last 16 seconds (or (not (configf:lookup *configdat* "server" "runtime")) ;; skip if not set (< (- now start-time) (+ (- (string->number (configf:lookup *configdat* "server" "runtime")) 180) - (random 360)))) ;; under one hour running time +/- 180 + (pseudo-random-integer 360)))) ;; under one hour running time +/- 180 )) #f)) srvlst) (lambda (a b) (< (list-ref a 3) @@ -331,11 +331,11 @@ (define (server:get-rand-best areapath) (let ((srvrs (server:get-best (server:get-list areapath)))) (if (and (list? srvrs) (not (null? srvrs))) (let* ((len (length srvrs)) - (idx (random len))) + (idx (pseudo-random-integer len))) (list-ref srvrs idx)) #f))) (define (server:record->id servr) (handle-exceptions @@ -410,11 +410,11 @@ (run-delay (+ (case call-num ((0) 0) ((1) 20) ((2) 300) (else 600)) - (random 5))) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously + (pseudo-random-integer 5))) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously (lock-file (conc areapath "/logs/server-start.lock"))) (if (> (- (current-seconds) when-run) run-delay) (let* ((start-flag (conc areapath "/logs/server-start-last"))) (common:simple-file-lock-and-wait lock-file expire-time: 15) (debug:print-info 0 *default-log-port* "server:kind-run: touching " start-flag) @@ -455,11 +455,11 @@ (servers (server:get-best (server:get-list areapath)))) (if (or (and servers (null? servers)) (not servers) (and (list? servers) - (< (length servers) (random ns)))) ;; somewhere between 0 and numservers + (< (length servers) (pseudo-random-integer ns)))) ;; somewhere between 0 and numservers #f (let loop ((hed (car servers)) (tal (cdr servers))) (let ((res (server:check-server hed))) (if res Index: stml2.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)))) ;;====================================================================== 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)