Changes In Branch v1.6584-ck5 Through [ee54617ab1] Excluding Merge-Ins
This is equivalent to a diff from b6403cb822 to ee54617ab1
2021-04-07
| ||
23:25 | wip check-in: 50cc8ed2e2 user: matt tags: v1.6584-ck5 | |
22:12 | Doesn't compile. WIP check-in: ee54617ab1 user: matt tags: v1.6584-ck5 | |
20:15 | Added missing file check-in: 984d886371 user: matt tags: v1.6584-ck5 | |
2021-04-03
| ||
06:28 | Minor cleanup check-in: 867b8b4e9e user: matt tags: v1.6584-ck5 | |
2021-03-09
| ||
21:03 | Very odd, missing egg in server.scm, util. check-in: 57b5fb07d6 user: matt tags: v1.65-real | |
18:48 | changed version to 1.6584 check-in: b6403cb822 user: mmgraham tags: v1.65-real | |
18:45 | merged v1.65-real-button-img check-in: 7a3804ade8 user: mmgraham tags: v1.65-real | |
Modified Makefile from [eb444dcd26] to [f00b41cab1].
︙ | ︙ | |||
17 18 19 20 21 22 23 | # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' # rm <files>.o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less SHELL=/bin/bash PREFIX=$(PWD) CSCOPTS= INSTALL=install | > > | | | | | | | | | > > > > | | < < < < < < < > > > > > > | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 | # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' # rm <files>.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 # module source files # MSRCFILES = # ftail.scm rmtmod.scm commonmod.scm removed MSRCFILES = autoload.scm dbi.scm ducttape-lib.scm pkts.scm stml2.scm \ cookie.scm mutils.scm mtargs.scm apimod.scm commonmod.scm \ dbmod.scm rmtmod.scm debugprint.scm mtver.scm csv-xml.scm \ servermod.scm hostinfo.scm adjutant.scm # commonmod.scm dbmod.scm adjutant.scm ulex.scm \ # rmtmod.scm apimod.scm GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \ dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \ vg.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o)) # compiled import files MOIMPFILES = $(MSRCFILES:%.scm=%.import.o) %.import.o : %.import.scm csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o mofiles/%.o : %.scm mkdir -p mofiles csc $(CSCOPTS) -J -c $< -o mofiles/$*.o # module dependencies mofiles/stml2.o : mofiles/dbi.o mofiles/dbi.o : mofiles/autoload.o mofiles/apimod.o mofiles/dbmod.o mofiles/rmtmod.o : mofiles/commonmod.o mofiles/commonmod.o : mofiles/mtargs.o mofiles/debugprint.o mofiles/megatest-version.o ADTLSCR=mt_laststep mt_runstep mt_ezstep HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR)) DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR)) MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}') ifeq ($(MTESTHASH),) $(error MTESTHASH is broken!) |
︙ | ︙ |
Modified adjutant.scm from [7560fecb1c] to [e7bfe77fd6].
︙ | ︙ | |||
18 19 20 21 22 23 24 | ;;====================================================================== (declare (unit adjutant)) (module adjutant * | | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | ;;====================================================================== (declare (unit adjutant)) (module adjutant * (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 version [805de76f5f].
> > > | 1 2 3 | ;; optional alternate db setup (define *available-db* (make-hash-table)) (import postgresql)(hash-table-set! *available-db* 'postgresql #t) |
Modified api.scm from [7029eb2f68] to [a67aba3194].
︙ | ︙ | |||
16 17 18 19 20 21 22 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;;====================================================================== | | | | | | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;;====================================================================== ;; (use srfi-69 posix) ;; ;; (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 get-var get-keys |
︙ | ︙ |
Modified apimod.scm from [a7cef484dc] to [dc935cc366].
︙ | ︙ | |||
16 17 18 19 20 21 22 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit apimod)) (declare (uses commonmod)) | < | | > > > > | | > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit apimod)) (declare (uses commonmod)) (module apimod * (import scheme (prefix sqlite3 sqlite3:) typed-records srfi-18 commonmod ) ) |
Modified archive.scm from [35b9e5966e] to [908fcb316e].
︙ | ︙ | |||
13 14 15 16 17 18 19 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') ;; ;; (use (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 "/" 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"))) (if section section |
︙ | ︙ |
Added attic/widgets.scm version [3a32b6256a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 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 <http://www.gnu.org/licenses/>. (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 version [2b9f0c7a0d].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 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 <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit autoload)) (include "autoload/autoload.scm") |
Added autoload/autoload.egg version [fdfe376fc0].
> > > > > | 1 2 3 4 5 | ((license "BSD") (category lang-exts) (author "Alex Shinn") (synopsis "Load modules lazily") (components (extension autoload))) |
Added autoload/autoload.meta version [eeb95f11ac].
> > > > > > > > > | 1 2 3 4 5 6 7 8 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 version [b29a83f03e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 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 version [ca258ae59c].
> > > > > > > | 1 2 3 4 5 6 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 version [018f37fa46].
> > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 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 version [827824779b].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 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 version [a5138452ec].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 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 version [9b19c97a90].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 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 version [aa68521cc2].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 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 version [c4f0264957].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | == call-with-environment-variables Set up and take down environment vars [[toc:]] === {{call-with-environment-variables}} <procedure>(call-with-environment-variables variables thunk) → unspecified</procedure> 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 <enscript highlight="scheme">(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))))) </enscript> === 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]]. |
Modified cgisetup/models/pgdb.scm from [4136225c9c] to [3f24f4a8cc].
︙ | ︙ | |||
14 15 16 17 18 19 20 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== | | | | | | | | | | | | | | | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== ;; (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 (args:get-arg "-pgsync") (if configdat |
︙ | ︙ |
Modified client.scm from [dc4c7b41e8] to [b72ee8db86].
︙ | ︙ | |||
16 17 18 19 20 21 22 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== ;; C L I E N T S ;;====================================================================== | | | | | | | | | | | | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== ;; C L I E N T S ;;====================================================================== ;; (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)))) (set! *my-client-signature* sig) *my-client-signature*))) |
︙ | ︙ | |||
121 122 123 124 125 126 127 | (thread-sleep! 1) (client:setup-http areapath remaining-tries: (- remaining-tries 1)) ))) (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) | | | 121 122 123 124 125 126 127 128 129 130 | (thread-sleep! 1) (client:setup-http areapath remaining-tries: (- remaining-tries 1)) ))) (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 (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))))))))) |
Modified common.scm from [82673dacdb] to [1b32ae0d45].
︙ | ︙ | |||
14 15 16 17 18 19 20 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== | | | | | | | | < | > | | | | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== ;; (use srfi-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") ;; (define old-exit exit) ;; |
︙ | ︙ | |||
173 174 175 176 177 178 179 180 181 182 183 184 185 186 | (define *server-kind-run* (make-hash-table)) (define *home-host* #f) ;; (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) ;; client (define *rmt-mutex* (make-mutex)) ;; remote access calls mutex ;; RPC transport (define *rpc:listener* #f) | > | 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 | (define *server-kind-run* (make-hash-table)) (define *home-host* #f) ;; (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 (define *rpc:listener* #f) |
︙ | ︙ | |||
197 198 199 200 201 202 203 | (define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set (define *homehost-mutex* (make-mutex)) ;; Miscellaneous (define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers (define *numcpus-cache* (make-hash-table)) | | | | | | | | | | | | | | > > > > > | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 | (define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set (define *homehost-mutex* (make-mutex)) ;; Miscellaneous (define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers (define *numcpus-cache* (make-hash-table)) ;; (use posix-extras pathname-expand files) ;; this plugs a hole in posix-extras in recent chicken versions > 4.9) ;; (let-values (( (chicken-release-number chicken-major-version) ;; (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) (string-match "^(.*/csi|csi)$" (car argv)) (string-match "^-(s|ss|sx|script)$" (cadr argv))) |
︙ | ︙ | |||
590 591 592 593 594 595 596 | ;; Do NOT check if not on homehost! ;; (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")) | | | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 | ;; Do NOT check if not on homehost! ;; (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-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)) (cond ((get-environment-variable "MT_SKIP_DB_MIGRATE") #t) |
︙ | ︙ | |||
722 723 724 725 726 727 728 | (begin (debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (print-call-chain (current-error-port)) #f) (read (open-input-string (base64:base64-decode instr)))) (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 728 729 730 731 732 733 734 735 736 737 738 739 740 741 | (begin (debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (print-call-chain (current-error-port)) #f) (read (open-input-string (base64:base64-decode instr)))) (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== ;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls (define *common:std-states* ;; for toggle buttons in dashboard '( |
︙ | ︙ | |||
1002 1003 1004 1005 1006 1007 1008 | (time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S")) ;;====================================================================== ;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp ;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server) ;; (define (common:readonly-watchdog dbstruct) | > | | 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 | (time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S")) ;;====================================================================== ;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp ;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server) ;; (define (common:readonly-watchdog dbstruct) (let ((just-testing 0.0501)) (thread-sleep! just-testing)) ;; (/ 1 20)) ;; 0.051) ;; delay for startup (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.") ;; sync megatest.db to /tmp/.../megatst.db (let* ((sync-cool-off-duration 3) (golden-mtdb (dbr:dbstruct-mtdb dbstruct)) (golden-mtpath (db:dbdat-get-path golden-mtdb)) (tmp-mtdb (dbr:dbstruct-tmpdb dbstruct)) (tmp-mtpath (db:dbdat-get-path tmp-mtdb))) |
︙ | ︙ | |||
1203 1204 1205 1206 1207 1208 1209 | ;; (define (common:get-create-writeable-dir dirs) (if (null? dirs) #f (let loop ((hed (car dirs)) (tal (cdr dirs))) (let ((res (or (and (directory? hed) | | | 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 | ;; (define (common:get-create-writeable-dir dirs) (if (null? dirs) #f (let loop ((hed (car dirs)) (tal (cdr dirs))) (let ((res (or (and (directory? hed) (file-writable? hed) hed) (handle-exceptions exn (begin (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road. exn=" exn) #f) |
︙ | ︙ | |||
1360 1361 1362 1363 1364 1365 1366 | (define (common:directory-writable? path-string) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "Failed to identify access to " path-string ", exn=" exn) #f) (if (and (directory-exists? path-string) | | | 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 | (define (common:directory-writable? path-string) (handle-exceptions 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-writable? path-string)) path-string #f))) (define (common:get-linktree) (or (getenv "MT_LINKTREE") (if *configdat* (configf:lookup *configdat* "setup" "linktree") |
︙ | ︙ | |||
1467 1468 1469 1470 1471 1472 1473 | (debug:print 0 *default-log-port* "ERROR: ["(common:human-time) "] Failed to read .homehost file after trying five times. Giving up and exiting, message: " ((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) | | | 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 | (debug:print 0 *default-log-port* "ERROR: ["(common:human-time) "] Failed to read .homehost file after trying five times. Giving up and exiting, message: " ((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-writable? *toppath*) (begin (with-output-to-file hhf (lambda () (print bestadrs))) (begin (mutex-unlock! *homehost-mutex*) (car (common:get-homehost)))) |
︙ | ︙ | |||
1854 1855 1856 1857 1858 1859 1860 | (if *toppath* (let* ((fullpath (conc *toppath* "/.sysdata/" key "-" dtype ".log")) (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) | | | 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 | (if *toppath* (let* ((fullpath (conc *toppath* "/.sysdata/" key "-" dtype ".log")) (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-readable? fullpath)) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "failed to get cached info from " fullpath ", exn=" exn) #f) (debug:print 2 *default-log-port* "reading file " fullpath) (let ((real-age (- (current-seconds) |
︙ | ︙ | |||
2160 2161 2162 2163 2164 2165 2166 | (hh (if hh-dat (car hh-dat) #f))) (common:wait-for-normalized-load maxnormload msg hh))) (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) | | | 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 | (hh (if hh-dat (car hh-dat) #f))) (common:wait-for-normalized-load maxnormload msg hh))) (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 (pseudo-random-integer 3600))) (let* ((proc (lambda () (let loop ((numcpu 0) (inl (read-line))) (if (eof-object? inl) (if (> numcpu 0) numcpu #f) ;; if zero return #f so caller knows that things are not working |
︙ | ︙ | |||
2192 2193 2194 2195 2196 2197 2198 | ;; wait for normalized cpu load to drop below maxload ;; (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 | | | 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 | ;; wait for normalized cpu load to drop below maxload ;; (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! (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))))) ;;====================================================================== ;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load ;; count - count down to zero, at some point we'd give up if the load never drops |
︙ | ︙ | |||
2271 2272 2273 2274 2275 2276 2277 | ", normalized effective load: " normalized-effective-load )) ;; 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 " | | | 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 | ", normalized effective load: " normalized-effective-load )) ;; 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 " 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 ;; ;; (define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f)(num-tries 5)) |
︙ | ︙ | |||
2301 2302 2303 2304 2305 2306 2307 | ;; ;; at least use 1 ;; (loadjmp (- first (if (> next (* numcpus 0.7)) ;; could do something with average of first and next? ;; 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 | | | | 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 | ;; ;; at least use 1 ;; (loadjmp (- first (if (> next (* numcpus 0.7)) ;; could do something with average of first and next? ;; 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 (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 ;; ;; etc. ;; (effective-load (common:get-intercept first next)) ;; (effective-host (or remote-host "localhost")) ;; (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"))) ;; (> (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 ;; ", effective load: " effective-load ;; ", numcpus: " numcpus |
︙ | ︙ | |||
2503 2504 2505 2506 2507 2508 2509 | (lambda (disk-num) (let* ((dirpath (cadr (assoc disk-num disks))) (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) | | | | 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 | (lambda (disk-num) (let* ((dirpath (cadr (assoc disk-num disks))) (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-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) (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) -1) (else (get-df dirpath)))) (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-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) (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) -1) |
︙ | ︙ | |||
3494 3495 3496 3497 3498 3499 3500 | (for-each (lambda (pktsdir) ;; look at all (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.")) | | | 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 | (for-each (lambda (pktsdir) ;; look at all (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-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 (lambda (pkt) (let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt))) |
︙ | ︙ | |||
3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 | (begin (debug:print 0 *default-log-port* "joining threads failed. exn=" exn) #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception (thread-join! thread)) ))) (hash-table-keys *common:thread-punchlist*))) ;;====================================================================== ;; (define *common:telemetry-log-state* 'startup) ;; (define *common:telemetry-log-socket* #f) ;; ;; (define (common:telemetry-log-open) ;; (if (eq? *common:telemetry-log-state* 'startup) ;; (let* ((serverhost (configf:lookup *configdat* "telemetry" "host")) | > > > > > > > > > > > > > > > > > > | 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 | (begin (debug:print 0 *default-log-port* "joining threads failed. exn=" exn) #t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception (thread-join! thread)) ))) (hash-table-keys *common:thread-punchlist*))) (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) ;; (if (eq? *common:telemetry-log-state* 'startup) ;; (let* ((serverhost (configf:lookup *configdat* "telemetry" "host")) |
︙ | ︙ |
Modified common_records.scm from [80f9e14f2d] to [9a86cd2d43].
︙ | ︙ | |||
66 67 68 69 70 71 72 | (with-output-to-port (current-error-port) (lambda () (print ((condition-property-accessor 'exn 'message) exn)) (print "Callback error in " procname) (print "Full condition info:\n" (condition->list exn))))) (proc))) | < < < < < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 | (with-output-to-port (current-error-port) (lambda () (print ((condition-property-accessor 'exn 'message) exn)) (print "Callback error in " procname) (print "Full condition info:\n" (condition->list exn))))) (proc))) ;; ;; this was cached based on results from profiling but it turned out the profiling ;; ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching ;; ;; in for now but can probably take it out later. ;; ;; ;; (define (debug:calc-verbosity vstr) ;; (or (hash-table-ref/default *verbosity-cache* vstr #f) ;; (let ((res (cond ;; ((number? vstr) vstr) ;; ((not (string? vstr)) 1) ;; ;; ((string-match "^\\s*$" vstr) 1) ;; (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) ;; (cond ;; ((> (length debugvals) 1) debugvals) ;; ((> (length debugvals) 0)(car debugvals)) ;; (else 1)))) ;; ((args:get-arg "-v") 2) ;; ((args:get-arg "-q") 0) ;; (else 1)))) ;; (hash-table-set! *verbosity-cache* vstr res) ;; res))) ;; ;; ;; check verbosity, #t is ok ;; (define (debug:check-verbosity verbosity vstr) ;; (if (not (or (number? verbosity) ;; (list? verbosity))) ;; (begin ;; (print "ERROR: Invalid debug value \"" vstr "\"") ;; #f) ;; #t)) ;; ;; (define (debug:debug-mode n) ;; (cond ;; ((and (number? *verbosity*) ;; number number ;; (number? n)) ;; (<= n *verbosity*)) ;; ((and (list? *verbosity*) ;; list number ;; (number? n)) ;; (member n *verbosity*)) ;; ((and (list? *verbosity*) ;; list list ;; (list? n)) ;; (not (null? (lset-intersection! eq? *verbosity* n)))) ;; ((and (number? *verbosity*) ;; (list? n)) ;; (member *verbosity* n)))) ;; ;; (define (debug:setup) ;; (let ((debugstr (or (args:get-arg "-debug") ;; (args:get-arg "-debug-noprop") ;; (getenv "MT_DEBUG_MODE")))) ;; (set! *verbosity* (debug:calc-verbosity debugstr)) ;; (debug:check-verbosity *verbosity* debugstr) ;; ;; if we were handed a bad verbosity rule then we will override it with 1 and continue ;; (if (not *verbosity*)(set! *verbosity* 1)) ;; (if (and (not (args:get-arg "-debug-noprop")) ;; (or (args:get-arg "-debug") ;; (not (getenv "MT_DEBUG_MODE")))) ;; (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) ;; (string-intersperse (map conc *verbosity*) ",") ;; (conc *verbosity*)))))) ;; ;; (define (debug:print n e . params) ;; (if (debug:debug-mode n) ;; (with-output-to-port (or e (current-error-port)) ;; (lambda () ;; (if *logging* ;; (db:log-event (apply conc params)) ;; (apply print params) ;; ))))) ;; ;; ;; Brandon's debug printer shortcut (indulge me :) ;; (define *BB-process-starttime* (current-milliseconds)) ;; (define (BB> . in-args) ;; (let* ((stack (get-call-chain)) ;; (location "??")) ;; (for-each ;; (lambda (frame) ;; (let* ((this-loc (vector-ref frame 0)) ;; (temp (string-split (->string this-loc) " ")) ;; (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???"))) ;; (if (equal? this-func "BB>") ;; (set! location this-loc)))) ;; stack) ;; (let* ((color-on "\x1b[1m") ;; (color-off "\x1b[0m") ;; (dp-args ;; (append ;; (list 0 *default-log-port* ;; (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") ) ;; in-args))) ;; (apply debug:print dp-args)))) ;; ;; (define *BBpp_custom_expanders_list* (make-hash-table)) ;; ;; ;; ;; ;; register hash tables with BBpp. ;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE: ;; (cons hash-table? hash-table->alist)) ;; ;; ;; test name converter ;; (define (BBpp_custom_converter arg) ;; (let ((res #f)) ;; (for-each ;; (lambda (custom-type-name) ;; (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name)) ;; (custom-type-test (car custom-type-info)) ;; (custom-type-converter (cdr custom-type-info))) ;; (when (and (not res) (custom-type-test arg)) ;; (set! res (custom-type-converter arg))))) ;; (hash-table-keys *BBpp_custom_expanders_list*)) ;; (if res (BBpp_ res) arg))) ;; ;; (define (BBpp_ arg) ;; (cond ;; ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg))) ;; ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg))) ;; ((hash-table? arg) ;; (let ((al (hash-table->alist arg))) ;; (BBpp_ (cons HASH_TABLE: al)))) ;; ((null? arg) '()) ;; ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) ;; ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) ;; (else (BBpp_custom_converter arg)))) ;; ;; ;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp ;; (define (BBpp arg) ;; (pp (BBpp_ arg))) ;; ;; ;(use define-macro) ;; (define-syntax inspect ;; (syntax-rules () ;; [(_ x) ;; ;; (with-output-to-port (current-error-port) ;; (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x)))) ;; ;; ) ;; ] ;; [(_ x y ...) (begin (inspect x) (inspect y ...))])) ;; ;; (define (debug:print-error n e . params) ;; ;; normal print ;; (if (debug:debug-mode n) ;; (with-output-to-port (if (port? e) e (current-error-port)) ;; (lambda () ;; (if *logging* ;; (db:log-event (apply conc params)) ;; ;; (apply print "pid:" (current-process-id) " " params) ;; (apply print "ERROR: " params) ;; )))) ;; ;; pass important messages to stderr ;; (if (and (eq? n 0)(not (eq? e (current-error-port)))) ;; (with-output-to-port (current-error-port) ;; (lambda () ;; (apply print "ERROR: " params) ;; )))) ;; ;; (define (debug:print-info n e . params) ;; (if (debug:debug-mode n) ;; (with-output-to-port (if (port? e) e (current-error-port)) ;; (lambda () ;; (if *logging* ;; (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) ;; (db:log-event res)) ;; ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) ;; (apply print "INFO: (" n ") " params) ;; res) ;; ))))) ;; ;; ;; ;; ;; if a value is printable (i.e. string or number) return the value ;; ;; else return an empty string ;; (define-inline (printable val) ;; (if (or (number? val)(string? val)) val "")) ;; ;; |
Modified commonmod.scm from [9423abd515] to [b5e3523a1c].
︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit commonmod)) (module commonmod * | > | > > > > > > > > > | > > > > | > | > > > > > < > > | < | | < | | < | < | < < < | < < < < < < < | < < < < | < < | | < < | < < < | < < < < < | < < < < < | | | < < < < | > > | | | < | < < < | < < < < > > | < | | < < | < | | < < < < < | < < | < < < < | | < < < | < < < < < < < < | | < < < < < < | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit commonmod)) (declare (uses mtver)) (module commonmod * (import scheme chicken.base chicken.condition chicken.file chicken.time chicken.file.posix chicken.process-context.posix chicken.io chicken.string (prefix sqlite3 sqlite3:) system-information typed-records md5 message-digest regex srfi-1 srfi-18 srfi-69 mtver ) ;;====================================================================== ;; CONTENTS ;; ;; config file utils ;; misc conversion, data manipulation functions ;; testsuite and area utilites ;; ;;====================================================================== (include "megatest-fossil-hash.scm") ;; dot-locking egg seems not to work, using this for now ;; if lock is older than expire-time then remove it and try again ;; to get the lock ;; (define (common:simple-file-lock fname #!key (expire-time 300)) (let ((fmod-time (handle-exceptions ext (current-seconds) (file-modification-time fname)))) (if (file-exists? fname) (if (> (- (current-seconds) fmod-time) expire-time) (begin (handle-exceptions exn #f (delete-file* fname)) (common:simple-file-lock fname expire-time: expire-time)) #f) (let ((key-string (conc (get-host-name) "-" (current-process-id)))) (with-output-to-file fname (lambda () (print key-string))) (thread-sleep! 0.251) (if (file-exists? fname) (handle-exceptions exn #f (with-input-from-file fname (lambda () (equal? key-string (read-line))))) #f))))) (define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) (let ((end-time (+ expire-time (current-seconds)))) (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) (if got-lock #t (if (> end-time (current-seconds)) (begin (thread-sleep! 3) (loop (common:simple-file-lock fname expire-time: expire-time))) #f))))) (define (common:simple-file-release-lock fname) (handle-exceptions exn #f ;; I don't really care why this failed (at least for now) (delete-file* fname))) ) |
Modified configf.scm from [15f0835800] to [7587db552f].
︙ | ︙ | |||
18 19 20 21 22 23 24 | ;;====================================================================== ;;====================================================================== ;; Config file handling ;;====================================================================== | | | | | | | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | ;;====================================================================== ;;====================================================================== ;; 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") ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) (if toppath (let ((cfname (conc toppath "/" configname))) (if (common:file-exists? cfname) (list toppath cfname configname) |
︙ | ︙ | |||
356 357 358 359 360 361 362 | (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) (configf:script-rx ( x include-script params);; handle-exceptions ;; exn ;; (begin ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) | | | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 | (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) (configf:script-rx ( x include-script params);; handle-exceptions ;; exn ;; (begin ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (if (and (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 (lambda () (open-input-pipe (conc include-script " " params)))))) |
︙ | ︙ | |||
715 716 717 718 719 720 721 | ;; reads a refdb into an assoc array of assoc arrays ;; returns (list dat msg) (define (configf:read-refdb refdb-path) (let ((sheets-file (conc refdb-path "/sheet-names.cfg"))) (if (not (common:file-exists? sheets-file)) (list #f (conc "ERROR: no refdb found at " refdb-path)) | | | 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 | ;; reads a refdb into an assoc array of assoc arrays ;; returns (list dat msg) (define (configf:read-refdb refdb-path) (let ((sheets-file (conc refdb-path "/sheet-names.cfg"))) (if (not (common:file-exists? sheets-file)) (list #f (conc "ERROR: no refdb found at " refdb-path)) (if (not (file-readable? sheets-file)) (list #f (conc "ERROR: refdb file not readable at " refdb-path)) (let* ((sheets (with-input-from-file sheets-file (lambda () (let loop ((inl (read-line)) (res '())) (if (eof-object? inl) (reverse res) |
︙ | ︙ |
Added configfmod.scm version [d26d1d864a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 | ;;====================================================================== ;; Copyright 2017, Matthew Welland. ;; ;; This file is part of Megatest. ;; ;; Megatest is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; Megatest is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit configfmod)) (declare (uses mtargs)) (declare (uses debugprint)) (module configfmod * (import scheme chicken.base chicken.condition chicken.file chicken.io chicken.pathname chicken.port chicken.pretty-print chicken.process chicken.process-context chicken.sort chicken.string chicken.time debugprint mtargs pkts (prefix base64 base64:) (prefix dbi dbi:) (prefix sqlite3 sqlite3:) (srfi 18) directory-utils format matchable md5 message-digest regex regex-case sparse-vectors srfi-1 srfi-13 srfi-69 stack typed-records z3 ) (define getenv get-environment-variable) (define setenv set-environment-variable!) (define unsetenv unset-environment-variable!) ;;====================================================================== ;; move debug stuff to separate module then put these back where they belong ;;====================================================================== ;;====================================================================== ;; lookup routines - replicated from configf ;;====================================================================== (define (configf:lookup cfgdat section var) (if (hash-table? cfgdat) (let ((sectdat (hash-table-ref/default cfgdat section '()))) (if (null? sectdat) #f (let ((match (assoc var sectdat))) (if match ;; (and match (list? match)(> (length match) 1)) (cadr match) #f)) )) #f)) (define (configf:assoc-safe-add alist key val #!key (metadata #f)) (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) (append newalist (list (if metadata (list key val metadata) (list key val)))))) (define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f)) (hash-table-set! cfgdat section-name (configf:assoc-safe-add (hash-table-ref/default cfgdat section-name '()) var value metadata: metadata))) ;; use to have definitive setting: ;; [foo] ;; var yes ;; ;; (configf:var-is? cfgdat "foo" "var" "yes") => #t ;; (define (configf:var-is? cfgdat section var expected-val) (equal? (configf:lookup cfgdat section var) expected-val)) ;; redefines (define config-lookup configf:lookup) ;; safely look up a value that is expected to be a number, return ;; a default (#f unless provided) ;; (define (configf:lookup-number cfdat section varname #!key (default #f)) (let* ((val (configf:lookup cfdat section varname)) (res (if val (string->number (string-substitute "\\s+" "" val #t)) #f))) (cond (res res) (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val)) (else default)))) (define (configf:section-vars cfgdat section) (let ((sectdat (hash-table-ref/default cfgdat section '()))) (if (null? sectdat) '() (map car sectdat)))) (define (configf:get-section cfgdat section) (hash-table-ref/default cfgdat section '())) (define (configf:set-section-var cfgdat section var val) (let ((sectdat (configf:get-section cfgdat section))) (hash-table-set! cfgdat section (configf:assoc-safe-add sectdat var val)))) ;;======================================================================the end ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) (if toppath (let ((cfname (conc toppath "/" configname))) (if (file-exists? cfname) (list toppath cfname configname) (list #f #f #f))) (let* ((cwd (string-split (current-directory) "/"))) (let loop ((dir cwd)) (let* ((path (conc "/" (string-intersperse dir "/"))) (fullpath (conc path "/" configname))) (if (file-exists? fullpath) (list path fullpath configname) (let ((remcwd (take dir (- (length dir) 1)))) (if (null? remcwd) (list #f #f #f) ;; #f #f) (loop remcwd))))))))) (define (configf:eval-string-in-environment str) ;; (if (or (string-null? str) ;; (equal? "!" (substring str 0 1))) ;; null string or starts with ! are preserved but NOT set in the environment str (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment, exn=" exn) #f) (let ((cmdres (process:cmd-run->list (conc "echo " str)))) (if (null? cmdres) "" (caar cmdres))))) ;; ) ;;====================================================================== ;; Make the regexp's needed globally available ;;====================================================================== (define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) (define configf:script-rx (regexp "^\\[scriptinc\\s+(\\S+)([^\\]]*)\\]\\s*$")) ;; include output from a script (define configf:section-rx (regexp "^\\[(.*)\\]\\s*$")) (define configf:blank-l-rx (regexp "^\\s*$")) (define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) (define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$")) (define configf:key-no-val (regexp "^(\\S+)(\\s*)$")) (define configf:comment-rx (regexp "^\\s*#.*")) (define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")) (define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$")) ;; read a line and process any #{ ... } constructs (define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)")) (define (configf:system ht cmd) (system cmd) ) (define (configf:process-line l ht allow-system #!key (linenum #f)) (let loop ((res l)) (if (string? res) (let ((matchdat (string-search configf:var-expand-regex res))) (if matchdat (let* ((prestr (list-ref matchdat 1)) (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv (cmd (list-ref matchdat 3)) (poststr (list-ref matchdat 4)) (result #f) (start-time (current-seconds)) (cmdsym (string->symbol cmdtype)) (fullcmd (case cmdsym ((scheme scm) (conc "(lambda (ht)" cmd ")")) ((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))")) ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))")) ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))")) ((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))")) ((mtrah) (conc "(lambda (ht)" " (let ((extra \"" cmd "\"))" " (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))" " (if (string-null? extra) \"\" \"/\")" " extra)))")) ((get g) (match (string-split cmd) ((sect var)(conc "(lambda (ht)(configfmod#configf:lookup ht \"" sect "\" \"" var "\"))")) (else (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.") "(lambda (ht) #f)"))) ((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) ;; ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) ;; (print "fullcmd=" fullcmd) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) ;; (print "exn=" (condition->list exn)) (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd))) (if (or allow-system (not (member cmdtype '("system" "shell" "sh")))) (with-input-from-string fullcmd (lambda () (set! result ((eval (read)) ht)))) (set! result (conc "#{(" cmdtype ") " cmd "}")))) (case cmdsym ((system shell scheme) (let ((delta (- (current-seconds) start-time))) (if (> delta 2) (debug:print-info 0 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result) (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result))))) (loop (conc prestr result poststr))) res)) res))) ;; Run a shell command and return the output as a string (define (shell cmd) (let* ((output (process:cmd-run->list cmd)) (res (car output)) (status (cadr output))) (if (equal? status 0) (let ((outres (string-intersperse res "\n"))) (debug:print-info 4 *default-log-port* "shell result:\n" outres) outres) (begin (with-output-to-port (current-error-port) (lambda () (print "ERROR: " cmd " returned bad exit code " status))) "")))) ;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ... ;; (define (configf:read-line p ht allow-processing settings) (let loop ((inl (read-line p))) (let ((cont-line (and (string? inl) (not (string-null? inl)) (equal? "\\" (string-take-right inl 1))))) (if cont-line ;; last character is \ (let ((nextl (read-line p))) (if (not (eof-object? nextl)) (loop (string-append (if cont-line (string-take inl (- (string-length inl) 1)) inl) nextl)))) (let ((res (case allow-processing ;; if (and allow-processing ;; (not (eq? allow-processing 'return-string))) ((#t #f) (configf:process-line inl ht allow-processing)) ((return-string) inl) (else (configf:process-line inl ht allow-processing))))) (if (and (string? res) ;; must set to "no" to force NOT trimming trailing spaces (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "yes") "no"))) (string-substitute "\\s+$" "" res) res)))))) (define (configf:cfgdat->env-alist section cfgdat-ht allow-system) (filter (lambda (pair) (let* ((var (car pair)) (val (cdr pair))) (cons var (cond ((and allow-system (procedure? val)) ;; if we decided to use something other than #t or #f for allow-system ('return-procs or 'return-string) , this may become problematic (val)) ((procedure? val) #f) ((string? val) val) (else "#f"))))) (append (hash-table-ref/default cfgdat-ht "default" '()) (if (equal? section "default") '() (hash-table-ref/default cfgdat-ht section '()))))) (define (calc-allow-system allow-system section sections) (if sections (and (or (equal? "default" section) (member section sections)) allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings allow-system)) ;; given a config hash and a section name, apply that section to all matching sections (using wildcard % or regex if /..../) ;; remove the section when done so that there is no downstream clobbering ;; (define (configf:apply-wildcards ht section-name) (if (hash-table-exists? ht section-name) (let* ((vars (hash-table-ref ht section-name)) (rxstr (if (string-contains section-name "%") (string-substitute (regexp "%") ".*" section-name) (string-substitute (regexp "^/(.*)/$") "\\1" section-name))) (rx (regexp rxstr))) ;; (print "\nsection-name: " section-name " rxstr: " rxstr) (for-each (lambda (section) (if section (let ((same-section (string=? section-name section)) (rx-match (string-match rx section))) ;; (print "section: " section " vars: " vars " same-section: " same-section " rx-match: " rx-match) (if (and (not same-section) rx-match) (for-each (lambda (bundle) ;; (print "bundle: " bundle) (let ((key (car bundle)) (val (cadr bundle)) (meta (if (> (length bundle) 2)(caddr bundle) #f))) (hash-table-set! ht section (configf:assoc-safe-add (hash-table-ref ht section) key val metadata: meta)))) vars))))) (hash-table-keys ht)))) ht) ;; read a config file, returns hash table of alists ;; read a config file, returns hash table of alists ;; adds to ht if given (must be #f otherwise) ;; allow-system: ;; #f - do not evaluate [system ;; #t - immediately evaluate [system and store result as string ;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time ;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time ;; envion-patt is a regex spec that identifies sections that will be eval'd ;; in the environment on the fly ;; sections: #f => get all, else list of sections to gather ;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path) ;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections ;; (define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f) (sections #f) (settings (make-hash-table)) (keep-filenames #f) (post-section-procs '()) (apply-wildcards #t) ) (debug:print 9 *default-log-port* "START: " path) ;; (if *configdat* ;; (common:save-pkt `((action . read-config) ;; (f . ,(cond ((string? path) path) ;; ((port? path) "port") ;; (else (conc path)))) ;; (T . configf)) ;; *configdat* #t add-only: #t)) (if (and (not (port? path)) (not (file-exists? path))) ;; for case where we are handed a port (begin (debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory)) ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read? #f) ;; (if (not ht)(make-hash-table) ht)) (let ((inp (if (string? path) (open-input-file path) path)) ;; we can be handed a port (res (if (not ht)(make-hash-table) ht)) (metapath (if (or (debug:debug-mode 9) keep-filenames) path #f)) (process-wildcards (lambda (res curr-section-name) (if (and apply-wildcards (or (string-contains curr-section-name "%") ;; wildcard (string-match "/.*/" curr-section-name))) ;; regex (begin (configf:apply-wildcards res curr-section-name) (hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp)) (curr-section-name (if curr-section curr-section "default")) (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere (lead #f)) (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") (if (eof-object? inl) (begin ;; process last section for wildcards (process-wildcards res curr-section-name) (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it. (close-input-port inp)) (if (list? sections) ;; delete all sections except given when sections is provided (for-each (lambda (section) (if (not (member section sections)) (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht (hash-table-keys res))) (debug:print 9 *default-log-port* "END: " path) res ) ;; retval (regex-case inl (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (configf:settings ( x setting val ) (begin (hash-table-set! settings setting val) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) (configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path)) (full-conf (if (and (absolute-pathname? include-file) (file-exists? include-file)) include-file (common:nice-path (conc (if curr-conf-dir curr-conf-dir ".") "/" include-file))))) (let ((all-matches (sort (handle-exceptions exn (begin (debug:print '(2 9) *default-log-port* "glob of " full-conf " gave no match. , exn=" exn) (list)) (glob full-conf)) string<=?))) (if (null? all-matches) (begin (debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")") (debug:print 2 *default-log-port* " " full-conf)) (for-each (lambda (fpath) ;; (push-directory conf-dir) (debug:print 9 *default-log-port* "Including: " full-conf) (read-config fpath res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)) all-matches)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) (configf:script-rx ( x include-script params);; handle-exceptions ;; exn ;; (begin ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (if (and (file-exists? include-script)(file-executable? include-script)) (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections)) (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system)) (new-inp-port (common:with-env-vars env-delta (lambda () (open-input-pipe (conc include-script " " params)))))) (debug:print '(2 9) *default-log-port* "Including from script output: " include-script) ;; (print "We got here, calling read-config next. Port is: " new-inp-port) (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) (close-input-port new-inp-port) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (begin (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) ) ;; ) (configf:section-rx ( x section-name ) (begin ;; call post-section-procs (for-each (lambda (dat) (let ((patt (car dat)) (proc (cdr dat))) (if (string-match patt curr-section-name) (proc curr-section-name section-name res path)))) post-section-procs) ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards ;; NOTE: we are processing the curr-section-name, NOT section-name. (process-wildcards res curr-section-name) (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) ;; if we have the sections list then force all settings into "" and delete it later? ;; (if (or (not sections) ;; (member section-name sections)) ;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later. section-name #f #f))) (configf:key-sys-pr ( x key cmd ) (if (calc-allow-system allow-system curr-section-name sections) (let ((alist (hash-table-ref/default res curr-section-name '())) (val-proc (lambda () (let* ((start-time (current-seconds)) (local-allow-system (calc-allow-system allow-system curr-section-name sections)) (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system)) (cmdres (process:cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars! (delta (- (current-seconds) start-time)) (status (cadr cmdres)) (res (car cmdres))) (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n")) (if (not (eq? status 0)) (begin (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status " output: " cmdres))) (if (> delta 2) (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) (if (null? res) "" (string-intersperse res " ")))))) (hash-table-set! res curr-section-name (configf:assoc-safe-add alist key (case (calc-allow-system allow-system curr-section-name sections) ((return-procs) val-proc) ((return-string) cmd) (else (val-proc))) metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '())) (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t") (safe-setenv key fval) (hash-table-set! res curr-section-name (configf:assoc-safe-add alist key fval metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '())) (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name) ;; does the section match the envionpatt? (and (not (string-null? key)) (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment ;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs )) (realval (if envar (configf:eval-string-in-environment val) val))) (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) (if envar (safe-setenv key realval)) (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val) (hash-table-set! res curr-section-name (configf:assoc-safe-add alist key realval metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) ;; if a continued line (configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) (if var-flag ;; if set to a string then we have a continued var (let ((newval (conc (configf:lookup res curr-section-name var-flag) "\n" ;; trim lead from the incoming whsp to support some indenting. (if lead (string-substitute (regexp lead) "" whsp) "") val))) ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) (hash-table-set! res curr-section-name (configf:assoc-safe-add alist var-flag newval metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"") (set! var-flag #f) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) ) ;; end loop ))) ;;====================================================================== ;; lookup and manipulation routines ;;====================================================================== ;; (define (configf:assoc-safe-add alist key val #!key (metadata #f)) ;; (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) ;; (append newalist (list (if metadata ;; (list key val metadata) ;; (list key val)))))) ;; ;; (define (configf:section-var-set! cfgdat section-name var value #!key (metadata #f)) ;; (hash-table-set! cfgdat section-name ;; (configf:assoc-safe-add ;; (hash-table-ref/default cfgdat section-name '()) ;; var value metadata: metadata))) ;; ;; (define (configf:lookup cfgdat section var) ;; (if (hash-table? cfgdat) ;; (let ((sectdat (hash-table-ref/default cfgdat section '()))) ;; (if (null? sectdat) ;; #f ;; (let ((match (assoc var sectdat))) ;; (if match ;; (and match (list? match)(> (length match) 1)) ;; (cadr match) ;; #f)) ;; )) ;; #f)) ;; ;; ;; use to have definitive setting: ;; ;; [foo] ;; ;; var yes ;; ;; ;; ;; (configf:var-is? cfgdat "foo" "var" "yes") => #t ;; ;; ;; (define (configf:var-is? cfgdat section var expected-val) ;; (equal? (configf:lookup cfgdat section var) expected-val)) ;; ;; (define config-lookup configf:lookup) (define configf:read-file read-config) ;; ;; safely look up a value that is expected to be a number, return ;; ;; a default (#f unless provided) ;; ;; ;; (define (configf:lookup-number cfdat section varname #!key (default #f)) ;; (let* ((val (configf:lookup *configdat* section varname)) ;; (res (if val ;; (string->number (string-substitute "\\s+" "" val #t)) ;; #f))) ;; (cond ;; (res res) ;; (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val)) ;; (else default)))) ;; ;; (define (configf:section-vars cfgdat section) ;; (let ((sectdat (hash-table-ref/default cfgdat section '()))) ;; (if (null? sectdat) ;; '() ;; (map car sectdat)))) ;; ;; (define (configf:get-section cfgdat section) ;; (hash-table-ref/default cfgdat section '())) ;; ;; (define (configf:set-section-var cfgdat section var val) ;; (let ((sectdat (configf:get-section cfgdat section))) ;; (hash-table-set! cfgdat section ;; (configf:assoc-safe-add sectdat var val)))) ;; ;; ;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat) ;; ;; (list var val)))) ;; ;;====================================================================== ;; setup ;;====================================================================== ;;====================================================================== (define (setup) (let* ((configf (find-config "megatest.config")) (config (if configf (read-config configf #f #t) #f))) (if config (setenv "RUN_AREA_HOME" (pathname-directory configf))) config)) (define getenv get-environment-variable) (define (safe-setenv key val) (if (or (substring-index "!" key) (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables. (substring-index "." key)) ;; periods are not allowed in environment variables (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"") (if (and (string? val) (string? key)) (handle-exceptions exn (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val ", exn=" exn) (setenv key val)) (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)))) ;;====================================================================== ;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) ;; execute thunk in context of environment modified as per this list ;; restore env to prior state then return value of eval'd thunk. ;; ** this is not thread safe ** (define (common:with-env-vars delta-env-alist-or-hash-table thunk) (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table) (hash-table->alist delta-env-alist-or-hash-table) delta-env-alist-or-hash-table)) (restore-thunks (filter identity (map (lambda (env-pair) (let* ((env-var (car env-pair)) (new-val (let ((tmp (cdr env-pair))) (if (list? tmp) (car tmp) tmp))) (current-val (get-environment-variable env-var)) (restore-thunk (cond ((not current-val) (lambda () (unsetenv env-var))) ((not (string? new-val)) #f) ((eq? current-val new-val) #f) (else (lambda () (setenv env-var current-val)))))) ;;(when (not (string? new-val)) ;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist) ;; (pp delta-env-alist) ;; (exit 1)) (cond ((not new-val) ;; modify env here (unsetenv env-var)) ((string? new-val) (setenv env-var new-val))) restore-thunk)) delta-env-alist)))) (let ((rv (thunk))) (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state rv))) ;; return a nice clean pathname made absolute (define (common:nice-path dir) (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) (if match ;; using ~ for home? (common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match))) (normalize-pathname (if (absolute-pathname? dir) dir (conc (current-directory) "/" dir)))))) ;; make "nice-path" available in config files and the repl (define nice-path common:nice-path) (define (common:read-link-f path) (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed. exn=" exn) path) ;; just give up (with-input-from-pipe (conc "/bin/readlink -f " path) (lambda () (read-line))))) ;;====================================================================== ;; Non destructive writing of config file ;;====================================================================== (define (configf:compress-multi-lines fdat) ;; step 1.5 - compress any continued lines (if (null? fdat) fdat (let loop ((hed (car fdat)) (tal (cdr fdat)) (cur "") (led #f) (res '())) ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!! ;; 1. remove led whitespace ;; 2. tack on to hed with "\n" (let ((match (string-match configf:cont-ln-rx hed))) (if match ;; blast! have to deal with a multiline (let* ((lead (cadr match)) (lval (caddr match)) (newl (conc cur "\n" lval))) (if (not led)(set! led lead)) (if (null? tal) (set! fdat (append fdat (list newl))) (loop (car tal)(cdr tal) newl led res))) ;; NB// not tacking newl onto res (let ((newres (if led (append res (list cur hed)) (append res (list hed))))) ;; prev was a multiline (if (null? tal) newres (loop (car tal)(cdr tal) "" #f newres)))))))) ;; note: I'm cheating a little here. I merely replace "\n" with "\n " (define (configf:expand-multi-lines fdat) ;; step 1.5 - compress any continued lines (if (null? fdat) fdat (let loop ((hed (car fdat)) (tal (cdr fdat)) (res '())) (let ((newres (append res (list (string-substitute (regexp "\n") "\n " hed #t))))) (if (null? tal) newres (loop (car tal)(cdr tal) newres)))))) (define (configf:file->list fname) (if (file-exists? fname) (let ((inp (open-input-file fname))) (let loop ((inl (read-line inp)) (res '())) (if (eof-object? inl) (begin (close-input-port inp) (reverse res)) (loop (read-line inp)(cons inl res))))) '())) ;;====================================================================== ;; Write a config ;; 0. Given a refererence data structure "indat" ;; 1. Open the output file and read it into a list ;; 2. Flatten any multiline entries ;; 3. Modify values per contents of "indat" and remove absent values ;; 4. Append new values to the section (immediately after last legit entry) ;; 5. Write out the new list ;;====================================================================== (define (configf:write-config indat fname #!key (required-sections '())) (let* (;; step 1: Open the output file and read it into a list (fdat (configf:file->list fname)) (refdat (make-hash-table)) (sechash (make-hash-table)) ;; current section hash, init with hash for "default" section (new #f) ;; put the line to be used in new, if it is to be deleted the set new to #f (secname #f)) ;; step 2: Flatten multiline entries (if (not (null? fdat))(set! fdat (configf:compress-multi-lines fdat))) ;; step 3: Modify values per contents of "indat" and remove absent values (if (not (null? fdat)) (let loop ((hed (car fdat)) (tal (cadr fdat)) (res '()) (lnum 0)) (regex-case hed (configf:comment-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f)) (configf:blank-l-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f)) (configf:section-rx ( x section-name ) (let ((section-hash (hash-table-ref/default refdat section-name #f))) (if (not section-hash) (let ((newhash (make-hash-table))) (hash-table-set! refdat section-name newhash) ;; was refhash - not sure that refdat is correct here (set! sechash newhash)) (set! sechash section-hash)) (set! new hed) ;; will append this at the bottom of the loop (set! secname section-name) )) ;; No need to process key cmd, let it fall though to key val (configf:key-val-pr ( x key val ) (let ((newval (configf:lookup indat secname key))) ;; was sec, bug or correct? ;; can handle newval == #f here => that means key is removed (cond ((equal? newval val) (set! res (append res (list hed)))) ((not newval) ;; key has been removed (set! new #f)) ((not (equal? newval val)) (hash-table-set! sechash key newval) (set! new (conc key " " newval))) (else (debug:print-error 0 *default-log-port* "problem parsing line number " lnum "\"" hed "\""))))) (else (debug:print-error 0 *default-log-port* "Problem parsing line num " lnum " :\n " hed ))) (if (not (null? tal)) (loop (car tal)(cdr tal)(if new (append res (list new)) res)(+ lnum 1))) ;; drop to here when done processing, res contains modified list of lines (set! fdat res))) ;; step 4: Append new values to the section (for-each (lambda (section) (let ((sdat '()) ;; append needed bits here (svars (configf:section-vars indat section))) (for-each (lambda (var) (let ((val (configf:lookup refdat section var))) (if (not val) ;; this one is new (begin (if (null? sdat)(set! sdat (list (conc "[" section "]")))) (set! sdat (append sdat (list (conc var " " val)))))))) svars) (set! fdat (append fdat sdat)))) (delete-duplicates (append required-sections (hash-table-keys indat)))) ;; step 5: Write out new file (with-output-to-file fname (lambda () (for-each (lambda (line) (print line)) (configf:expand-multi-lines fdat)))))) (define (process:cmd-run->list cmd #!key (delta-env-alist-or-hash-table '())) (common:with-env-vars delta-env-alist-or-hash-table (lambda () (let* ((fh (open-input-pipe cmd)) (res (port->list fh)) (status (close-input-pipe fh))) (list res status))))) (define (port->list fh) (if (eof-object? fh) #f (let loop ((curr (read-line fh)) (result '())) (if (not (eof-object? curr)) (loop (read-line fh) (append result (list curr))) result)))) ;;====================================================================== ;; refdb ;;====================================================================== ;; reads a refdb into an assoc array of assoc arrays ;; returns (list dat msg) (define (configf:read-refdb refdb-path) (let ((sheets-file (conc refdb-path "/sheet-names.cfg"))) (if (not (file-exists? sheets-file)) (list #f (conc "ERROR: no refdb found at " refdb-path)) (if (not (file-readable? sheets-file)) (list #f (conc "ERROR: refdb file not readable at " refdb-path)) (let* ((sheets (with-input-from-file sheets-file (lambda () (let loop ((inl (read-line)) (res '())) (if (eof-object? inl) (reverse res) (loop (read-line)(cons inl res))))))) (data '())) (for-each (lambda (sheet-name) (let* ((dat-path (conc refdb-path "/" sheet-name ".dat")) (ref-dat (configf:read-file dat-path #f #t)) (ref-assoc (map (lambda (key) (list key (hash-table-ref ref-dat key))) (hash-table-keys ref-dat)))) ;; (hash-table->alist ref-dat))) ;; (set! data (append data (list (list sheet-name ref-assoc)))))) (set! data (cons (list sheet-name ref-assoc) data)))) sheets) (list data "NO ERRORS")))))) ;; map over all pairs in a three level hierarchial alist and apply a function to the keys/val ;; (define (configf:map-all-hier-alist data proc #!key (initproc1 #f)(initproc2 #f)(initproc3 #f)) (for-each (lambda (sheetname) (let* ((sheettmp (assoc sheetname data)) (sheetdat (if sheettmp (cadr sheettmp) '()))) (if initproc1 (initproc1 sheetname)) (for-each (lambda (sectionname) (let* ((sectiontmp (assoc sectionname sheetdat)) (sectiondat (if sectiontmp (cadr sectiontmp) '()))) (if initproc2 (initproc2 sheetname sectionname)) (for-each (lambda (varname) (let* ((valtmp (assoc varname sectiondat)) (val (if valtmp (cadr valtmp) ""))) (proc sheetname sectionname varname val))) (map car sectiondat)))) (map car sheetdat)))) (map car data)) data) ;;====================================================================== ;; C O N F I G T O / F R O M A L I S T ;;====================================================================== (define (configf:config->alist cfgdat) (hash-table->alist cfgdat)) (define (configf:alist->config adat) (let ((ht (make-hash-table))) (for-each (lambda (section) (hash-table-set! ht (car section)(cdr section))) adat) ht)) ;; convert hierarchial list to ini format ;; (define (configf:config->ini data) (map (lambda (section) (let ((section-name (car section)) (section-dat (cdr section))) (print "\n[" section-name "]") (map (lambda (dat-pair) (let* ((var (car dat-pair)) (val (cadr dat-pair)) (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f))) (if fname (print "# " var "=>" fname)) (print var " " val))) section-dat))) ;; (print "section-dat: " section-dat)) (hash-table->alist data))) ;; if (define (configf:read-alist fname) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "read of alist " fname " failed. exn=" exn) #f) (configf:alist->config (with-input-from-file fname read)))) ;;====================================================================== ;; DO THE LOCKING AROUND THE CALL ;;====================================================================== ;; (define (configf:write-alist cdat fname) #;(if (not (common:faux-lock fname)) (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname)) (let* ((dat (configf:config->alist cdat)) (res (begin (with-output-to-file fname ;; first write out the file (lambda () (pp dat))) (if (file-exists? fname) ;; now verify it is readable (if (configf:read-alist fname) #t ;; data is good. (begin (handle-exceptions exn (begin (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn) #f) (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.") (delete-file fname)) #f)) #f)))) ;; (common:faux-unlock fname) res)) ) |
Added csv-xml.scm version [86b3f1ae82].
> > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | ;; Copyright 2006-2017, Matthew Welland. ;; ;; This file is part of Megatest. ;; ;; Megatest is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; Megatest is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit csv-xml)) (include "csv-xml/csv-xml.scm") |
Added csv-xml/csv-out.impl version [a1397a6ff6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 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 - <system> | #\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 version [fd2d3bfc5b].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 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 version [63c836b4b4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 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 version [510ab3ecb8].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 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 version [817d757d1f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 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) |
Modified dashboard-tests.scm from [237d160a6c] to [4ccafc8c2c].
︙ | ︙ | |||
53 54 55 56 57 58 59 | (define (message-window msg) (iup:show (iup:dialog (iup:vbox (iup:label msg #:margin "40x40"))))) | | | | | | | | | | | | | | | | | | | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 | (define (message-window msg) (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 (test-info-panel testdat store-label widgets) (iup:frame #:title "Test Info" ; #:expand "YES" (iup:hbox ; #:expand "YES" (apply iup:vbox ; #:expand "YES" (append (map (lambda (val) (iup:label val ; #:expand "HORIZONTAL" |
︙ | ︙ |
Modified datashare.scm from [2c1663032f] to [bce23aa6ff].
︙ | ︙ | |||
251 252 253 254 255 256 257 | (datashare:initialize-db db))) db) (print "ERROR: invalid path for storing database: " path)))) (define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn | | | 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 | (datashare:initialize-db db))) db) (print "ERROR: invalid path for storing database: " path)))) (define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn (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 (print "EXCEPTION: database overloaded or unreadable.") (print " message: " ((condition-property-accessor 'exn 'message) exn)) |
︙ | ︙ |
Modified db.scm from [ed256dd44f] to [d384bd54d1].
︙ | ︙ | |||
14 15 16 17 18 19 20 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;;====================================================================== | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;;====================================================================== ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== (define (db:general-sqlite-error-dump exn stmt . params) (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work? ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) |
︙ | ︙ | |||
244 245 246 247 248 249 250 | ;; RA => Returns a db handler; sets the lock if opened in writable mode ;; ;; (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)) | | | | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 | ;; RA => Returns a db handler; sets the lock if opened in writable mode ;; ;; (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-writable? parent-dir)) (file-exists (common:file-exists? fname)) (file-write (if file-exists (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")) (readyfname (conc parent-dir "/.ready-" raw-fname)) (readyexists (common:file-exists? readyfname))) |
︙ | ︙ | |||
330 331 332 333 334 335 336 | (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time (conc *toppath* "/megatest.db")) #f)) (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")) | | | 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 | (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time (conc *toppath* "/megatest.db")) #f)) (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-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)) (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime)))) |
︙ | ︙ | |||
422 423 424 425 426 427 428 | (dbpath (conc dbdir "/" (or name "megatest.db"))) (dbexists (common:file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) ;;(db:initialize-run-id-db db) ))) | | | 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 | (dbpath (conc dbdir "/" (or name "megatest.db"))) (dbexists (common:file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) ;;(db:initialize-run-id-db db) ))) (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))) ;; sync run to disk if touched ;; |
︙ | ︙ | |||
625 626 627 628 629 630 631 | ;; (define (db:repair-db dbdat #!key (numtries 1)) (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 | | | 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 | ;; (define (db:repair-db dbdat #!key (numtries 1)) (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-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 ;; ;; NOPE: apply this same approach to all db files ;; |
︙ | ︙ | |||
713 714 715 716 717 718 719 | ((not (sqlite3:database? (db:dbdat-get-db fromdb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb) -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) | | | | 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 | ((not (sqlite3:database? (db:dbdat-get-db fromdb))) (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb) -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-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-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)) readonly-slave-dbs) readonly-slave-dbs))) -6) |
︙ | ︙ | |||
1037 1038 1039 1040 1041 1042 1043 | ;; (if (not cache-dir) ;; (begin ;; (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) | | | 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 | ;; (if (not cache-dir) ;; (begin ;; (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-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 ;; megatest-db ;; (conc cache-dir "/" fname) |
︙ | ︙ | |||
1097 1098 1099 1100 1101 1102 1103 | (delete-file* (common:get-sync-lock-filepath)) ) ;; clear out junk records ;; ((dejunk) ;; (db:delay-if-busy mtdb) ;; ok to delay on mtdb | | | 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 | (delete-file* (common:get-sync-lock-filepath)) ) ;; clear out junk records ;; ((dejunk) ;; (db:delay-if-busy mtdb) ;; ok to delay on 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. ;; ((old2new) (set! data-synced |
︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 | (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" ) res) #f)) #;(define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn | | | 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 | (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" ) res) #f)) #;(define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn (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 (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.") (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) |
︙ | ︙ | |||
1770 1771 1772 1773 1774 1775 1776 | (null? toplevels)) #f #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 | | | 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 | (null? toplevels)) #f #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-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 ) (with-input-from-file infile read-lines) ))) |
︙ | ︙ | |||
4882 4883 4884 4885 4886 4887 4888 | (let* ((keysstr (string-intersperse (map car keypatt-alist) ",")) (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND ")) (numkeys (length keypatt-alist)) (test-ids '()) (dbdat (db:get-db dbstruct)) (db (db:dbdat-get-db dbdat)) (windows (and pathmod (substring-index "\\" pathmod))) | | | 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 | (let* ((keysstr (string-intersperse (map car keypatt-alist) ",")) (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND ")) (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 "_" (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 "State" ; 5 "Status" ; 6 |
︙ | ︙ |
Added dbi.scm version [3f996117f2].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 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 <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit dbi)) (include "dbi/dbi.scm") |
Added dbi/dbi.egg version [ce14ed7e9e].
> > > > > | 1 2 3 4 5 | ((license "BSD") (category db) (dependencies autoload sql-null) (test-dependencies test) (components (extension dbi))) |
Added dbi/dbi.meta version [df5803e479].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 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 version [8881b5e958].
> > > > > > > | 1 2 3 4 5 6 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 version [0d4d10831e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 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 version [e37bd8290c].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 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 version [fa8cc725eb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 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;") |
Modified dbmod.scm from [2029a02dc3] to [f2badf7d83].
︙ | ︙ | |||
19 20 21 22 23 24 25 | ;;====================================================================== (declare (unit dbmod)) (module dbmod * | | > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > | > > > | > > > > > > > > > > > > > > | | > > > > > > > | > > > > > | > > > | | > > > > > > > > > > > > > > > > > > > > > | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 | ;;====================================================================== (declare (unit dbmod)) (module dbmod * (import scheme chicken.base (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 ) ;;====================================================================== ;; Database access ;;====================================================================== ;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc ;; (use (srfi 18) extras tcp stack) ;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable) ;; (import (prefix sqlite3 sqlite3:)) ;; (import (prefix base64 base64:)) ;; ;; (declare (unit db)) ;; (declare (uses common)) ;; (declare (uses keys)) ;; (declare (uses ods)) ;; (declare (uses client)) ;; (declare (uses mt)) ;; ;; (include "common_records.scm") ;; (include "db_records.scm") ;; (include "key_records.scm") ;; (include "run_records.scm") (define *number-of-writes* 0) (define *number-non-write-queries* 0) ;;====================================================================== ;; R E C O R D S ;;====================================================================== ;; each db entry is a pair ( db . dbfilepath ) ;; I propose this record evolves into the area record ;; (defstruct dbr:dbstruct (tmpdb #f) (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack (mtdb #f) (refndb #f) (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet (read-only #f) (stmt-cache (make-hash-table)) (locdbs (make-hash-table)) ;; legacy junk in db_records ) ;; goal is to converge on one struct for an area but for now it is too confusing ;; record for keeping state,status and count for doing roll-ups in ;; iterated tests ;; (defstruct dbr:counts (state #f) (status #f) (count 0)) ;;====================================================================== ;; alist-of-alists ;;====================================================================== ;; ;; (define (db:aa-set! dat key1 key2 val) ;; (let loop (( ;;====================================================================== ;; hash of hashs ;;====================================================================== (define (db:hoh-set! dat key1 key2 val) (let* ((subhash (hash-table-ref/default dat key1 #f))) (if subhash (hash-table-set! subhash key2 val) (begin (hash-table-set! dat key1 (make-hash-table)) (db:hoh-set! dat key1 key2 val))))) (define (db:hoh-get dat key1 key2) (let* ((subhash (hash-table-ref/default dat key1 #f))) (and subhash (hash-table-ref/default subhash key2 #f)))) (define (db:get-cache-stmth dbstruct db stmt) (let* ((stmt-cache (dbr:dbstruct-stmt-cache dbstruct)) (stmth (db:hoh-get stmt-cache db stmt))) (or stmth (let* ((newstmth (sqlite3:prepare db stmt))) (db:hoh-set! stmt-cache db stmt newstmth) newstmth)))) ) |
Added debugprint.scm version [668a77fa42].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 | (declare (unit debugprint)) (declare (uses mtargs)) (module debugprint * ;;(import scheme chicken data-structures extras files ports) (import scheme chicken.base chicken.string chicken.port mtargs srfi-1 ) ;;====================================================================== ;; debug stuff ;;====================================================================== (define verbosity (make-parameter '())) (define *default-log-port* (current-error-port)) ;;====================================================================== ;; (define (debug:print . params) #f) ;; (define (debug:print-info . params) #f) ;; ;; (define (set-functions dbgp dbgpinfo) ;; (set! debug:print dbgp) ;; (set! debug:print-info dbgpinfo)) ;;====================================================================== ;; this was cached based on results from profiling but it turned out the profiling ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching ;; in for now but can probably take it out later. ;; (define (debug:calc-verbosity vstr arg) ;; arg is 'v (verbose) or 'q (quiet) (let* ((res (cond ((number? vstr) vstr) ((not (string? vstr)) 1) ;; ((string-match "^\\s*$" vstr) 1) (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) (cond ((> (length debugvals) 1) debugvals) ((> (length debugvals) 0)(car debugvals)) (else 1)))) ((eq? arg 'v) 2) ;; verbose ((eq? arg 'q) 0) ;; quiet (else 1)))) (verbosity res) res)) ;;====================================================================== ;; check verbosity, #t is ok #;(define (debug-check-verbosity verbosity vstr) (if (not (or (number? verbosity) (list? verbosity))) (begin (print "ERROR: Invalid debug value \"" vstr "\"") #f) #t)) (define (debug:debug-mode n) (let* ((vb (verbosity))) (cond ((and (number? vb) ;; number number (number? n)) (<= n vb)) ((and (list? vb) ;; list number (number? n)) (member n vb)) ((and (list? vb) ;; list list (list? n)) (not (null? (lset-intersection! eq? vb n)))) ((and (number? vb) (list? n)) (member vb n))))) (define (debug:print n e . params) (if (debug:debug-mode n) (with-output-to-port (or e (current-error-port)) (lambda () ;; (if *logging* ;; (db:log-event (apply conc params)) (apply print params) )))) ;; ) (define (debug:print-error n e . params) ;; normal print (if (debug:debug-mode n) (with-output-to-port (if (port? e) e (current-error-port)) (lambda () (apply print "ERROR: " params) ))) ;; pass important messages to stderr (if (and (eq? n 0)(not (eq? e (current-error-port)))) (with-output-to-port (current-error-port) (lambda () (apply print "ERROR: " params) )))) (define (debug:print-info n e . params) (if (debug:debug-mode n) (with-output-to-port (if (port? e) e (current-error-port)) (lambda () (apply print "INFO: (" n ") " params) ;; res) )))) ) |
Modified diff-report.scm from [722e4fdcd5] to [9cbd17eb23].
︙ | ︙ | |||
12 13 14 15 16 17 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; | | | | | | | | | > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; (declare (unit 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 (lambda (item) (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1))) |
︙ | ︙ |
Modified ducttape/ducttape-lib.scm from [59b0a2f94a] to [c4ffa8169c].
︙ | ︙ | |||
47 48 49 50 51 52 53 | current-wwdate current-isodate *this-exe-dir* *this-exe-name* *this-exe-fullpath* ) | | | | > | | > | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | current-wwdate current-isodate *this-exe-dir* *this-exe-name* *this-exe-fullpath* ) (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* ;;(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 (import pathname-expand chicken.file chicken.string) (define ##sys#expand-home-path pathname-expand) (define (realpath x) (print "Path: " x) (normalize-pathname (pathname-expand (or x "/dev/null")) )) ;;(define (realpath x) (pathname-expand (or x "/dev/null"))) ;; (include "mimetypes.scm") ; provides ext->mimetype ;; (include "workweekdate.scm") ;; gathered from macosx: ;; cat /etc/apache2/mime.types | grep -v '^#' | perl -ne 'print "(\"$2\" . \"$1\")\n" if /(\S+)\s+(\S+)/' > mimetypes.scm ;; + manual manipulation |
︙ | ︙ | |||
839 840 841 842 843 844 845 | ("wmx" . "video/x-ms-wmx") ("wvx" . "video/x-ms-wvx") ("avi" . "video/x-msvideo") ("movie" . "video/x-sgi-movie") ("smv" . "video/x-smv") ("ice" . "x-conference/x-cooltalk"))) | | | | | 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 | ("wmx" . "video/x-ms-wmx") ("wvx" . "video/x-ms-wvx") ("avi" . "video/x-msvideo") ("movie" . "video/x-sgi-movie") ("smv" . "video/x-smv") ("ice" . "x-conference/x-cooltalk"))) (import srfi-19) (import test) ;;(use format) (import regex) ;(declare (unit wwdate)) ;; utility procedures to convert among ;; different ways to express date (wwdate, seconds since epoch, isodate) ;; ;; samples: ;; isodate -> "2016-01-01" ;; wwdate -> "16ww01.5" |
︙ | ︙ | |||
1056 1057 1058 1059 1060 1061 1062 | (let loop ((rest-path-items path-items)) (if (null? rest-path-items) #f (let* ((this-dir (car rest-path-items)) (next-rest (cdr rest-path-items)) (candidate (conc this-dir "/" exe))) | | | 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 | (let loop ((rest-path-items path-items)) (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-executable? candidate) candidate (loop next-rest))))))) ;;;; define some handy globals ;; resolve fullpath to this script or binary. |
︙ | ︙ | |||
1245 1246 1247 1248 1249 1250 1251 | (let ( (raw-debug-level (get-environment-variable "DUCTTAPE_DEBUG_LEVEL")) ) (if raw-debug-level (let ((num-debug-level (runs-ok (string->number raw-debug-level)))) (if (integer? num-debug-level) (begin (let ((new-num-debug-level (- num-debug-level 1))) (if (> new-num-debug-level 0) ;; decrement | | | | | 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 | (let ( (raw-debug-level (get-environment-variable "DUCTTAPE_DEBUG_LEVEL")) ) (if raw-debug-level (let ((num-debug-level (runs-ok (string->number raw-debug-level)))) (if (integer? num-debug-level) (begin (let ((new-num-debug-level (- num-debug-level 1))) (if (> new-num-debug-level 0) ;; decrement (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 (unset-environment-variable! "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it #f))) ; value was invalid, mode is f #f)))) ; var not set, mode is f (define ducttape-debug-mode (if (ducttape-debug-level) #t #f)) ;; ducttape-debug-regex-filter suppresses non-matching debug messages |
︙ | ︙ | |||
1358 1359 1360 1361 1362 1363 1364 | " ")) (pwd (or (get-environment-variable "PWD") "nopwd")) (user (or (get-environment-variable "USER") "nouser")) (host (or (get-environment-variable "HOST") "nohost"))) (if logfile (begin (ducttape-log-file logfile) | | | 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 | " ")) (pwd (or (get-environment-variable "PWD") "nopwd")) (user (or (get-environment-variable "USER") "nouser")) (host (or (get-environment-variable "HOST") "nohost"))) (if logfile (begin (ducttape-log-file logfile) (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) (let ((orig-exit-handler (exit-handler))) (exit-handler |
︙ | ︙ | |||
1520 1521 1522 1523 1524 1525 1526 | ) (define (sendmail-proc sendmail-port) (define (wl line-str) (write-line line-str sendmail-port)) (define (get-uuid) | > > | | 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 | ) (define (sendmail-proc sendmail-port) (define (wl line-str) (write-line line-str sendmail-port)) (define (get-uuid) (print "ERROR in ducttape lib") "foo") ;;(string-upcase (uuid->string (uuid-generate)))) (let ((mailpart-uuid (get-uuid)) (mailpart-body-uuid (get-uuid))) (define (boundary) (wl (conc "--" mailpart-uuid))) |
︙ | ︙ | |||
1700 1701 1702 1703 1704 1705 1706 | ;; are sure they can coexist. (define (ducttape-process-command-line) ;; --quiet (let ((quiet-opts (skim-cmdline-opts-noarg-by-regex "--?quiet"))) (if (not (null? quiet-opts)) (begin | | | | | | | | | 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 | ;; are sure they can coexist. (define (ducttape-process-command-line) ;; --quiet (let ((quiet-opts (skim-cmdline-opts-noarg-by-regex "--?quiet"))) (if (not (null? quiet-opts)) (begin (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 (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 (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 (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))) (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)) (begin (ducttape-debug-level (let loop ((opts debug-opts) (debuglevel initial-debuglevel)) (if (null? opts) debuglevel (let* ( (curopt (car opts)) (restopts (cdr opts)) (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))))))))) (set-environment-variable! "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level)))))) ;; -dp <pat> / --debug-pattern <pat> (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 "|")) (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) ;;(set-ducttape-log-exit-handler) |
︙ | ︙ |
Modified env.scm from [028e47144f] to [dcc9cbb083].
︙ | ︙ | |||
14 15 16 17 18 19 20 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== | | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== ;; (declare (unit env)) ;; (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) (begin (exec (sql db "CREATE TABLE envvars ( |
︙ | ︙ |
Modified ezsteps.scm from [5de5d166c7] to [a411433d05].
︙ | ︙ | |||
15 16 17 18 19 20 21 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') | | | | | | | | | | | | | | | | | | > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') ;; (use 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 (stepinfo (cadr ezstep)) ;; (let ((info (cadr ezstep))) |
︙ | ︙ | |||
261 262 263 264 265 266 267 | (loop (- count 1)))))) (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)) | > | > | | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 | (loop (- count 1)))))) (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)) (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 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)) (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each (stepcmd (list-ref stepparts 3)) |
︙ | ︙ |
Deleted fs-transport.scm version [d1050dcefe].
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Modified gen-data-for-graph.scm from [253156d2fd] to [6f0d8b5e9a].
︙ | ︙ | |||
29 30 31 32 33 34 35 | (with-transaction db (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) | | | | | | | | | | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | (with-transaction db (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 (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) (pseudo-random-integer 1000) (pseudo-random-integer 6)))) (if (< count 20) (loop (max sec lastsec)(pseudo-random-integer 60)(+ count 1)))))))) (close-database db) ;; (with-transaction ;; db ;; (lambda () ;; (loop ((for d (up-from 0 (to 365)))) ;; days of the year ;; (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 (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) ;; (pseudo-random-integer 100) ;; (pseudo-random-integer 6)))) ;; (if (< count 20) ;; (loop (max sec lastsec)(pseudo-random-integer 60)(+ count 1)))))))))) ;; ;; (close-database db) |
Modified genexample.scm from [c6a2ab2853] to [17c365cd01].
︙ | ︙ | |||
14 15 16 17 18 19 20 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== | | | | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== ;; (declare (unit genexample)) ;; (use posix regex matchable) ;; ;; (include "db_records.scm") (define genexample:example-logpro #<<EOF ;; You should have at least one expect:required. This ensures that your process ran ;; comment out the line below and replace "put pattern here" with a pattern that will ;; always be seen in your log file if the step runs successfully. ;; |
︙ | ︙ |
Added hostinfo.scm version [e131d5b66f].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 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 <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit hostinfo)) (include "hostinfo/hostinfo.scm") |
Added hostinfo/hostinfo.h version [4f39d60970].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | #ifdef _WIN32 # include <winsock2.h> # include <ws2tcpip.h> 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 <sys/types.h> # include <sys/socket.h> # include <netinet/in.h> /* in_addr */ # include <arpa/inet.h> /* inet_ntop, ... */ # include <netdb.h> /* hostent, gethostby* */ # include <unistd.h> #endif |
Added hostinfo/hostinfo.meta version [90c3b6c82d].
> > > > > > > > > | 1 2 3 4 5 6 7 8 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 version [15139d566b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 | ;;; hostinfo extension to Chicken Scheme ;;; Description: Look up host, service, and protocol information ;; Copyright (c) 2005-2008, Jim Ursetto. All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are met: ;; ;; Redistributions of source code must retain the above copyright notice, ;; this list of conditions and the following disclaimer. Redistributions in ;; binary form must reproduce the above copyright notice, this list of ;; conditions and the following disclaimer in the documentation and/or ;; other materials provided with the distribution. Neither the name of the ;; author nor the names of its contributors may be used to endorse or ;; promote products derived from this software without specific prior ;; written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS ;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, ;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;; This extension performs host, protocol and service information lookups ;; via underlying calls to gethostbyname(3), getprotobyname(3), and ;; getservbyname(3). Depending on your system, this may consult DNS, ;; NIS, /etc/hosts, /etc/services, /etc/protocols, and so on. ;; A simple interface is provided for the most commmon queries. Also ;; provided is a more comprehensive interface using records, which ;; contain all data available in a lookup. ;; IP addresses are represented by 4 (IPv4) or 16 (IPv6) byte ;; u8vectors. The interface requires, and returns, addresses in this ;; format; functions are provided to convert between the string and ;; u8vector representations. However, the "do what I want" procedures ;; (e.g. host-information) will do the conversion for you. ;; Caveats: ;; - IPv6 addresses can be converted to and from strings, and the underlying structure ;; supports IPv6, but lookup of IPv6 addresses and records is not currently implemented. ;; - array0->string-vector and array0->bytevector-vector contain redundant code. ;; - host, services, and protocol-information check their argument types, even ;; though the underlying code already does it. (declare (fixnum)) (cond-expand [paranoia] [else (declare (no-bound-checks))]) #> #include "../hostinfo/hostinfo.h" <# ;; (require-extension srfi-4 lolevel posix) (module hostinfo ;;; Short and sweet lookups (current-hostname hostname->ip ip->hostname protocol-name->number protocol-number->name service-port->name service-name->port ;;; Entire host, protocol or service record lookup hostname->hostinfo ip->hostinfo protocol-name->protoinfo protocol-number->protoinfo service-port->servinfo service-name->servinfo ;;; Record accessors and predicates hostinfo? hostinfo-name hostinfo-aliases hostinfo-addresses hostinfo-address hostinfo-type hostinfo-length protoinfo? protoinfo-name protoinfo-aliases protoinfo-number servinfo? servinfo-name servinfo-aliases servinfo-port servinfo-protocol ;;; One-stop shops -- does what you want host-information protocol-information service-information ;;; Utilities string->ip ip->string) (import chicken.fixnum chicken.string chicken.blob srfi-2 scheme typed-records srfi-9 chicken.foreign srfi-4 chicken.base foreigners system-information chicken.format) (define (vector-map p v0) ; to avoid linking in vector-lib (let* ((len (vector-length v0)) (v (make-vector len))) (do ((i 0 (+ i 1))) ((>= i len) v) (vector-set! v i (p i (vector-ref v0 i)))))) (cond-expand [unsafe (eval-when (compile) (define-inline (##sys#check-string . r) (##core#undefined))) ] [else]) ;;; C data structure conversions (define (c-pointer->blob ptr len) (let ((bv (make-blob len)) (memcpy (foreign-lambda bool "C_memcpy" blob c-pointer integer))) (memcpy bv ptr len) bv)) ;; Convert from null-terminated array of c-strings to vector of strings. ;; These functions use C_alloc and so are not suitable for large datasets. ;; Note: get_argv_2 of runtime.c shows how to build a list instead of a vector (in reverse). (define array0->string-vector (foreign-primitive scheme-object (((c-pointer "char *") list)) " char **p; int len = 0; C_word *a, vec, *elt; for (p = list; *p; ++p, ++len); a = C_alloc(C_SIZEOF_VECTOR(len)); vec = (C_word)a; *a++ = C_make_header(C_VECTOR_TYPE, len); for (p = list; *p; ++p) { len = strlen(*p); elt = C_alloc(C_SIZEOF_STRING(len)); /* Both C_mutate and *a++ = seem to work fine here. */ C_mutate(a++, C_string(&elt, len, *p)); } return(vec);" )) ;; Convert from null-terminated array of IP addresses to vector of strings. (define array0->bytevector-vector (foreign-primitive scheme-object (((c-pointer "char *") list) (integer addrlen)) " char **p; int len = 0; C_word *a, vec, *elt; for (p = list; *p; ++p, ++len); a = C_alloc(C_SIZEOF_VECTOR(len)); vec = (C_word)a; *a++ = C_make_header(C_VECTOR_TYPE, len); for (p = list; *p; ++p) { elt = C_alloc(C_SIZEOF_STRING(addrlen)); C_mutate(a++, C_bytevector(&elt, addrlen, *p)); } return(vec);" )) ;; Not currently used. Could make the array0-> stuff somewhat cleaner. ;; (define array0-length ;; (foreign-lambda* integer (((pointer "void *") list)) #<<EOF ;; void **p; int len = 0; ;; for (p = list; *p; ++p, ++len); ;; return(len); ;; EOF ;; )) ;;; string->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 version [94d320c0dc].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 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"))) |
Modified http-transport.scm from [2202b22e9f] to [92216113da].
︙ | ︙ | |||
12 13 14 15 16 17 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. | | | | | | | | | | | | | | | | | | | | | | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; (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) (define (http-transport:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) (define *server-loop-heart-beat* (current-seconds)) |
︙ | ︙ | |||
222 223 224 225 226 227 228 | (define (http-transport:dec-requests-count-and-close-all-connections) (set! *http-requests-in-progress* (- *http-requests-in-progress* 1)) (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds (if (> *http-requests-in-progress* 0) (if (> etime (current-seconds)) (begin | | | | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 | (define (http-transport:dec-requests-count-and-close-all-connections) (set! *http-requests-in-progress* (- *http-requests-in-progress* 1)) (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds (if (> *http-requests-in-progress* 0) (if (> etime (current-seconds)) (begin (thread-sleep! 0.052) (loop etime)) (debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) (close-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*) (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))) |
︙ | ︙ | |||
297 298 299 300 301 302 303 | (list (cons 'key (or server-id "thekey")) (cons 'cmd cmd) (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? | | | 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 | (list (cons 'key (or server-id "thekey")) (cons 'cmd cmd) (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-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!!") #f)) (th1 (make-thread send-recieve "with-input-from-request")) |
︙ | ︙ | |||
520 521 522 523 524 525 526 | (if (common:low-noise-print 120 "server continuing") (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) (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*) | | | 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 | (if (common:low-noise-print 120 "server continuing") (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) (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*) (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))))))) (define (http-transport:server-shutdown port) (begin |
︙ | ︙ | |||
610 611 612 613 614 615 616 | "-") )) "Server run")) (th3 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server monitor thread started") (http-transport:keep-running) "Keep running")))) (thread-start! th2) | | | 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 | "-") )) "Server run")) (th3 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server monitor thread started") (http-transport:keep-running) "Keep running")))) (thread-start! th2) (thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor. (thread-start! th3) (set! *didsomething* #t) (thread-join! th2) (exit)))) ;; (define (http-transport:server-signal-handler signum) ;; (signal-mask! signum) |
︙ | ︙ |
Modified items.scm from [16328a4b96] to [4777d396de].
︙ | ︙ | |||
17 18 19 20 21 22 23 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; (define itemdat '((ripeness "green ripe overripe") ;; (temperature "cool medium hot") ;; (season "summer winter fall spring"))) | | | | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; (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") ;; Puts out all combinations (define (process-itemlist hierdepth curritemkey itemlist) (let ((res '())) (if (not hierdepth) (set! hierdepth (length itemlist))) (let loop ((hed (car itemlist)) |
︙ | ︙ |
Modified keys.scm from [9fa2c0cfa5] to [6b0d666bea].
︙ | ︙ | |||
17 18 19 20 21 22 23 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;;====================================================================== ;; Run keys, these are used to hierarchially organise tests and run areas ;;====================================================================== | | | | | | | | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;;====================================================================== ;; 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") (define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... (string-intersperse keys ",")) (define (args:usage . a) #f) ;;====================================================================== |
︙ | ︙ |
Modified launch.scm from [7e65ac64d4] to [914613830c].
︙ | ︙ | |||
17 18 19 20 21 22 23 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== | | | | | | | | | | | | | | | | | | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== ;; 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") ;;====================================================================== ;; ezsteps ;;====================================================================== ;; ezsteps were going to be coded as ;; stepname[,predstep1,predstep2 ...] [{VAR1=first,second,third}] command to execute |
︙ | ︙ | |||
305 306 307 308 309 310 311 | ))) (mutex-unlock! m) ;; 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 | | | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 | ))) (mutex-unlock! m) ;; 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 (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))))))) (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional |
︙ | ︙ | |||
355 356 357 358 359 360 361 | (keyvals #f) (fullrunscript (if (not runscript) #f (if (substring-index "/" runscript) runscript ;; use unadultered if contains slashes (let ((fulln (conc work-area "/" runscript))) (if (and (common:file-exists? fulln) | | | 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 | (keyvals #f) (fullrunscript (if (not runscript) #f (if (substring-index "/" runscript) runscript ;; use unadultered if contains slashes (let ((fulln (conc work-area "/" runscript))) (if (and (common:file-exists? 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)) (if (or (common:directory-exists? work-area) (> count 10)) |
︙ | ︙ | |||
612 613 614 615 616 617 618 | ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (common:file-exists? fullrunscript) | | | | | 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 | ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (common:file-exists? 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 ;; (db:test-remove-steps db run-id testname itemdat) ;; now is also a good time to write the .testconfig file (let* ((tconfig-fname (conc work-area "/.testconfig")) (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) (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) (match scriptdat ((name content) (with-output-to-file name (lambda () (print content) (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)) (kill-job? #f) (exit-info (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status |
︙ | ︙ | |||
911 912 913 914 915 916 917 | ;; checking for null cachefiles should not be necessary, I was seeing error car of '(), might be a chicken bug or a red herring ... (mtcachef (if (null? cachefiles) #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))) | | | 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 | ;; checking for null cachefiles should not be necessary, I was seeing error car of '(), might be a chicken bug or a red herring ... (mtcachef (if (null? cachefiles) #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-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) mtcachef rccachef use-cache |
︙ | ︙ | |||
1092 1093 1094 1095 1096 1097 1098 | ) (if (and rccachef mtcachef *runconfigdat* *configdat*) (set! *configstatus* 'fulldata))) ;; if have -append-config then read and append here (let ((cfname (args:get-arg "-append-config"))) (if (and cfname | | | 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 | ) (if (and rccachef mtcachef *runconfigdat* *configdat*) (set! *configstatus* 'fulldata))) ;; if have -append-config then read and append here (let ((cfname (args:get-arg "-append-config"))) (if (and 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) (let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f)) (hash-table-ref/default confdat "disks" #f))) |
︙ | ︙ |
Modified margs.scm from [812fd1b225] to [c1ea22878c].
︙ | ︙ | |||
12 13 14 15 16 17 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; (declare (unit margs)) ;; (declare (uses common)) (define args:arg-hash (make-hash-table)) (define (args:get-arg arg . default) (if (null? default) (hash-table-ref/default args:arg-hash arg #f) |
︙ | ︙ |
Deleted megatest-version.scm version [f92dc46346].
|
| < < < < < < < < < < < < < < < < < < < < < < < |
Modified megatest.scm from [35ed864745] to [165242d338].
︙ | ︙ | |||
12 13 14 15 16 17 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; | > > > > > > | > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | > > > > > | | | | | < | | > | | | | | | < > | | | > > > > > > > > > < > > > | < < < < > | < | < < < < | > > | | | | | > | | | | | | | | | | | | | | | | | | < < < | < < < < < < | | > > > > > > | | | | < | > | < | < < < | | | | | | | | | < | | < < | | | < | | | > > > > > > > < < | | > | | | > > | | < < | < | | < < | < | | > | | | | | | | | < < < | < | > | < > > | | | > > | | | | | | | | | > > | < | | | | | | < | < > | < | | | | | | | | | < < | > | > | | | > | < | | < | | | | | | | | | | | < | > | | | | | | | < | | | | | | | < < | | > | | > | | | | > > | | < < > | | | | | | | | | | | | | | | | | | < < < | | | | | | < | | > > | < | | | > > > > > > | > > > | > > > > > > > > | < > > | < | | | < < < < < < < < < < < | > > | > | | | | | > | | > | > > > | | < | | | | | | | | | | | | | | | | | | | < < < < > | > > | > > > | | | > | < > | > > > > > > | < < < | < < < < < < < | | > | | | | | | < | > > > | | < < | > > | > > | | > | > | | > | | | > > | > > | < < < | > > | > > > | | | > > | | < | < | | < | < | | < < < < | | | | | | | | | > > > | < | < | | | > > > | | | | | | < > | < | > > > > > | > > | < < > | < < < < < | | > > > > > > > > | | < < < < > > > > | < < | < > | > > > > > > > > | < | < | | < < | | < < < < > > > > > | < | > > > | < < < | | | | | > > > | < > > > > > > | | | | | < > | > > | | < > | < < | < | > | | | < < | | | | > | < | | | < < | > > | | | | | | | | | | | > > | | | < < < < < < < | > > > | < > | | | | < < < < > > | | | < | > | | | < < < < | | > > | > > | | | | | | > > | | < | < | < < < < < < < < | | | < > | < > > > > | < < < | | < > > | | | | | | | < > > > | < < > | < | | | | > > > | | | | | | | | | | > > | | > > > | < | < < > > | > > > > > | > | | | | > | | | | < < < < < < | | < > | > > > | < < < | | | > > | < < | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | < > | | | | | | | | | | | < < | < < < < < < < < < | > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > | < < < < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > | < < < < < < < | < < < < < < < < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > | | | | | | | | | | | | | | | | | | | | | | > > > > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; megatest.scm mofiles/autoload.o mofiles/dbi.o mofiles/ducttape-lib.o ;; mofiles/pkts.o mofiles/stml2.o mofiles/cookie.o mofiles/mutils.o ;; mofiles/mtargs.o ;; (include "mutils/mutils.scm") ;; (include "autoload/autoload.scm") ;; (include "dbi/dbi.scm") ;; (include "stml2/cookie.scm") ;; (include "stml2/stml2.scm") ;; (include "pkts/pkts.scm") ;; (include "csv-xml/csv-xml.scm") ;; (include "ducttape/ducttape-lib.scm") ;; (include "hostinfo/hostinfo.scm") ;; (include "adjutant.scm") (declare (uses autoload)) (declare (uses pkts)) (declare (uses stml2)) (declare (uses cookie)) (declare (uses csv-xml)) (declare (uses hostinfo)) (declare (uses mutils)) (declare (uses ducttape-lib)) (declare (uses mtargs)) (declare (uses commonmod)) (declare (uses apimod)) (declare (uses dbmod)) (declare (uses rmtmod)) (declare (uses servermod)) (declare (uses mtver)) (declare (uses adjutant)) ;; (include "call-with-environment-variables/call-with-environment-variables.scm") (module megatest-main * (import scheme chicken.base chicken.bitwise chicken.condition chicken.file chicken.file.posix chicken.format chicken.io chicken.irregex chicken.pathname chicken.port chicken.pretty-print chicken.process chicken.process-context chicken.process-context.posix chicken.process.signal chicken.random chicken.repl chicken.sort chicken.string chicken.tcp chicken.time chicken.time.posix (prefix sqlite3 sqlite3:) (prefix base64 base64:) address-info csv-abnf directory-utils fmt json matchable md5 message-digest queues regex regex-case sql-de-lite stack typed-records s11n sparse-vectors sxml-serializer sxml-modifications system-information z3 spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing srfi-1 srfi-4 srfi-18 srfi-13 srfi-98 srfi-69 ;; local modules adjutant csv-xml ducttape-lib hostinfo mtver mutils autoload cookie csv-xml ducttape-lib mtargs pkts stml2 (prefix dbi dbi:) apimod commonmod dbmod rmtmod servermod debugprint ) ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (define setenv set-environment-variable!) (define unsetenv unset-environment-variable!) ;; (declare (uses common)) ;; ;; (declare (uses megatest-version)) ;; (declare (uses margs)) ;; (declare (uses runs)) ;; (declare (uses launch)) ;; (declare (uses server)) ;; (declare (uses client)) ;; (declare (uses tests)) ;; (declare (uses genexample)) ;; ;; (declare (uses daemon)) ;; (declare (uses db)) ;; ;; (declare (uses dcommon)) ;; ;; (declare (uses tdb)) ;; (declare (uses mt)) ;; (declare (uses api)) ;; (declare (uses tasks)) ;; only used for debugging. ;; (declare (uses env)) ;; (declare (uses diff-report)) ;; (declare (uses ftail)) ;; (import ftail) ;; (define (blahblah)(thread-sleep! 1.234)) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") (include "common.scm") (include "megatest-fossil-hash.scm") (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) ;;; ;; ;;; ;; (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 ;;; ;; ;;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc"))) ;;; (if (common:file-exists? debugcontrolf) ;;; (load debugcontrolf))) ;;; ;;; ;; usage logging, careful with this, it is not designed to deal with all real world challenges! ;;; ;; ;;; (if (and *usage-log-file* ;;; (file-writable? *usage-log-file*)) ;;; (with-output-to-file ;;; *usage-log-file* ;;; (lambda () ;;; (print ;;; (if *usage-use-seconds* ;;; (current-seconds) ;;; (time->string ;;; (seconds->local-time (current-seconds)) ;;; "%Yww%V.%w %H:%M:%S")) ;;; " " ;;; (current-user-name) " " ;;; (current-directory) " " ;;; "\"" (string-intersperse (argv) " ") "\"")) ;;; #:append)) ;;; ;;; ;; Disabled help items ;;; ;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s) ;;; ;; from prior runs with same keys ;;; ;; -daemonize : fork into background and disconnect from stdin/out ;;; ;;; (define help (conc " ;;; Megatest, documentation at http://www.kiatoa.com/fossils/megatest ;;; version " megatest-version " ;;; license GPL, Copyright Matt Welland 2006-2017 ;;; ;;; Usage: megatest [options] ;;; -h : this help ;;; -manual : show the Megatest user manual ;;; -version : print megatest version (currently " megatest-version ") ;;; ;;; Launching and managing runs ;;; -run : run all tests or as specified by -testpatt ;;; -remove-runs : remove the data for a run, requires -runname and -testpatt ;;; Optionally use :state and :status, use -keep-records to remove only ;;; the run data. Use -kill-wait to override the 10 second ;;; per test wait after kill delay (e.g. -kill-wait 0). ;;; -kill-runs : kill existing run(s) (all incomplete tests killed) ;;; -kill-rerun : kill an existing run (all incomplete tests killed and run is rerun) ;;; -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs ;;; -rerun FAIL,WARN... : force re-run for tests with specificed status(s) ;;; -rerun-clean : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a ;;; and then run the specified testpatt with -preclean ;;; -rerun-all : set all tests to NOT_STARTED,n/a and run with -preclean ;;; -lock : lock run specified by target and runname ;;; -unlock : unlock run specified by target and runname ;;; -set-run-status status : sets status for run to status, requires -target and -runname ;;; -get-run-status : gets status for run specified by target and runname ;;; -run-wait : wait on run specified by target and runname ;;; -preclean : remove the existing test directory before running the test ;;; -clean-cache : remove the cached megatest.config and runconfigs.config files ;;; -no-cache : do not use the cached config files. ;;; -one-pass : launch as many tests as you can but do not wait for more to be ready ;;; -remove-keep N : remove all but N most recent runs per target; use '-actions, -age, -precmd' ;;; -age <age> : 120d,3h,20m to apply only to runs older than the ;;; specified age. NB// M=month, m=minute ;;; -actions <action>[,...] : actions to take; print,remove-runs,archive,kill-runs ;;; -precmd : insert a wrapper command in front of the commands run ;;; ;;; Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) ;;; -target key1/key2/... : run for key1, key2, etc. ;;; -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfigs ;;; -testpatt patt1/patt2,patt3/... : % is wildcard ;;; -runname : required, name for this particular test run ;;; -state : Applies to runs, tests or steps depending on context ;;; -status : Applies to runs, tests or steps depending on context ;;; -modepatt key : load testpatt from <key> in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified ;;; -tagexpr tag1,tag2%,.. : select tests with tags matching expression ;;; ;;; ;;; Test helpers (for use inside tests) ;;; -step stepname ;;; -test-status : set the state and status of a test (use :state and :status) ;;; -setlog logfname : set the path/filename to the final log relative to the test ;;; directory. may be used with -test-status ;;; -set-toplog logfname : set the overall log for a suite of sub-tests ;;; -summarize-items : for an itemized test create a summary html ;;; -m comment : insert a comment for this test ;;; ;;; Test data capture ;;; -set-values : update or set values in the testdata table ;;; :category : set the category field (optional) ;;; :variable : set the variable name (optional) ;;; :value : value measured (required) ;;; :expected : value expected (required) ;;; :tol : |value-expect| <= tol (required, can be <, >, >=, <= or number) ;;; :units : name of the units for value, expected_value etc. (optional) ;;; -load-test-data : read test specific data for storage in the test_data table ;;; from standard in. Each line is comma delimited with four ;;; fields category,variable,value,comment ;;; ;;; Queries ;;; -list-runs patt : list runs matching pattern \"patt\", % is the wildcard ;;; -show-keys : show the keys used in this megatest setup ;;; -test-files targpatt : get the most recent test path/file matching targpatt e.g. %/% or '*.log' ;;; returns list sorted by age ascending, see examples below ;;; -test-paths : get the test paths matching target, runname, item and test ;;; patterns. ;;; -list-disks : list the disks available for storing runs ;;; -list-targets : list the targets in runconfigs.config ;;; -list-db-targets : list the target combinations used in the db ;;; -show-config : dump the internal representation of the megatest.config file ;;; -show-runconfig : dump the internal representation of the runconfigs.config file ;;; -dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line) ;;; -show-cmdinfo : dump the command info for a test (run in test environment) ;;; -section sectionName ;;; -var varName : for config and runconfig lookup value for sectionName varName ;;; -since N : get list of runs changed since time N (Unix seconds) ;;; -fields fieldspec : fields to include in json dump; runs:id,runame+tests:testname+steps ;;; -sort fieldname : in -list-runs sort tests by this field ;;; -testdata-csv [categorypatt/]varpatt : dump testdata for given category ;;; ;;; Misc ;;; -start-dir path : switch to this directory before running megatest ;;; -contour cname : add a level of hierarcy to the linktree and run paths ;;; -area-tag tagname : add a tag to an area while syncing to pgdb ;;; -run-tag tagname : add a tag to a run while syncing to pgdb ;;; -rebuild-db : bring the database schema up to date ;;; -cleanup-db : remove any orphan records, vacuum the db ;;; -import-megatest.db : push data from megatest.db to cache db files in /tmp/$USER ;;; -sync-to-megatest.db : pull data from cache files in /tmp/$USER to megatest.db ;;; -sync-to dest : sync to new postgresql central style database ;;; -update-meta : update the tests metadata for all tests ;;; -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are ;;; overwritten by values set in config files. ;;; -server -|hostname : start the server (reduces contention on megatest.db), use ;;; - to automatically figure out hostname ;;; -adjutant C,M : start the server/adjutant with allocated cores C and Mem M (Gig), ;;; use 0,0 to auto use full machine ;;; -transport http|rpc : use http or rpc for transport (default is http) ;;; -log logfile : send stdout and stderr to logfile ;;; -list-servers : list the servers ;;; -kill-servers : kill all servers ;;; -repl : start a repl (useful for extending megatest) ;;; -load file.scm : load and run file.scm ;;; -mark-incompletes : find and mark incomplete tests ;;; -ping run-id|host:port : ping server, exit with 0 if found ;;; -debug N|N,M,O... : enable debug 0-N or N and M and O ... ;;; -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG ;;; -config fname : override the megatest.config file with fname ;;; -append-config fname : append fname to the megatest.config file ;;; ;;; Utilities ;;; -env2file fname : write the environment to fname.csh and fname.sh ;;; -envcap a : save current variables labeled as context 'a' in file envdat.db ;;; -envdelta a-b : output enviroment delta from context a to context b to -o fname ;;; set the output mode with -dumpmode csh, bash or ini ;;; note: ini format will use calls to use curr and minimize path ;;; -refdb2dat refdb : convert refdb to sexp or to format specified by s-dumpmode ;;; formats: perl, ruby, sqlite3, csv (for csv the -o param ;;; will substitute %s for the sheet name in generating ;;; multiple sheets) ;;; -o : output file for refdb2dat (defaults to stdout) ;;; -archive cmd : archive runs specified by selectors to one of disks specified ;;; in the [archive-disks] section. ;;; cmd: keep-html, restore, save, save-remove, get, replicate-db (use ;;; -dest to set destination), -include path1,path2... to get or save specific files ;;; -generate-html : create a simple html dashboard for browsing your runs ;;; -generate-html-structure : create a top level html veiw to list targets/runs and a Run view within each run directory. ;;; -list-run-time : list time requered to complete runs. It supports following switches ;;; -run-patt <patt> -target-patt <patt> -dumpmode <csv,json,plain-text> ;;; -list-test-time : list time requered to complete each test in a run. It following following arguments ;;; -runname <patt> -target <patt> -dumpmode <csv,json,plain-text> ;;; -syscheck : do some very basic checks; write access and space in tmp, home, runs, links and ;;; is $DISPLAY valid ;;; -list-waivers : dump waivers for specified target, runname, testpatt to stdout ;;; ;;; Diff report ;;; -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname ;;; and either -diff-email or -diff-html) ;;; -src-target <target> ;;; -src-runname <target> ;;; -diff-email <emails> : comma separated list of email addresses to send diff report ;;; -diff-html <rep.html> : path to html file to generate ;;; ;;; Spreadsheet generation ;;; -extract-ods fname.ods : extract an open document spreadsheet from the database ;;; -pathmod path : insert path, i.e. path/runame/itempath/logfile.html ;;; will clear the field if no rundir/testname/itempath/logfile ;;; if it contains forward slashes the path will be converted ;;; to windows style ;;; Getting started ;;; -create-megatest-area : create a skeleton megatest area. You will be prompted for paths ;;; -create-test testname : create a skeleton megatest test. You will be prompted for info ;;; ;;; Examples ;;; ;;; # Get test path, use '.' to get a single path or a specific path/file pattern ;;; megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt% ;;; ;;; Called as " (string-intersperse (argv) " ") " ;;; Version " megatest-version ", built from " megatest-fossil-hash )) ;;; ;;; ;; -gui : start a gui interface ;;; ;; -config fname : override the runconfigs file with fname ;;; ;;; ;; process args ;;; (define remargs (args:get-args ;;; (argv) ;;; (list "-runtests" ;; run a specific test ;;; "-config" ;; override the config file name ;;; "-append-config" ;;; "-execute" ;; run the command encoded in the base64 parameter ;;; "-step" ;;; "-target" ;;; "-reqtarg" ;;; ":runname" ;;; "-runname" ;;; ":state" ;;; "-state" ;;; ":status" ;;; "-status" ;;; "-list-runs" ;;; "-testdata-csv" ;;; "-testpatt" ;;; "--modepatt" ;;; "-modepatt" ;;; "-tagexpr" ;;; "-itempatt" ;;; "-setlog" ;;; "-set-toplog" ;;; "-runstep" ;;; "-logpro" ;;; "-m" ;;; "-rerun" ;;; ;;; "-days" ;;; "-rename-run" ;;; "-to" ;;; "-dest" ;;; "-source" ;;; "-time-stamp" ;;; ;; values and messages ;;; ":category" ;;; ":variable" ;;; ":value" ;;; ":expected" ;;; ":tol" ;;; ":units" ;;; ;;; ;; misc ;;; "-start-dir" ;;; "-run-patt" ;;; "-target-patt" ;;; "-contour" ;;; "-area-tag" ;;; "-area" ;;; "-run-tag" ;;; "-server" ;;; "-adjutant" ;;; "-transport" ;;; "-port" ;;; "-extract-ods" ;;; "-pathmod" ;;; "-env2file" ;;; "-envcap" ;;; "-envdelta" ;;; "-setvars" ;;; "-set-state-status" ;;; ;;; ;; move runs stuff here ;;; "-remove-keep" ;;; "-set-run-status" ;;; "-age" ;;; ;;; ;; archive ;;; "-archive" ;;; "-actions" ;;; "-precmd" ;;; "-include" ;;; "-exclude-rx" ;;; "-exclude-rx-from" ;;; ;;; "-debug" ;; for *verbosity* > 2 ;;; "-debug-noprop" ;;; "-create-test" ;;; "-override-timeout" ;;; "-test-files" ;; -test-paths is for listing all ;;; "-load" ;; load and exectute a scheme file ;;; "-section" ;;; "-var" ;;; "-dumpmode" ;;; "-run-id" ;;; "-ping" ;;; "-refdb2dat" ;;; "-o" ;;; "-log" ;;; "-sync-log" ;;; "-since" ;;; "-fields" ;;; "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state ;;; "-sort" ;;; "-target-db" ;;; "-source-db" ;;; "-prefix-target" ;;; ;;; "-src-target" ;;; "-src-runname" ;;; "-diff-email" ;;; "-sync-to" ;;; "-pgsync" ;;; "-kill-wait" ;; wait this long before removing test (default is 10 sec) ;;; "-diff-html" ;;; ;;; ;; wizards, area capture, setup new ... ;;; "-extract-skeleton" ;;; ) ;;; (list "-h" "-help" "--help" ;;; "-manual" ;;; "-version" ;;; "-force" ;;; "-xterm" ;;; "-showkeys" ;;; "-show-keys" ;;; "-test-status" ;;; "-set-values" ;;; "-load-test-data" ;;; "-summarize-items" ;;; "-gui" ;;; "-daemonize" ;;; "-preclean" ;;; "-rerun-clean" ;;; "-rerun-all" ;;; "-clean-cache" ;;; "-no-cache" ;;; "-cache-db" ;;; "-cp-eventtime-to-publishtime" ;;; "-use-db-cache" ;;; "-prepend-contour" ;;; ;;; ;;; ;; misc ;;; "-repl" ;;; "-lock" ;;; "-unlock" ;;; "-list-servers" ;;; "-kill-servers" ;;; "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) ;;; "-one-pass" ;; ;;; "-local" ;; run some commands using local db access ;;; "-generate-html" ;;; "-generate-html-structure" ;;; "-list-run-time" ;;; "-list-test-time" ;;; ;;; ;; misc queries ;;; "-list-disks" ;;; "-list-targets" ;;; "-list-db-targets" ;;; "-show-runconfig" ;;; "-show-config" ;;; "-show-cmdinfo" ;;; "-get-run-status" ;;; "-list-waivers" ;;; ;;; ;; queries ;;; "-test-paths" ;; get path(s) to a test, ordered by youngest first ;;; ;;; "-runall" ;; run all tests, respects -testpatt, defaults to % ;;; "-run" ;; alias for -runall ;;; "-remove-runs" ;;; "-kill-runs" ;;; "-kill-rerun" ;;; "-keep-records" ;; use with -remove-runs to remove only the run data ;;; "-rebuild-db" ;;; "-cleanup-db" ;;; "-rollup" ;;; "-update-meta" ;;; "-create-megatest-area" ;;; "-mark-incompletes" ;;; ;;; "-convert-to-norm" ;;; "-convert-to-old" ;;; "-import-megatest.db" ;;; "-sync-to-megatest.db" ;;; "-sync-brute-force" ;;; "-logging" ;;; "-v" ;; verbose 2, more than normal (normal is 1) ;;; "-q" ;; quiet 0, errors/warnings only ;;; ;;; "-diff-rep" ;;; ;;; "-syscheck" ;;; "-obfuscate" ;;; ;; junk placeholder ;;; ;; "-:p" ;;; ;;; ) ;;; args:arg-hash ;;; 0)) ;;; ;;; ;; Add args that use remargs here ;;; ;; ;;; (if (and (not (null? remargs)) ;;; (not (or ;;; (args:get-arg "-runstep") ;;; (args:get-arg "-envcap") ;;; (args:get-arg "-envdelta") ;;; ) ;;; )) ;;; (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) ;;; ;;; ;; before doing anything else change to the start-dir if provided ;;; ;; ;;; (if (args:get-arg "-start-dir") ;;; (if (common:file-exists? (args:get-arg "-start-dir")) ;;; (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) ;;; (setenv "PWD" fullpath) ;;; (change-directory fullpath)) ;;; (begin ;;; (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") ;;; (exit 1)))) ;;; ;;; ;; immediately set MT_TARGET if -reqtarg or -target are available ;;; ;; ;;; (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) ;;; (if targ (setenv "MT_TARGET" targ))) ;;; ;;; ;; The watchdog is to keep an eye on things like db sync etc. ;;; ;; ;;; ;;; ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage ;;; (define *watchdog* (make-thread ;;; (lambda () ;;; (handle-exceptions ;;; exn ;;; (begin ;;; (print-call-chain) ;;; (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)) ;;; (common:watchdog))) ;;; "Watchdog thread")) ;;; ;;; ;;(if (not (args:get-arg "-server")) ;;; ;; (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog ;;; (let* ((no-watchdog-args ;;; '("-list-runs" ;;; "-testdata-csv" ;;; "-list-servers" ;;; "-server" ;;; "-adjutant" ;;; "-list-disks" ;;; "-list-targets" ;;; "-show-runconfig" ;;; ;;"-list-db-targets" ;;; "-show-runconfig" ;;; "-show-config" ;;; "-show-cmdinfo" ;;; "-cleanup-db" ;;; )) ;;; (no-watchdog-argvals (list '("-archive" . "replicate-db"))) ;;; (start-watchdog-specail-arg-val (let loop ((hed (car no-watchdog-argvals)) ;;; (tail (cdr no-watchdog-argvals))) ;;; ;; (print "hed" hed " arg " (args:get-arg (car hed)) " val:" (cdr hed) " eql" (equal? (args:get-arg (car hed)) (cdr hed))) ;;; (if (equal? (args:get-arg (car hed)) (cdr hed)) ;;; #f ;;; (if (null? tail) ;;; #t ;;; (loop (car tail) (cdr tail)))))) ;;; (no-watchdog-args-vals (filter (lambda (x) x) ;;; (map args:get-arg no-watchdog-args))) ;;; (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val))) ;;; ;(print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog) ;;; (if start-watchdog ;;; (thread-start! *watchdog*))) ;;; ;;; ;;; ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions ;;; (define (open-logfile logpath-in) ;;; (condition-case ;;; (let* ((log-dir (or (pathname-directory logpath-in) ".")) ;;; (fname (pathname-strip-directory logpath-in)) ;;; (logpath (if (> (string-length fname) 250) ;;; (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log"))) ;;; (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf) ;;; newlogf) ;;; logpath-in))) ;;; (if (not (directory-exists? log-dir)) ;;; (system (conc "mkdir -p " log-dir))) ;;; (open-output-file logpath)) ;;; (exn () ;;; (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in) ;;; (define *didsomething* #t) ;;; (exit 1)))) ;;; ;;; ;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not ;;; ;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation ;;; ;; where (launch:setup) returns #f? ;;; ;; ;;; (if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server ;;; (handle-exceptions ;;; exn ;;; (begin ;;; (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) ;;; ) ;;; (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified ;;; (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name ;;; (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log"))) ;;; (oup (open-logfile logf))) ;;; (if (not (args:get-arg "-log")) ;;; (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log ;;; (debug:print-info 0 *default-log-port* "Sending log output to " logf) ;;; (set! *default-log-port* oup)))) ;;; ;;; (if (or (args:get-arg "-h") ;;; (args:get-arg "-help") ;;; (args:get-arg "--help")) ;;; (begin ;;; (print help) ;;; (exit))) ;;; ;;; (if (args:get-arg "-manual") ;;; (let* ((htmlviewercmd (or (configf:lookup *configdat* "setup" "htmlviewercmd") ;;; (common:which '("firefox" "arora")))) ;;; (install-home (common:get-install-area)) ;;; (manual-html (conc install-home "/share/docs/megatest_manual.html"))) ;;; (if (and install-home ;;; (common:file-exists? manual-html)) ;;; (system (conc "(" htmlviewercmd " " manual-html " ) &")) ;;; (system (conc "(" htmlviewercmd " http://www.kiatoa.com/cgi-bin/fossils/megatest/doc/tip/docs/manual/megatest_manual.html ) &"))) ;;; (exit))) ;;; ;;; (if (args:get-arg "-version") ;;; (begin ;;; (print (common:version-signature)) ;; (print megatest-version) ;;; (exit))) ;;; ;;; (define *didsomething* #f) ;;; ;;; ;; Overall exit handling setup immediately ;;; ;; ;;; (if (or (args:get-arg "-process-reap")) ;;; ;; (args:get-arg "-runtests") ;;; ;; (args:get-arg "-execute") ;;; ;; (args:get-arg "-remove-runs") ;;; ;; (args:get-arg "-runstep")) ;;; (let ((original-exit (exit-handler))) ;;; (exit-handler (lambda (#!optional (exit-code 0)) ;;; (printf "Preparing to exit with exit code ~A ...\n" exit-code) ;;; (for-each ;;; ;;; (lambda (pid) ;;; (handle-exceptions ;;; exn ;;; (begin ;;; (printf "process reap failed. exn=~A\n" exn) ;;; #t) ;;; (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) ;;; (if (or (eq? pid-val pid) ;;; (eq? pid-val 0)) ;;; (begin ;;; (printf "Sending signal/term to ~A\n" pid) ;;; (process-signal pid signal/term)))))) ;;; (process:children #f)) ;;; (original-exit exit-code))))) ;;; ;;; ;; for some switches always print the command to stderr ;;; ;; ;;; (if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun") ;;; (debug:print 0 *default-log-port* (string-intersperse (argv) " "))) ;;; ;;; ;; some switches imply homehost. Exit here if not on homehost ;;; ;; ;;; (let ((homehost-required (list "-cleanup-db" "-server"))) ;;; (if (apply args:any? homehost-required) ;;; (if (not (common:on-homehost?)) ;;; (for-each ;;; (lambda (switch) ;;; (if (args:get-arg switch) ;;; (begin ;;; (debug:print 0 *default-log-port* "ERROR: you must be on the homehost to run with " switch ;;; ", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.") ;;; (exit 1)))) ;;; homehost-required)))) ;;; ;;; ;;====================================================================== ;;; ;; Misc setup stuff ;;; ;;====================================================================== ;;; ;;; (debug:setup) ;;; ;;; (if (args:get-arg "-logging")(set! *logging* #t)) ;;; ;;; ;;(if (debug:debug-mode 3) ;; we are obviously debugging ;;; ;; (set! open-run-close open-run-close-no-exception-handling)) ;;; ;;; (if (args:get-arg "-itempatt") ;;; (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) ;;; (debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) ;;; (hash-table-set! args:arg-hash "-testpatt" newval) ;;; (hash-table-delete! args:arg-hash "-itempatt"))) ;;; ;;; (if (args:get-arg "-runtests") ;;; (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead")) ;;; ;;; (on-exit std-exit-procedure) ;;; ;;; ;;====================================================================== ;;; ;; Misc general calls ;;; ;;====================================================================== ;;; ;;; (if (and (args:get-arg "-cache-db") ;;; (args:get-arg "-source-db")) ;;; (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_"))))) ;;; (target-db (conc temp-dir "/cached.db")) ;;; (source-db (args:get-arg "-source-db"))) ;;; (db:cache-for-read-only source-db target-db) ;;; (set! *didsomething* #t))) ;;; ;;; ;; handle a clean-cache request as early as possible ;;; ;; ;;; (if (args:get-arg "-clean-cache") ;;; (let ((toppath (launch:setup))) ;;; (set! *didsomething* #t) ;; suppress the help output. ;;; (runs:clean-cache (common:args-get-target) ;;; (args:get-arg "-runname") ;;; toppath))) ;;; ;;; (if (args:get-arg "-env2file") ;;; (begin ;;; (save-environment-as-files (args:get-arg "-env2file")) ;;; (set! *didsomething* #t))) ;;; ;;; (if (args:get-arg "-list-disks") ;;; (let ((toppath (launch:setup))) ;;; (print ;;; (string-intersperse ;;; (map (lambda (x) ;;; (string-intersperse ;;; x ;;; " => ")) ;;; (common:get-disks *configdat*)) ;;; "\n")) ;;; (set! *didsomething* #t))) ;;; ;;; ;; csv processing record ;;; (define (make-refdb:csv) ;;; (vector ;;; (make-sparse-array) ;;; (make-hash-table) ;;; (make-hash-table) ;;; 0 ;;; 0)) ;;; (define-inline (refdb:csv-get-svec vec) (vector-ref vec 0)) ;;; (define-inline (refdb:csv-get-rows vec) (vector-ref vec 1)) ;;; (define-inline (refdb:csv-get-cols vec) (vector-ref vec 2)) ;;; (define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3)) ;;; (define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4)) ;;; (define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val)) ;;; (define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val)) ;;; (define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val)) ;;; (define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val)) ;;; (define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val)) ;;; ;;; (define (get-dat results sheetname) ;;; (or (hash-table-ref/default results sheetname #f) ;;; (let ((tmp-vec (make-refdb:csv))) ;;; (hash-table-set! results sheetname tmp-vec) ;;; tmp-vec))) ;;; ;;; (if (args:get-arg "-refdb2dat") ;;; (let* ((input-db (args:get-arg "-refdb2dat")) ;;; (out-file (args:get-arg "-o")) ;;; (out-fmt (or (args:get-arg "-dumpmode") "scheme")) ;;; (out-port (if (and out-file ;;; (not (member out-fmt '("sqlite3" "csv")))) ;;; (open-output-file out-file) ;;; (current-output-port))) ;;; (res-data (configf:read-refdb input-db)) ;;; (data (car res-data)) ;;; (msg (cadr res-data))) ;;; (if (not data) ;;; (debug:print 0 *default-log-port* "Bad input? data=" data) ;; some error occurred ;;; (with-output-to-port out-port ;;; (lambda () ;;; (case (string->symbol out-fmt) ;;; ((scheme)(pp data)) ;;; ((perl) ;;; ;; (print "%hash = (") ;;; ;; key1 => 'value1', ;;; ;; key2 => 'value2', ;;; ;; key3 => 'value3', ;;; ;; ); ;;; (configf:map-all-hier-alist ;;; data ;;; (lambda (sheetname sectionname varname val) ;;; (print "$data{\"" sheetname "\"}{\"" sectionname "\"}{\"" varname "\"} = \"" val "\";")))) ;;; ((python ruby) ;;; (print "data={}") ;;; (configf:map-all-hier-alist ;;; data ;;; (lambda (sheetname sectionname varname val) ;;; (print "data[\"" sheetname "\"][\"" sectionname "\"][\"" varname "\"] = \"" val "\"")) ;;; initproc1: ;;; (lambda (sheetname) ;;; (print "data[\"" sheetname "\"] = {}")) ;;; initproc2: ;;; (lambda (sheetname sectionname) ;;; (print "data[\"" sheetname "\"][\"" sectionname "\"] = {}")))) ;;; ((csv) ;;; (let* ((results (make-hash-table)) ;; (make-sparse-array))) ;;; (row-cols (make-hash-table))) ;; hash of hashes where section => ht { row-<name> => num or col-<name> => num ;;; ;; (print "data=") ;;; ;; (pp data) ;;; (configf:map-all-hier-alist ;;; data ;;; (lambda (sheetname sectionname varname val) ;;; ;; (print "sheetname: " sheetname ", sectionname: " sectionname ", varname: " varname ", val: " val) ;;; (let* ((dat (get-dat results sheetname)) ;;; (vec (refdb:csv-get-svec dat)) ;;; (rownames (refdb:csv-get-rows dat)) ;;; (colnames (refdb:csv-get-cols dat)) ;;; (currrown (hash-table-ref/default rownames varname #f)) ;;; (currcoln (hash-table-ref/default colnames sectionname #f)) ;;; (rown (or currrown ;;; (let* ((lastn (refdb:csv-get-maxrow dat)) ;;; (newrown (+ lastn 1))) ;;; (refdb:csv-set-maxrow! dat newrown) ;;; newrown))) ;;; (coln (or currcoln ;;; (let* ((lastn (refdb:csv-get-maxcol dat)) ;;; (newcoln (+ lastn 1))) ;;; (refdb:csv-set-maxcol! dat newcoln) ;;; newcoln)))) ;;; (if (not (sparse-array-ref vec 0 coln)) ;; (eq? rown 0) ;;; (begin ;;; (sparse-array-set! vec 0 coln sectionname) ;;; ;; (print "sparse-array-ref " 0 "," coln "=" (sparse-array-ref vec 0 coln)) ;;; )) ;;; (if (not (sparse-array-ref vec rown 0)) ;; (eq? coln 0) ;;; (begin ;;; (sparse-array-set! vec rown 0 varname) ;;; ;; (print "sparse-array-ref " rown "," 0 "=" (sparse-array-ref vec rown 0)) ;;; )) ;;; (if (not currrown)(hash-table-set! rownames varname rown)) ;;; (if (not currcoln)(hash-table-set! colnames sectionname coln)) ;;; ;; (print "dat=" dat ", rown=" rown ", coln=" coln) ;;; (sparse-array-set! vec rown coln val) ;;; ;; (print "sparse-array-ref " rown "," coln "=" (sparse-array-ref vec rown coln)) ;;; ))) ;;; (for-each ;;; (lambda (sheetname) ;;; (let* ((sheetdat (get-dat results sheetname)) ;;; (svec (refdb:csv-get-svec sheetdat)) ;;; (maxrow (refdb:csv-get-maxrow sheetdat)) ;;; (maxcol (refdb:csv-get-maxcol sheetdat)) ;;; (fname (if out-file ;;; (string-substitute "%s" sheetname out-file) ;; "/foo/bar/%s.csv") ;;; (conc sheetname ".csv")))) ;;; (with-output-to-file fname ;;; (lambda () ;;; ;; (print "Sheetname: " sheetname) ;;; (let loop ((row 0) ;;; (col 0) ;;; (curr-row '()) ;;; (result '())) ;;; (let* ((val (sparse-array-ref svec row col)) ;;; (disp-val (if val ;;; (conc "\"" val "\"") ;;; ""))) ;;; (if (> col 0)(display ",")) ;;; (display disp-val) ;;; (cond ;;; ((> row maxrow)(display "\n") result) ;;; ((>= col maxcol) ;;; (display "\n") ;;; (loop (+ row 1) 0 '() (append result (list curr-row)))) ;;; (else ;;; (loop row (+ col 1) (append curr-row (list val)) result))))))))) ;;; (hash-table-keys results)))) ;;; ((sqlite3) ;;; (let* ((db-file (or out-file (pathname-file input-db))) ;;; (db-exists (common:file-exists? db-file)) ;;; (db (sqlite3:open-database db-file))) ;;; (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);")) ;;; (configf:map-all-hier-alist ;;; data ;;; (lambda (sheetname sectionname varname val) ;;; (sqlite3:execute db ;;; "INSERT OR REPLACE INTO data (sheet,section,var,val) VALUES (?,?,?,?);" ;;; sheetname sectionname varname val))) ;;; (sqlite3:finalize! db))) ;;; (else ;;; (pp data)))))) ;;; (if out-file (close-output-port out-port)) ;;; (exit) ;; yes, bending the rules here - need to exit since this is a utility ;;; )) ;;; ;;; (if (args:get-arg "-ping") ;;; (let* ((server-id (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":" ;;; (host:port (args:get-arg "-ping"))) ;;; (server:ping (or server-id host:port) #f do-exit: #t))) ;;; ;;; ;;====================================================================== ;;; ;; Capture, save and manipulate environments ;;; ;;====================================================================== ;;; ;;; ;; NOTE: Keep these above the section where the server or client code is setup ;;; ;;; (let ((envcap (args:get-arg "-envcap"))) ;;; (if envcap ;;; (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs))))) ;;; (env:save-env-vars db envcap) ;;; (env:close-database db) ;;; (set! *didsomething* #t)))) ;;; ;;; ;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b ;;; ;; ;;; (let ((envdelta (args:get-arg "-envdelta"))) ;;; (if envdelta ;;; (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta))) ;;; (if (not (null? match)) ;;; (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs)))) ;;; ;; (resctx (cadr match)) ;;; ;; (equn (caddr match)) ;;; (parts match) ;; (string-split equn "-")) ;;; (minuend (car parts)) ;;; (subtraend (cadr parts)) ;;; (added (env:get-added db minuend subtraend)) ;;; (removed (env:get-removed db minuend subtraend)) ;;; (changed (env:get-changed db minuend subtraend))) ;;; ;; (pp (hash-table->alist added)) ;;; ;; (pp (hash-table->alist removed)) ;;; ;; (pp (hash-table->alist changed)) ;;; (if (args:get-arg "-o") ;;; (with-output-to-file ;;; (args:get-arg "-o") ;;; (lambda () ;;; (env:print added removed changed))) ;;; (env:print added removed changed)) ;;; (env:close-database db) ;;; (set! *didsomething* #t)) ;;; (debug:print-error 0 *default-log-port* "Parameter to -envdelta should be new=start-end"))))) ;;; ;;; ;;====================================================================== ;;; ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;;; ;; we start the server if not running else start the client thread ;;; ;;====================================================================== ;;; ;;; ;; Server? Start up here. ;;; ;; ;;; (if (args:get-arg "-server") ;;; (let ((tl (launch:setup)) ;;; (transport-type (string->symbol (or (args:get-arg "-transport") "http")))) ;;; (server:launch 0 transport-type) ;;; (set! *didsomething* #t))) ;;; ;;; ;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to ;;; ;; a specific Megatest area. Detail are being hashed out and this may change. ;;; ;; ;;; (if (args:get-arg "-adjutant") ;;; (begin ;;; (adjutant-run) ;;; (set! *didsomething* #t))) ;;; ;;; (if (or (args:get-arg "-list-servers") ;;; (args:get-arg "-kill-servers")) ;;; (let ((tl (launch:setup))) ;;; (if tl ;; all roads from here exit ;;; (let* ((servers (server:get-list *toppath*)) ;;; (fmtstr "~8a~22a~20a~20a~8a\n")) ;;; (format #t fmtstr "pid" "Interface:port" "age (hms)" "Last mod" "State") ;;; (format #t fmtstr "===" "==============" "=========" "========" "=====") ;;; (for-each ;; ( mod-time host port start-time pid ) ;;; (lambda (server) ;;; (let* ((mtm (any->number (car server))) ;;; (mod (if mtm (- (current-seconds) mtm) "unk")) ;;; (age (- (current-seconds)(or (any->number (list-ref server 3)) (current-seconds)))) ;;; (url (conc (cadr server) ":" (caddr server))) ;;; (pid (list-ref server 4)) ;;; (alv (if (number? mod)(< mod 10) #f))) ;;; (format #t ;;; fmtstr ;;; pid ;;; url ;;; (seconds->hr-min-sec age) ;;; (seconds->hr-min-sec mod) ;;; (if alv "alive" "dead")) ;;; (if (and alv ;;; (args:get-arg "-kill-servers")) ;;; (begin ;;; (debug:print-info 0 *default-log-port* "Attempting to kill server with pid " pid) ;;; (server:kill server))))) ;;; (sort servers (lambda (a b) ;;; (let ((ma (or (any->number (car a)) 9e9)) ;;; (mb (or (any->number (car b)) 9e9))) ;;; (> ma mb))))) ;;; ;; (debug:print-info 1 *default-log-port* "Done with listservers") ;;; (set! *didsomething* #t) ;;; (exit)) ;;; (exit)))) ;;; ;; must do, would have to add checks to many/all calls below ;;; ;;; ;;====================================================================== ;;; ;; Weird special calls that need to run *after* the server has started? ;;; ;;====================================================================== ;;; ;;; (if (args:get-arg "-list-targets") ;;; (if (launch:setup) ;;; (let ((targets (common:get-runconfig-targets))) ;;; ;; (debug:print 1 *default-log-port* "Found "(length targets) " targets") ;;; (case (string->symbol (or (args:get-arg "-dumpmode") "alist")) ;;; ((alist) ;;; (for-each (lambda (x) ;;; ;; (print "[" x "]")) ;;; (print x)) ;;; targets)) ;;; ((json) ;;; (json-write targets)) ;;; (else ;;; (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets"))) ;;; (set! *didsomething* #t)))) ;;; ;;; ;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig ;;; ;; ;;; (define (full-runconfigs-read) ;;; ;; in the envprocessing branch the below code replaces the further below code ;;; ;; (if (eq? *configstatus* 'fulldata) ;;; ;; *runconfigdat* ;;; ;; (begin ;;; ;; (launch:setup) ;;; ;; *runconfigdat*))) ;;; ;;; (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME")) ;;; (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")) ;;; #f)) ;;; (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f))) ;;; (if (and cfgf ;;; (common:file-exists? cfgf) ;;; (file-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)) ;;; (sections (if target (list "default" target) #f)) ;;; (data (begin ;;; (setenv "MT_RUN_AREA_HOME" *toppath*) ;;; (if key-vals ;;; (for-each (lambda (kt) ;;; (setenv (car kt) (cadr kt))) ;;; 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-writable? rundir)) ;;; (begin ;;; (if (not (common:in-running-test?)) ;;; (configf:write-alist data cfgf)) ;;; ;; force re-read of megatest.config - this resolves circular references between megatest.config ;;; (launch:setup force-reread: #t) ;;; ;; (launch:cache-config) ;; there are two independent config cache locations, turning this one off for now. MRW. ;;; )) ;; we can safely cache megatest.config since we have a valid runconfig ;;; data)))) ;;; ;;; (if (args:get-arg "-show-runconfig") ;;; (let ((tl (launch:setup))) ;;; (push-directory *toppath*) ;;; (let ((data (full-runconfigs-read))) ;;; ;; keep this one local ;;; (cond ;;; ((and (args:get-arg "-section") ;;; (args:get-arg "-var")) ;;; (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")) ;;; (configf:lookup data "default" (args:get-arg "-var"))))) ;;; (if val (print val)))) ;;; ((or (not (args:get-arg "-dumpmode")) ;;; (string=? (args:get-arg "-dumpmode") "ini")) ;;; (configf:config->ini data)) ;;; ((string=? (args:get-arg "-dumpmode") "sexp") ;;; (pp (hash-table->alist data))) ;;; ((string=? (args:get-arg "-dumpmode") "json") ;;; (json-write data)) ;;; (else ;;; (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) ;;; (set! *didsomething* #t)) ;;; (pop-directory))) ;;; ;;; (if (args:get-arg "-show-config") ;;; (let ((tl (launch:setup)) ;;; (data *configdat*)) ;; (read-config "megatest.config" #f #t))) ;;; (push-directory *toppath*) ;;; ;; keep this one local ;;; (cond ;;; ((and (args:get-arg "-section") ;;; (args:get-arg "-var")) ;;; (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var")))) ;;; (if val (print val)))) ;;; ;;; ;; print just a section if only -section ;;; ;;; ((equal? (args:get-arg "-dumpmode") "sexp") ;;; (pp (hash-table->alist data))) ;;; ((equal? (args:get-arg "-dumpmode") "json") ;;; (json-write data)) ;;; ((or (not (args:get-arg "-dumpmode")) ;;; (string=? (args:get-arg "-dumpmode") "ini")) ;;; (configf:config->ini data)) ;;; (else ;;; (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) ;;; (set! *didsomething* #t) ;;; (pop-directory) ;;; (set! *time-to-exit* #t))) ;;; ;;; (if (args:get-arg "-show-cmdinfo") ;;; (if (or (args:get-arg ":value")(getenv "MT_CMDINFO")) ;;; (let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO"))))) ;;; (if (equal? (args:get-arg "-dumpmode") "json") ;;; (json-write data) ;;; (pp data)) ;;; (set! *didsomething* #t)) ;;; (debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set"))) ;;; ;;; ;;====================================================================== ;;; ;; Remove old run(s) ;;; ;;====================================================================== ;;; ;;; ;; since several actions can be specified on the command line the removal ;;; ;; is done first ;;; (define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default" ;;; (let* ((runrec (runs:runrec-make-record)) ;;; (target (or target-in (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target ;;; (runname (or runname-in ;;; (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls ;;; (testpatt (or (args:get-arg "-testpatt") ;;; (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH ;;; (common:get-full-test-name)) ;;; (and (eq? action 'kill-runs) ;;; "%/%") ;; I'm just guessing that this is correct :( ;;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt"))) ;;; ))) ;; ;;; (cond ;;; ((not target) ;;; (debug:print-error 0 *default-log-port* "Missing required parameter for " ;;; action ", you must specify -target or -reqtarg") ;;; (exit 1)) ;;; ((not runname) ;;; (debug:print-error 0 *default-log-port* "Missing required parameter for " ;;; action ", you must specify the run name pattern with -runname patt") ;;; (exit 2)) ;;; ((not testpatt) ;;; (debug:print-error 0 *default-log-port* "Missing required parameter for " ;;; action ", you must specify the test pattern with -testpatt") ;;; (exit 3)) ;;; (else ;;; (if (not (car *configinfo*)) ;;; (begin ;;; (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found") ;;; (exit 1)) ;;; ;; put test parameters into convenient variables ;;; (begin ;;; ;; check for correct version, exit with message if not correct ;;; (common:exit-on-version-changed) ;;; (runs:operate-on action ;;; target ;;; runname ;;; testpatt ;;; state: (common:args-get-state) ;;; status: (common:args-get-status) ;;; new-state-status: (args:get-arg "-set-state-status") ;;; mode: mode))) ;;; (set! *didsomething* #t))))) ;;; ;;; (if (args:get-arg "-kill-runs") ;;; (general-run-call ;;; "-kill-runs" ;;; "kill runs" ;;; (lambda (target runname keys keyvals) ;;; (operate-on 'kill-runs mode: #f) ;;; ))) ;;; ;;; (if (args:get-arg "-kill-rerun") ;;; (let* ((target-patt (common:args-get-target)) ;;; (runname-patt (args:get-arg "-runname"))) ;;; (cond ((not target-patt) ;;; (debug:print-error 0 *default-log-port* "Missing target, must specify target for -kill-rerun with -target <target name>") ;;; (exit 1)) ;;; ((not runname-patt) ;;; (debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname <run name>") ;;; (exit 1)) ;;; ((string-search "[ ,%]" target-patt) ;;; (debug:print-error 0 *default-log-port* "Invalid target ["target-patt"], must specify exact target (no wildcards) for -kill-rerun with -target <target name>") ;;; (exit 1)) ;;; ((string-search "[ ,%]" runname-patt) ;;; (debug:print-error 0 *default-log-port* "Invalid runname ["runname-patt"], must specify exact runname (no wildcards) for -kill-rerun with -runname <runname name>") ;;; (exit 1)) ;;; (else ;;; (general-run-call ;;; "-kill-runs" ;;; "kill runs" ;;; (lambda (target runname keys keyvals) ;;; (operate-on 'kill-runs mode: #f) ;;; )) ;;; ;;; (thread-sleep! 15)) ;;; ;; fall thru and let "-run" loop fire ;;; ))) ;;; ;;; ;;; (if (args:get-arg "-remove-runs") ;;; (general-run-call ;;; "-remove-runs" ;;; "remove runs" ;;; (lambda (target runname keys keyvals) ;;; (operate-on 'remove-runs mode: (if (args:get-arg "-keep-records") ;;; 'remove-data-only ;;; 'remove-all))))) ;;; ;;; (if (args:get-arg "-remove-keep") ;;; (general-run-call ;;; "-remove-keep" ;;; "remove keep" ;;; (lambda (target runname keys keyvals) ;;; (let ((actions (map string->symbol ;;; (string-split ;;; (or (args:get-arg "-actions") ;;; "print") ;;; ",")))) ;; default to printing the output ;;; (runs:remove-all-but-last-n-runs-per-target target runname ;;; (string->number (args:get-arg "-remove-keep")) ;;; actions: actions))))) ;;; ;;; (if (args:get-arg "-set-state-status") ;;; (general-run-call ;;; "-set-state-status" ;;; "set state and status" ;;; (lambda (target runname keys keyvals) ;;; (operate-on 'set-state-status)))) ;;; ;;; (if (or (args:get-arg "-set-run-status") ;;; (args:get-arg "-get-run-status")) ;;; (general-run-call ;;; "-set-run-status" ;;; "set run status" ;;; (lambda (target runname keys keyvals) ;;; (let* ((runsdat (rmt:get-runs-by-patt keys runname ;;; (common:args-get-target) ;;; #f #f #f #f)) ;;; (header (vector-ref runsdat 0)) ;;; (rows (vector-ref runsdat 1))) ;;; (if (null? rows) ;;; (begin ;;; (debug:print-info 0 *default-log-port* "No matching run found.") ;;; (exit 1)) ;;; (let* ((row (car (vector-ref runsdat 1))) ;;; (run-id (db:get-value-by-header row header "id"))) ;;; (if (args:get-arg "-set-run-status") ;;; (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m")) ;;; (print (rmt:get-run-status run-id)) ;;; ))))))) ;;; ;;; ;;====================================================================== ;;; ;; Query runs ;;; ;;====================================================================== ;;; ;;; ;; -fields runs:id,target,runname,comment+tests:id,testname,item_path+steps ;;; ;; ;;; ;; csi> (extract-fields-constraints "runs:id,target,runname,comment+tests:id,testname,item_path+steps") ;;; ;; => (("runs" "id" "target" "runname" "comment") ("tests" "id" "testname" "item_path") ("steps")) ;;; ;; ;;; ;; NOTE: remember that the cdr will be the list you expect (cdr ("runs" "id" "target" "runname" "comment")) => ("id" "target" "runname" "comment") ;;; ;; and so alist-ref will yield what you expect ;;; ;; ;;; (define (extract-fields-constraints fields-spec) ;;; (map (lambda (table-spec) ;; runs:id,target,runname ;;; (let ((dat (string-split table-spec ":"))) ;; ("runs" "id,target,runname") ;;; (if (> (length dat) 1) ;;; (cons (car dat)(string-split (cadr dat) ",")) ;; "id,target,runname" ;;; dat))) ;;; (string-split fields-spec "+"))) ;;; ;;; (define (get-value-by-fieldname datavec test-field-index fieldname) ;;; (let ((indx (hash-table-ref/default test-field-index fieldname #f))) ;;; (if indx ;;; (if (>= indx (vector-length datavec)) ;;; #f ;; index too high, should raise an error I suppose ;;; (vector-ref datavec indx)) ;;; #f))) ;;; ;;; ;;; ;;; ;;; ;;; (when (args:get-arg "-testdata-csv") ;;; (if (launch:setup) ;;; (let* ((keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) ;;; (runpatt (or (args:get-arg "-runname") "%")) ;;; (testpatt (common:args-get-testpatt #f)) ;;; (datapatt (args:get-arg "-testdata-csv")) ;;; (match-data (string-match "^([^/]+)/(.*)" (args:get-arg "-testdata-csv"))) ;;; (categorypatt (if match-data (list-ref match-data 1) "%")) ;;; (setvarpatt (if match-data ;;; (list-ref match-data 2) ;;; (args:get-arg "-testdata-csv"))) ;;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") ;;; (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) ;;; (header (db:get-header runsdat)) ;;; (access-mode (db:get-access-mode)) ;;; (testpatt (common:args-get-testpatt #f)) ;;; (fields-spec (if (args:get-arg "-fields") ;;; (extract-fields-constraints (args:get-arg "-fields")) ;;; (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count"))) ;;; (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path") ;;; (list "steps" "id" "stepname")))) ;;; (tests-spec (let ((t (alist-ref "tests" fields-spec equal?))) ;;; (if (and t (null? t)) ;; all fields ;;; db:test-record-fields ;;; t))) ;;; (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;;; (test-field-index (make-hash-table)) ;;; (runs (db:get-rows runsdat)) ;;; ) ;;; (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec ;;; (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec))) ;;; (if (null? invalid-tests-spec) ;;; ;; generate the lookup map test-field-name => index-number ;;; (let loop ((hed (car adj-tests-spec)) ;;; (tal (cdr adj-tests-spec)) ;;; (idx 0)) ;;; (hash-table-set! test-field-index hed idx) ;;; (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1)))) ;;; (begin ;;; (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) ;;; (exit))))) ;;; (let* ((table-header (string-split "target,run,test,itempath,category,var,value,comment" ",")) ;;; (table-rows ;;; (apply append (map ;;; (lambda (run) ;;; (let* ((target (string-intersperse (map (lambda (x) ;;; (db:get-value-by-header run header x)) ;;; keys) "/")) ;;; (statuses (string-split (or (args:get-arg "-status") "") ",")) ;;; (run-id (db:get-value-by-header run header "id")) ;;; (runname (db:get-value-by-header run header "runname")) ;;; (states (string-split (or (args:get-arg "-state") "") ",")) ;;; (tests (if tests-spec ;;; (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc ;;; ;; use qryvals if test-spec provided ;;; (if tests-spec ;;; (string-intersperse adj-tests-spec ",") ;;; ;; db:test-record-fields ;;; #f) ;;; #f ;;; 'normal) ;;; '()))) ;;; (apply append ;;; (map ;;; (lambda (test) ;;; (let* ( ;;; (test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test)) ;;; (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test)) ;;; (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test)) ;;; (fullname (conc testname ;;; (if (equal? itempath "") ;;; "" ;;; (conc "/" itempath )))) ;;; (testdat-raw (map vector->list (rmt:read-test-data-varpatt run-id test-id categorypatt setvarpatt))) ;;; (testdat (filter ;;; (lambda (x) ;;; (not (equal? "logpro" ;;; (list-ref x 10)))) ;;; testdat-raw))) ;;; (map ;;; (lambda (item) ;;; (receive (id test_id category ;;; variable value expected ;;; tol units comment status type) ;;; (apply values item) ;;; (list target runname testname itempath category variable value comment))) ;;; testdat))) ;;; tests)))) ;;; runs)))) ;;; (print (string-join table-header ",")) ;;; (for-each (lambda(table-row) ;;; (print (string-join (map ->string table-row) ","))) ;;; ;;; ;;; table-rows)))) ;;; (set! *didsomething* #t) ;;; (set! *time-to-exit* #t)) ;;; ;;; ;;; ;;; ;; NOTE: list-runs and list-db-targets operate on local db!!! ;;; ;; ;;; ;; IDEA: megatest list -runname blah% ... ;;; ;; ;;; (if (or (args:get-arg "-list-runs") ;;; (args:get-arg "-list-db-targets")) ;;; (if (launch:setup) ;;; (let* (;; (dbstruct (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local"))) ;;; (runpatt (args:get-arg "-list-runs")) ;;; (access-mode (db:get-access-mode)) ;;; (testpatt (common:args-get-testpatt #f)) ;;; ;; (if (args:get-arg "-testpatt") ;;; ;; (args:get-arg "-testpatt") ;;; ;; "%")) ;;; (keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) ;;; ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) ;;; ;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) ;;; ;; #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) ;;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") ;;; (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) ;;; (runstmp (db:get-rows runsdat)) ;;; (header (db:get-header runsdat)) ;;; ;; this is "-since" support. This looks at last mod times of <run-id>.db files ;;; ;; and collects those modified since the -since time. ;;; (runs runstmp) ;;; ;; (if (and (not (null? runstmp)) ;;; ;; (args:get-arg "-since")) ;;; ;; (let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since"))))) ;;; ;; (let loop ((hed (car runstmp)) ;;; ;; (tal (cdr runstmp)) ;;; ;; (res '())) ;;; ;; (let ((new-res (if (member (db:get-value-by-header hed header "id") changed-ids) ;;; ;; (cons hed res) ;;; ;; res))) ;;; ;; (if (null? tal) ;;; ;; (reverse new-res) ;;; ;; (loop (car tal)(cdr tal) new-res))))) ;;; ;; runstmp)) ;;; (db-targets (args:get-arg "-list-db-targets")) ;;; (seen (make-hash-table)) ;;; (dmode (let ((d (args:get-arg "-dumpmode"))) ;; json, sexpr ;;; (if d (string->symbol d) #f))) ;;; (data (make-hash-table)) ;;; (fields-spec (if (args:get-arg "-fields") ;;; (extract-fields-constraints (args:get-arg "-fields")) ;;; (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count"))) ;;; (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path") ;;; (list "steps" "id" "stepname")))) ;;; (runs-spec (let ((r (alist-ref "runs" fields-spec equal?))) ;; the check is now unnecessary ;;; (if (and r (not (null? r))) r (list "id" )))) ;;; (tests-spec (let ((t (alist-ref "tests" fields-spec equal?))) ;;; (if (and t (null? t)) ;; all fields ;;; db:test-record-fields ;;; t))) ;;; (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id")))) ;;; (steps-spec (alist-ref "steps" fields-spec equal?)) ;;; (test-field-index (make-hash-table))) ;;; (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec ;;; (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec))) ;;; (if (null? invalid-tests-spec) ;;; ;; generate the lookup map test-field-name => index-number ;;; (let loop ((hed (car adj-tests-spec)) ;;; (tal (cdr adj-tests-spec)) ;;; (idx 0)) ;;; (hash-table-set! test-field-index hed idx) ;;; (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1)))) ;;; (begin ;;; (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) ;;; (exit))))) ;;; ;; Each run ;;; (for-each ;;; (lambda (run) ;;; (let ((targetstr (string-intersperse (map (lambda (x) ;;; (db:get-value-by-header run header x)) ;;; keys) "/"))) ;;; (if db-targets ;;; (if (not (hash-table-ref/default seen targetstr #f)) ;;; (begin ;;; (hash-table-set! seen targetstr #t) ;;; ;; (print "[" targetstr "]")))) ;;; (if (not dmode) ;;; (print targetstr) ;;; (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '()))) ;;; ))) ;;; (let* ((run-id (db:get-value-by-header run header "id")) ;;; (runname (db:get-value-by-header run header "runname")) ;;; (states (string-split (or (args:get-arg "-state") "") ",")) ;;; (statuses (string-split (or (args:get-arg "-status") "") ",")) ;;; (tests (if tests-spec ;;; (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc ;;; ;; use qryvals if test-spec provided ;;; (if tests-spec ;;; (string-intersperse adj-tests-spec ",") ;;; ;; db:test-record-fields ;;; #f) ;;; #f ;;; 'normal) ;;; '()))) ;;; (case dmode ;;; ((json ods sexpr) ;;; (if runs-spec ;;; (for-each ;;; (lambda (field-name) ;;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name)) ;;; runs-spec))) ;;; ;; (mutils:hierhash-set! data (db:get-value-by-header run header "status") targetstr runname "meta" "status" ) ;;; ;; (mutils:hierhash-set! data (db:get-value-by-header run header "state") targetstr runname "meta" "state" ) ;;; ;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id")) targetstr runname "meta" "id" ) ;;; ;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" ) ;;; ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) ;;; ;; ;; add last entry twice - seems to be a bug in hierhash? ;;; ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" ) ;;; (else ;;; (if (null? runs-spec) ;;; (print "Run: " targetstr "/" runname ;;; " status: " (db:get-value-by-header run header "state") ;;; " run-id: " run-id ", number tests: " (length tests) ;;; " event_time: " (db:get-value-by-header run header "event_time")) ;;; (begin ;;; (if (not (member "target" runs-spec)) ;;; ;; (display (conc "Target: " targetstr)) ;;; (display (conc "Run: " targetstr "/" runname " "))) ;;; (for-each ;;; (lambda (field-name) ;;; (if (equal? field-name "target") ;;; (display (conc "target: " targetstr " ")) ;;; (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " ")))) ;;; runs-spec) ;;; (newline))))) ;;; ;;; (for-each ;;; (lambda (test) ;;; (common:debug-handle-exceptions #f ;;; exn ;;; (begin ;;; (debug:print-error 0 *default-log-port* "Bad data in test record? " test) ;;; (debug:print-error 5 *default-log-port* "exn=" (condition->list exn)) ;;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) ;;; (print-call-chain (current-error-port))) ;;; (let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test)) ;;; (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test)) ;;; (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test)) ;;; (comment (if (member "comment" tests-spec)(get-value-by-fieldname test test-field-index "comment" ) #f)) ;; (db:test-get-comment test)) ;;; (tstate (if (member "state" tests-spec)(get-value-by-fieldname test test-field-index "state" ) #f)) ;; (db:test-get-state test)) ;;; (tstatus (if (member "status" tests-spec)(get-value-by-fieldname test test-field-index "status" ) #f)) ;; (db:test-get-status test)) ;;; (event-time (if (member "event_time" tests-spec)(get-value-by-fieldname test test-field-index "event_time" ) #f)) ;; (db:test-get-event_time test)) ;;; (rundir (if (member "rundir" tests-spec)(get-value-by-fieldname test test-field-index "rundir" ) #f)) ;; (db:test-get-rundir test)) ;;; (final_logf (if (member "final_logf" tests-spec)(get-value-by-fieldname test test-field-index "final_logf" ) #f)) ;; (db:test-get-final_logf test)) ;;; (run_duration (if (member "run_duration" tests-spec)(get-value-by-fieldname test test-field-index "run_duration") #f)) ;; (db:test-get-run_duration test)) ;;; (fullname (conc testname ;;; (if (equal? itempath "") ;;; "" ;;; (conc "(" itempath ")"))))) ;;; (case dmode ;;; ((json ods sexpr) ;;; (if tests-spec ;;; (for-each ;;; (lambda (field-name) ;;; (mutils:hierhash-set! data (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name)) ;;; tests-spec))) ;;; ;; ;; (mutils:hierhash-set! data fullname targetstr runname "data" (conc test-id) "tname" ) ;;; ;; (mutils:hierhash-set! data testname targetstr runname "data" (conc test-id) "testname" ) ;;; ;; (mutils:hierhash-set! data itempath targetstr runname "data" (conc test-id) "itempath" ) ;;; ;; (mutils:hierhash-set! data comment targetstr runname "data" (conc test-id) "comment" ) ;;; ;; (mutils:hierhash-set! data tstate targetstr runname "data" (conc test-id) "state" ) ;;; ;; (mutils:hierhash-set! data tstatus targetstr runname "data" (conc test-id) "status" ) ;;; ;; (mutils:hierhash-set! data rundir targetstr runname "data" (conc test-id) "rundir" ) ;;; ;; (mutils:hierhash-set! data final_logf targetstr runname "data" (conc test-id) "final_logf") ;;; ;; (mutils:hierhash-set! data run_duration targetstr runname "data" (conc test-id) "run_duration") ;;; ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time") ;;; ;; ;; add last entry twice - seems to be a bug in hierhash? ;;; ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time") ;;; ;; ) ;;; (else ;;; (if (and tstate tstatus event-time) ;;; (format #t ;;; " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" ;;; (if fullname fullname "") ;;; (if tstate tstate "") ;;; (if tstatus tstatus "") ;;; (get-value-by-fieldname test test-field-index "run_duration");;(if test (db:test-get-run_duration test) "") ;;; (if event-time event-time "") ;;; (get-value-by-fieldname test test-field-index "host")) ;;(if test (db:test-get-host test)) "") ;;; (print " Test: " fullname ;;; (if tstate (conc " State: " tstate) "") ;;; (if tstatus (conc " Status: " tstatus) "") ;;; (if (get-value-by-fieldname test test-field-index "run_duration") ;;; (conc " Runtime: " (get-value-by-fieldname test test-field-index "run_duration")) ;;; "") ;;; (if event-time (conc " Time: " event-time) "") ;;; (if (get-value-by-fieldname test test-field-index "host") ;;; (conc " Host: " (get-value-by-fieldname test test-field-index "host")) ;;; ""))) ;;; (if (not (or (equal? (get-value-by-fieldname test test-field-index "status") "PASS") ;;; (equal? (get-value-by-fieldname test test-field-index "status") "WARN") ;;; (equal? (get-value-by-fieldname test test-field-index "state") "NOT_STARTED"))) ;;; (begin ;;; (print (if (get-value-by-fieldname test test-field-index "cpuload") ;;; (conc " cpuload: " (get-value-by-fieldname test test-field-index "cpuload")) ;;; "") ;; (db:test-get-cpuload test) ;;; (if (get-value-by-fieldname test test-field-index "diskfree") ;;; (conc "\n diskfree: " (get-value-by-fieldname test test-field-index "diskfree")) ;; (db:test-get-diskfree test) ;;; "") ;;; (if (get-value-by-fieldname test test-field-index "uname") ;;; (conc "\n uname: " (get-value-by-fieldname test test-field-index "uname")) ;; (db:test-get-uname test) ;;; "") ;;; (if (get-value-by-fieldname test test-field-index "rundir") ;;; (conc "\n rundir: " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test) ;;; "") ;;; ;; "\n rundir: " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* ;;; ;; (db:test-get-rundir test) ;; ) ;;; ) ;;; ;; Each test ;;; ;; DO NOT remote run ;;; (let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) ;;; (for-each ;;; (lambda (step) ;;; (format #t ;;; " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" ;;; (tdb:step-get-stepname step) ;;; (tdb:step-get-state step) ;;; (tdb:step-get-status step) ;;; (tdb:step-get-event_time step))) ;;; steps))))))))) ;;; (if (args:get-arg "-sort") ;;; (sort tests ;;; (lambda (a-test b-test) ;;; (let* ((key (args:get-arg "-sort")) ;;; (first (get-value-by-fieldname a-test test-field-index key)) ;;; (second (get-value-by-fieldname b-test test-field-index key))) ;;; ((cond ;;; ((and (number? first)(number? second)) <) ;;; ((and (string? first)(string? second)) string<=?) ;;; (else equal?)) ;;; first second)))) ;;; tests)))))) ;;; runs) ;;; (case dmode ;;; ((json) (json-write data)) ;;; ((sexpr) (pp (common:to-alist data)))) ;;; (let* ((metadat-fields (delete-duplicates ;;; (append keys '( "runname" "time" "owner" "pass_count" "fail_count" "state" "status" "comment" "id")))) ;;; (run-fields '( ;;; "testname" ;;; "item_path" ;;; "state" ;;; "status" ;;; "comment" ;;; "event_time" ;;; "host" ;;; "run_id" ;;; "run_duration" ;;; "attemptnum" ;;; "id" ;;; "archived" ;;; "diskfree" ;;; "cpuload" ;;; "final_logf" ;;; "shortdir" ;;; "rundir" ;;; "uname" ;;; ) ;;; ) ;;; (newdat (common:to-alist data)) ;;; (allrundat (if (null? newdat) ;;; '() ;;; (car (map cdr newdat)))) ;; (car (map cdr (car (map cdr newdat))))) ;;; (runs (append ;;; (list "runs" ;; sheetname ;;; metadat-fields) ;;; (map (lambda (run) ;;; ;; (print "run: " run) ;;; (let* ((runname (car run)) ;;; (rundat (cdr run)) ;;; (metadat (let ((tmp (assoc "meta" rundat))) ;;; (if tmp (cdr tmp) #f)))) ;;; ;; (print "runname: " runname "\n\nrundat: " )(pp rundat)(print "\n\nmetadat: ")(pp metadat) ;;; (if metadat ;;; (map (lambda (field) ;;; (let ((tmp (assoc field metadat))) ;;; (if tmp (cdr tmp) ""))) ;;; metadat-fields) ;;; (begin ;;; (debug:print 0 *default-log-port* "WARNING: meta data for run " runname " not found") ;;; '())))) ;;; allrundat))) ;;; ;; '( ( "target" ( "runname" ( "data" ( "runid" ( "id . "37" ) ( ... )))) ;;; (run-pages (map (lambda (targdat) ;;; (let* ((target (car targdat)) ;;; (runsdat (cdr targdat))) ;;; (if runsdat ;;; (map (lambda (rundat) ;;; (let* ((runname (car rundat)) ;;; (rundat (cdr rundat)) ;;; (testsdat (let ((tmp (assoc "data" rundat))) ;;; (if tmp (cdr tmp) #f)))) ;;; (if testsdat ;;; (let ((tests (map (lambda (test) ;;; (let* ((test-id (car test)) ;;; (test-dat (cdr test))) ;;; (map (lambda (field) ;;; (let ((tmp (assoc field test-dat))) ;;; (if tmp (cdr tmp) ""))) ;;; run-fields))) ;;; testsdat))) ;;; ;; (print "Target: " target "/" runname " tests:") ;;; ;; (pp tests) ;;; (cons (conc target "/" runname) ;;; (cons (list (conc target "/" runname)) ;;; (cons '() ;;; (cons run-fields tests))))) ;;; (begin ;;; (debug:print 4 *default-log-port* "WARNING: run " target "/" runname " appears to have no data") ;;; ;; (pp rundat) ;;; '())))) ;;; runsdat) ;;; '()))) ;;; newdat)) ;; we use newdat to get target ;;; (sheets (filter (lambda (x) ;;; (not (null? x))) ;;; (cons runs (map car run-pages))))) ;;; ;; (print "allrundat:") ;;; ;; (pp allrundat) ;;; ;; (print "runs:") ;;; ;; (pp runs) ;;; ;(print "sheets: ") ;;; ;; (pp sheets) ;;; (if (eq? dmode 'ods) ;;; (let* ((tempdir (conc "/tmp/" (current-user-name) "/" (pseudo-random-integer 10000) "_" (current-process-id))) ;;; (outputfile (or (args:get-arg "-o") "out.ods")) ;;; (ouf (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path? ;;; outputfile ;;; (begin ;;; (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory") ;;; (conc (current-directory) "/" outputfile))))) ;;; (create-directory tempdir #t) ;;; (ods:list->ods tempdir ouf sheets)))) ;;; ;; (system (conc "rm -rf " tempdir)) ;;; (set! *didsomething* #t) ;;; (set! *time-to-exit* #t) ;;; ) ;; end if true branch (end of a let) ;;; ) ;; end if ;;; ) ;; end if -list-runs ;;; ;;; ;; list-waivers ;;; (if (and (args:get-arg "-list-waivers") ;;; (launch:setup)) ;;; (let* ((runpatt (or (args:get-arg "-runname") "%")) ;;; (testpatt (common:args-get-testpatt #f)) ;;; (keys (rmt:get-keys)) ;;; (runsdat (rmt:get-runs-by-patt ;;; keys runpatt ;;; (common:args-get-target) #f #f ;;; '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) ;;; (runs (db:get-rows runsdat)) ;;; (header (db:get-header runsdat)) ;;; (results (make-hash-table)) ;; [target] ( (testname/itempath . "comment") ... ) ;;; (addtest (lambda (target testname itempath comment) ;;; (hash-table-set! results target (cons (cons (conc testname "/" itempath) comment) ;;; (hash-table-ref/default results target '()))))) ;;; (last-target #f)) ;;; (for-each ;;; (lambda (run) ;;; (let* ((run-id (db:get-value-by-header run header "id")) ;;; (target (rmt:get-target run-id)) ;;; (runname (db:get-value-by-header run header "runname")) ;;; (tests (rmt:get-tests-for-run ;;; run-id testpatt '("COMPLETED") '("WAIVED") #f #f #f 'testname 'asc ;; use qryvals if test-spec provided ;;; #f #f #f))) ;;; (if (not (equal? target last-target)) ;;; (print "[" target "]")) ;;; (set! last-target target) ;;; (print "# " runname) ;;; (for-each ;;; (lambda (testdat) ;;; (let* ((testfullname (conc (db:test-get-testname testdat) ;;; (if (equal? "" (db:test-get-item-path testdat)) ;;; "" ;;; (conc "/" (db:test-get-item-path testdat))) ;;; ))) ;;; (print testfullname " " (db:test-get-comment testdat)))) ;;; tests))) ;;; runs) ;;; (set! *didsomething* #t))) ;;; ;;; ;;====================================================================== ;;; ;; full run ;;; ;;====================================================================== ;;; ;;; (define (handle-run-requests target runname keys keyvals need-clean) ;;; (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct ;;; ;; For rerun-clean do we or do we not support the testpatt? ;;; (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states") ;;; "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED")) ;;; (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses") ;;; "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED"))) ;;; (hash-table-set! args:arg-hash "-preclean" #t) ;;; (runs:operate-on 'set-state-status ;;; target ;;; (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) ;;; ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") ;;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") ;;; state: states ;;; ;; status: statuses ;;; new-state-status: "NOT_STARTED,n/a") ;;; (runs:clean-cache target runname *toppath*) ;;; (runs:operate-on 'set-state-status ;;; target ;;; (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) ;;; ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") ;;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") ;;; ;; state: states ;;; status: statuses ;;; new-state-status: "NOT_STARTED,n/a"))) ;;; ;; RERUN ALL ;;; (if (args:get-arg "-rerun-all") ;; first set states/statuses correct ;;; (let* ((rconfig (full-runconfigs-read))) ;;; (hash-table-set! args:arg-hash "-preclean" #t) ;;; (runs:operate-on 'set-state-status ;;; target ;;; (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) ;;; (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt") ;;; state: #f ;;; ;; status: statuses ;;; new-state-status: "NOT_STARTED,n/a") ;;; (runs:clean-cache target runname *toppath*) ;;; (runs:operate-on 'set-state-status ;;; target ;;; (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) ;;; (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt") ;;; ;; state: states ;;; status: #f ;;; new-state-status: "NOT_STARTED,n/a"))) ;;; (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) ;;; (if x (string->number x) #f))) ;;; (rerun-cnt (if config-reruns ;;; config-reruns ;;; 1))) ;;; ;;; (runs:run-tests target ;;; runname ;;; #f ;; (common:args-get-testpatt #f) ;;; ;; (or (args:get-arg "-testpatt") ;;; ;; "%") ;;; user ;;; args:arg-hash ;;; run-count: rerun-cnt))) ;;; ;;; ;; get lock in db for full run for this directory ;;; ;; for all tests with deps ;;; ;; walk tree of tests to find head tasks ;;; ;; add head tasks to task queue ;;; ;; add dependant tasks to task queue ;;; ;; add remaining tasks to task queue ;;; ;; for each task in task queue ;;; ;; if have adequate resources ;;; ;; launch task ;;; ;; else ;;; ;; put task in deferred queue ;;; ;; if still ok to run tasks ;;; ;; process deferred tasks per above steps ;;; ;;; ;; run all tests are are Not COMPLETED and PASS or CHECK ;;; (if (or (args:get-arg "-runall") ;;; (args:get-arg "-run") ;;; (args:get-arg "-rerun-clean") ;;; (args:get-arg "-rerun-all") ;;; (args:get-arg "-runtests") ;;; (args:get-arg "-kill-rerun")) ;;; (let ((need-clean (or (args:get-arg "-rerun-clean") ;;; (args:get-arg "-rerun-all"))) ;;; (orig-cmdline (string-intersperse (argv) " "))) ;;; (general-run-call ;;; "-runall" ;;; "run all tests" ;;; (lambda (target runname keys keyvals) ;;; (if (or (string-search "%" target) ;;; (string-search "%" runname)) ;; we are being asked to re-run multiple runs ;;; (let* ((run-specs (rmt:simple-get-runs runname #f #f target #f))) ;; list of simple-run records ;;; (debug:print-info 0 *default-log-port* "Pattern supplied for target or runname with " ;;; (length run-specs) " matches round. Running each in turn.") ;;; (if (null? run-specs) ;;; (debug:print 0 *default-log-port* "WARNING: No runs match target " target " and runname " runname)) ;;; (for-each (lambda (spec) ;;; (let* ((precmd (if (args:get-arg "-precmd")(conc (args:get-arg "-precmd") " ") "")) ;;; (newcmdline (conc ;;; precmd ;;; (string-substitute ;;; (conc "target " target) ;;; (conc "target " (simple-run-target spec)) ;;; (string-substitute ;;; (conc "runname " runname) ;;; (conc "runname " (simple-run-runname spec)) ;;; orig-cmdline))))) ;;; (debug:print 0 *default-log-port* "ORIG: " orig-cmdline) ;;; (debug:print 0 *default-log-port* "NEW: " newcmdline) ;;; (system newcmdline))) ;;; run-specs)) ;;; (handle-run-requests target runname keys keyvals need-clean)))))) ;;; ;;; ;;====================================================================== ;;; ;; run one test ;;; ;;====================================================================== ;;; ;;; ;; 1. find the config file ;;; ;; 2. change to the test directory ;;; ;; 3. update the db with "test started" status, set running host ;;; ;; 4. process launch the test ;;; ;; - monitor the process, update stats in the db every 2^n minutes ;;; ;; 5. as the test proceeds internally it calls megatest as each step is ;;; ;; started and completed ;;; ;; - step started, timestamp ;;; ;; - step completed, exit status, timestamp ;;; ;; 6. test phone home ;;; ;; - if test run time > allowed run time then kill job ;;; ;; - if cannot access db > allowed disconnect time then kill job ;;; ;;; ;; == duplicated == (if (or (args:get-arg "-run")(args:get-arg "-runtests")) ;;; ;; == duplicated == (general-run-call ;;; ;; == duplicated == "-runtests" ;;; ;; == duplicated == "run a test" ;;; ;; == duplicated == (lambda (target runname keys keyvals) ;;; ;; == duplicated == ;; ;;; ;; == duplicated == ;; May or may not implement it this way ... ;;; ;; == duplicated == ;; ;;; ;; == duplicated == ;; Insert this run into the tasks queue ;;; ;; == duplicated == ;; (open-run-close tasks:add tasks:open-db ;;; ;; == duplicated == ;; "runtests" ;;; ;; == duplicated == ;; user ;;; ;; == duplicated == ;; target ;;; ;; == duplicated == ;; runname ;;; ;; == duplicated == ;; (args:get-arg "-runtests") ;;; ;; == duplicated == ;; #f)))) ;;; ;; == duplicated == (runs:run-tests target ;;; ;; == duplicated == runname ;;; ;; == duplicated == (common:args-get-testpatt #f) ;; (args:get-arg "-runtests") ;;; ;; == duplicated == user ;;; ;; == duplicated == args:arg-hash)))) ;;; ;;; ;;====================================================================== ;;; ;; Rollup into a run ;;; ;;====================================================================== ;;; ;;; ;; (if (args:get-arg "-rollup") ;;; ;; (general-run-call ;;; ;; "-rollup" ;;; ;; "rollup tests" ;;; ;; (lambda (target runname keys keyvals) ;;; ;; (runs:rollup-run keys ;;; ;; keyvals ;;; ;; (or (args:get-arg "-runname")(args:get-arg ":runname") ) ;;; ;; user)))) ;;; ;;; ;;====================================================================== ;;; ;; Lock or unlock a run ;;; ;;====================================================================== ;;; ;;; (if (or (args:get-arg "-lock")(args:get-arg "-unlock")) ;;; (general-run-call ;;; (if (args:get-arg "-lock") "-lock" "-unlock") ;;; "lock/unlock tests" ;;; (lambda (target runname keys keyvals) ;;; (runs:handle-locking ;;; target ;;; keys ;;; (or (args:get-arg "-runname")(args:get-arg ":runname") ) ;;; (args:get-arg "-lock") ;;; (args:get-arg "-unlock") ;;; user)))) ;;; ;;; ;;====================================================================== ;;; ;; Get paths to tests ;;; ;;====================================================================== ;;; ;; Get test paths matching target, runname, and testpatt ;;; (if (or (args:get-arg "-test-files")(args:get-arg "-test-paths")) ;;; ;; if we are in a test use the MT_CMDINFO data ;;; (if (getenv "MT_CMDINFO") ;;; (let* ((startingdir (current-directory)) ;;; (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) ;;; (transport (assoc/default 'transport cmdinfo)) ;;; (testpath (assoc/default 'testpath cmdinfo)) ;;; (test-name (assoc/default 'test-name cmdinfo)) ;;; (runscript (assoc/default 'runscript cmdinfo)) ;;; (db-host (assoc/default 'db-host cmdinfo)) ;;; (run-id (assoc/default 'run-id cmdinfo)) ;;; (itemdat (assoc/default 'itemdat cmdinfo)) ;;; (state (args:get-arg ":state")) ;;; (status (args:get-arg ":status")) ;;; ;;(target (args:get-arg "-target")) ;;; (target (common:args-get-target)) ;;; (toppath (assoc/default 'toppath cmdinfo))) ;;; (change-directory toppath) ;;; (if (not target) ;;; (begin ;;; (debug:print-error 0 *default-log-port* "-target is required.") ;;; (exit 1))) ;;; (if (not (launch:setup)) ;;; (begin ;;; (debug:print 0 *default-log-port* "Failed to setup, giving up on -test-paths or -test-files, exiting") ;;; (exit 1))) ;;; (let* ((keys (rmt:get-keys)) ;;; ;; db:test-get-paths must not be run remote ;;; (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) ;;; (set! *didsomething* #t) ;;; (for-each (lambda (path) ;;; (if (common:file-exists? path) ;;; (print path))) ;;; paths))) ;;; ;; else do a general-run-call ;;; (general-run-call ;;; "-test-files" ;;; "Get paths to test" ;;; (lambda (target runname keys keyvals) ;;; (let* ((db #f) ;;; ;; DO NOT run remote ;;; (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) ;;; (for-each (lambda (path) ;;; (print path)) ;;; paths)))))) ;;; ;;; ;;====================================================================== ;;; ;; Archive tests ;;; ;;====================================================================== ;;; ;; Archive tests matching target, runname, and testpatt ;;; (if (equal? (args:get-arg "-archive") "replicate-db") ;;; (begin ;;; ;; check if source ;;; ;; check if megatest.db exist ;;; (launch:setup) ;;; (if (not (args:get-arg "-source")) ;;; (begin ;;; (debug:print-info 1 *default-log-port* "Missing required argument -source <archive path>") ;;; (exit 1))) ;;; (if (common:file-exists? (conc *toppath* "/megatest.db")) ;;; (begin ;;; (debug:print-info 1 *default-log-port* "File " (conc *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db") ;;; (exit 1))) ;;; (if (and (common:get-db-tmp-area) (> (length (directory (common:get-db-tmp-area) #f)) 0)) ;;; (begin ;;; (debug:print-info 1 *default-log-port* (common:get-db-tmp-area) " not empty. Please remove it before trying to replicate db") ;;; (exit 1))) ;;; ;; check if timestamp ;;; (let* ((source (args:get-arg "-source")) ;;; (src (if (not (equal? (substring source 0 1) "/")) ;;; (conc (current-directory) "/" source) ;;; source)) ;;; (ts (if (args:get-arg "-time-stamp") (args:get-arg "-time-stamp") "latest"))) ;;; (if (common:directory-exists? src) ;;; (begin ;;; (archive:restore-db src ts) ;;; (set! *didsomething* #t)) ;;; (begin ;;; (debug:print-error 1 *default-log-port* "Path " source " not found") ;;; (exit 1)))))) ;;; ;; else do a general-run-call ;;; (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicate-db"))) ;;; (begin ;;; ;; for the archive get we need to preserve the starting dir as part of the target path ;;; (if (and (args:get-arg "-dest") ;;; (not (equal? (substring (args:get-arg "-dest") 0 1) "/"))) ;;; (let ((newpath (conc (current-directory) "/" (args:get-arg "-dest")))) ;;; (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath) ;;; (hash-table-set! args:arg-hash "-dest" newpath))) ;;; (general-run-call ;;; "-archive" ;;; "Archive" ;;; (lambda (target runname keys keyvals) ;;; (operate-on 'archive target-in: target runname-in: runname ))))) ;;; ;;; ;;====================================================================== ;;; ;; Extract a spreadsheet from the runs database ;;; ;;====================================================================== ;;; ;;; (if (args:get-arg "-extract-ods") ;;; (general-run-call ;;; "-extract-ods" ;;; "Make ods spreadsheet" ;;; (lambda (target runname keys keyvals) ;;; (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) ;;; (outputfile (args:get-arg "-extract-ods")) ;;; (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname"))) ;;; (pathmod (args:get-arg "-pathmod"))) ;;; ;; (keyvalalist (keys->alist keys "%"))) ;;; (debug:print 2 *default-log-port* "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) ;;; (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod) ;;; (db:close-all dbstruct) ;;; (set! *didsomething* #t))))) ;;; ;;; ;;====================================================================== ;;; ;; execute the test ;;; ;; - gets called on remote host ;;; ;; - receives info from the -execute param ;;; ;; - passes info to steps via MT_CMDINFO env var (future is to use a dot file) ;;; ;; - gathers host info and ;;; ;;====================================================================== ;;; ;;; (if (args:get-arg "-execute") ;;; (begin ;;; (launch:execute (args:get-arg "-execute")) ;;; (set! *didsomething* #t))) ;;; ;;; ;;====================================================================== ;;; ;; recover from a test where the managing mtest was killed but the underlying ;;; ;; process might still be salvageable ;;; ;;====================================================================== ;;; ;;; (if (args:get-arg "-recover-test") ;;; (let* ((params (string-split (args:get-arg "-recover-test") ","))) ;;; (if (> (length params) 1) ;; run-id and test-id ;;; (let ((run-id (string->number (car params))) ;;; (test-id (string->number (cadr params)))) ;;; (if (and run-id test-id) ;;; (begin ;;; (launch:recover-test run-id test-id) ;;; (set! *didsomething* #t)) ;;; (begin ;;; (debug:print-error 0 *default-log-port* "bad run-id or test-id, must be integers") ;;; (exit 1))))))) ;;; ;;; ;;====================================================================== ;;; ;; Test commands (i.e. for use inside tests) ;;; ;;====================================================================== ;;; ;;; (define (megatest:step step state status logfile msg) ;;; (if (not (getenv "MT_CMDINFO")) ;;; (begin ;;; (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") ;;; (exit 5)) ;;; (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) ;;; (transport (assoc/default 'transport cmdinfo)) ;;; (testpath (assoc/default 'testpath cmdinfo)) ;;; (test-name (assoc/default 'test-name cmdinfo)) ;;; (runscript (assoc/default 'runscript cmdinfo)) ;;; (db-host (assoc/default 'db-host cmdinfo)) ;;; (run-id (assoc/default 'run-id cmdinfo)) ;;; (test-id (assoc/default 'test-id cmdinfo)) ;;; (itemdat (assoc/default 'itemdat cmdinfo)) ;;; (work-area (assoc/default 'work-area cmdinfo)) ;;; (db #f)) ;;; (change-directory testpath) ;;; (if (not (launch:setup)) ;;; (begin ;;; (debug:print 0 *default-log-port* "Failed to setup, exiting") ;;; (exit 1))) ;;; (if (and state status) ;;; (let ((comment (launch:load-logpro-dat run-id test-id step))) ;;; ;; (rmt:test-set-log! run-id test-id (conc stepname ".html")))) ;;; (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile)) ;;; (begin ;;; (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step") ;;; (exit 6)))))) ;;; ;;; (define (main) ;;; (if (args:get-arg "-step") ;;; (begin ;;; (thread-sleep! 1.5) ;;; (megatest:step ;;; (args:get-arg "-step") ;;; (or (args:get-arg "-state")(args:get-arg ":state")) ;;; (or (args:get-arg "-status")(args:get-arg ":status")) ;;; (args:get-arg "-setlog") ;;; (args:get-arg "-m")) ;;; ;; (if db (sqlite3:finalize! db)) ;;; (set! *didsomething* #t) ;;; (thread-sleep! 1.5))) ;;; ;;; (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status ;;; ;; (not (args:get-arg "-step"))) ;; -setlog may have been processed already in the "-step" previous ;;; ;; NEW POLICY - -setlog sets test overall log on every call. ;;; (args:get-arg "-set-toplog") ;;; (args:get-arg "-test-status") ;;; (args:get-arg "-set-values") ;;; (args:get-arg "-load-test-data") ;;; (args:get-arg "-runstep") ;;; (args:get-arg "-summarize-items")) ;;; (if (not (getenv "MT_CMDINFO")) ;;; (begin ;;; (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") ;;; (exit 5)) ;;; (let* ((startingdir (current-directory)) ;;; (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) ;;; (transport (assoc/default 'transport cmdinfo)) ;;; (testpath (assoc/default 'testpath cmdinfo)) ;;; (test-name (assoc/default 'test-name cmdinfo)) ;;; (runscript (assoc/default 'runscript cmdinfo)) ;;; (db-host (assoc/default 'db-host cmdinfo)) ;;; (run-id (assoc/default 'run-id cmdinfo)) ;;; (test-id (assoc/default 'test-id cmdinfo)) ;;; (itemdat (assoc/default 'itemdat cmdinfo)) ;;; (work-area (assoc/default 'work-area cmdinfo)) ;;; (db #f) ;; (open-db)) ;;; (state (args:get-arg ":state")) ;;; (status (args:get-arg ":status")) ;;; (stepname (args:get-arg "-step"))) ;;; (if (not (launch:setup)) ;;; (begin ;;; (debug:print 0 *default-log-port* "Failed to setup, exiting") ;;; (exit 1))) ;;; ;;; (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area)) ;;; (change-directory work-area) ;;; ;; can setup as client for server mode now ;;; ;; (client:setup) ;;; ;;; (if (args:get-arg "-load-test-data") ;;; ;; has sub commands that are rdb: ;;; ;; DO NOT put this one into either rmt: or open-run-close ;;; (tdb:load-test-data run-id test-id)) ;;; (if (args:get-arg "-setlog") ;;; (let ((logfname (args:get-arg "-setlog"))) ;;; (rmt:test-set-log! run-id test-id logfname))) ;;; (if (args:get-arg "-set-toplog") ;;; ;; DO NOT run remote ;;; (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog"))) ;;; (if (args:get-arg "-summarize-items") ;;; ;; DO NOT run remote ;;; (tests:summarize-items run-id test-id test-name #t)) ;; do force here ;;; (if (args:get-arg "-runstep") ;;; (if (null? remargs) ;;; (begin ;;; (debug:print-error 0 *default-log-port* "nothing specified to run!") ;;; (if db (sqlite3:finalize! db)) ;;; (exit 6)) ;;; (let* ((stepname (args:get-arg "-runstep")) ;;; (logprofile (args:get-arg "-logpro")) ;;; (logfile (conc stepname ".log")) ;;; (cmd (if (null? remargs) #f (car remargs))) ;;; (params (if cmd (cdr remargs) '())) ;;; (exitstat #f) ;;; (shell (let ((sh (get-environment-variable "SHELL") )) ;;; (if sh ;;; (last (string-split sh "/")) ;;; "bash"))) ;;; (redir (case (string->symbol shell) ;;; ((tcsh csh ksh) ">&") ;;; ((zsh bash sh ash) "2>&1 >") ;;; (else ">&"))) ;;; (fullcmd (conc "(" (string-intersperse ;;; (cons cmd params) " ") ;;; ") " redir " " logfile))) ;;; ;; mark the start of the test ;;; (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile) ;;; ;; run the test step ;;; (debug:print-info 2 *default-log-port* "Running \"" fullcmd "\" in directory \"" startingdir) ;;; (change-directory startingdir) ;;; (set! exitstat (system fullcmd)) ;;; (set! *globalexitstatus* exitstat) ;;; ;; (change-directory testpath) ;;; ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) ;;; (if logprofile ;;; (let* ((htmllogfile (conc stepname ".html")) ;;; (oldexitstat exitstat) ;;; (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) ;;; (debug:print-info 2 *default-log-port* "running \"" cmd "\"") ;;; (change-directory startingdir) ;;; (set! exitstat (system cmd)) ;;; (set! *globalexitstatus* exitstat) ;; no necessary ;;; (change-directory testpath) ;;; (rmt:test-set-log! run-id test-id htmllogfile))) ;;; (let ((msg (args:get-arg "-m"))) ;;; (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile)) ;;; ))) ;;; (if (or (args:get-arg "-test-status") ;;; (args:get-arg "-set-values")) ;;; (let ((newstatus (cond ;;; ((number? status) (if (equal? status 0) "PASS" "FAIL")) ;;; ((and (string? status) ;;; (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL")) ;;; (else status))) ;;; ;; transfer relevant keys into a hash to be passed to test-set-status! ;;; ;; could use an assoc list I guess. ;;; (otherdata (let ((res (make-hash-table))) ;;; (for-each (lambda (key) ;;; (if (args:get-arg key) ;;; (hash-table-set! res key (args:get-arg key)))) ;;; (list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable")) ;;; res))) ;;; (if (and (args:get-arg "-test-status") ;;; (or (not state) ;;; (not status))) ;;; (begin ;;; (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -test-status\n" help) ;;; (if (sqlite3:database? db)(sqlite3:finalize! db)) ;;; (exit 6))) ;;; (let* ((msg (args:get-arg "-m")) ;;; (numoth (length (hash-table-keys otherdata)))) ;;; ;; Convert to rpc inside the tests:test-set-status! call, not here ;;; (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area)))) ;;; (if (sqlite3:database? db)(sqlite3:finalize! db)) ;;; (set! *didsomething* #t)))) ;;; ;;; ;;====================================================================== ;;; ;; Various helper commands can go below here ;;; ;;====================================================================== ;;; ;;; (if (or (args:get-arg "-showkeys") ;;; (args:get-arg "-show-keys")) ;;; (let ((db #f) ;;; (keys #f)) ;;; (if (not (launch:setup)) ;;; (begin ;;; (debug:print 0 *default-log-port* "Failed to setup, exiting") ;;; (exit 1))) ;;; (set! keys (rmt:get-keys)) ;; db)) ;;; (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", ")) ;;; (if (sqlite3:database? db)(sqlite3:finalize! db)) ;;; (set! *didsomething* #t))) ;;; ;;; (if (args:get-arg "-gui") ;;; (begin ;;; (debug:print 0 *default-log-port* "Look at the dashboard for now") ;;; ;; (megatest-gui) ;;; (set! *didsomething* #t))) ;;; ;;; (if (args:get-arg "-create-megatest-area") ;;; (begin ;;; (genexample:mk-megatest.config) ;;; (set! *didsomething* #t))) ;;; ;;; (if (args:get-arg "-create-test") ;;; (let ((testname (args:get-arg "-create-test"))) ;;; (genexample:mk-megatest-test testname) ;;; (set! *didsomething* #t))) ;;; ;;; ;;====================================================================== ;;; ;; Update the database schema, clean up the db ;;; ;;====================================================================== ;;; ;;; (if (args:get-arg "-rebuild-db") ;;; (begin ;;; (if (not (launch:setup)) ;;; (begin ;;; (debug:print 0 *default-log-port* "Failed to setup, exiting") ;;; (exit 1))) ;;; ;; keep this one local ;;; ;; (open-run-close patch-db #f) ;;; (let ((dbstruct (db:setup #f areapath: *toppath*))) ;;; (common:cleanup-db dbstruct full: #t)) ;;; (set! *didsomething* #t))) ;;; ;;; (if (args:get-arg "-cleanup-db") ;;; (begin ;;; (if (not (launch:setup)) ;;; (begin ;;; (debug:print 0 *default-log-port* "Failed to setup, exiting") ;;; (exit 1))) ;;; (let ((dbstruct (db:setup #f areapath: *toppath*))) ;;; (common:cleanup-db dbstruct)) ;;; (set! *didsomething* #t))) ;;; ;;; (if (args:get-arg "-mark-incompletes") ;;; (begin ;;; (if (not (launch:setup)) ;;; (begin ;;; (debug:print 0 *default-log-port* "Failed to setup, exiting") ;;; (exit 1))) ;;; (rmt:find-and-mark-incomplete #f) ;;; (set! *didsomething* #t))) ;;; ;;; ;;====================================================================== ;;; ;; Update the tests meta data from the testconfig files ;;; ;;====================================================================== ;;; ;;; (if (args:get-arg "-update-meta") ;;; (begin ;;; (if (not (launch:setup)) ;;; (begin ;;; (debug:print 0 *default-log-port* "Failed to setup, exiting") ;;; (exit 1))) ;;; (runs:update-all-test_meta #f) ;;; (set! *didsomething* #t))) ;;; ;;; ;;====================================================================== ;;; ;; Start a repl ;;; ;;====================================================================== ;;; ;;; ;; fakeout readline ;;; ;; (include "readline-fix.scm") ;;; ;;; ;;; (when (args:get-arg "-diff-rep") ;;; (when (and ;;; (not (args:get-arg "-diff-html")) ;;; (not (args:get-arg "-diff-email"))) ;;; (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep") ;;; (set! *didsomething* 1) ;;; (exit 1)) ;;; ;;; (let* ((toppath (launch:setup))) ;;; (do-diff-report ;;; (args:get-arg "-src-target") ;;; (args:get-arg "-src-runname") ;;; (args:get-arg "-target") ;;; (args:get-arg "-runname") ;;; (args:get-arg "-diff-html") ;;; (args:get-arg "-diff-email")) ;;; (set! *didsomething* #t) ;;; (exit 0))) ;;; ;;; (if (or (getenv "MT_RUNSCRIPT") ;;; (args:get-arg "-repl") ;;; (args:get-arg "-load")) ;;; (let* ((toppath (launch:setup)) ;;; (dbstruct (if (and toppath ;;; (common:on-homehost?)) ;;; (db:setup #t) ;;; #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f))) ;;; (if *toppath* ;;; (cond ;;; ((getenv "MT_RUNSCRIPT") ;;; ;; How to run megatest scripts ;;; ;; ;;; ;; #!/bin/bash ;;; ;; ;;; ;; export MT_RUNSCRIPT=yes ;;; ;; megatest << EOF ;;; ;; (print "Hello world") ;;; ;; (exit) ;;; ;; EOF ;;; ;;; (repl)) ;;; (else ;;; (begin ;;; (set! *db* dbstruct) ;;; ;; (import extras) ;; might not be needed ;;; ;; (import csi) ;;; ;; (import readline) ;;; (import apropos) ;;; ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... ;;; ;;; ;; (if *use-new-readline* ;;; ;; (begin ;;; ;; (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) ;;; ;; (current-input-port (make-readline-port "megatest> "))) ;;; ;; (begin ;;; ;; (gnu-history-install-file-manager ;;; ;; (string-append ;;; ;; (or (get-environment-variable "HOME") ".") "/.megatest_history")) ;;; ;; (current-input-port (make-gnu-readline-port "megatest> ")))) ;;; (if (args:get-arg "-repl") ;;; (repl) ;;; (load (args:get-arg "-load"))) ;;; ;; (db:close-all dbstruct) <= taken care of by on-exit call ;;; ) ;;; (exit))) ;;; (set! *didsomething* #t)))) ;;; ;;; ;;====================================================================== ;;; ;; Wait on a run to complete ;;; ;;====================================================================== ;;; ;;; (if (and (args:get-arg "-run-wait") ;;; (not (or (args:get-arg "-run") ;;; (args:get-arg "-runtests")))) ;; run-wait is built into runtests now ;;; (begin ;;; (if (not (launch:setup)) ;;; (begin ;;; (debug:print 0 *default-log-port* "Failed to setup, exiting") ;;; (exit 1))) ;;; (operate-on 'run-wait) ;;; (set! *didsomething* #t))) ;;; ;;; ;; ;; ;; redo me ;; Not converted to use dbstruct yet ;;; ;; ;; ;; redo me ;; ;;; ;; ;; ;; redo me (if (args:get-arg "-convert-to-norm") ;;; ;; ;; ;; redo me (let* ((toppath (setup-for-run)) ;;; ;; ;; ;; redo me (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t)))) ;;; ;; ;; ;; redo me (for-each ;;; ;; ;; ;; redo me (lambda (field) ;;; ;; ;; ;; redo me (let ((dat '())) ;;; ;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Getting data for field " field) ;;; ;; ;; ;; redo me (sqlite3:for-each-row ;;; ;; ;; ;; redo me (lambda (id val) ;;; ;; ;; ;; redo me (set! dat (cons (list id val) dat))) ;;; ;; ;; ;; redo me (db:get-db db run-id) ;;; ;; ;; ;; redo me (conc "SELECT id," field " FROM tests;")) ;;; ;; ;; ;; redo me (debug:print-info 0 *default-log-port* "found " (length dat) " items for field " field) ;;; ;; ;; ;; redo me (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;")))) ;;; ;; ;; ;; redo me (for-each ;;; ;; ;; ;; redo me (lambda (item) ;;; ;; ;; ;; redo me (let ((newval ;; (sdb:qry 'getid ;;; ;; ;; ;; redo me (cadr item))) ;; ) ;;; ;; ;; ;; redo me (if (not (equal? newval (cadr item))) ;;; ;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item))) ;;; ;; ;; ;; redo me (sqlite3:execute qry newval (car item)))) ;;; ;; ;; ;; redo me dat) ;;; ;; ;; ;; redo me (sqlite3:finalize! qry)))) ;;; ;; ;; ;; redo me (db:close-all dbstruct) ;;; ;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment")) ;;; ;; ;; ;; redo me (set! *didsomething* #t))) ;;; ;;; (if (args:get-arg "-import-megatest.db") ;;; (begin ;;; (db:multi-db-sync ;;; (db:setup #f) ;;; 'killservers ;;; 'dejunk ;;; 'adj-testids ;;; 'old2new ;;; ;; 'new2old ;;; ) ;;; (set! *didsomething* #t))) ;;; ;;; (when (args:get-arg "-sync-brute-force") ;;; ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t)) ;;; (set! *didsomething* #t)) ;;; ;;; (if (args:get-arg "-sync-to-megatest.db") ;;; (let* ((dbstruct (db:setup #f)) ;;; (tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct))) ;;; (lockfile (conc tmpdbpth ".lock")) ;;; (locked (common:simple-file-lock lockfile)) ;;; (res (if locked ;;; (db:multi-db-sync ;;; dbstruct ;;; 'new2old) ;;; #f))) ;;; (if res ;;; (begin ;;; (common:simple-file-release-lock lockfile) ;;; (print "Synced " res " records to megatest.db")) ;;; (print "Skipping sync, there is a sync in progress.")) ;;; (set! *didsomething* #t))) ;;; ;;; (if (args:get-arg "-sync-to") ;;; (let ((toppath (launch:setup))) ;;; (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to")) ;;; (set! *didsomething* #t))) ;;; ;;; (if (args:get-arg "-list-test-time") ;;; (let* ((toppath (launch:setup))) ;;; (task:get-test-times) ;;; (set! *didsomething* #t))) ;;; ;;; (if (args:get-arg "-list-run-time") ;;; (let* ((toppath (launch:setup))) ;;; (task:get-run-times) ;;; (set! *didsomething* #t))) ;;; ;;; (if (args:get-arg "-generate-html") ;;; (let* ((toppath (launch:setup))) ;;; (if (tests:create-html-tree #f) ;;; (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page0.html") ;;; (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) ;;; (set! *didsomething* #t))) ;;; ;;; (if (args:get-arg "-generate-html-structure") ;;; (let* ((toppath (launch:setup))) ;;; ;(if (tests:create-html-tree #f) ;;; (if (tests:create-html-summary #f) ;;; (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html") ;;; (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) ;;; (set! *didsomething* #t))) ;;; ;;; (if (args:get-arg "-syscheck") ;;; (begin ;;; (mutils:syscheck common:raw-get-remote-host-load ;;; server:get-best-guess-address ;;; read-config) ;;; (set! *didsomething* #t))) ;;; ;;; (if (args:get-arg "-extract-skeleton") ;;; (let* ((toppath (launch:setup))) ;;; (genexample:extract-skeleton-area (args:get-arg "-extract-skeleton")) ;;; (set! *didsomething* #t))) ;;; ;;; ;;====================================================================== ;;; ;; Exit and clean up ;;; ;;====================================================================== ;;; ;;; (if (not *didsomething*) ;;; (debug:print 0 *default-log-port* help) ;;; (set! *time-to-exit* #t) ;;; ) ;;; ;;(debug:print-info 13 *default-log-port* "thread-join! watchdog") ;;; ;;; ;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state) ;;; ;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead) ;;; ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage ;;; (if (thread? *watchdog*) ;;; (case (thread-state *watchdog*) ;;; ((ready running blocked sleeping terminated dead) ;;; (thread-join! *watchdog*)))) ;;; ;;; (set! *time-to-exit* #t) ;;; ;;; (if (not (eq? *globalexitstatus* 0)) ;;; (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall")) ;;; (begin ;;; (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) ;;; (exit 0)) ;;; (case *globalexitstatus* ;;; ((0)(exit 0)) ;;; ((1)(exit 1)) ;;; ((2)(exit 2)) ;;; (else (exit 3))))) ;;; ) ) ;; (main) (print "Got here") |
Modified mt.scm from [e9055c2687] to [872eb49e64].
︙ | ︙ | |||
13 14 15 16 17 18 19 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; | | | | | | | | | | | | | | | | | | | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; (use 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. ;;====================================================================== ;; R U N S ;;====================================================================== |
︙ | ︙ | |||
153 154 155 156 157 158 159 | actual-state " " actual-status " " event-time )) (prev-nbfake-log (get-environment-variable "NBFAKE_LOG"))) (setenv "NBFAKE_LOG" (conc (cond ((and (directory-exists? test-rundir) | | | | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 | actual-state " " actual-status " " event-time )) (prev-nbfake-log (get-environment-variable "NBFAKE_LOG"))) (setenv "NBFAKE_LOG" (conc (cond ((and (directory-exists? test-rundir) (file-writable? test-rundir)) test-rundir) ((and (directory-exists? *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 ;; `(("NBFAKE_LOG" . ,(conc test-rundir "/" logname))) ;; (lambda () |
︙ | ︙ | |||
283 284 285 286 287 288 289 | tconf (let ((test-dirs (tests:get-tests-search-path *configdat*))) (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) | | | 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 | tconf (let ((test-dirs (tests:get-tests-search-path *configdat*))) (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-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) (if old-link-tree (setenv "MT_LINKTREE" old-link-tree) |
︙ | ︙ |
Modified mtargs/mtargs.scm from [e2f1c247b7] to [40b7a0d6eb].
︙ | ︙ | |||
24 25 26 27 28 29 30 | usage get-args print-args any-defined? help ) | | < | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | usage get-args print-args any-defined? help ) (import scheme chicken.base chicken.process-context srfi-69 srfi-1) (define arg-hash (make-hash-table)) (define help "") (define (get-arg arg . default) (if (null? default) (hash-table-ref/default arg-hash arg #f) |
︙ | ︙ |
Added mtver.scm version [88befd643e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | ;; Copyright 2006-2017, Matthew Welland. ;; ;; This file is part of Megatest. ;; ;; Megatest is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; Megatest is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit mtver)) (module mtver * (import scheme chicken.module) (define megatest-version 1.6584) ) |
Modified mutils/mutils.scm from [9fa9e34972] to [b79d63c449].
︙ | ︙ | |||
10 11 12 13 14 15 16 | ;; This is from the perl world, a hash of hashes is a super easy way to keep a handle on ;; lots of disparate data ;; (module mutils * | | > > > > > > > > > > > > > | | < < > > | > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | ;; This is from the perl world, a hash of hashes is a super easy way to keep a handle on ;; lots of disparate data ;; (module mutils * (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 srfi-98 regex matchable sparse-vectors system-information ) (define (mutils:hierhash-ref hh . keys) (if (null? keys) #f (let loop ((ht hh) (key (car keys)) (tail (cdr keys))) |
︙ | ︙ | |||
88 89 90 91 92 93 94 | (if (eof-object? l) (reverse res) (if (or (string-match comment l) (string-match blank l)) (loop (read-line fh) res) (loop (read-line fh) (cons l res))))))) | < < | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | (if (eof-object? l) (reverse res) (if (or (string-match comment l) (string-match blank l)) (loop (read-line fh) res) (loop (read-line fh) (cons l res))))))) ;; this is a simple two dimensional sparse array ;; ONLY TWO DIMENSIONS!!! SEE ARRAY-LIB IF YOUR NEEDS ARE GREATER!! ;; (define (mutils:make-sparse-array) (let ((a (make-sparse-vector))) (sparse-vector-set! a 0 (make-sparse-vector)) |
︙ | ︙ | |||
187 188 189 190 191 192 193 | (apply mutils:hier-list-get @hierlist @path)))) ;;====================================================================== ;; Other utils ;;====================================================================== (define (check-write-create fpath) | | | > | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 | (apply mutils:hier-list-get @hierlist @path)))) ;;====================================================================== ;; Other utils ;;====================================================================== (define (check-write-create fpath) (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 (with-output-to-file fname (lambda () |
︙ | ︙ |
Modified ods.scm from [42e94b826f] to [58135ee6ad].
︙ | ︙ | |||
12 13 14 15 16 17 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; | | | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; (use csv-xml regex) ;; (declare (unit ods)) ;; (declare (uses common)) (define ods:dirs '("Configurations2" "Configurations2/toolpanel" "Configurations2/menubar" "Configurations2/toolbar" "Configurations2/progressbar" |
︙ | ︙ |
Modified pkts/pkts.scm from [90f8c93eeb] to [c88a79173d].
︙ | ︙ | |||
160 161 162 163 164 165 166 | pktdb-pktspec ;; utility procs increment-string ;; used to get indexes for strings in ref pkts make-report ;; make a .dot file ) | > | | | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 | pktdb-pktspec ;; utility procs increment-string ;; used to get indexes for strings in ref pkts make-report ;; make a .dot file ) (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 ;;====================================================================== (define-inline (unescape-data data) (string-translate* data '(("\\n" . "\n") ("\\\\" . "\\")))) |
︙ | ︙ | |||
693 694 695 696 697 698 699 | (for-each (lambda (pktsdir) ;; look at all (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.")) | | | 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 | (for-each (lambda (pktsdir) ;; look at all (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-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 (lambda (pkt) (let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt))) |
︙ | ︙ |
Added pktsmod.scm version [4f496b5684].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 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 <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit pkts)) (include "pkts/pkts.scm") |
Modified portlogger.scm from [36a4964f50] to [e7dc27d254].
︙ | ︙ | |||
13 14 15 16 17 18 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; | | | | | | | | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; (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 (exists (common:file-exists? fname)) (db (if avail (sqlite3:open-database fname) (begin (system (conc "rm -f " fname)) (sqlite3:open-database fname)))) (handler (sqlite3:make-busy-timeout 136000)) (canwrite (file-writable? fname))) ;; (db-init (lambda () ;; (sqlite3:execute ;; db ;; "CREATE TABLE IF NOT EXISTS ports ( ;; port INTEGER PRIMARY KEY, ;; state TEXT DEFAULT 'not-used', ;; fail_count INTEGER DEFAULT 0, |
︙ | ︙ | |||
128 129 130 131 132 133 134 | (let* ((lowport (let ((val (configf:lookup *configdat* "server" "lowport"))) (if (and val (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 | | | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | (let* ((lowport (let ((val (configf:lookup *configdat* "server" "lowport"))) (if (and val (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 (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)) (debug:print 5 *default-log-port* "exn=" (condition->list exn)) (print-call-chain (current-error-port)) |
︙ | ︙ |
Modified process.scm from [f9dfbe5500] to [df1baf0131].
︙ | ︙ | |||
18 19 20 21 22 23 24 | ;;====================================================================== ;;====================================================================== ;; Process convience utils ;;====================================================================== | | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | ;;====================================================================== ;;====================================================================== ;; Process convience utils ;;====================================================================== ;; (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))) res))) |
︙ | ︙ |
Modified rmt.scm from [ed2cbd88f2] to [9c5b8773ea].
︙ | ︙ | |||
14 15 16 17 18 19 20 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;;====================================================================== | | | | | | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;;====================================================================== ;; (use format 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) ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; |
︙ | ︙ | |||
66 67 68 69 70 71 72 | payload: `((rid . ,rid) (params . ,params))) (if (> attemptnum 2) (debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum)) (cond | | | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 | payload: `((rid . ,rid) (params . ,params))) (if (> attemptnum 2) (debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum)) (cond ((> attemptnum 2) (thread-sleep! 0.053)) ((> attemptnum 10) (thread-sleep! 0.5)) ((> attemptnum 20) (thread-sleep! 1))) (if (and (> attemptnum 5) (= 0 (modulo attemptnum 15))) (begin (server:run *toppath*) (thread-sleep! 3))) ;;DOT digraph megatest_state_status { |
︙ | ︙ | |||
369 370 371 372 373 374 375 | (mutex-unlock! *db-stats-mutex*) res)) (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))) | | | 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 | (mutex-unlock! *db-stats-mutex*) res)) (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-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 (begin (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) |
︙ | ︙ | |||
393 394 395 396 397 398 399 | (duration (- (current-milliseconds) start))) (if (and read-only qry-is-write) (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.") | | | 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 | (duration (- (current-milliseconds) start))) (if (and read-only qry-is-write) (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! (/ (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 ;; (rmt:update-db-stats run-id cmd params duration) ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it |
︙ | ︙ | |||
612 613 614 615 616 617 618 | (mutex-lock! multi-run-mutex) (set! result (append result res)) (mutex-unlock! multi-run-mutex)) (debug:print-error 0 *default-log-port* "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) (conc "multi-run-thread for run-id " hed))) (newthreads (cons newthread threads))) (thread-start! newthread) | | | 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 | (mutex-lock! multi-run-mutex) (set! result (append result res)) (mutex-unlock! multi-run-mutex)) (debug:print-error 0 *default-log-port* "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) (conc "multi-run-thread for run-id " hed))) (newthreads (cons newthread threads))) (thread-start! newthread) (thread-sleep! 0.054) ;; give that thread some time to start (if (null? tal) newthreads (loop (car tal)(cdr tal) newthreads)))))) result)) ;; ;; IDEA: Threadify these - they spend a lot of time waiting ... ;; ;; |
︙ | ︙ | |||
972 973 974 975 976 977 978 | (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")) | | | 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 | (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-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) ro-mode)))) |
︙ | ︙ |
Modified rmtmod.scm from [4f89f84546] to [cb38f42270].
︙ | ︙ | |||
17 18 19 20 21 22 23 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit rmtmod)) (declare (uses commonmod)) (declare (uses apimod)) | < < < < | | > > > | | | > | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit rmtmod)) (declare (uses commonmod)) (declare (uses apimod)) (module rmtmod * (import scheme (prefix sqlite3 sqlite3:) typed-records srfi-18 commonmod apimod ) (defstruct alldat (areapath #f) (ulexdat #f) ) ;;====================================================================== |
︙ | ︙ |
Modified runconfig.scm from [66b9c38588] to [f03a86116d].
︙ | ︙ | |||
16 17 18 19 20 21 22 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== ;; read a config file, loading only the section pertinent ;; to this run field1val/field2val/field3val ... ;;====================================================================== | | | | | | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== ;; read a config file, loading only the section pertinent ;; to this run field1val/field2val/field3val ... ;;====================================================================== ;; (use format directory-utils) ;; ;; (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)))) ;; NB// to process a runconfig ensure to use environ-patt with target! |
︙ | ︙ |
Modified runs.scm from [2583922f1c] to [ec21108c67].
︙ | ︙ | |||
13 14 15 16 17 18 19 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') | | | | | | | | | | | | | | | | | | | | | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') ;; (use (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 ;; (defstruct runs:dat reglen regfull |
︙ | ︙ | |||
126 127 128 129 130 131 132 | (rtime 0) (startt (current-seconds)) (endt (+ startt duration))) ((or proc runs:parallel-runners-mgmt) rdat) (let loop () (let* ((wstart (current-seconds))) (if (< wstart endt) | | | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 | (rtime 0) (startt (current-seconds)) (endt (+ startt duration))) ((or proc runs:parallel-runners-mgmt) rdat) (let loop () (let* ((wstart (current-seconds))) (if (< wstart endt) (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) (loop))))) (let* ((done-time (current-seconds))) |
︙ | ︙ | |||
506 507 508 509 510 511 512 | (define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names (let* ((keys (keys:config-get-fields *configdat*)) (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")) | | | 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 | (define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names (let* ((keys (keys:config-get-fields *configdat*)) (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-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)) (required-tests #f) ;; Put fully qualified test/testpath names in this list to be done (waitors-upon (make-hash-table)) ;; given a test, return list of tests waiting upon this test. |
︙ | ︙ | |||
1266 1267 1268 1269 1270 1271 1272 | ;; If no resources are available just kill time and loop again ;; ((not have-resources) ;; simply try again after waiting a second (if (runs:lownoise "no resources" 60) (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ...")) ;; Have gone back and forth on this but db starvation is an issue. ;; wait one second before looking again to run jobs. | | | 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 | ;; If no resources are available just kill time and loop again ;; ((not have-resources) ;; simply try again after waiting a second (if (runs:lownoise "no resources" 60) (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ...")) ;; Have gone back and forth on this but db starvation is an issue. ;; wait one second before looking again to run jobs. (thread-sleep! 0.253) ;; could have done hed tal here but doing car/cdr of newtal to rotate tests (list (car newtal)(cdr newtal) reg reruns)) ;; This is the final stage, everything is in place so launch the test ;; ((and have-resources (or (null? prereqs-not-met) |
︙ | ︙ | |||
2340 2341 2342 2343 2344 2345 2346 | (rp-mutex (make-mutex)) (bup-mutex (make-mutex)) (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")) | | | 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 | (rp-mutex (make-mutex)) (bup-mutex (make-mutex)) (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-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))) (debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status) (if (> 2 (length state-status)) |
︙ | ︙ | |||
2563 2564 2565 2566 2567 2568 2569 | (if (and (not (string= rundir "/tmp/badname")) (file-exists? rundir) (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 | | | 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 | (if (and (not (string= rundir "/tmp/badname")) (file-exists? rundir) (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 (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") (debug:print 2 *default-log-port* "Is /tmp/badname: " (string= rundir "/tmp/badname")) (debug:print 2 *default-log-port* "Exists: " (file-exists? rundir)) |
︙ | ︙ | |||
2731 2732 2733 2734 2735 2736 2737 | ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f)) ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) ((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. | | | 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 | ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f)) ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) ((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 (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 (debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist") (debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done"))) |
︙ | ︙ | |||
2957 2958 2959 2960 2961 2962 2963 | (define doc-template '(*TOP* (*PI* xml "version='1.0'") (testsuite))) (define (runs:update-junit-test-reporter-xml run-id) | < | | 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 | (define doc-template '(*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")) (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"))) #f)) (xml-ts-name (if xml-dir |
︙ | ︙ | |||
3001 3002 3003 3004 3005 3006 3007 | (test-itempath (vector-ref test 11)) (tc-name (conc test-name (if (and test-itempath (not (equal? test-itempath ""))) (conc "." (string-translate test-itempath "/" "." )) ""))) (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 | | | | | | | | | | | | | | | | | | | | | | | 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 | (test-itempath (vector-ref test 11)) (tc-name (conc test-name (if (and test-itempath (not (equal? test-itempath ""))) (conc "." (string-translate test-itempath "/" "." )) ""))) (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))) (if (null? tail) (let* ((final-doc ((sxml-modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc))) (debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt) (handle-exceptions exn (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))) |
︙ | ︙ |
Modified server.scm from [5b645d5dff] to [ec8310146f].
︙ | ︙ | |||
12 13 14 15 16 17 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; | | | | | | | | | | | | | | | | | | | | | < < < < < < < | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; (require-extension (srfi 18) extras tcp s11n) ;; ;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest ;; directory-utils posix-extras matchable) ;; ;; (use spiffy uri-common intarweb http-client spiffy-request-vars) ;; ;; (declare (unit server)) ;; ;; (declare (uses common)) ;; (declare (uses db)) ;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. ;; ;; (declare (uses synchash)) ;; (declare (uses http-transport)) ;; ;;(declare (uses rpc-transport)) ;; (declare (uses launch)) ;; ;; (declare (uses daemon)) ;; ;; (include "common_records.scm") ;; (include "db_records.scm") ;;====================================================================== ;; P K T S S T U F F ;;====================================================================== ;; ??? |
︙ | ︙ | |||
152 153 154 155 156 157 158 | (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) (not (equal? curr-ip target-host))) (begin (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile) (setenv "TARGETHOST" target-host))) (setenv "TARGETHOST_LOGF" logfile) | | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 | (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) (not (equal? curr-ip target-host))) (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! (/ (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")) (thread-join! log-rotate) (pop-directory))) |
︙ | ︙ | |||
204 205 206 207 208 209 210 | (if dbprep-found (begin (debug:print-info 0 *default-log-port* "Server is in dbprep at " (current-seconds)) (thread-sleep! 25) ) (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (current-seconds)) ) | | | | < | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 | (if dbprep-found (begin (debug:print-info 0 *default-log-port* "Server is in dbprep at " (current-seconds)) (thread-sleep! 25) ) (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (current-seconds)) ) (list #f #f #f #f))))))))) ;; get a list of servers with all relevant data ;; ( mod-time host port start-time pid ) ;; (define (server:get-list areapath #!key (limit #f)) (let ((fname-rx (regexp "^(|.*/)server-(\\d+)-(\\S+).log$")) (day-seconds (* 24 60 60))) ;; 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-writable? areapath) (begin (condition-case (create-directory (conc areapath "/logs") #t) (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs"))) (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn))) (directory-exists? (conc areapath "/logs"))) '())) ;; Get the list of server logs that do not contain "exiting". Ignore logs for servers that have exited. (let* ((server-logs (server:get-logs-list areapath)) (num-serv-logs (length server-logs))) (if (or (null? server-logs) (= num-serv-logs 0)) (let () (debug:print 1 *default-log-port* "There are no servers running") '() ) (let loop ((hed (string-chomp (car server-logs))) |
︙ | ︙ | |||
306 307 308 309 310 311 312 | (and start-time mod-time (> (- now start-time) 0) ;; been running at least 0 seconds (< (- 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) | | | 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 | (and start-time mod-time (> (- now start-time) 0) ;; been running at least 0 seconds (< (- 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) (pseudo-random-integer 360)))) ;; under one hour running time +/- 180 )) #f)) srvlst) (lambda (a b) (< (list-ref a 3) (list-ref b 3)))))) (if (> (length slst) nums) |
︙ | ︙ | |||
329 330 331 332 333 334 335 | #f))) (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)) | | | 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 | #f))) (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 (pseudo-random-integer len))) (list-ref srvrs idx)) #f))) (define (server:record->id servr) (handle-exceptions exn (begin |
︙ | ︙ | |||
380 381 382 383 384 385 386 | (all-go (> delta reftime))) (if (and all-go (begin (debug:print-info 0 *default-log-port* "Writing " start-flag) (with-output-to-file start-flag (lambda () (print server-key))) | | | 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 | (all-go (> delta reftime))) (if (and all-go (begin (debug:print-info 0 *default-log-port* "Writing " start-flag) (with-output-to-file start-flag (lambda () (print server-key))) (thread-sleep! 0.254) (let ((res (with-input-from-file start-flag (lambda () (read-line))))) (equal? server-key res)))) #t ;; (system (conc "touch " start-flag)) ;; lazy but safe (begin (debug:print-info 0 *default-log-port* "Gating server start, last start: " |
︙ | ︙ | |||
408 409 410 411 412 413 414 | (call-num (car last-run-dat)) (when-run (cadr last-run-dat)) (run-delay (+ (case call-num ((0) 0) ((1) 20) ((2) 300) (else 600)) | | | 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 | (call-num (car last-run-dat)) (when-run (cadr last-run-dat)) (run-delay (+ (case call-num ((0) 0) ((1) 20) ((2) 300) (else 600)) (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) (system (conc "touch " start-flag)) ;; lazy but safe (server:run areapath) |
︙ | ︙ | |||
453 454 455 456 457 458 459 | (define (server:check-if-running areapath) ;; #!key (numservers "2")) (let* ((ns (server:get-num-servers)) (servers (server:get-best (server:get-list areapath)))) (if (or (and servers (null? servers)) (not servers) (and (list? servers) | | | 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 | (define (server:check-if-running areapath) ;; #!key (numservers "2")) (let* ((ns (server:get-num-servers)) (servers (server:get-best (server:get-list areapath)))) (if (or (and servers (null? servers)) (not servers) (and (list? servers) (< (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 hed (if (null? tal) |
︙ | ︙ | |||
713 714 715 716 717 718 719 | (final-sync) (if (common:low-noise-print 30) (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))) (define (server:writable-watchdog-deltasync dbstruct) | | | 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 | (final-sync) (if (common:low-noise-print 30) (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))) (define (server:writable-watchdog-deltasync dbstruct) (thread-sleep! 0.054) ;; delay for startup (let ((legacy-sync (common:run-sync?)) (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds)) (no-sync-db (db:open-no-sync-db)) (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)) (sync-duration 0) ;; run time of the sync in milliseconds |
︙ | ︙ |
Added servermod.scm version [348a7a1225].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | ;;====================================================================== ;; Copyright 2017, Matthew Welland. ;; ;; This file is part of Megatest. ;; ;; Megatest is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; Megatest is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit servermod)) (module servermod * (import scheme chicken.base chicken.string chicken.process chicken.io chicken.time (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-69 ) (define (server:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) (define *server-loop-heart-beat* (current-seconds)) (define (server:get-logs-list area-path) (let* ((server-logs-cmd (conc "grep -iL exiting " area-path "/logs/server-*-*.log")) (server-logs (string-split (string-chomp (with-input-from-pipe server-logs-cmd read-string))))) server-logs)) ) |
Modified stml2.scm from [63b057818a] to [47f316ad28].
︙ | ︙ | |||
17 18 19 20 21 22 23 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit stml2)) (include "stml2/stml2.scm") | > > > > | 17 18 19 20 21 22 23 24 25 26 27 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit stml2)) (include "stml2/stml2.scm") (import stml2) (write "true") |
Modified stml2/cookie.scm from [d78a525a3a] to [fba413a4c8].
︙ | ︙ | |||
43 44 45 46 47 48 49 | ;; <http://www.netscape.com/newsref/std/cookie_spec.html> ;; (declare (unit cookie)) (module cookie * | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | ;; <http://www.netscape.com/newsref/std/cookie_spec.html> ;; (declare (unit cookie)) (module cookie * (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)) ;; #> ;; #include <time.h> |
︙ | ︙ |
Modified stml2/stml2.scm from [ee4c13898d] to [ccb26a2824].
︙ | ︙ | |||
10 11 12 13 14 15 16 | ;; stml is a list of html strings ;; (declare (unit stml)) (module stml2 * | | > > > > > > > > > > > > > > > > > | > > > > > > | < < > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | ;; stml is a list of html strings ;; (declare (unit stml)) (module stml2 * (import (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 ) ;; The (usually global) sdat contains everything about the session ;; (defstruct sdat ;; database (dbtype 'pg) (dbinit #f) |
︙ | ︙ | |||
419 420 421 422 423 424 425 | ;; to obscure and indirect database ids use one time keys ;; ;; (s:get-key 'n 1) => "n99e1882" n=number 99e is the week number since 1970, remainder is random ;; (s:key->val "n1882") => 1 ;; ;; first letter is a type: n=number, s=string, b=boolean (define (s:get-key key-type val) | | | 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 | ;; to obscure and indirect database ids use one time keys ;; ;; (s:get-key 'n 1) => "n99e1882" n=number 99e is the week number since 1970, remainder is random ;; (s:key->val "n1882") => 1 ;; ;; first letter is a type: n=number, s=string, b=boolean (define (s:get-key key-type val) (let ((mkrandstr (lambda (innum)(number->string (pseudo-random-integer innum) 16))) (week (number->string (quotient (current-seconds) (* 7 24 60 60)) 16))) (let loop ((siz 1000) (key (conc key-type week (mkrandstr 100))) (num 0)) (if (s:session-var-get key) ;; have a collision (loop (cond ;; in the unlikey event we have trouble getting a new var, keep increasing the size of the number ((< num 50) 100) |
︙ | ︙ | |||
647 648 649 650 651 652 653 | #;(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive. #;(define session:num-valid-chars (string-length session:valid-chars)) #;(define (session:get-nth-char nth) (substring session:valid-chars nth (+ nth 1))) #;(define (session:get-rand-char) | | | | 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 | #;(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive. #;(define session:num-valid-chars (string-length session:valid-chars)) #;(define (session:get-nth-char nth) (substring session:valid-chars nth (+ nth 1))) #;(define (session:get-rand-char) (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 (loop (string-append res (session:get-rand-char)) (+ n 1))))) ;; maybe replace above make-rand-string with this someday? ;; #;(define (session:generic-make-rand-string len seed-string) (let ((num-chars (string-length seed-string))) (let loop ((res "") (n 1)) (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 ;; backwards-compatible OpenSSL crypt passwords too. ;; |
︙ | ︙ | |||
730 731 732 733 734 735 736 | ((string? val) (string->number val)) ((symbol? val) (string->number (symbol->string val))) (else #f))) ;; NB// this is *illegal* pgint (define (s:illegal-pgint val) (cond | | | | 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 | ((string? val) (string->number val)) ((symbol? val) (string->number (symbol->string val))) (else #f))) ;; NB// this is *illegal* pgint (define (s:illegal-pgint val) (cond ((> 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 (if (s:illegal-pgint n) #f |
︙ | ︙ | |||
1103 1104 1105 1106 1107 1108 1109 | (formdat:load-all-port (current-input-port)) (make-formdat:formdat)))) ;; (s:process-cgi-input (caaar dat)) (define (formdat:load-all-port inp) (let* ((formdat (make-formdat:formdat)) (debugp #f)) | | | | | 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 | (formdat:load-all-port (current-input-port)) (make-formdat:formdat)))) ;; (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")))) ;; (write-string (read-string #f inp) #f debugp) ;; destroys all data! (formdat:initialize formdat) (let ((alldats (formdat:dat->list inp 10e6 debug-port: #f debugp))) #;(if debugp (format debugp "formdat : alldats: ~A\n" alldats)) (let ((firstitem (car alldats)) (multipass #f)) (if (and (not (null? firstitem)) (not (null? (car firstitem)))) (if (string-match formdat:delim-patt-rex (caar firstitem)) (set! multipass #t))) |
︙ | ︙ | |||
1148 1149 1150 1151 1152 1153 1154 | ;; (munged (s:process-cgi-input datstr))) ;; (print "datstr: " datstr " munged: " munged) (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) | | | 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 | ;; (munged (s:process-cgi-input datstr))) ;; (print "datstr: " datstr " munged: " munged) (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)) ;; (sdat-formdat-set! s:session formdat) formdat)))) #| (define inp (open-input-file "tests/example.post.in")) (define dat (read-string #f inp)) (define datstr (open-input-string dat)) |
︙ | ︙ | |||
1427 1428 1429 1430 1431 1432 1433 | (define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive. (define session:num-valid-chars (string-length session:valid-chars)) (define (session:get-nth-char nth) (substring session:valid-chars nth (+ nth 1))) (define (session:get-rand-char) | | | | 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 | (define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive. (define session:num-valid-chars (string-length session:valid-chars)) (define (session:get-nth-char nth) (substring session:valid-chars nth (+ nth 1))) (define (session:get-rand-char) (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 (loop (string-append res (session:get-rand-char)) (+ n 1))))) ;; maybe replace above make-rand-string with this someday? ;; (define (session:generic-make-rand-string len seed-string) (let ((num-chars (string-length seed-string))) (let loop ((res "") (n 1)) (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))))))) ;;====================================================================== ;; P A R A M S |
︙ | ︙ | |||
1705 1706 1707 1708 1709 1710 1711 | (if debugmode (session:log self "session:setup dbfname=" dbfname ", dbtype=" dbtype ", dbinit=" dbinit)) (if (eq? dbtype 'sqlite3) ;; The 'auto method will distribute dbs across the disk using hash ;; of user host and user. TODO ;; (if (eq? dbfname 'auto) ;; This is the auto assignment of a db based on hash of IP (let ((dbpath (pathname-directory dbfname))) ;; do a couple sanity checks here to make setting up easier (if debugmode (session:log self "INFO: setting up for sqlite3 db access to " dbfname)) | | | 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 | (if debugmode (session:log self "session:setup dbfname=" dbfname ", dbtype=" dbtype ", dbinit=" dbinit)) (if (eq? dbtype 'sqlite3) ;; The 'auto method will distribute dbs across the disk using hash ;; of user host and user. TODO ;; (if (eq? dbfname 'auto) ;; This is the auto assignment of a db based on hash of IP (let ((dbpath (pathname-directory dbfname))) ;; do a couple sanity checks here to make setting up easier (if debugmode (session:log self "INFO: setting up for sqlite3 db access to " dbfname)) (if (not (file-writable? dbpath)) (session:log self "WARNING: Cannot write to " dbpath) (if debugmode (session:log self "INFO: " dbpath " is writeable"))) (if (file-exists? dbfname) (begin ;; (session:log self "setting dbexists to #t") (set! dbexists #t)))) (if debugmode (session:log self "INFO: setting up for pg db access to account info " dbinit))) |
︙ | ︙ |
Modified subrun.scm from [bd1952a98c] to [e0be46add8].
︙ | ︙ | |||
14 15 16 17 18 19 20 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') | | | | | | | | | | | | | | | | | | | | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') ;; (use (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 #f)) |
︙ | ︙ |
Modified tasks.scm from [a73c5b318e] to [a6c2485239].
︙ | ︙ | |||
14 15 16 17 18 19 20 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') | | | | | | | | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') ;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking 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") ;;====================================================================== |
︙ | ︙ | |||
105 106 107 108 109 110 111 | (print-call-chain (current-error-port)) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (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)) | | | | | | | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 | (print-call-chain (current-error-port)) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (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-writable? dbpath)) (mdb (cond ;; what the hek is *toppath* doing here? ((and (string? *toppath*)(file-writable? *toppath*)) (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-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, ;; action TEXT DEFAULT '', ;; owner TEXT, |
︙ | ︙ |
Modified tdb.scm from [6edff6262d] to [c7832c1d4c].
︙ | ︙ | |||
18 19 20 21 22 23 24 | ;; ;;====================================================================== ;;====================================================================== ;; Database access ;;====================================================================== | | | | | | | | | | | | | | | | | | | | | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | ;; ;;====================================================================== ;;====================================================================== ;; 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") ;;====================================================================== ;; ;; T E S T D A T A B A S E S ;; ;;====================================================================== ;;====================================================================== ;; T E S T S P E C I F I C D B ;;====================================================================== ;; Create the sqlite db for the individual test(s) ;; ;; Moved these tables into <runid>.db ;; THIS CODE TO BE REMOVED ;; (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-readable? work-area)) (let* ((dbpath (conc work-area "/testdat.db")) (dbexists (common:file-exists? dbpath)) (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" ((condition-property-accessor 'exn 'message) exn)) (set! dbexists #f) ;; must force re-creation of tables, more tom-foolery (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-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 *db-write-access*) (sqlite3:set-busy-handler! db handler)) |
︙ | ︙ |
Modified tests.scm from [58a365a2ab] to [ef56b9a810].
︙ | ︙ | |||
18 19 20 21 22 23 24 | ;; ;;====================================================================== ;;====================================================================== ;; Tests ;;====================================================================== | | | | | | | | | | | | | | | | | | | | | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | ;; ;;====================================================================== ;;====================================================================== ;; 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") (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")) ) ;; Call this one to do all the work and get a standardized list of tests |
︙ | ︙ | |||
557 558 559 560 561 562 563 | (begin (print "failed to get mod time on " lockf ", exn=" exn) 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") | | | 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 | (begin (print "failed to get mod time on " lockf ", exn=" exn) 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 (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)) (outtxt "") (tot 0) |
︙ | ︙ | |||
907 908 909 910 911 912 913 | (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function (close-output-port oup) ; (set! page (+ 1 page)) (if (> total-runs (* (+ 1 page) pg-size)) (loop (+ 1 page))))) (common:simple-file-release-lock lockfile)) (begin | | | 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 | (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function (close-output-port oup) ; (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)))) (define (tests:readlines filename) (call-with-input-file filename (lambda (p) (let loop ((line (read-line p)) (result '())) |
︙ | ︙ | |||
1212 1213 1214 1215 1216 1217 1218 | '() (lambda (x p) (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) | | | 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 | '() (lambda (x p) (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-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) (common:simple-file-release-lock lockfile) |
︙ | ︙ | |||
1251 1252 1253 1254 1255 1256 1257 | path-parts)) test-dats)) (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) | | | 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 | path-parts)) test-dats)) (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-writable? html-dir)) (open-output-file html-path) #f))) ;; (print "run-dir: " run-dir ", tests-tree-dat: " tests-tree-dat) (if oup (begin (s:output-new oup |
︙ | ︙ | |||
1283 1284 1285 1286 1287 1288 1289 | (alt-file (conc full-targ "/megatest-rollup-" test-name ".html")) (html-file (if (common:file-exists? alt-file) alt-file std-file)) (run-name (car (reverse p)))) (if (and (not (common:file-exists? full-targ)) (directory? full-targ) | | | 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 | (alt-file (conc full-targ "/megatest-rollup-" test-name ".html")) (html-file (if (common:file-exists? alt-file) alt-file std-file)) (run-name (car (reverse p)))) (if (and (not (common:file-exists? full-targ)) (directory? 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) (begin (debug:print 0 *default-log-port* "ERROR: can't access " full-targ) |
︙ | ︙ | |||
1416 1417 1418 1419 1420 1421 1422 | ;; (define (tests:save-final-status 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)) (status-file (conc out-dir "/.final-status")) ) ;; first verify we are able to write the output file | | | | 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 | ;; (define (tests:save-final-status 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)) (status-file (conc out-dir "/.final-status")) ) ;; first verify we are able to write the output file (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))) (fprintf outp "~S\n" state) (fprintf outp "~S\n" status) (close-output-port outp))))) ;; summarize test in to a file test-summary.html in the test directory ;; (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-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)) (oup (open-output-file out-file)) (status (db:test-get-status test-dat)) |
︙ | ︙ | |||
1593 1594 1595 1596 1597 1598 1599 | local-tcdir #f)) (conc *toppath* "/tests/" test-name))) (test-configf (conc test-path "/testconfig")) (testexists (let loopa ((tries-left 30)) (cond ( | | | 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 | local-tcdir #f)) (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-readable? test-configf)) #t) ( (common:file-exists? test-configf) (debug:print 0 *default-log-port* "WARNING: Cannot read testconfig file: "test-configf) #f) ( (and wait-a-minute (> tries-left 0)) |
︙ | ︙ | |||
1617 1618 1619 1620 1621 1622 1623 | "pre-launch-env-vars" #f)) #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 | | | 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 | "pre-launch-env-vars" #f)) #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-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)))) tcfg)))))) |
︙ | ︙ | |||
1726 1727 1728 1729 1730 1731 1732 | (conc "env -i PATH=$PATH dot -T" outtype " < " temp-path) (lambda () (let ((res (read-lines))) ;; (delete-file temp-path) res)))))) (define (tests:write-dot-file test-records fname sizex sizey) | | | 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 | (conc "env -i PATH=$PATH dot -T" outtype " < " temp-path) (lambda () (let ((res (read-lines))) ;; (delete-file temp-path) res)))))) (define (tests:write-dot-file test-records fname sizex sizey) (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) (let ((all-testnames (hash-table-keys test-records))) (if (null? all-testnames) |
︙ | ︙ |
Modified vg.scm from [48b3b2908c] to [d31bf89ee1].
︙ | ︙ | |||
377 378 379 380 381 382 383 | (arithmetic-shift r 16) (arithmetic-shift g 8) b)) ;; Obsolete function ;; (define (vg:generate-color) | | | | | | | | 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 | (arithmetic-shift r 16) (arithmetic-shift g 8) b)) ;; Obsolete function ;; (define (vg:generate-color) (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 (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)))) ;;====================================================================== ;; graphing ;;====================================================================== |
︙ | ︙ |
Added vgmod.scm version [2e376f7175].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 | ;; ;; Copyright 2016 Matthew Welland. ;; ;; This file is part of Megatest. ;; ;; Megatest is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; Megatest is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (declare (unit vgmod)) (module vgmod * (import scheme chicken data-structures extras ports) (use canvas-draw iup) (use typed-records srfi-1 srfi-69) (import canvas-draw-iup) (include "vg_records.scm") ;; ;; structs ;; ;; ;; (defstruct vg:lib comps) ;; (defstruct vg:comp objs name file) ;; ;; extents caches extents calculated on draw ;; ;; proc is called on draw and takes the obj itself as a parameter ;; ;; attrib is an alist of parameters ;; (defstruct vg:obj type pts fill-color text line-color call-back angle font attrib extents proc) ;; (defstruct vg:inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache) ;; (defstruct vg:drawing libs insts scalex scaley xoff yoff cnv cache) ;; libs: hash of name->lib, insts: hash of instname->inst ;; inits ;; (define (vg:comp-new) (make-vg:comp objs: '() name: #f file: #f)) (define (vg:lib-new) (make-vg:lib comps: (make-hash-table))) (define (vg:drawing-new) (make-vg:drawing scalex: 1 scaley: 1 xoff: 0 yoff: 0 libs: (make-hash-table) insts: (make-hash-table) cache: '())) ;;====================================================================== ;; scaling and offsets ;;====================================================================== (define-inline (vg:scale-offset val s o) (+ o (* val s))) ;; (* (+ o val) s)) ;; apply scale and offset to a list of x y values ;; (define (vg:scale-offset-xy lstxy sx sy ox oy) (if (> (length lstxy) 1) ;; have at least one xy pair (let loop ((x (car lstxy)) (y (cadr lstxy)) (tal (cddr lstxy)) (res '())) (let ((newres (cons (vg:scale-offset y sy oy) (cons (vg:scale-offset x sx ox) res)))) (if (> (length tal) 1) (loop (car tal)(cadr tal)(cddr tal) newres) (reverse newres)))) '())) ;; apply drawing offset and scaling to the points in lstxy ;; (define (vg:drawing-apply-scale drawing lstxy) (vg:scale-offset-xy lstxy (vg:drawing-scalex drawing) (vg:drawing-scaley drawing) (vg:drawing-xoff drawing) (vg:drawing-yoff drawing))) ;; apply instance offset and scaling to the points in lstxy ;; (define (vg:inst-apply-scale inst lstxy) (vg:scale-offset-xy lstxy (vg:inst-scalex inst) (vg:inst-scaley inst) (vg:inst-xoff inst) (vg:inst-yoff inst))) ;; apply both drawing and instance scaling to a list of xy points ;; (define (vg:drawing-inst-apply-scale-offset drawing inst lstxy) (vg:drawing-apply-scale drawing (vg:inst-apply-scale inst lstxy))) ;;====================================================================== ;; objects ;;====================================================================== ;; (vg:inst-apply-scale ;; inst ;; (vg:drawing-apply-scale drawing lstxy))) ;; make a rectangle obj ;; (define (vg:make-rect-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f)) (make-vg:obj type: 'r pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: extents)) ;; make a rectangle obj ;; (define (vg:make-line-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(extents #f)) (make-vg:obj type: 'l pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color extents: extents)) ;; make a text obj ;; (define (vg:make-text-obj x1 y1 text #!key (line-color #f)(fill-color #f) (angle #f)(scale-with-zoom #f)(font #f) (font-size #f)) (make-vg:obj type: 't pts: (list x1 y1) text: text line-color: line-color fill-color: fill-color angle: angle font: font extents: #f attributes: (vg:make-attrib 'font-size font-size))) ;; proc takes startnum and endnum and yields scalef, per-grad and unitname ;; (define (vg:make-xaxis-obj x1 y1 x2 y2 #!key (line-color #f)(fill-color #f)(text #f)(font #f)(proc #f)) (make-vg:obj type: 'x pts: (list x1 y1 x2 y2) text: text font: font line-color: line-color fill-color: fill-color extents: #f proc: proc)) ;;====================================================================== ;; obj modifiers and queries ;;====================================================================== ;; get extents, use knowledge of type ... ;; (define (vg:obj-get-extents drawing obj) (let ((type (vg:obj-type obj))) (case type ((l)(vg:rect-get-extents obj)) ((r)(vg:rect-get-extents obj)) ((t)(vg:draw-text drawing obj draw: #f)) (else #f)))) (define (vg:rect-get-extents obj) (vg:obj-pts obj)) ;; extents are just the points for a rectangle (define (vg:grow-rect borderx bordery x1 y1 x2 y2) (list (- x1 borderx) (- y1 bordery) (+ x2 borderx) (+ y2 bordery))) (define (vg:make-attrib . attrib-list) #f) ;;====================================================================== ;; components ;;====================================================================== ;; add obj to comp ;; (define (vg:add-objs-to-comp comp . objs) (vg:comp-objs-set! comp (append (vg:comp-objs comp) objs))) (define (vg:add-obj-to-comp comp obj) (vg:comp-objs-set! comp (cons obj (vg:comp-objs comp)))) ;; use the struct. leave this here to remind of this! ;; ;; (define (vg:comp-get-objs comp) ;; (vg:comp-objs comp)) ;; add comp to lib ;; (define (vg:add-comp-to-lib lib compname comp) (hash-table-set! (vg:lib-comps lib) compname comp)) ;; instanciate component in drawing ;; (define (vg:instantiate drawing libname compname instname xoff yoff #!key (theta 0)(scalex 1)(scaley 1)(mirrx #f)(mirry #f)) (let ((inst (make-vg:inst libname: libname compname: compname xoff: xoff yoff: yoff theta: theta scalex: scalex scaley: scaley mirrx: mirrx mirry: mirry)) ) (hash-table-set! (vg:drawing-insts drawing) instname inst))) (define (vg:instance-move drawing instname newx newy) (let ((inst (hash-table-ref (vg:drawing-insts drawing) instname))) (vg:inst-xoff-set! inst newx) (vg:inst-yoff-set! inst newy))) ;; get component from drawing (look in apropriate lib) given libname and compname (define (vg:get-component drawing libname compname) (let* ((lib (hash-table-ref (vg:drawing-libs drawing) libname)) (inst (hash-table-ref (vg:lib-comps lib) compname))) inst)) (define (vg:get-extents-for-objs drawing objs) (if (or (not objs) (null? objs)) #f (let loop ((hed (car objs)) (tal (cdr objs)) (extents (vg:obj-get-extents drawing (car objs)))) (let ((newextents (vg:get-extents-for-two-rects extents (vg:obj-get-extents drawing hed)))) (if (null? tal) extents (loop (car tal)(cdr tal) newextents)))))) ;; (let ((extents #f)) ;; (for-each ;; (lambda (obj) ;; (set! extents ;; (vg:get-extents-for-two-rects ;; extents ;; (vg:obj-get-extents drawing obj)))) ;; objs) ;; extents)) ;; given rectangles r1 and r2, return the box that bounds both ;; (define (vg:get-extents-for-two-rects r1 r2) (if (not r1) r2 (if (not r2) r1 ;; #f ;; no extents from #f #f (list (min (car r1)(car r2)) ;; llx (min (cadr r1)(cadr r2)) ;; lly (max (caddr r1)(caddr r2)) ;; ulx (max (cadddr r1)(cadddr r2)))))) ;; uly (define (vg:components-get-extents drawing . comps) (if (null? comps) #f (let loop ((hed (car comps)) (tal (cdr comps)) (extents #f)) (let* ((objs (vg:comp-objs hed)) (newextents (if extents (vg:get-extents-for-two-rects extents (vg:get-extents-for-objs drawing objs)) (vg:get-extents-for-objs drawing objs)))) (if (null? tal) newextents (loop (car tal)(cdr tal) newextents)))))) ;;====================================================================== ;; libraries ;;====================================================================== ;; register lib with drawing ;; (define (vg:add-lib drawing libname lib) (hash-table-set! (vg:drawing-libs drawing) libname lib)) (define (vg:get-lib drawing libname) (hash-table-ref/default (vg:drawing-libs drawing) libname #f)) (define (vg:get/create-lib drawing libname) (let ((lib (vg:get-lib drawing libname))) (if lib lib (let ((newlib (vg:lib-new))) (vg:add-lib drawing libname newlib) newlib)))) ;;====================================================================== ;; map objects given offset, scale and mirror, resulting obj is displayed ;;====================================================================== ;; dispatch the drawing of obj off to the correct drawing routine ;; (define (vg:map-obj drawing inst obj) (case (vg:obj-type obj) ((l)(vg:map-line drawing inst obj)) ((r)(vg:map-rect drawing inst obj)) ((t)(vg:map-text drawing inst obj)) ((x)(vg:map-xaxis drawing inst obj)) (else #f))) ;; given a drawing and a inst map a rectangle to it screen coordinates ;; (define (vg:map-rect drawing inst obj) (let ((res (make-vg:obj type: 'r ;; is there a defstruct copy? fill-color: (vg:obj-fill-color obj) text: (vg:obj-text obj) line-color: (vg:obj-line-color obj) font: (vg:obj-font obj))) (pts (vg:obj-pts obj))) (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts)) (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) )) res)) ;; given a drawing and a inst map a line to it screen coordinates ;; (define (vg:map-line drawing inst obj) (let ((res (make-vg:obj type: 'l ;; is there a defstruct copy? line-color: (vg:obj-line-color obj) font: (vg:obj-font obj))) (pts (vg:obj-pts obj))) (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts)) (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) )) res)) ;; given a drawing and a inst map a text to it screen coordinates ;; (define (vg:map-text drawing inst obj) (let ((res (make-vg:obj type: 't fill-color: (vg:obj-fill-color obj) text: (vg:obj-text obj) line-color: (vg:obj-line-color obj) font: (vg:obj-font obj) angle: (vg:obj-angle obj) attrib: (vg:obj-attrib obj))) (pts (vg:obj-pts obj))) (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts)) (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing))) res)) ;; given a drawing and a inst map a line to it screen coordinates ;; (define (vg:map-xaxis drawing inst obj) (let ((res (make-vg:obj type: 'x ;; is there a defstruct copy? line-color: (vg:obj-line-color obj) font: (vg:obj-font obj))) (pts (vg:obj-pts obj))) (vg:obj-pts-set! res (vg:drawing-inst-apply-scale-offset drawing inst pts)) (vg:drawing-cache-set! drawing (cons res (vg:drawing-cache drawing) )) res)) ;;====================================================================== ;; instances ;;====================================================================== (define (vg:instances-get-extents drawing . instance-names) (let ((xtnt-lst (vg:draw drawing #f))) (if (null? xtnt-lst) #f (let loop ((extents (car xtnt-lst)) (tal (cdr xtnt-lst)) (llx #f) (lly #f) (ulx #f) (uly #f)) (let ((nllx (if llx (min llx (list-ref extents 0))(list-ref extents 0))) (nlly (if lly (min lly (list-ref extents 1))(list-ref extents 1))) (nulx (if ulx (max ulx (list-ref extents 2))(list-ref extents 2))) (nuly (if uly (max uly (list-ref extents 3))(list-ref extents 3)))) (if (null? tal) (list llx lly ulx uly) (loop (car tal)(cdr tal) nllx nlly nulx nuly))))))) (define (vg:lib-get-component lib instname) (hash-table-ref/default (vg:lib-comps lib) instname #f)) ;;====================================================================== ;; color ;;====================================================================== (define (vg:rgb->number r g b #!key (a 0)) (bitwise-ior (arithmetic-shift a 24) (arithmetic-shift r 16) (arithmetic-shift g 8) b)) ;; Obsolete function ;; (define (vg:generate-color) (vg:rgb->number (random 255) (random 255) (random 255))) ;; Need to return a string of random iup-color for graph ;; (define (vg:generate-color-rgb) (conc (number->string (random 255)) " " (number->string (random 255)) " " (number->string (random 255)))) (define (vg:iup-color->number iup-color) (apply vg:rgb->number (map string->number (string-split iup-color)))) ;;====================================================================== ;; graphing ;;====================================================================== (define (vg:make-xaxis drawing component x1 y1 x2 y2 startnum endnum scaleproc) (let ((obj (vg:make-xaxis-obj x1 y1 x2 y2))) #f)) ;;====================================================================== ;; Unravel and draw the objects ;;====================================================================== ;; with get-extents = #t return the extents ;; with draw = #f don't actually draw the object ;; (define (vg:draw-obj drawing obj #!key (draw #t)) ;; (print "obj type: " (vg:obj-type obj)) (case (vg:obj-type obj) ((l)(vg:draw-line drawing obj draw: draw)) ((r)(vg:draw-rect drawing obj draw: draw)) ((t)(vg:draw-text drawing obj draw: draw)))) ;; given a rect obj draw it on the canvas applying first the drawing ;; scale and offset ;; (define (vg:draw-rect drawing obj #!key (draw #t)) (let* ((cnv (vg:drawing-cnv drawing)) (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) (fill-color (vg:obj-fill-color obj)) (line-color (vg:obj-line-color obj)) (text (vg:obj-text obj)) (font (vg:obj-font obj)) (llx (car pts)) (lly (cadr pts)) (ulx (caddr pts)) (uly (cadddr pts)) (w (- ulx llx)) (h (- uly lly)) (text-xmax #f) (text-ymax #f)) (if draw (let ((prev-background-color (canvas-background cnv)) (prev-foreground-color (canvas-foreground cnv))) (if fill-color (begin (canvas-foreground-set! cnv fill-color) (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h) (if line-color (canvas-foreground-set! cnv line-color) (if fill-color (canvas-foreground-set! cnv prev-foreground-color))) (canvas-rectangle! cnv llx ulx lly uly) (canvas-foreground-set! cnv prev-foreground-color) (if text (let* ((prev-font (canvas-font cnv)) (font-changed (and font (not (equal? font prev-font))))) (if font-changed (canvas-font-set! cnv font)) (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) (if (eq? draw 'get-extents) (let-values (((xmax ymax)(canvas-text-size cnv text))) (set! text-xmax xmax)(set! text-ymax ymax))) (if font-changed (canvas-font-set! cnv prev-font)))))) ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax) (if (vg:obj-extents obj) (vg:obj-extents obj) (if (not text) pts ;; no text (if (and text-xmax text-ymax) ;; have text (let ((xt (list llx lly (max ulx (+ llx text-xmax)) (max uly (+ lly text-ymax))))) (vg:obj-extents-set! obj xt) xt) (if cnv (if (eq? draw 'get-extents) (let-values (((xmax ymax)(canvas-text-size cnv text))) (let ((xt (list llx lly (max ulx (+ llx xmax)) (max uly (+ lly ymax))))) (vg:obj-extents-set! obj xt) xt)) pts) pts)))))) ;; return extents ;; given a rect obj draw it on the canvas applying first the drawing ;; scale and offset ;; (define (vg:draw-line drawing obj #!key (draw #t)) (let* ((cnv (vg:drawing-cnv drawing)) (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) ;; (fill-color (vg:obj-fill-color obj)) (line-color (vg:obj-line-color obj)) (text (vg:obj-text obj)) (font (vg:obj-font obj)) (llx (car pts)) (lly (cadr pts)) (ulx (caddr pts)) (uly (cadddr pts)) (w (- ulx llx)) (h (- uly lly)) (text-xmax #f) (text-ymax #f)) (if draw (let ((prev-background-color (canvas-background cnv)) (prev-foreground-color (canvas-foreground cnv))) ;; (if fill-color ;; (begin ;; (canvas-foreground-set! cnv fill-color) ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h) (if line-color (canvas-foreground-set! cnv line-color)) ;; (if fill-color ;; (canvas-foreground-set! cnv prev-foreground-color))) (canvas-line! cnv llx lly ulx uly) (canvas-foreground-set! cnv prev-foreground-color) (if text (let* ((prev-font (canvas-font cnv)) (font-changed (and font (not (equal? font prev-font))))) (if font-changed (canvas-font-set! cnv font)) (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) (let-values (((xmax ymax)(canvas-text-size cnv text))) (set! text-xmax xmax)(set! text-ymax ymax)) (if font-changed (canvas-font-set! cnv prev-font)))))) ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax) (if (vg:obj-extents obj) (vg:obj-extents obj) (if (not text) pts (if (and text-xmax text-ymax) (let ((xt (list llx lly (max ulx (+ llx text-xmax)) (max uly (+ lly text-ymax))))) (vg:obj-extents-set! obj xt) xt) (if cnv (let-values (((xmax ymax)(canvas-text-size cnv text))) (let ((xt (list llx lly (max ulx (+ llx xmax)) (max uly (+ lly ymax))))) (vg:obj-extents-set! obj xt) xt)) pts)))))) ;; return extents ;; given a rect obj draw it on the canvas applying first the drawing ;; scale and offset ;; (define (vg:draw-xaxis drawing obj #!key (draw #t)) (let* ((cnv (vg:drawing-cnv drawing)) (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) ;; (fill-color (vg:obj-fill-color obj)) (line-color (vg:obj-line-color obj)) (text (vg:obj-text obj)) (font (vg:obj-font obj)) (llx (car pts)) (lly (cadr pts)) (ulx (caddr pts)) (uly (cadddr pts)) (w (- ulx llx)) (h (- uly lly)) (text-xmax #f) (text-ymax #f)) (if draw (let ((prev-background-color (canvas-background cnv)) (prev-foreground-color (canvas-foreground cnv))) ;; (if fill-color ;; (begin ;; (canvas-foreground-set! cnv fill-color) ;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h) (if line-color (canvas-foreground-set! cnv line-color) #;(if fill-color (canvas-foreground-set! cnv prev-foreground-color))) (canvas-line! cnv llx ulx lly uly) (canvas-foreground-set! cnv prev-foreground-color) (if text (let* ((prev-font (canvas-font cnv)) (font-changed (and font (not (equal? font prev-font))))) (if font-changed (canvas-font-set! cnv font)) (canvas-text! cnv (+ 2 llx)(+ 2 lly) text) (let-values (((xmax ymax)(canvas-text-size cnv text))) (set! text-xmax xmax)(set! text-ymax ymax)) (if font-changed (canvas-font-set! cnv prev-font)))))) ;; (print "text-xmax: " text-xmax " text-ymax: " text-ymax) (if (vg:obj-extents obj) (vg:obj-extents obj) (if (not text) pts (if (and text-xmax text-ymax) (let ((xt (list llx lly (max ulx (+ llx text-xmax)) (max uly (+ lly text-ymax))))) (vg:obj-extents-set! obj xt) xt) (if cnv (let-values (((xmax ymax)(canvas-text-size cnv text))) (let ((xt (list llx lly (max ulx (+ llx xmax)) (max uly (+ lly ymax))))) (vg:obj-extents-set! obj xt) xt)) pts)))))) ;; return extents ;; given a rect obj draw it on the canvas applying first the drawing ;; scale and offset ;; (define (vg:draw-text drawing obj #!key (draw #t)) (let* ((cnv (vg:drawing-cnv drawing)) (pts (vg:drawing-apply-scale drawing (vg:obj-pts obj))) (text (vg:obj-text obj)) (font (vg:obj-font obj)) (fill-color (vg:obj-fill-color obj)) (line-color (vg:obj-line-color obj)) (llx (car pts)) (lly (cadr pts))) (if draw (let* ((prev-background-color (canvas-background cnv)) (prev-foreground-color (canvas-foreground cnv)) (prev-font (canvas-font cnv)) (font-changed (and font (not (equal? font prev-font))))) (if line-color (canvas-foreground-set! cnv line-color) (if fill-color (canvas-foreground-set! cnv prev-foreground-color))) (if font-changed (canvas-font-set! cnv font)) (canvas-text! cnv llx lly text) ;; NOTE: we do not set the font back!! (canvas-foreground-set! cnv prev-foreground-color))) (if cnv (if (eq? draw 'get-extents) (let-values (((xmax ymax)(canvas-text-size cnv text))) (append pts (list (+ llx xmax)(+ lly ymax)))) ;; will be wrong if text is rotated? (append pts pts)) (append pts pts)))) (define (vg:draw-inst drawing inst #!key (draw-mode #t)(prev-extents '())) (let* ((libname (vg:inst-libname inst)) (compname (vg:inst-compname inst)) (comp (vg:get-component drawing libname compname)) (objs (vg:comp-objs comp))) ;; (print "comp: " comp) (if (null? objs) prev-extents (let loop ((obj (car objs)) (tal (cdr objs)) (res prev-extents)) (let* ((obj-xfrmd (vg:map-obj drawing inst obj)) (newres (cons (vg:draw-obj drawing obj-xfrmd draw: draw-mode) res))) (if (null? tal) newres (loop (car tal)(cdr tal) newres))))))) (define (vg:draw drawing draw-mode . instnames) (let* ((insts (vg:drawing-insts drawing)) (all-inst-names (hash-table-keys insts)) (master-list (if (null? instnames) all-inst-names instnames))) (if (null? master-list) '() (let loop ((instname (car master-list)) (tal (cdr master-list)) (res '())) (let* ((inst (hash-table-ref/default insts instname #f)) (newres (if inst (vg:draw-inst drawing inst draw-mode: draw-mode prev-extents: res) res))) (if (null? tal) newres (loop (car tal)(cdr tal) newres))))))) ) |
Deleted widgets.scm version [3a32b6256a].
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |