Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -18,16 +18,16 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;;======================================================================
-(use srfi-69 posix)
-
-(declare (unit api))
-(declare (uses rmt))
-(declare (uses db))
-(declare (uses tasks))
+;; (use srfi-69 posix)
+;;
+;; (declare (unit api))
+;; (declare (uses rmt))
+;; (declare (uses db))
+;; (declare (uses tasks))
;; allow these queries through without starting a server
;;
(define api:read-only-queries
'(get-key-val-pairs
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -15,20 +15,20 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-
-(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)
-
-(declare (unit archive))
-(declare (uses db))
-(declare (uses common))
-
-(include "common_records.scm")
-(include "db_records.scm")
-
+;;
+;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)
+;;
+;; (declare (unit archive))
+;; (declare (uses db))
+;; (declare (uses common))
+;;
+;; (include "common_records.scm")
+;; (include "db_records.scm")
+;;
;;======================================================================
;;
;;======================================================================
;; NOT CURRENTLY USED
@@ -39,11 +39,11 @@
(maxload 1.5) ;; max allowed load for this work
(adisks (archive:get-archive-disks)))
;; get testdir size
;; - hand off du to job mgr
(if (and (common:file-exists? testdir)
- (file-is-writable? testdir))
+ (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
ADDED attic/widgets.scm
Index: attic/widgets.scm
==================================================================
--- /dev/null
+++ attic/widgets.scm
@@ -0,0 +1,208 @@
+;; Copyright 2006-2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+(require-library srfi-4 iup)
+(import srfi-4 iup
+ ;; iup-pplot
+ iup-glcanvas) ;; iup-web
+
+(define (popup dlg . args)
+ (apply show dlg #:modal? 'yes args)
+ (destroy! dlg))
+
+(define (properties ih)
+ (popup (element-properties-dialog ih))
+ 'default)
+
+(define dlg
+ (dialog
+ (vbox
+ (hbox ; headline
+ (fill)
+ (frame (label " Inspect control and dialog classes "
+ fontsize: 15))
+ (fill)
+ margin: '0x0)
+
+ (label "")
+ (label "Dialogs" fontsize: 12)
+ (hbox
+ (button "dialog"
+ action: (lambda (self) (properties (dialog (vbox)))))
+ (button "color-dialog"
+ action: (lambda (self) (properties (color-dialog))))
+ (button "file-dialog"
+ action: (lambda (self) (properties (file-dialog))))
+ (button "font-dialog"
+ action: (lambda (self) (properties (font-dialog))))
+ (button "message-dialog"
+ action: (lambda (self) (properties (message-dialog))))
+ (fill)
+ margin: '0x0)
+ (hbox
+ (button "layout-dialog"
+ action: (lambda (self) (properties (layout-dialog))))
+ (button "element-properties-dialog"
+ action: (lambda (self)
+ (properties
+ (element-properties-dialog (create 'user)))))
+ (fill)
+ margin: '0x0)
+
+ (label "")
+ (label "Composition widgets" fontsize: 12)
+ (hbox
+ (button "fill"
+ action: (lambda (self) (properties (fill))))
+ (button "hbox"
+ action: (lambda (self) (properties (hbox))))
+ (button "vbox"
+ action: (lambda (self) (properties (vbox))))
+ (button "zbox"
+ action: (lambda (self) (properties (zbox))))
+ (button "radio"
+ action: (lambda (self) (properties (radio (vbox)))))
+ (button "normalizer"
+ action: (lambda (self) (properties (normalizer))))
+ (button "cbox"
+ action: (lambda (self) (properties (cbox))))
+ (button "sbox"
+ action: (lambda (self) (properties (sbox (vbox)))))
+ (button "split"
+ action: (lambda (self) (properties (split (vbox) (vbox)))))
+ (fill)
+ margin: '0x0)
+
+ (label "")
+ (label "Standard widgets" fontsize: 12)
+ (hbox
+ (button "button"
+ action: (lambda (self) (properties (button))))
+ (button "canvas"
+ action: (lambda (self) (properties (canvas))))
+ (button "frame"
+ action: (lambda (self) (properties (frame))))
+ (button "label"
+ action: (lambda (self) (properties (label))))
+ (button "listbox"
+ action: (lambda (self) (properties (listbox))))
+ (button "progress-bar"
+ action: (lambda (self) (properties (progress-bar))))
+ (button "spin"
+ action: (lambda (self) (properties (spin))))
+ (fill)
+ margin: '0x0)
+ (hbox
+ (button "tabs"
+ action: (lambda (self) (properties (tabs))))
+ (button "textbox"
+ action: (lambda (self) (properties (textbox))))
+ (button "toggle"
+ action: (lambda (self) (properties (toggle))))
+ (button "treebox"
+ action: (lambda (self) (properties (treebox))))
+ (button "valuator"
+ action: (lambda (self) (properties (valuator ""))))
+ (fill)
+ margin: '0x0)
+
+ (label "")
+ (label "Additional widgets" fontsize: 12)
+ (hbox
+ (button "cells"
+ action: (lambda (self) (properties (cells))))
+ (button "color-bar"
+ action: (lambda (self) (properties (color-bar))))
+ (button "color-browser"
+ action: (lambda (self) (properties (color-browser))))
+ (button "dial"
+ action: (lambda (self) (properties (dial ""))))
+ (button "matrix"
+ action: (lambda (self) (properties (matrix))))
+ (fill)
+ margin: '0x0)
+ (hbox
+ #;(button "pplot"
+ action: (lambda (self) (properties (pplot))))
+ (button "glcanvas"
+ action: (lambda (self) (properties (glcanvas))))
+ ;; (button "web-browser"
+ ;; action: (lambda (self) (properties (web-browser))))
+ (fill)
+ margin: '0x0)
+
+ (label "")
+ (label "Menu widgets" fontsize: 12)
+ (hbox
+ (button "menu"
+ action: (lambda (self) (properties (menu))))
+ (button "menu-item"
+ action: (lambda (self) (properties (menu-item))))
+ (button "menu-separator"
+ action: (lambda (self) (properties (menu-separator))))
+ (fill)
+ margin: '0x0)
+
+ (label "")
+ (label "Images" fontsize: 12)
+ (hbox
+ (button "image/palette"
+ action: (lambda (self)
+ (properties
+ (image/palette 1 1 (u8vector->blob (u8vector 0))))))
+ (button "image/rgb"
+ action: (lambda (self)
+ (properties
+ (image/rgb 1 1 (u8vector->blob (u8vector 0))))))
+ (button "image/rgba"
+ action: (lambda (self)
+ (properties
+ (image/rgba 1 1 (u8vector->blob (u8vector 0))))))
+ (button "image/file"
+ action: (lambda (self)
+ (properties
+ ;; same attributes as image/palette
+ (image/palette 1 1 (u8vector->blob (u8vector 0))))))
+ ;; needs a file in current directory
+ ;(image/file "chicken.ico")))) ; ok
+ ;(image/file "chicken.png")))) ; doesn't work
+ (fill)
+ margin: '0x0)
+
+ (label "")
+ (label "Other widgets" fontsize: 12)
+ (hbox
+ (button "clipboard"
+ action: (lambda (self) (properties (clipboard))))
+ (button "timer"
+ action: (lambda (self) (properties (timer))))
+ (button "spinbox"
+ action: (lambda (self) (properties (spinbox (vbox)))))
+ (fill)
+ margin: '0x0)
+
+ (fill)
+ (button "E&xit"
+ expand: 'horizontal
+ action: (lambda (self) 'close))
+ )
+ margin: '15x15
+ title: "Iup inspector"))
+
+(show dlg)
+(main-loop)
+(exit 0)
ADDED autoload/autoload.egg
Index: autoload/autoload.egg
==================================================================
--- /dev/null
+++ autoload/autoload.egg
@@ -0,0 +1,5 @@
+((license "BSD")
+ (category lang-exts)
+ (author "Alex Shinn")
+ (synopsis "Load modules lazily")
+ (components (extension autoload)))
ADDED autoload/autoload.meta
Index: autoload/autoload.meta
==================================================================
--- /dev/null
+++ autoload/autoload.meta
@@ -0,0 +1,9 @@
+;;; autoload.meta -*- Hen -*-
+
+((egg "autoload.egg")
+ (synopsis "Load modules lazily")
+ (category lang-exts)
+ (license "BSD")
+ (author "Alex Shinn")
+ (doc-from-wiki)
+ (files "autoload.meta" "autoload.scm" "autoload.release-info" "autoload.setup"))
ADDED autoload/autoload.scm
Index: autoload/autoload.scm
==================================================================
--- /dev/null
+++ autoload/autoload.scm
@@ -0,0 +1,93 @@
+;;;; autoload.scm -- load modules lazily
+;;
+;; Copyright (c) 2005-2009 Alex Shinn
+;; All rights reserved.
+;;
+;; BSD-style license: http://www.debian.org/misc/bsd.license
+
+;; Provides an Emacs-style autoload facility which takes the basic form
+;;
+;; (autoload unit procedure-name ...)
+;;
+;; such that the first time procedure-name is called, it will perform a
+;; runtime require of 'unit and then apply the procedure from the newly
+;; loaded unit to the args it was passed. Subsequent calls to
+;; procedure-name will thereafter refer to the new procedure and will
+;; thus not incur any overhead.
+;;
+;; You may also specify an alias for the procedure, and a default
+;; procedure if the library can't be loaded:
+;;
+;; (autoload unit (name alias default) ...)
+;;
+;; In this case, although the procedure name from the unit is "name,"
+;; the form defines the autoload procedure as "alias."
+;;
+;; If the library can't be loaded then an error is signalled, unless
+;; default is given, in which case the values are passed to that.
+;;
+;; Examples:
+;;
+;; ;; load iconv procedures lazily
+;; (autoload iconv iconv iconv-open)
+;;
+;; ;; load some sqlite procedures lazily with "-" names
+;; (autoload sqlite (sqlite:open sqlite-open)
+;; (sqlite:execute sqlite-execute))
+;;
+;; ;; load md5 library, falling back on slower scheme version
+;; (autoload scheme-md5 (md5:digest scheme-md5:digest))
+;; (autoload md5 (md5:digest #f scheme-md5:digest))
+
+(module autoload (autoload)
+
+(import scheme (chicken base))
+
+(define-syntax autoload
+ (er-macro-transformer
+ (lambda (expr rename compare)
+ (let ((module (cadr expr))
+ (procs (cddr expr))
+ (_import (rename 'import))
+ (_define (rename 'define))
+ (_let (rename 'let))
+ (_set! (rename 'set!))
+ (_begin (rename 'begin))
+ (_apply (rename 'apply))
+ (_args (rename 'args))
+ (_tmp (rename 'tmp))
+ (_eval (rename 'eval))
+ (_condition-case (rename 'condition-case)))
+ `(,_begin
+ ,@(map
+ (lambda (x)
+ (let* ((x (if (pair? x) x (list x)))
+ (name (car x))
+ (full-name
+ (string->symbol
+ (string-append (symbol->string module) "#"
+ (symbol->string name))))
+ (alias (or (and (pair? (cdr x)) (cadr x)) name))
+ (default (and (pair? (cdr x)) (pair? (cddr x)) (caddr x))))
+ (if default
+ `(,_define (,alias . ,_args)
+ (,_let ((,_tmp (,_condition-case
+ (,_begin
+ (,_eval
+ (begin (require-library ,module)
+ #f))
+ (,_eval ',full-name))
+ (exn () ,default))))
+ (,_set! ,alias ,_tmp)
+ (,_apply ,_tmp ,_args)))
+ `(,_define (,alias . ,_args)
+ (,_let ((,_tmp (,_begin
+ (,_eval
+ (begin (require-library ,module)
+ #f))
+ (,_eval ',full-name))))
+ (,_set! ,alias ,_tmp)
+ (,_apply ,_tmp ,_args))))))
+ procs))))))
+
+)
ADDED autoload/autoload.setup
Index: autoload/autoload.setup
==================================================================
--- /dev/null
+++ autoload/autoload.setup
@@ -0,0 +1,7 @@
+
+(compile -s -O2 -j autoload autoload.scm)
+(compile -s -O2 autoload.import.scm)
+
+(install-extension
+ 'autoload '("autoload.so" "autoload.import.so")
+ '((version 3.0) (syntax)))
ADDED call-with-environment-variables/call-with-environment-variables-core.scm
Index: call-with-environment-variables/call-with-environment-variables-core.scm
==================================================================
--- /dev/null
+++ call-with-environment-variables/call-with-environment-variables-core.scm
@@ -0,0 +1,25 @@
+(define (call-with-environment-variables variables thunk)
+ @("Sets up environment variable via dynamic-wind which are taken down after thunk."
+ (variables "An alist of the form {{'((\"var\" . \"value\") ...)}}")
+ (thunk "The thunk to execute with a modified environment"))
+ (let ((pre-existing-variables
+ (map (lambda (var-value)
+ (let ((var (car var-value)))
+ (cons var (get-environment-variable var))))
+ variables)))
+ (dynamic-wind
+ (lambda () (void))
+ (lambda ()
+;; (use posix)
+ (for-each (lambda (var-value)
+ (setenv (car var-value) (cdr var-value)))
+ variables)
+ (thunk))
+ (lambda ()
+ (for-each (lambda (var-value)
+ (let ((var (car var-value))
+ (value (cdr var-value)))
+ (if value
+ (setenv var value)
+ (unsetenv var))))
+ pre-existing-variables)))))
ADDED call-with-environment-variables/call-with-environment-variables.meta
Index: call-with-environment-variables/call-with-environment-variables.meta
==================================================================
--- /dev/null
+++ call-with-environment-variables/call-with-environment-variables.meta
@@ -0,0 +1,11 @@
+((synopsis "Set up and take down environment vars")
+ (author "Peter Danenberg")
+ (email "pcd@roxygen.org")
+ (user "klutometis")
+ (repo "https://github.com/klutometis/call-with-environment-variables")
+ (category os)
+ (license "BSD")
+ (depends (hahn "0.9.3")
+ setup-helper)
+ (test-depends test)
+ (foreign-depends))
ADDED call-with-environment-variables/call-with-environment-variables.release-info
Index: call-with-environment-variables/call-with-environment-variables.release-info
==================================================================
--- /dev/null
+++ call-with-environment-variables/call-with-environment-variables.release-info
@@ -0,0 +1,10 @@
+(repo git "git://github.com/klutometis/{egg-name}.git")
+(uri targz "https://github.com/klutometis/{egg-name}/tarball/{egg-release}")
+(release "0.1")
+(release "0.1.1")
+(release "0.1.2")
+(release "0.1.3")
+(release "0.1.4")
+(release "0.1.5")
+(release "0.1.6")
+(release "0.1.7")
ADDED call-with-environment-variables/call-with-environment-variables.scm
Index: call-with-environment-variables/call-with-environment-variables.scm
==================================================================
--- /dev/null
+++ call-with-environment-variables/call-with-environment-variables.scm
@@ -0,0 +1,10 @@
+(module
+ call-with-environment-variables
+ (call-with-environment-variables)
+
+ (import scheme
+ chicken.base
+ chicken.process-context
+ )
+
+ (include "call-with-environment-variables/call-with-environment-variables-core.scm"))
ADDED call-with-environment-variables/call-with-environment-variables.setup
Index: call-with-environment-variables/call-with-environment-variables.setup
==================================================================
--- /dev/null
+++ call-with-environment-variables/call-with-environment-variables.setup
@@ -0,0 +1,10 @@
+(use hahn setup-helper-mod)
+
+(verify-extension-name "call-with-environment-variables")
+
+(setup-shared-extension-module
+ 'call-with-environment-variables
+ (extension-version "0.1.6")
+ compile-options: '(-X hahn))
+
+(run-hahn -o call-with-environment-variables.wiki call-with-environment-variables-core.scm)
ADDED call-with-environment-variables/call-with-environment-variables.wiki
Index: call-with-environment-variables/call-with-environment-variables.wiki
==================================================================
--- /dev/null
+++ call-with-environment-variables/call-with-environment-variables.wiki
@@ -0,0 +1,54 @@
+== call-with-environment-variables
+
+Set up and take down environment vars
+[[toc:]]
+=== {{call-with-environment-variables}}
+(call-with-environment-variables variables thunk) → unspecified
+Sets up environment variable via dynamic-wind which are taken down after thunk.
+; {{variables}} : An alist of the form {{'(("var" . "value") ...)}}
+; {{thunk}} : The thunk to execute with a modified environment
+(define (call-with-environment-variables variables thunk)
+ (let ((pre-existing-variables
+ (map (lambda (var-value)
+ (let ((var (car var-value)))
+ (cons var (get-environment-variable var))))
+ variables)))
+ (dynamic-wind
+ (lambda () (void))
+ (lambda ()
+ (use posix)
+ (for-each
+ (lambda (var-value) (setenv (car var-value) (cdr var-value)))
+ variables)
+ (thunk))
+ (lambda ()
+ (for-each
+ (lambda (var-value)
+ (let ((var (car var-value)) (value (cdr var-value)))
+ (if value (setenv var value) (unsetenv var))))
+ pre-existing-variables)))))
+
+=== About this egg
+
+==== Author
+
+[[/users/klutometis|Peter Danenberg]]
+==== Repository
+[[https://github.com/klutometis/call-with-environment-variables]]
+==== License
+BSD
+==== Dependencies
+* [[(hahn 0.9.3)]]
+* [[setup-helper]]
+
+==== Versions
+; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1|0.1]] : Initial release
+; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.1|0.1.1]] : Add the actual code.
+; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.2|0.1.2]] : Fix versions.
+; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.3|0.1.3]] : Update docs.
+; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.4|0.1.4]] : With a note about cock-utils
+; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.5|0.1.5]] : Docs
+; [[https://github.com/klutometis/call-with-environment-variables/releases/tag/0.1.6|0.1.6]] : Use hahn.
+==== Colophon
+
+Documented by [[/egg/hahn|hahn]].
Index: cgisetup/models/pgdb.scm
==================================================================
--- cgisetup/models/pgdb.scm
+++ cgisetup/models/pgdb.scm
@@ -16,25 +16,25 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;======================================================================
-(declare (unit pgdb))
-(declare (uses configf))
-
-;; I don't know how to mix compilation units and modules, so no module here.
-;;
-;; (module pgdb
-;; (
-;; open-pgdb
-;; )
-;;
-;; (import scheme)
-;; (import data-structures)
-;; (import chicken)
-
-(use typed-records (prefix dbi dbi:))
+;; (declare (unit pgdb))
+;; (declare (uses configf))
+;;
+;; ;; I don't know how to mix compilation units and modules, so no module here.
+;; ;;
+;; ;; (module pgdb
+;; ;; (
+;; ;; open-pgdb
+;; ;; )
+;; ;;
+;; ;; (import scheme)
+;; ;; (import data-structures)
+;; ;; (import chicken)
+;;
+;; (use typed-records (prefix dbi dbi:))
;; given a configdat lookup the connection info and open the db
;;
(define (pgdb:open configdat #!key (dbname #f)(dbispec #f))
(let ((pgconf (or dbispec
Index: client.scm
==================================================================
--- client.scm
+++ client.scm
@@ -18,22 +18,22 @@
;;======================================================================
;; C L I E N T S
;;======================================================================
-(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5
- message-digest matchable spiffy uri-common intarweb http-client
- spiffy-request-vars uri-common intarweb directory-utils)
-
-(declare (unit client))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-
-(include "common_records.scm")
-(include "db_records.scm")
+;; (use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5
+;; message-digest matchable spiffy uri-common intarweb http-client
+;; spiffy-request-vars uri-common intarweb directory-utils)
+;;
+;; (declare (unit client))
+;;
+;; (declare (uses common))
+;; (declare (uses db))
+;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
+;;
+;; (include "common_records.scm")
+;; (include "db_records.scm")
;; client:get-signature
(define (client:get-signature)
(if *my-client-signature* *my-client-signature*
(let ((sig (conc (get-host-name) " " (current-process-id))))
@@ -123,8 +123,8 @@
)))
(begin ;; no server registered
;; (server:kind-run areapath)
(server:start-and-wait areapath)
(debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries)
- (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms.
+ (thread-sleep! 1) ;; (+ 5 (pseudo-random-integer (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms.
(client:setup-http areapath remaining-tries: (- remaining-tries 1)))))))))
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -16,24 +16,24 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;======================================================================
-(use srfi-1 data-structures posix regex-case (prefix base64 base64:)
- format dot-locking csv-xml z3 udp ;; sql-de-lite
- hostinfo md5 message-digest typed-records directory-utils stack
- matchable regex posix (srfi 18) extras ;; tcp
- (prefix nanomsg nmsg:)
- (prefix sqlite3 sqlite3:)
- pkts (prefix dbi dbi:)
- )
-
-(declare (unit common))
-;; (declare (uses commonmod))
-;; (import commonmod)
-
-(include "common_records.scm")
+;; (use srfi-1 data-structures posix regex-case (prefix base64 base64:)
+;; format dot-locking csv-xml z3 udp ;; sql-de-lite
+;; hostinfo md5 message-digest typed-records directory-utils stack
+;; matchable regex posix (srfi 18) extras ;; tcp
+;; (prefix nanomsg nmsg:)
+;; (prefix sqlite3 sqlite3:)
+;; pkts (prefix dbi dbi:)
+;; )
+;;
+;; (declare (unit common))
+;; ;; (declare (uses commonmod))
+;; ;; (import commonmod)
+;;
+;; (include "common_records.scm")
;; (require-library margs)
;; (include "margs.scm")
@@ -199,26 +199,31 @@
;; Miscellaneous
(define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers
(define *numcpus-cache* (make-hash-table))
-(use posix-extras pathname-expand files)
+;; (use posix-extras pathname-expand files)
;; this plugs a hole in posix-extras in recent chicken versions > 4.9)
-(let-values (( (chicken-release-number chicken-major-version)
- (apply values
- (map string->number
- (take
- (string-split (chicken-version) ".")
- 2)))))
- (let ((resolve-pathname-broken?
- (or (> chicken-release-number 4)
- (and (eq? 4 chicken-release-number) (> chicken-major-version 9)))))
- (if resolve-pathname-broken?
- (define ##sys#expand-home-path pathname-expand))))
-
-(define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) ))
+;; (let-values (( (chicken-release-number chicken-major-version)
+;; (apply values
+;; (map string->number
+;; (take
+;; (string-split (chicken-version) ".")
+;; 2)))))
+;; (let ((resolve-pathname-broken?
+;; (or (> chicken-release-number 4)
+;; (and (eq? 4 chicken-release-number) (> chicken-major-version 9)))))
+;; (if resolve-pathname-broken?
+;; (define ##sys#expand-home-path pathname-expand))))
+
+;; (define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) ))
+;; (define (realpath x)(pathname-expand (or x "/dev/null")) )
+(define (realpath x)
+ (with-input-from-pipe
+ (string-append "readlink -f \""x"\"")
+ read-line))
(define (common:get-this-exe-fullpath #!key (argv (argv)))
(let* ((this-script
(cond
((and (> (length argv) 2)
@@ -592,11 +597,11 @@
(define (common:exit-on-version-changed)
(if (common:on-homehost?)
(if (common:api-changed?)
(let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
(dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
- (read-only (not (file-write-access? dbfile)))
+ (read-only (not (file-writable? dbfile)))
(dbstruct (db:setup #t)))
(debug:print 0 *default-log-port*
"WARNING: Version mismatch!\n"
" expected: " (common:version-signature) "\n"
" got: " (common:get-last-run-version))
@@ -1205,11 +1210,11 @@
(if (null? dirs)
#f
(let loop ((hed (car dirs))
(tal (cdr dirs)))
(let ((res (or (and (directory? hed)
- (file-write-access? hed)
+ (file-writable? hed)
hed)
(handle-exceptions
exn
(begin
(debug:print-info 0 *default-log-port* "could not create " hed
@@ -1362,11 +1367,11 @@
exn
(begin
(debug:print 0 *default-log-port* "Failed to identify access to " path-string ", exn=" exn)
#f)
(if (and (directory-exists? path-string)
- (file-write-access? path-string))
+ (file-writable? path-string))
path-string
#f)))
(define (common:get-linktree)
(or (getenv "MT_LINKTREE")
@@ -1469,11 +1474,11 @@
((condition-property-accessor 'exn 'message) exn))
(exit 1)))
(let ((hhf (conc *toppath* "/.homehost")))
(if (common:file-exists? hhf)
(with-input-from-file hhf read-line)
- (if (file-write-access? *toppath*)
+ (if (file-writable? *toppath*)
(begin
(with-output-to-file hhf
(lambda ()
(print bestadrs)))
(begin
@@ -1856,11 +1861,11 @@
(delfile (lambda (exn)
(debug:print-info 1 *default-log-port* " removing bad file " fullpath ", exn=" exn)
(delete-file* fullpath)
#f)))
(if (and (file-exists? fullpath)
- (file-read-access? fullpath))
+ (file-readable? fullpath))
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "failed to get cached info from " fullpath ", exn=" exn)
#f)
@@ -2162,11 +2167,11 @@
(define (common:get-num-cpus remote-host)
(let* ((actual-host (or remote-host (get-host-name))))
;; hosts had better not be changing the number of cpus too often!
(or (hash-table-ref/default *numcpus-cache* actual-host #f)
- (let* ((numcpus (or (common:get-cached-info actual-host "num-cpus" age: (+ 2592000 (random 3600)))
+ (let* ((numcpus (or (common:get-cached-info actual-host "num-cpus" age: (+ 2592000 (pseudo-random-integer 3600)))
(let* ((proc (lambda ()
(let loop ((numcpu 0)
(inl (read-line)))
(if (eof-object? inl)
(if (> numcpu 0)
@@ -2194,11 +2199,11 @@
(define (common:wait-for-normalized-load maxnormload msg remote-host #!optional (rem-tries 5))
(let ((num-cpus (common:get-num-cpus remote-host)))
(if num-cpus
(common:wait-for-cpuload maxnormload num-cpus 15 msg: msg remote-host: remote-host)
(begin
- (thread-sleep! (random 60)) ;; we failed to get num cpus. wait a bit and try again
+ (thread-sleep! (pseudo-random-integer 60)) ;; we failed to get num cpus. wait a bit and try again
(if (> rem-tries 0)
(common:wait-for-normalized-load maxnormload msg remote-host (- rem-tries 1))
#f)))))
;;======================================================================
@@ -2273,11 +2278,11 @@
;; overloaded and count expired (i.e. went to zero)
(else
(if (> num-tries 0) ;; should be "num-tries-left".
(if (common:low-noise-print 30 (conc (round effective-load) "-load-acceptable-" effective-host))
(debug:print 0 *default-log-port* "Load on " effective-host " is acceptable at effective normalized load of "
- effective-normalized-load " continuing."))
+ normalized-effective-load " continuing."))
(debug:print 0 *default-log-port* "Load on " effective-host ", "
first" could not be retrieved. Giving up and continuing."))))))
;;======================================================================
;; DO NOT CALL THIS DIRECTLY. It is called from common:wait-for-normalized-load
@@ -2303,11 +2308,11 @@
;; 0
;; next))) ;; we will force a conservative calculation any time next is large.
;; (first-next-avg (/ (+ first next) 2))
;; ;; add some randomness to the time to break any alignment
;; ;; where netbatch dumps many jobs to machines simultaneously
-;; (adjwait (min (+ 300 (random 10)) (abs (* (+ (random 10)
+;; (adjwait (min (+ 300 (pseudo-random-integer 10)) (abs (* (+ (pseudo-random-integer 10)
;; (/ (- 1000 count) 10)
;; waitdelay)
;; (- first adjmaxload) ))))
;; (load-jump-limit (configf:lookup-number *configdat* "setup" "load-jump-limit"))
;; ;; effective load accounts for load jumps, this should elminate all the first-next-avg, adjwait, load-jump-limit
@@ -2317,11 +2322,11 @@
;; (normalized-effective-load (/ effective-load numcpus))
;; (will-wait (> normalized-effective-load maxload)))
;;
;; ;; let's let the user know once in a long while that load checking
;; ;; is happening but not constantly report it
-;; #;(if (common:low-noise-print 30 (conc "cpuload" (or remote-host "localhost"))) ;; (> (random 100) 75) ;; about 25% of the time
+;; #;(if (common:low-noise-print 30 (conc "cpuload" (or remote-host "localhost"))) ;; (> (pseudo-random-integer 100) 75) ;; about 25% of the time
;; (debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload
;; ", load: " first ", adjmaxload: " adjmaxload ", loadjmp: " loadjmp))
;;
;; (debug:print-info 1 *default-log-port*
;; "On host: " effective-host
@@ -2505,11 +2510,11 @@
(freespc (cond
((not (directory? dirpath))
(if (common:low-noise-print 300 "disks not a dir " disk-num)
(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it."))
-1)
- ((not (file-write-access? dirpath))
+ ((not (file-writable? dirpath))
(if (common:low-noise-print 300 "disks not writeable " disk-num)
(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it."))
-1)
((not (eq? (string-ref dirpath 0) #\/))
(if (common:low-noise-print 300 "disks not a proper path " disk-num)
@@ -2520,11 +2525,11 @@
(free-inodes (cond
((not (directory? dirpath))
(if (common:low-noise-print 300 "disks not a dir " disk-num)
(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it."))
-1)
- ((not (file-write-access? dirpath))
+ ((not (file-writable? dirpath))
(if (common:low-noise-print 300 "disks not writeable " disk-num)
(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it."))
-1)
((not (eq? (string-ref dirpath 0) #\/))
(if (common:low-noise-print 300 "disks not a proper path " disk-num)
@@ -3496,11 +3501,11 @@
(cond
((not (common:file-exists? pktsdir))
(debug:print 0 *default-log-port* "ERROR: packets directory " pktsdir " does not exist."))
((not (directory? pktsdir))
(debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not a directory."))
- ((not (file-read-access? pktsdir))
+ ((not (file-readable? pktsdir))
(debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not readable."))
(else
(debug:print-info 0 *default-log-port* "Loading packets found in " pktsdir)
(let ((pkts (glob (conc pktsdir "/*.pkt"))))
(for-each
@@ -3611,10 +3616,28 @@
#t) ;; just ignore it, it might have died in the meantime so joining it will throw an exception
(thread-join! thread))
)))
(hash-table-keys *common:thread-punchlist*)))
+(define (dtests:get-pre-command #!key (default-override #f))
+ (let* ((orig-pre-command "export CMD='")
+ (viewscreen-pre-command "viewscreen ")
+ (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen"))
+ (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command))
+ (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command")))
+ (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \""))
+
+
+(define (dtests:get-post-command #!key (default-override #f))
+ (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&"
+ "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))
+ (viewscreen-post-command "")
+ (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen"))
+ (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command))
+ (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command")))
+ (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
+
;;======================================================================
;; (define *common:telemetry-log-state* 'startup)
;; (define *common:telemetry-log-socket* #f)
;;
;; (define (common:telemetry-log-open)
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -20,17 +20,17 @@
;;======================================================================
;; Config file handling
;;======================================================================
-(use regex regex-case matchable) ;; directory-utils)
-(declare (unit configf))
-(declare (uses process))
-(declare (uses env))
-(declare (uses keys))
-
-(include "common_records.scm")
+;; (use regex regex-case matchable) ;; directory-utils)
+;; (declare (unit configf))
+;; (declare (uses process))
+;; (declare (uses env))
+;; (declare (uses keys))
+;;
+;; (include "common_records.scm")
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
(if toppath
(let ((cfname (conc toppath "/" configname)))
@@ -358,11 +358,11 @@
(configf:script-rx ( x include-script params);; handle-exceptions
;; exn
;; (begin
;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.")
;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
- (if (and (common:file-exists? include-script)(file-execute-access? include-script))
+ (if (and (common:file-exists? include-script)(file-executable? include-script))
(let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections))
(env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system))
(new-inp-port
(common:with-env-vars
env-delta
@@ -717,11 +717,11 @@
;; returns (list dat msg)
(define (configf:read-refdb refdb-path)
(let ((sheets-file (conc refdb-path "/sheet-names.cfg")))
(if (not (common:file-exists? sheets-file))
(list #f (conc "ERROR: no refdb found at " refdb-path))
- (if (not (file-read-access? sheets-file))
+ (if (not (file-readable? sheets-file))
(list #f (conc "ERROR: refdb file not readable at " refdb-path))
(let* ((sheets (with-input-from-file sheets-file
(lambda ()
(let loop ((inl (read-line))
(res '()))
ADDED csv-xml/csv-out.impl
Index: csv-xml/csv-out.impl
==================================================================
--- /dev/null
+++ csv-xml/csv-out.impl
@@ -0,0 +1,261 @@
+;;;; cvs-out.impl -*- Hen -*-
+;;;; Kon Lovett, Jun '17
+
+;;;; *** included source file ***
+
+;;Issues
+;;
+;;- missing explicit types for exports; too much '*' type
+
+;;
+
+(define-constant CRLF-STR "\r\n")
+(define-constant LF-STR "\n")
+(define-constant CR-STR "\r") ;old MacOS
+
+(define *system-newline*
+ (cond-expand
+ (windows
+ CRLF-STR )
+ (unix
+ LF-STR )
+ (else
+ LF-STR ) ) )
+
+(define-constant +newline-char-default+ #t) ;#t - | #\n | ...
+(define-constant +separator-char-default+ #\,)
+(define-constant +quote-char-default+ #\") ;#f | #\" | ...
+(define-constant +comment-char-default+ #\#) ;#f | #\# | ...
+(define-constant +quote-doubling-escapes?-default+ #t)
+(define-constant +quote-controls?-default+ #t)
+(define-constant +always-quote?-default+ #t)
+
+#|
+(define-constant +sxml-top-symbol+ '|*TOP*|)
+(define-constant +sxml-row-element-default+ 'row)
+(define-constant +sxml-col-elements-limit-default+ 32) ; arbitrary (see csv.ss)
+|#
+
+;;
+
+;very loose : newline-char | separator-char | quote-char
+;see "csv-xml.scm"
+(define csv-writer-spec? alist?)
+(define-check+error-type csv-writer-spec)
+
+(define csv-writer? procedure?)
+(define-check+error-type csv-writer)
+
+;;
+
+(define *default-writer-spec* (writer-spec-with-defaults '()))
+
+(define (list->csv ls #!optional (writer-or-out (current-output-port)))
+ (let (
+ (writer
+ (cond
+ ((csv-writer? writer-or-out)
+ writer-or-out )
+ ((output-port? writer-or-out)
+ (make-csv-line-writer 'list->csv writer-or-out *default-writer-spec*) )
+ (else
+ (error 'list->csv "invalid csv-writer or output-port" writer-or-out) ) ) ) )
+ (for-each writer ls) ) )
+
+#|
+;;
+
+(define (list->sxml ls
+ #!optional
+ (row-element (sxml-row-element-default))
+ (column-elements (sxml-col-elements-default))
+ (writer-spec *default-writer-spec*))
+ (append!
+ `(,(sxml-top-symbol))
+ (map (cut list->sxml-element <> row-element column-elements writer-spec) ls)) )
+|#
+
+;;
+
+(define (writer-spec
+ #!key
+ (newline-char +newline-char-default+)
+ (separator-char +separator-char-default+)
+ (quote-char +quote-char-default+)
+ (comment-char +comment-char-default+)
+ (quote-doubling-escapes? +quote-doubling-escapes?-default+)
+ (quote-controls? +quote-controls?-default+)
+ (always-quote? +always-quote?-default+))
+ ;FIXME checking the input types
+ `((newline-char . ,newline-char)
+ (separator-char . ,separator-char)
+ (quote-char . ,quote-char)
+ (comment-char . ,comment-char)
+ (quote-doubling-escapes? . ,quote-doubling-escapes?)
+ (quote-controls? . ,quote-controls?)
+ (always-quote? . ,always-quote?)) )
+
+;;
+
+(define (make-csv-writer out-or-str #!optional (writer-spec '()))
+ (let ((make-spec-csv-writer (make-csv-writer-maker writer-spec)))
+ (make-spec-csv-writer out-or-str) ) )
+
+(define (make-csv-writer-maker #!optional (writer-spec '()))
+ (let ((writer-spec
+ (writer-spec-with-defaults
+ (check-csv-writer-spec 'make-csv-writer-maker writer-spec)) ) )
+ (lambda (out-or-str)
+ (let (
+ (out
+ (cond
+ ((string? out-or-str)
+ (open-output-file out-or-str) )
+ ((output-port? out-or-str)
+ out-or-str )
+ (else
+ (error
+ 'csv-writer-maker
+ "invalid output-port or string" out-or-str) ) ) ) )
+ (make-csv-line-writer 'csv-writer-maker out writer-spec) ) ) ) )
+
+;;
+
+(define (make-csv-line-writer loc out writer-spec)
+ (let (
+ (writer-spec
+ (check-csv-writer-spec loc writer-spec) )
+ (newline-obj
+ (select-newline-object loc (alist-ref 'newline-char writer-spec eq?)) )
+ (separator-char
+ (alist-ref 'separator-char writer-spec eq?) )
+ (quote-char
+ (alist-ref 'quote-char writer-spec eq?) )
+ (comment-char
+ (alist-ref 'comment-char writer-spec eq?) )
+ (quote-doubling-escapes?
+ (alist-ref 'quote-doubling-escapes? writer-spec eq?) )
+ (quote-controls?
+ (alist-ref 'quote-controls? writer-spec eq?) )
+ (always-quote?
+ (alist-ref 'always-quote? writer-spec eq?) ) )
+ ;
+ (let* (
+ (quote-char-str (unicode-char->string quote-char) )
+ (quote-char-str-2 (string-append quote-char-str quote-char-str)) )
+ ;
+ (define (csv-line-object->string obj)
+ ;
+ (define (quote-doubling? str)
+ (and quote-doubling-escapes? (string-index str quote-char)) )
+ ;
+ (define (quoting? str)
+ (or
+ always-quote?
+ (quote-doubling? str)
+ (and separator-char (string-index str separator-char))
+ (and quote-controls? (string-index str char-set:iso-control))) )
+ ;
+ (type-case obj
+ ((char)
+ (csv-line-object->string (unicode-char->string obj)) )
+ ((symbol)
+ (csv-line-object->string (symbol->string obj)) )
+ ((string)
+ (if (and quote-char (quoting? obj))
+ (let (
+ (str
+ (if (quote-doubling? obj)
+ (string-translate* obj `((,quote-char-str . ,quote-char-str-2)))
+ obj ) ) )
+ ;
+ (conc quote-char str quote-char) )
+ obj ) )
+ (number
+ (csv-line-object->string (number->string obj)) )
+ (else
+ (csv-line-object->string (->string obj)) ) ) )
+ ;
+ (lambda (obj)
+ (let (
+ ;build row to output as a string with a line-ending sequence
+ (lin
+ ;comment desired?
+ (if (list? obj)
+ ;row data
+ (let ((qstrs (map csv-line-object->string (check-list loc obj))))
+ (apply
+ conc
+ (append!
+ (intersperse qstrs separator-char)
+ `(,newline-obj))) )
+ ;are we supposed to do comments?
+ (if comment-char
+ (conc comment-char obj newline-obj)
+ obj
+ #;
+ (begin
+ (warning loc "comments not active" obj writer-spec)
+ "" ) ) ) ) )
+ ;
+ (display lin out) ) ) ) ) )
+
+;;
+
+(define (select-newline-object loc spec)
+ (case spec
+ ((cr)
+ #\return )
+ ((lf)
+ #\newline )
+ ((crlf)
+ CRLF-STR )
+ (else
+ *system-newline* ) ) )
+
+;;
+
+(define (writer-spec-with-defaults writer-spec)
+ `((newline-char . ,(alist-ref 'newline-char writer-spec eq? +newline-char-default+))
+ (separator-char . ,(alist-ref 'separator-char writer-spec eq? +separator-char-default+))
+ (quote-char . ,(alist-ref 'quote-char writer-spec eq? +quote-char-default+))
+ (comment-char . ,(alist-ref 'comment-char writer-spec eq? +comment-char-default+))
+ (quote-doubling-escapes? . ,(alist-ref 'quote-doubling-escapes? writer-spec eq? +quote-doubling-escapes?-default+))
+ (quote-controls? . ,(alist-ref 'quote-controls? writer-spec eq? +quote-controls?-default+))
+ (always-quote? . ,(alist-ref 'always-quote? writer-spec eq? +always-quote?-default+))) )
+
+#|
+;;
+
+(define (list->sxml-element ls row-element col-elements writer-spec)
+ (if (list? ls)
+ ;row data
+ `(,row-element ,@(map list col-elements (map ->string ls)))
+ ;are we supposed to do comments?
+ (if (alist-ref 'comment-char writer-spec eq?)
+ `(*COMMENT* ,(->string ls))
+ ls ) ) )
+
+(define (make-sxml-col-symbol n)
+ (string->symbol (string-append "col-" (number->string n))) )
+
+(define +sxml-col-elements-default+
+ (map make-sxml-col-symbol (sxml-col-iota)) )
+
+(define (sxml-top-symbol)
+ +sxml-top-symbol+ )
+
+(define (sxml-row-element-default)
+ +sxml-row-element-default+ )
+
+(define (sxml-col-elements-default)
+ +sxml-col-elements-default+ )
+
+(define (sxml-col-iota)
+ (iota +sxml-col-elements-limit-default+) )
+#;
+(define (sxml-col-iota)
+ (do ((i 0 add1)
+ (ls '() (cons (make-sxml-col-symbol i) ls)) )
+ ((= i +sxml-col-elements-limit-default+) ls) ) )
+|#
ADDED csv-xml/csv-xml.meta
Index: csv-xml/csv-xml.meta
==================================================================
--- /dev/null
+++ csv-xml/csv-xml.meta
@@ -0,0 +1,19 @@
+;;;; csv-xml.meta -*- Hen -*-
+
+((egg "csv-xml.egg")
+ (date "2011-07-02")
+ (category parsing)
+ (author "Neil van Dyke")
+ (license "LGPL 3")
+ (doc-from-wiki)
+ (synopsis "Parsing comma-separated values")
+ (depends
+ (setup-helper "1.5.2")
+ (check-errors "2.0.2")
+ (moremacros "1.4.2")
+ (string-utils "1.5.5"))
+ (test-depends testeez test)
+ (files
+ "csv-xml.meta" "csv-xml.setup"
+ "csv-xml.scm" "csv-out.impl" "csv.ss"
+ "test/run.scm" "test/test-csv.ss") )
ADDED csv-xml/csv-xml.scm
Index: csv-xml/csv-xml.scm
==================================================================
--- /dev/null
+++ csv-xml/csv-xml.scm
@@ -0,0 +1,118 @@
+;;;; csv-xml.scm -*- Hen -*-
+;;;; Kon Lovett, Jun '17
+;;;; Kon Lovett, ??? '??
+
+(module csv-xml
+
+(;export
+ ;
+ reader-spec
+ ;
+ make-csv-reader
+ make-csv-reader-maker
+ ;
+ csv->list
+ csv->sxml
+ csv-for-each
+ csv-map
+ ;
+ csv-reader? check-csv-reader error-csv-reader
+ csv-reader-spec? check-csv-reader-spec error-csv-reader-spec
+ ;
+ writer-spec
+ ;
+ make-csv-writer-maker
+ make-csv-writer
+ ;
+ list->csv
+ #;list->sxml
+ ;
+ csv-writer? check-csv-writer error-csv-writer
+ csv-writer-spec? check-csv-writer-spec error-csv-writer-spec)
+
+(import scheme
+ chicken.base
+ chicken.string
+
+ moremacros
+ srfi-1
+ srfi-13
+ srfi-14
+ type-checks
+ unicode-utils
+ )
+
+#;(import (except chicken provide))
+;; (import chicken)
+
+;;;
+
+;Need to process `#lang' as well. So just "commented out" the "offending"
+;sections in the source.
+#;(define-syntax provide (syntax-rules () ((_ ?x0 ...) (begin))))
+(define null '())
+
+(include "csv-xml/csv.ss")
+
+;;;
+
+;; (import (only data-structures conc intersperse ->string alist-ref string-translate*))
+;; (require-library data-structures)
+;;
+;; #;(import (only list-utils alist?))
+;; (import (only (srfi 1) every iota append! map))
+;; (require-library (srfi 1))
+;;
+;; (import (only (srfi 13) string-index))
+;; (require-library (srfi 13))
+;;
+;; (import (only (srfi 14) char-set:iso-control))
+;; (require-library (srfi 14))
+;;
+;; (import (only type-checks define-check+error-type check-string check-list))
+;; (require-library type-checks)
+;;
+;; (import (only unicode-utils unicode-char->string))
+;; (require-library unicode-utils)
+;;
+;; (require-extension moremacros)
+
+;(from list-utils egg)
+(define (alist? obj)
+ (if (pair? obj)
+ (every pair? obj)
+ (null? obj) ) )
+
+;very loose ...
+(define csv-reader-spec? alist?)
+(define-check+error-type csv-reader-spec)
+
+(define csv-reader? procedure?)
+(define-check+error-type csv-reader)
+
+(define (reader-spec
+ #!key
+ (newline-type 'lax)
+ (separator-chars '(#\,))
+ (quote-char #\")
+ (quote-doubling-escapes? #t)
+ (comment-chars '())
+ (whitespace-chars '(#\space))
+ (strip-leading-whitespace? #f)
+ (strip-trailing-whitespace? #f)
+ (newlines-in-quotes? #t))
+ `((newline-type . ,newline-type)
+ (separator-chars . ,separator-chars)
+ (quote-char . ,quote-char)
+ (quote-doubling-escapes? . ,quote-doubling-escapes?)
+ (comment-chars . ,comment-chars)
+ (whitespace-chars . ,whitespace-chars)
+ (strip-leading-whitespace? . ,strip-leading-whitespace?)
+ (strip-trailing-whitespace? . ,strip-trailing-whitespace?)
+ (newlines-in-quotes? . ,newlines-in-quotes?)) )
+
+;;;
+
+(include "csv-xml/csv-out.impl")
+
+) ;csv-xml
ADDED csv-xml/csv-xml.setup
Index: csv-xml/csv-xml.setup
==================================================================
--- /dev/null
+++ csv-xml/csv-xml.setup
@@ -0,0 +1,12 @@
+;;;; csv-xml.setup -*- Hen -*-
+
+(use setup-helper-mod)
+
+(verify-extension-name "csv-xml")
+
+(setup-shared+static-extension-module (extension-name) (extension-version "0.12.1")
+ #:types? #t
+ #:inline? #t
+ #:compile-options '(
+ -optimize-level 3 -debug-level 2
+ -no-procedure-checks-for-toplevel-bindings -no-procedure-checks-for-usual-bindings))
ADDED csv-xml/csv.ss
Index: csv-xml/csv.ss
==================================================================
--- /dev/null
+++ csv-xml/csv.ss
@@ -0,0 +1,969 @@
+;;; @Package csv
+;;; @Subtitle Comma-Separated Value (CSV) Utilities in Scheme
+;;; @HomePage http://www.neilvandyke.org/csv-scheme/
+;;; @Author Neil Van Dyke
+;;; @Version 0.10
+;;; @Date 2010-04-13
+;;; @PLaneT neil/csv:1:6
+
+;; $Id: csv.ss,v 1.199 2010/04/13 17:56:20 neilpair Exp $
+
+;;; @legal
+;;; Copyright @copyright{} 2004--2009 Neil Van Dyke. This program is Free
+;;; Software; you can redistribute it and/or modify it under the terms of the
+;;; GNU Lesser General Public License as published by the Free Software
+;;; Foundation; either version 3 of the License (LGPL 3), or (at your option)
+;;; any later version. This program is distributed in the hope that it will be
+;;; useful, but without any warranty; without even the implied warranty of
+;;; merchantability or fitness for a particular purpose. See
+;;; @indicateurl{http://www.gnu.org/licenses/} for details. For other licenses
+;;; and consulting, please contact the author.
+;;; @end legal
+
+;#lang scheme/base
+
+;;; @section Introduction
+
+;;; The @b{csv} Scheme library provides utilities for reading various kinds of
+;;; what are commonly known as ``comma-separated value'' (CSV) files. Since
+;;; there is no standard CSV format, this library permits CSV readers to be
+;;; constructed from a specification of the peculiarities of a given variant.
+;;; A default reader handles the majority of formats.
+;;;
+;;; One of the main uses of this library is to import data from old crusty
+;;; legacy applications into Scheme for data conversion and other processing.
+;;; To that end, this library includes various conveniences for iterating over
+;;; parsed CSV rows, and for converting CSV input to the
+;;; @uref{http://pobox.com/~oleg/ftp/Scheme/SXML.html, SXML 3.0} Scheme XML
+;;; format.
+;;;
+;;; This library requires R5RS, SRFI-6, SRFI-23, and an @code{integer->char}
+;;; procedure that accepts ASCII values.
+;;;
+;;; Other implementations of some kind of CSV reading for Scheme include
+;;; Gauche's @code{text.csv} module, and Scsh's @code{record-reader} and
+;;; related procedures. This library intends to be portable and more
+;;; comprehensive.
+
+;; TODO: Briefly introduce terms "row", "column", and "field".
+
+(define-syntax %csv:error
+ (syntax-rules () ((_ p m o)
+ (error (string-append p " : " m) o)
+ ;; Bigloo: (error p m o)
+ )))
+
+(define-syntax %csv:type-error
+ (syntax-rules ()
+ ((_ proc-str expected-str got-value)
+ (%csv:error proc-str
+ (string-append "expected " expected-str ", received:")
+ got-value))))
+
+(define %csv:a2c integer->char)
+
+(define %csv:cr (%csv:a2c 13))
+(define %csv:lf (%csv:a2c 10))
+
+(define-syntax %csv:gosc
+ (syntax-rules ()
+ ((_ os-stx)
+ (let* ((os os-stx)
+ (str (get-output-string os)))
+ (close-output-port os)
+ str))))
+
+(define (%csv:in-arg proc-name in)
+ (cond ((input-port? in) in)
+ ((string? in) (open-input-string in))
+ (else (%csv:type-error proc-name "input port or string" in))))
+
+(define (%csv:reader-or-in-arg proc-name reader-or-in)
+ (cond ((procedure? reader-or-in) reader-or-in)
+ ((input-port? reader-or-in) (make-csv-reader reader-or-in))
+ ((string? reader-or-in) (make-csv-reader (open-input-string
+ reader-or-in)))
+ (else (%csv:type-error proc-name
+ "csv reader or input port or string"
+ reader-or-in))))
+
+;;; @section Reader Specs
+
+;;; CSV readers are constructed using @dfn{reader specs}, which are sets of
+;;; attribute-value pairs, represented in Scheme as association lists keyed on
+;;; symbols. Each attribute has a default value if not specified otherwise.
+;;; The attributes are:
+
+;;; @table @code
+;;;
+;;; @item newline-type
+;;; Symbol representing the newline, or record-terminator, convention. The
+;;; convention can be a fixed character sequence (@code{lf}, @code{crlf}, or
+;;; @code{cr}, corresponding to combinations of line-feed and carriage-return),
+;;; any string of one or more line-feed and carriage-return characters
+;;; (@code{lax}), or adaptive (@code{adapt}). @code{adapt} attempts to detect
+;;; the newline convention at the start of the input and assume that convention
+;;; for the remainder of the input. Default: @code{lax}
+;;;
+;;; @item separator-chars
+;;; Non-null list of characters that serve as field separators. Normally, this
+;;; will be a list of one character. Default: @code{(#\,)} (list of the comma
+;;; character)
+;;;
+;;; @item quote-char
+;;; Character that should be treated as the quoted field delimiter character,
+;;; or @code{#f} if fields cannot be quoted. Note that there can be only one
+;;; quote character. Default: @code{#\"} (double-quote)
+;;;
+;;; @item quote-doubling-escapes?
+;;; Boolean for whether or not a sequence of two @code{quote-char} quote
+;;; characters within a quoted field constitute an escape sequence for
+;;; including a single @code{quote-char} within the string. Default: @code{#t}
+;;;
+;;; @item comment-chars
+;;; List of characters, possibly null, which comment out the entire line of
+;;; input when they appear as the first character in a line. Default:
+;;; @code{()} (null list)
+;;;
+;;; @item whitespace-chars
+;;; List of characters, possibly null, that are considered @dfn{whitespace}
+;;; constituents for purposes of the @code{strip-leading-whitespace?} and
+;;; @code{strip-trailing-whitespace?} attributes described below.
+;;; Default: @code{(#\space)} (list of the space character)
+;;;
+;;; @item strip-leading-whitespace?
+;;; Boolean for whether or not leading whitespace in fields should be
+;;; stripped. Note that whitespace within a quoted field is never stripped.
+;;; Default: @code{#f}
+;;;
+;;; @item strip-trailing-whitespace?
+;;; Boolean for whether or not trailing whitespace in fields should be
+;;; stripped. Note that whitespace within a quoted field is never stripped.
+;;; Default: @code{#f}
+;;;
+;;; @item newlines-in-quotes?
+;;; Boolean for whether or not newline sequences are permitted within quoted
+;;; fields. If true, then the newline characters are included as part of the
+;;; field value; if false, then the newline sequence is treated as a premature
+;;; record termination. Default: @code{#t}
+;;;
+;;; @end table
+
+;; TODO: Do not expose this procedure for now. We expect it to go away and be
+;; replaced with two other procedures.
+;;
+;; @defproc %csv:csv-spec-derive orig-spec changes
+;;
+;; Yields a new CSV spec that is derived from @var{orig-spec} by applying spec
+;; @var{changes} as attribute substitions and additions to the original. For
+;; example, given an original CSV reader spec:
+;;
+;; @lisp
+;; (define my-first-csv-spec
+;; '((newline-type . lax)
+;; (separator-chars . (#\,))
+;; (quote-char . #\")
+;; (quote-doubling-escapes? . #t)
+;; (whitespace-chars . (#\space))))
+;; @end lisp
+;;
+;; a derived spec with a different @code{separator-chars} attribute and an
+;; added @code{comment-chars} attribute can be created like:
+;;
+;; @lisp
+;; (%csv:csv-spec-derive my-first-csv-spec
+;; '((separator-chars . (#\%))
+;; (comment-chars . (#\#))))
+;; @result{}
+;; ((separator-chars . (#\%))
+;; (comment-chars . (#\#))
+;; (newline-type . lax)
+;; (quote-char . #\")
+;; (quote-doubling-escapes? . #t)
+;; (whitespace-chars . (#\space)))
+;; @end lisp
+;;
+;; In that the yielded spec might share some structure with @var{orig-spec}
+;; and/or @var{changes}. Most applications will not use this procedure
+;; directly.
+
+(define (%csv:csv-spec-derive orig-spec changes)
+ ;; TODO: Make this not share structure. Error-check and normalize at the
+ ;; same time we clone.
+ (let ((new-spec '()))
+ (let ((add-to-new-spec
+ (lambda (alist)
+ (for-each (lambda (cell)
+ (or (assq (car cell) new-spec)
+ (set! new-spec (cons cell new-spec))))
+ alist))))
+ (add-to-new-spec changes)
+ (add-to-new-spec orig-spec)
+ (reverse new-spec))))
+
+;;; @section Making Reader Makers
+
+;;; CSV readers are procedures that are constructed dynamically to close over a
+;;; particular CSV input and yield a parsed row value each time the procedure
+;;; is applied. For efficiency reasons, the reader procedures are themselves
+;;; constructed by another procedure, @code{make-csv-reader-maker}, for
+;;; particular CSV reader specs.
+
+(define (%csv:csv-error code extra)
+ ;; TODO: Maybe make the CSV error handler user-specifiable, or allow user to
+ ;; specify some errors that should be disregarded.
+ ;;
+ ;; TODO: Add position information. Keep track of character position while
+ ;; reading.
+ (%csv:error
+ "[csv-reader]"
+ (string-append "Erroneous CSV format: "
+ (case code
+ ((junk-after-quote-close)
+ "Junk after close of quoted field:")
+ (else (string-append "INTERNAL ERROR: Unknown code: "
+ (symbol->string code)))))
+ extra))
+
+(define (%csv:newline-check-step0 newline-type c port)
+ ;; (display "*DEBUG* (equal? newline-type 'lax) = ")
+ ;; (write (equal? newline-type 'lax))
+ ;; (newline)
+ ;; (display "*DEBUG* (eqv? newline-type 'lax) = ")
+ ;; (write (eqv? newline-type 'lax))
+ ;; (newline)
+ (case newline-type
+ ((cr) (eqv? c %csv:cr))
+ ((lf) (eqv? c %csv:lf))
+ ((crlf) (if (eqv? c %csv:cr)
+ (let ((c2 (peek-char port)))
+ (cond ((eof-object? c2)
+ ;; Note: This is a CR-EOF in an input that uses CR-LF
+ ;; for terminating records. We are discarding the CR,
+ ;; so it will not be added to the field string. We
+ ;; might want to signal an error.
+ #t)
+ ((eqv? c2 %csv:lf)
+ (read-char port)
+ #t)
+ (else #f)))
+ #f))
+ ((lax detect) (cond ((eqv? c %csv:cr)
+ (let ((c2 (peek-char port)))
+ (cond ((eof-object? c2) #t)
+ ((eqv? c2 %csv:lf)
+ (read-char port)
+ 'crlf)
+ (else 'cr))))
+ ((eqv? c %csv:lf) 'lf)
+ (else #f)))
+ (else (%csv:error
+ "%csv:make-portreader/positional"
+ "unrecognized newline-type"
+ newline-type))))
+
+(define %csv:make-portreader/positional
+ (letrec-syntax
+ ((newline-check
+ (syntax-rules ()
+ ((_ newline-type c port detected-newline-type)
+ ;; Note: "port" and "detected-newline-type" must be identifiers.
+ ;; "newline-type" and "c" must be identifiers or self-evals.
+ (if (eqv? newline-type 'detect)
+ (begin (set! detected-newline-type
+ (%csv:newline-check-step0 newline-type c port))
+ detected-newline-type)
+ (%csv:newline-check-step0 newline-type c port)))))
+ (gosc-cons
+ ;; Note: This is to ensure the output string is gotten and closed
+ ;; before consing it with the result of a recursive call.
+ (syntax-rules ()
+ ((_ os b) (let ((s (%csv:gosc os))) (cons s b))))))
+ (lambda (newline-type
+ separator-chars
+ quote-char
+ quote-doubling-escapes?
+ comment-chars
+ whitespace-chars
+ strip-leading-whitespace?
+ strip-trailing-whitespace?
+ newlines-in-quotes?)
+ (lambda (port)
+ (let ((dnlt #f)
+ (escape-char #\\))
+ (let read-fields-or-eof ((c (read-char port)))
+ (cond
+ ((eof-object? c) '())
+ ((and strip-leading-whitespace? (memv c whitespace-chars))
+ ;; It's leading whitespace char when we're ignoring leading
+ ;; whitespace in fields, and there might just be whitespace and
+ ;; then an EOF, which should probably be considered just an EOF
+ ;; rather than a row with one empty field, so just skip this
+ ;; whitespace char.
+ (read-fields-or-eof (read-char port)))
+ ((and (not (null? comment-chars)) (memv c comment-chars))
+ ;; It's a comment char in the first column (or in the first
+ ;; non-whitespace column, if "strip-leading-whitespace?" is
+ ;; true), so skip to end of line.
+ (let ((fake-dnlt #f))
+ (let loop ((c (read-char port)))
+ (cond ((eof-object? c) '())
+ ((newline-check newline-type c port fake-dnlt)
+ (read-fields-or-eof (read-char port)))
+ (else (loop (read-char port)))))))
+ (else
+ ;; It's not going to be just an EOF, so try to read a row.
+ (let ((row
+ (let read-fields ((c c))
+ (cond
+ ;; If an EOF or newline in an unquoted field, consider
+ ;; the field and row finished. (We don't consider EOF
+ ;; before newline to be an error, although perhaps that
+ ;; would be a useful check for a freak premature
+ ;; end-of-input when dealing with "well-formed" CSV).
+ ((or (eof-object? c)
+ (newline-check newline-type c port dnlt))
+ (list ""))
+ ;; If a field separator, finish this field and cons
+ ;; with value of recursive call to get the next field.
+ ((memv c separator-chars)
+ (cons "" (read-fields (read-char port))))
+ ;; If we're ignoring leading whitespace, and it's a
+ ;; whitespace-chars character, then recurse to keep
+ ;; finding the field start.
+ ((and strip-leading-whitespace?
+ (memv c whitespace-chars))
+ (read-fields (read-char port)))
+ ;; If a quote, read a quoted field.
+ ((and quote-char (eqv? c quote-char))
+ (let ((os (open-output-string)))
+ (let loop ((c (read-char port)))
+ (cond
+ ((or (eof-object? c)
+ (and (not newlines-in-quotes?)
+ (newline-check newline-type
+ c port dnlt)))
+ (list (%csv:gosc os)))
+ ((and escape-char (eqv? c escape-char))
+ ;FIXME can become unsynchronized
+ (write-char (read-char port) os)
+ (loop (read-char port)))
+ ((and quote-char (eqv? c quote-char))
+ (if quote-doubling-escapes?
+ (let ((c2 (read-char port)))
+ (if (eqv? c2 quote-char)
+ (begin (write-char c2 os)
+ (loop (read-char port)))
+ (gosc-cons
+ os
+ (let skip-after ((c c2))
+ (cond
+ ((or (eof-object? c)
+ (newline-check
+ newline-type c port dnlt))
+ '())
+ ((memv c separator-chars)
+ (read-fields (read-char port)))
+ ((memv c whitespace-chars)
+ ;; Note: We tolerate
+ ;; whitespace after field
+ ;; close quote even if
+ ;; skip-trailing-whitespace?
+ ;; is false.
+ (skip-after (read-char port)))
+ (else (%csv:csv-error
+ 'junk-after-quote-close
+ c)))))))
+ (gosc-cons os
+ (read-fields (read-char port)))))
+ (else (write-char c os)
+ (loop (read-char port)))))))
+ ;; It's the start of an unquoted field.
+ (else
+ (let ((os (open-output-string)))
+ (write-char c os)
+ (let loop ((c (read-char port)))
+ (cond
+ ((or (eof-object? c)
+ (newline-check newline-type c port dnlt))
+ (list (get-output-string os)))
+ ((memv c separator-chars)
+ (gosc-cons os (read-fields (read-char port))))
+ ((and strip-trailing-whitespace?
+ (memv c whitespace-chars))
+ ;; TODO: Maybe optimize to avoid creating a new
+ ;; output string every time we see whitespace.
+ ;; We could use a string collector with unwrite.
+ ;; And/or do lookahead to see whether whitespace
+ ;; is only one character. Do this after we have
+ ;; a better regression test suite.
+ (let ((ws-os (open-output-string)))
+ (write-char c ws-os)
+ (let ws-loop ((c (read-char port)))
+ (cond
+ ((or (eof-object? c)
+ (newline-check
+ newline-type c port dnlt))
+ (close-output-port ws-os)
+ (list (%csv:gosc os)))
+ ((memv c separator-chars)
+ (close-output-port ws-os)
+ (gosc-cons os (read-fields (read-char
+ port))))
+ ((memv c whitespace-chars)
+ (write-char c ws-os)
+ (ws-loop (read-char port)))
+ (else
+ (display (%csv:gosc ws-os) os)
+ (write-char c os)
+ (loop (read-char port)))))))
+ (else (write-char c os)
+ (loop (read-char port)))))))))))
+ (if (null? row)
+ row
+ (if (eq? newline-type 'detect)
+ (cons dnlt row)
+ row)))))))))))
+
+(define %csv:make-portreader
+ ;; TODO: Make a macro for the three times we list the spec attributes.
+ (letrec ((pb (lambda (x) (if x #t #f)))
+ (pc (lambda (x)
+ (cond ((char? x) x)
+ ((string? x) (case (string-length x)
+ ((1) (string-ref x 0))
+ (else (%csv:type-error
+ "make-csv-reader-maker"
+ "character"
+ x))))
+ (else (%csv:type-error "make-csv-reader-maker"
+ "character"
+ x)))))
+ (pc-f (lambda (x)
+ (cond ((not x) x)
+ ((char? x) x)
+ ((string? x) (case (string-length x)
+ ((0) #f)
+ ((1) (string-ref x 0))
+ (else (%csv:type-error
+ "make-csv-reader-maker"
+ "character or #f"
+ x))))
+ (else (%csv:type-error "make-csv-reader-maker"
+ "character or #f"
+ x)))))
+ (pe (lambda (x acceptable)
+ (if (memq x acceptable)
+ x
+ (%csv:type-error
+ "make-csv-reader-maker"
+ (let ((os (open-output-string)))
+ (display "symbol from the set " os)
+ (write acceptable os)
+ (%csv:gosc os))
+ x))))
+ (plc-n (lambda (x)
+ (or (list? x)
+ (%csv:type-error "make-csv-reader-maker"
+ "list of characters"
+ x))
+ (map pc x)))
+ (plc (lambda (x)
+ (let ((result (plc-n x)))
+ (if (null? result)
+ (%csv:type-error "make-csv-reader-maker"
+ "non-null list of characters"
+ x)
+ result)))))
+ (lambda (reader-spec)
+ (let ((newline-type 'lax)
+ (separator-chars '(#\,))
+ (quote-char #\")
+ (quote-doubling-escapes? #t)
+ (comment-chars '())
+ (whitespace-chars '(#\space))
+ (strip-leading-whitespace? #f)
+ (strip-trailing-whitespace? #f)
+ (newlines-in-quotes? #t))
+ ;; TODO: It's erroneous to have two entries for the same attribute in a
+ ;; spec. However, it would be nice if we error-detected duplicate
+ ;; entries, or at least had assq semantics (first, rather than last,
+ ;; wins). Use csv-spec-derive's descendants for that.
+ (for-each
+ (lambda (item)
+ (let ((v (cdr item)))
+ (case (car item)
+ ((newline-type)
+ (set! newline-type (pe v '(cr crlf detect lax lf))))
+ ((separator-chars)
+ (set! separator-chars (plc v)))
+ ((quote-char)
+ (set! quote-char (pc-f v)))
+ ((quote-doubling-escapes?)
+ (set! quote-doubling-escapes? (pb v)))
+ ((comment-chars)
+ (set! comment-chars (plc-n v)))
+ ((whitespace-chars)
+ (set! whitespace-chars (plc-n v)))
+ ((strip-leading-whitespace?)
+ (set! strip-leading-whitespace? (pb v)))
+ ((strip-trailing-whitespace?)
+ (set! strip-trailing-whitespace? (pb v)))
+ ((newlines-in-quotes?)
+ (set! newlines-in-quotes? (pb v))))))
+ reader-spec)
+ (%csv:make-portreader/positional
+ newline-type
+ separator-chars
+ quote-char
+ quote-doubling-escapes?
+ comment-chars
+ whitespace-chars
+ strip-leading-whitespace?
+ strip-trailing-whitespace?
+ newlines-in-quotes?)))))
+
+;;; @defproc make-csv-reader-maker reader-spec
+;;;
+;;; Constructs a CSV reader constructor procedure from the @var{reader-spec},
+;;; with unspecified attributes having their default values.
+;;;
+;;; For example, given the input file @code{fruits.csv} with the content:
+;;;
+;;; @example
+;;; apples | 2 | 0.42
+;;; bananas | 20 | 13.69
+;;; @end example
+;;;
+;;; a reader for the file's apparent format can be constructed like:
+;;;
+;;; @lisp
+;;; (define make-food-csv-reader
+;;; (make-csv-reader-maker
+;;; '((separator-chars . (#\|))
+;;; (strip-leading-whitespace? . #t)
+;;; (strip-trailing-whitespace? . #t))))
+;;; @end lisp
+;;;
+;;; The resulting @code{make-food-csv-reader} procedure accepts one argument,
+;;; which is either an input port from which to read, or a string from which to
+;;; read. Our example input file then can be be read by opening an input port
+;;; on a file and using our new procedure to construct a reader on it:
+;;;
+;;; @lisp
+;;; (define next-row
+;;; (make-food-csv-reader (open-input-file "fruits.csv")))
+;;; @end lisp
+;;;
+;;; This reader, @code{next-row}, can then be called repeatedly to yield a
+;;; parsed representation of each subsequent row. The parsed format is a list
+;;; of strings, one string for each column. The null list is yielded to
+;;; indicate that all rows have already been yielded.
+;;;
+;;; @lisp
+;;; (next-row) @result{} ("apples" "2" "0.42")
+;;; (next-row) @result{} ("bananas" "20" "13.69")
+;;; (next-row) @result{} ()
+;;; @end lisp
+
+(define (make-csv-reader-maker reader-spec)
+ (let ((make-portread
+ (if (let ((p (assq 'newline-type reader-spec))) (and p (cdr p)))
+ ;; Newline-adapting portreader-maker.
+ (letrec
+ ((detect-portread
+ (%csv:make-portreader
+ (%csv:csv-spec-derive reader-spec
+ '((newline-type . detect)))))
+ ;; TODO: The set of cr/crlf/lf newline-type portreaders are
+ ;; constructed optimistically right now for two reasons:
+ ;; 1. we don't yet sanitize reader-specs of shared structure
+ ;; that can be mutated behind our backs; 2. eventually, we
+ ;; want to add a "lots-o-shots?" argument that, when true,
+ ;; would do this anyway. Consider.
+ (cr-portread
+ (%csv:make-portreader
+ (%csv:csv-spec-derive reader-spec
+ '((newline-type . cr)))))
+ (crlf-portread
+ (%csv:make-portreader
+ (%csv:csv-spec-derive reader-spec
+ '((newline-type . crlf)))))
+ (lf-portread
+ (%csv:make-portreader
+ (%csv:csv-spec-derive reader-spec
+ '((newline-type . lf))))))
+ (lambda ()
+ (let ((actual-portread #f))
+ (let ((adapt-portread
+ (lambda (port)
+ (let ((dnlt-row (detect-portread port)))
+ (if (null? dnlt-row)
+ dnlt-row
+ (begin (set! actual-portread
+ (case (car dnlt-row)
+ ((cr) cr-portread)
+ ((crlf) crlf-portread)
+ ((lf) lf-portread)
+ (else actual-portread)))
+ (cdr dnlt-row)))))))
+ (set! actual-portread adapt-portread)
+ (lambda (port) (actual-portread port))))))
+ ;; Stateless portreader-maker.
+ (let ((reusable-portread
+ (%csv:make-portreader reader-spec)))
+ (lambda () reusable-portread)))))
+ (lambda (in)
+ (let ((port (%csv:in-arg "[csv-reader]" in))
+ (portread (make-portread)))
+ (lambda () (portread port))))))
+
+;;; @section Making Readers
+
+;;; In addition to being constructed from the result of
+;;; @code{make-csv-reader-maker}, CSV readers can also be constructed using
+;;; @code{make-csv-reader}.
+
+;;; @defproc make-csv-reader in [reader-spec]
+;;;
+;;; Construct a CSV reader on the input @var{in}, which is an input port or a
+;;; string. If @var{reader-spec} is given, and is not the null list, then a
+;;; ``one-shot'' reader constructor is constructed with that spec and used. If
+;;; @var{reader-spec} is not given, or is the null list, then the default CSV
+;;; reader constructor is used. For example, the reader from the
+;;; @code{make-csv-reader-maker} example could alternatively have been
+;;; constructed like:
+;;;
+;;; @lisp
+;;; (define next-row
+;;; (make-csv-reader
+;;; (open-input-file "fruits.csv")
+;;; '((separator-chars . (#\|))
+;;; (strip-leading-whitespace? . #t)
+;;; (strip-trailing-whitespace? . #t))))
+;;; @end lisp
+
+(define make-csv-reader
+ (let ((default-maker (make-csv-reader-maker '())))
+ (lambda (in . rest)
+ (let ((spec (cond ((null? rest) '())
+ ((null? (cdr rest)) (car rest))
+ (else (%csv:error "make-csv-reader"
+ "extraneous arguments"
+ (cdr rest))))))
+ ((if (null? spec)
+ default-maker
+ (make-csv-reader-maker spec))
+ (%csv:in-arg "make-csv-reader" in))))))
+
+;;; @section High-Level Conveniences
+
+;;; Several convenience procedures are provided for iterating over the CSV rows
+;;; and for converting the CSV to a list.
+;;;
+;;; To the dismay of some Scheme purists, each of these procedures accepts a
+;;; @var{reader-or-in} argument, which can be a CSV reader, an input port, or a
+;;; string. If not a CSV reader, then the default reader constructor is used.
+;;; For example, all three of the following are equivalent:
+;;;
+;;; @lisp
+;;; (csv->list STRING )
+;;; @equiv{}
+;;; (csv->list (make-csv-reader STRING ))
+;;; @equiv{}
+;;; (csv->list (make-csv-reader (open-input-string STRING )))
+;;; @end lisp
+
+;;; @defproc csv-for-each proc reader-or-in
+;;;
+;;; Similar to Scheme's @code{for-each}, applies @var{proc}, a procedure of one
+;;; argument, to each parsed CSV row in series. @var{reader-or-in} is the CSV
+;;; reader, input port, or string. The return value is undefined.
+
+;; TODO: Doc an example for this.
+
+(define (csv-for-each proc reader-or-in)
+ (let ((reader (%csv:reader-or-in-arg "csv-for-each" reader-or-in)))
+ (let loop ((row (reader)))
+ (or (null? row)
+ (begin (proc row)
+ (loop (reader)))))))
+
+;;; @defproc csv-map proc reader-or-in
+;;;
+;;; Similar to Scheme's @code{map}, applies @var{proc}, a procedure of one
+;;; argument, to each parsed CSV row in series, and yields a list of the values
+;;; of each application of @var{proc}, in order. @var{reader-or-in} is the CSV
+;;; reader, input port, or string.
+
+;; TODO: Doc an example for this.
+
+;; (define (csv-map proc reader-or-in)
+;; (let ((reader (%csv:reader-or-in-arg "csv-for-each" reader-or-in)))
+;; (let ((head '()))
+;; (let ((row (reader)))
+;; (if (null? row)
+;; head
+;; (let ((pair (cons (proc row) '())))
+;; (set! head pair)
+;; (let loop ((prior pair))
+;; (let ((row (reader)))
+;; (if (null? row)
+;; head
+;; (let ((pair (cons (proc row) '())))
+;; (set-cdr! prior pair)
+;; (loop pair)))))))))))
+
+(define (csv-map proc reader-or-in)
+ (let ((reader (%csv:reader-or-in-arg "csv-for-each" reader-or-in)))
+ (let loop ((row (reader)) (ret null))
+ (if (null? row)
+ (reverse ret)
+ (let ((ret (cons (proc row) ret)))
+ (loop (reader) ret))))))
+
+;;; @defproc csv->list reader-or-in
+;;;
+;;; Yields a list of CSV row lists from input @var{reader-or-in}, which is a
+;;; CSV reader, input port, or string.
+
+;; TODO: Doc an example for this.
+
+;; (define (csv->list reader-or-in)
+;; (let ((reader (%csv:reader-or-in-arg "csv->list" reader-or-in)))
+;; (let ((head '()))
+;; (let ((row (reader)))
+;; (if (null? row)
+;; head
+;; (let ((pair (cons row '())))
+;; (set! head pair)
+;; (let loop ((prior pair))
+;; (let ((row (reader)))
+;; (if (null? row)
+;; head
+;; (let ((pair (cons row '())))
+;; (set-cdr! prior pair)
+;; (loop pair)))))))))))
+
+(define (csv->list reader-or-in)
+ (csv-map values reader-or-in))
+
+;;; @section Converting CSV to SXML
+
+;;; The @code{csv->sxml} procedure can be used to convert CSV to SXML format,
+;;; for processing with various XML tools.
+
+;;; @defproc csv->sxml reader-or-in [row-element [col-elements]]
+;;;
+;;; Reads CSV from input @var{reader-or-in} (which is a CSV reader, input port,
+;;; or string), and yields an SXML representation. If given, @var{row-element}
+;;; is a symbol for the XML row element. If @var{row-element} is not given,
+;;; the default is the symbol @code{row}. If given @var{col-elements} is a
+;;; list of symbols for the XML column elements. If not given, or there are
+;;; more columns in a row than given symbols, column element symbols are of the
+;;; format @code{col-@var{n}}, where @var{n} is the column number (the first
+;;; column being number 0, not 1).
+;;;
+;;; For example, given a CSV-format file @code{friends.csv} that has the
+;;; contents:
+;;;
+;;; @example
+;;; Binoche,Ste. Brune,33-1-2-3
+;;; Posey,Main St.,555-5309
+;;; Ryder,Cellblock 9,
+;;; @end example
+;;;
+;;; with elements not given, the result is:
+;;;
+;;; @lisp
+;;; (csv->sxml (open-input-file "friends.csv"))
+;;; @result{}
+;;; (*TOP*
+;;; (row (col-0 "Binoche") (col-1 "Ste. Brune") (col-2 "33-1-2-3"))
+;;; (row (col-0 "Posey") (col-1 "Main St.") (col-2 "555-5309"))
+;;; (row (col-0 "Ryder") (col-1 "Cellblock 9") (col-2 "")))
+;;; @end lisp
+;;;
+;;; With elements given, the result is like:
+;;;
+;;; @lisp
+;;; (csv->sxml (open-input-file "friends.csv")
+;;; 'friend
+;;; '(name address phone))
+;;; @result{}
+;;; (*TOP* (friend (name "Binoche")
+;;; (address "Ste. Brune")
+;;; (phone "33-1-2-3"))
+;;; (friend (name "Posey")
+;;; (address "Main St.")
+;;; (phone "555-5309"))
+;;; (friend (name "Ryder")
+;;; (address "Cellblock 9")
+;;; (phone "")))
+;;; @end lisp
+
+(define csv->sxml
+ (let* ((top-symbol
+ (string->symbol "*TOP*"))
+ (make-col-symbol
+ (lambda (n)
+ (string->symbol (string-append "col-" (number->string n)))))
+ (default-col-elements
+ (let loop ((i 0))
+ (if (= i 32) ; arbitrary magic number
+ '()
+ (cons (make-col-symbol i) (loop (+ 1 i)))))))
+ ;; TODO: Have option to error when columns count doesn't match provided
+ ;; column name list.
+ (lambda (reader-or-in . rest)
+ (let ((reader (%csv:reader-or-in-arg "csv->sxml"
+ reader-or-in))
+ (row-element 'row)
+ (col-elements #f))
+ ;; TODO: Maybe use case-lambda.
+ (or (null? rest)
+ (begin (set! row-element (car rest))
+ (let ((rest (cdr rest)))
+ (or (null? rest)
+ (begin (set! col-elements (car rest))
+ (let ((rest (cdr rest)))
+ (or (null? rest)
+ (%csv:error
+ "csv->sxml"
+ "extraneous arguments"
+ rest))))))))
+ ;; TODO: We could clone and grow default-col-elements for the duration
+ ;; of this procedure.
+ (cons top-symbol
+ (csv-map (lambda (row)
+ (cons row-element
+ (let loop ((vals row)
+ (i 0)
+ (names (or col-elements
+ default-col-elements)))
+ (if (null? vals)
+ '()
+ (cons (list (if (null? names)
+ (make-col-symbol i)
+ (car names))
+ (car vals))
+ (loop (cdr vals)
+ (+ 1 i)
+ (if (null? names)
+ '()
+ (cdr names))))))))
+ reader))))))
+
+;; TODO: Make a define-csv-reader/positional, for great constant-folding.
+;; That's part of the reason some things are done the way they are.
+
+;; TODO: Make a csv-bind, as a newbie convenience for people without advanced
+;; match forms, which looks good in examples. This is better than a
+;; csv-map/bind and a csv-for-each/bind.
+;;
+;; (csv-for-each/bind ((column-binding ...) body ...)
+;; { (else => closure) | (else body ...) | }
+;; input-port
+;; [ csv-reader ])
+;;
+;; (csv-for-each/bind
+;; ((lastname firstname email)
+;; ...)
+;; (else => (lambda (row) (error "CSV row didn't match pattern" row)))
+;; my-input-port
+;; my-csv-reader)
+
+;; TODO: Handle escapes, once we find an actual example or specification of any
+;; flavor of escapes in CSV other than quote-doubling inside a quoted field.
+
+;; TODO: Add a spec attribute for treating adjacent separators as one, or
+;; skipping empty fields. This would probably only be used in practice for
+;; parsing whitespace-separated input.
+
+;; TODO: Get access to MS Excel or documentation, and make this correct.
+;;
+;; (define msexcel-csv-reader-spec
+;; '((newline-type . crlf)
+;; (separator-chars . (#\,))
+;; (quote-char . #\")
+;; (quote-doubling-escapes? . #t)
+;; (comment-chars . ())
+;; (whitespace-chars . (#\space))
+;; (strip-leading-whitespace? . #f)
+;; (strip-trailing-whitespace? . #f)
+;; (newlines-in-quotes? . #t)))
+
+;; TODO: Maybe put this back in.
+;;
+;; (define default-csv-reader-spec
+;; '((newline-type . lax)
+;; (separator-chars . (#\,))
+;; (quote-char . #\")
+;; (quote-doubling-escapes? . #t)
+;; (comment-chars . ())
+;; (whitespace-chars . (#\space))
+;; (strip-leading-whitespace? . #f)
+;; (strip-trailing-whitespace? . #f)
+;; (newlines-in-quotes? . #t)))
+
+;; TODO: Implement CSV writing, after CSV reading is field-tested and polished.
+
+;; TODO: Call "close-input-port" once eof-object is hit, but make sure we still
+;; can return an empty list on subsequent calls to the CSV reader.
+
+;; TODO: Consider switching back to returning eof-object at the end of input.
+;; We originally changed to returning the null list because we might want to
+;; synthesize the EOF, and there is no R5RS binding for the eof-object.
+
+;; TODO: [2005-12-09] In one test, Guile has a stack overflow when parsing a
+;; row with 425 columns. Wouldn't hurt to see if we can make things more
+;; tail-recursive.
+
+;;; @unnumberedsec History
+
+;;; @table @asis
+;;;
+;;; @item Version 0.10 -- 2010-04-13 -- PLaneT @code{(1 6)}
+;;; Documentation fix.
+;;;
+;;; @item Version 0.9 -- 2009-03-14 -- PLaneT @code{(1 5)}
+;;; Documentation fix.
+;;;
+;;; @item Version 0.8 -- 2009-02-23 -- PLaneT @code{(1 4)}
+;;; Documentation changes.
+;;;
+;;; @item Version 0.7 -- 2009-02-22 -- PLaneT @code{(1 3)}
+;;; License is now LGPL 3. Moved to author's new Scheme administration system.
+;;;
+;;; @item Version 0.6 -- 2008-08-12 -- PLaneT @code{(1 2)}
+;;; For PLT 4 compatibility, new versions of @code{csv-map} and
+;;; @code{csv->list} that don't use @code{set-cdr!} (courtesy of Doug
+;;; Orleans). PLT 4 @code{if} compatibility change. Minor documentation fixes.
+;;;
+;;; @item Version 0.5 --- 2005-12-09
+;;; Changed a non-R5RS use of @code{letrec} to @code{let*}, caught by Guile and
+;;; David Pirotte.
+;;;
+;;; @item Version 0.4 --- 2005-06-07
+;;; Converted to Testeez. Minor documentation changes.
+;;;
+;;; @item Version 0.3 --- 2004-07-21
+;;; Minor documentation changes. Test suite now disabled by default.
+;;;
+;;; @item Version 0.2 --- 2004-06-01
+;;; Work-around for @code{case}-related bug observed in Gauche 0.8 and 0.7.4.2
+;;; that was tickled by @code{csv-internal:make-portreader/positional}. Thanks
+;;; to Grzegorz Chrupa@l{}a for reporting.
+;;;
+;;; @item Version 0.1 --- 2004-05-31
+;;; First release, for testing with real-world input.
+;;;
+;;; @end table
+
+#;(provide
+ csv->list
+ csv->sxml
+ csv-for-each
+ csv-map
+ make-csv-reader
+ make-csv-reader-maker)
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -55,29 +55,29 @@
(iup:show
(iup:dialog
(iup:vbox
(iup:label msg #:margin "40x40")))))
-(define (dtests:get-pre-command #!key (default-override #f))
- (let* ((orig-pre-command "export CMD='")
- (viewscreen-pre-command "viewscreen ")
- (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen"))
- (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command))
- (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command")))
- (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \""))
-
-
-(define (dtests:get-post-command #!key (default-override #f))
- (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&"
- "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))
- (viewscreen-post-command "")
- (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen"))
- (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command))
- (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command")))
- (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
-
-
+;; (define (dtests:get-pre-command #!key (default-override #f))
+;; (let* ((orig-pre-command "export CMD='")
+;; (viewscreen-pre-command "viewscreen ")
+;; (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen"))
+;; (default-pre-command (if use-viewscreen viewscreen-pre-command orig-pre-command))
+;; (cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command")))
+;; (or cfg-ovrd default-override default-pre-command))) ;; "xterm -geometry 180x20 -e \""))
+;;
+;;
+;; (define (dtests:get-post-command #!key (default-override #f))
+;; (let* ((orig-post-command (conc "';xterm -geometry 180x20 -e \"(echo; echo -n START:;date +ww%U.%w-$H:%M:%S;echo;echo $CMD;echo;$CMD)|&"
+;; "tee -a runlog-`date +ww%U.%w-%H:%M`.log;echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))
+;; (viewscreen-post-command "")
+;; (use-viewscreen (configf:lookup *configdat* "dashboard" "use-viewscreen"))
+;; (default-post-command (if use-viewscreen viewscreen-post-command orig-post-command))
+;; (cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command")))
+;; (or cfg-ovrd default-override default-post-command))) ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
+;;
+;;
(define (test-info-panel testdat store-label widgets)
(iup:frame
#:title "Test Info" ; #:expand "YES"
(iup:hbox ; #:expand "YES"
(apply iup:vbox ; #:expand "YES"
Index: datashare.scm
==================================================================
--- datashare.scm
+++ datashare.scm
@@ -253,11 +253,11 @@
(print "ERROR: invalid path for storing database: " path))))
(define (open-run-close-exception-handling proc idb . params)
(handle-exceptions
exn
- (let ((sleep-time (random 30))
+ (let ((sleep-time (pseudo-random-integer 30))
(err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
(case err-status
((busy)
(thread-sleep! sleep-time))
(else
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -22,26 +22,26 @@
;; Database access
;;======================================================================
;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc
-(use (srfi 18) extras tcp stack)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable)
-(import (prefix sqlite3 sqlite3:))
-(import (prefix base64 base64:))
-
-(declare (unit db))
-(declare (uses common))
-(declare (uses keys))
-(declare (uses ods))
-(declare (uses client))
-(declare (uses mt))
-
-(include "common_records.scm")
-(include "db_records.scm")
-(include "key_records.scm")
-(include "run_records.scm")
+;; (use (srfi 18) extras tcp stack)
+;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable)
+;; (import (prefix sqlite3 sqlite3:))
+;; (import (prefix base64 base64:))
+;;
+;; (declare (unit db))
+;; (declare (uses common))
+;; (declare (uses keys))
+;; (declare (uses ods))
+;; (declare (uses client))
+;; (declare (uses mt))
+;;
+;; (include "common_records.scm")
+;; (include "db_records.scm")
+;; (include "key_records.scm")
+;; (include "run_records.scm")
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
;;======================================================================
@@ -58,10 +58,11 @@
(refndb #f)
(homehost #f) ;; not used yet
(on-homehost #f) ;; not used yet
(read-only #f)
(stmt-cache (make-hash-table))
+ (locdbs (make-hash-table)) ;; legacy junk in db_records
) ;; goal is to converge on one struct for an area but for now it is too confusing
;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
@@ -246,14 +247,14 @@
;; (define *db-open-mutex* (make-mutex))
(define (db:lock-create-open fname initproc)
(let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local
(raw-fname (pathname-file fname))
- (dir-writable (file-write-access? parent-dir))
+ (dir-writable (file-writable? parent-dir))
(file-exists (common:file-exists? fname))
(file-write (if file-exists
- (file-write-access? fname)
+ (file-writable? fname)
dir-writable )))
;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped.
(if file-write ;; dir-writable
(condition-case
(let* ((lockfname (conc fname ".lock"))
@@ -332,11 +333,11 @@
(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
(mtdb (db:open-megatest-db))
(mtdbpath (db:dbdat-get-path mtdb))
(tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
(refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
- (write-access (file-write-access? mtdbpath))
+ (write-access (file-writable? mtdbpath))
;(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) ; moving this before db:open-megatest-db is called. if wal mode is on -WAL and -shm file get created with causing the tmpdbmodtime timestamp always greater than mtdbmodtime
;(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced
;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f))
;(fmt (file-modification-time tmpdbfname))
@@ -424,11 +425,11 @@
(db (db:lock-create-open dbpath
(lambda (db)
(db:initialize-main-db db)
;;(db:initialize-run-id-db db)
)))
- (write-access (file-write-access? dbpath)))
+ (write-access (file-writable? dbpath)))
(debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)
(if (and dbexists (not write-access))
(set! *db-write-access* #f))
(cons db dbpath)))
@@ -627,11 +628,11 @@
(let* ((dbpath (db:dbdat-get-path dbdat))
(dbdir (pathname-directory dbpath))
(fname (pathname-strip-directory dbpath)))
(debug:print-info 0 *default-log-port* "Checking db " dbpath " for errors.")
(cond
- ((not (file-write-access? dbdir))
+ ((not (file-writable? dbdir))
(debug:print 0 *default-log-port* "WARNING: can't write to " dbdir ", can't fix " fname)
#f)
;; handle special cases, megatest.db and monitor.db
;;
@@ -715,17 +716,17 @@
-3)
((not (sqlite3:database? (db:dbdat-get-db todb)))
(debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb)
-4)
- ((not (file-write-access? (db:dbdat-get-path todb)))
+ ((not (file-writable? (db:dbdat-get-path todb)))
(debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb)
-5)
((not (null? (let ((readonly-slave-dbs
(filter
(lambda (dbdat)
- (not (file-write-access? (db:dbdat-get-path todb))))
+ (not (file-writable? (db:dbdat-get-path todb))))
slave-dbs)))
(for-each
(lambda (bad-dbdat)
(debug:print-error
0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat))
@@ -1039,11 +1040,11 @@
;; (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db")
;; (exit 1))
;; (let* ((th1 (make-thread
;; (lambda ()
;; (if (and (common:file-exists? megatest-db)
-;; (file-write-access? megatest-db))
+;; (file-writable? megatest-db))
;; (begin
;; (db:sync-to-megatest.db dbstruct 'timestamps) ;; internally mutexes on *db-local-sync*
;; (debug:print-info 2 *default-log-port* "Done syncing to megatest.db"))))
;; "call-with-cached-db sync-to-megatest.db"))
;; (cache-db (db:cache-for-read-only
@@ -1099,11 +1100,11 @@
;; clear out junk records
;;
((dejunk)
;; (db:delay-if-busy mtdb) ;; ok to delay on mtdb
- (when (file-write-access? (db:dbdat-get-path mtdb)) (db:clean-up mtdb))
+ (when (file-writable? (db:dbdat-get-path mtdb)) (db:clean-up mtdb))
(db:clean-up tmpdb)
(db:clean-up refndb))
;; sync runs, test_meta etc.
;;
@@ -1201,11 +1202,11 @@
#f))
#;(define (open-run-close-exception-handling proc idb . params)
(handle-exceptions
exn
- (let ((sleep-time (random 30))
+ (let ((sleep-time (pseudo-random-integer 30))
(err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
(case err-status
((busy)
(thread-sleep! sleep-time))
(else
@@ -1772,11 +1773,11 @@
#t)))))
(define (db:get-status-from-final-status-file run-dir)
(let ((infile (conc run-dir "/.final-status")))
;; first verify we are able to write the output file
- (if (not (file-read-access? infile))
+ (if (not (file-readable? infile))
(begin
(debug:print 0 *default-log-port* "ERROR: cannot read " infile)
(debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir)
#f
)
@@ -4884,11 +4885,11 @@
(numkeys (length keypatt-alist))
(test-ids '())
(dbdat (db:get-db dbstruct))
(db (db:dbdat-get-db dbdat))
(windows (and pathmod (substring-index "\\" pathmod)))
- (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id)))
+ (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (pseudo-random-integer 10000) "_" (current-process-id)))
(runsheader (append (list "Run Id" "Runname") ; 0 1
(map car keypatt-alist) ; + N = length keypatt-alist
(list "Testname" ; 2
"Item Path" ; 3
"Description" ; 4
ADDED dbi/dbi.egg
Index: dbi/dbi.egg
==================================================================
--- /dev/null
+++ dbi/dbi.egg
@@ -0,0 +1,5 @@
+((license "BSD")
+ (category db)
+ (dependencies autoload sql-null)
+ (test-dependencies test)
+ (components (extension dbi)))
ADDED dbi/dbi.meta
Index: dbi/dbi.meta
==================================================================
--- /dev/null
+++ dbi/dbi.meta
@@ -0,0 +1,21 @@
+;; -*- scheme -*-
+(
+; Your egg's license:
+(license "BSD")
+
+; Pick one from the list of categories (see below) for your egg and enter it
+; here.
+(category db)
+
+; A list of eggs dbi depends on. If none, you can omit this declaration
+; altogether. If you are making an egg for chicken 3 and you need to use
+; procedures from the `files' unit, be sure to include the `files' egg in the
+; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit).
+; `depends' is an alias to `needs'.
+(needs (autoload "3.0") sql-null)
+
+; A list of eggs required for TESTING ONLY. See the `Tests' section.
+(test-depends test)
+
+(author "Matt Welland")
+(synopsis "An abstract database interface."))
ADDED dbi/dbi.release-info
Index: dbi/dbi.release-info
==================================================================
--- /dev/null
+++ dbi/dbi.release-info
@@ -0,0 +1,7 @@
+(repo fossil "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}")
+(uri zip "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}/zip/{egg-name}.zip?uuid={egg-release}")
+(release "0.5")
+(release "0.4")
+(release "0.3")
+(release "0.2")
+(release "0.1")
ADDED dbi/dbi.scm
Index: dbi/dbi.scm
==================================================================
--- /dev/null
+++ dbi/dbi.scm
@@ -0,0 +1,483 @@
+;;; dbi: Minimal gasket to postgresql, sqlite3 and mysql
+;;;
+;; Copyright (C) 2007-2018 Matt Welland
+;; Copyright (C) 2016 Peter Bex
+;; Redistribution and use in source and binary forms, with or without
+;; modification, is permitted.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;; DAMAGE.
+
+;; ONLY A LOWEST COMMON DEMOMINATOR IS SUPPORTED!
+
+;; d = db handle
+;; t = statement handle
+;; s = statement
+;; l = proc
+;; p = params
+;;
+;; sqlite3 postgres dbi
+;; prepare: (prepare d s) n/a prepare (sqlite3, pg)
+;; for-each (for-each-row l d s . p) (query-for-each l s d) for-each-row
+;; for-each (for-each-row l t . p) n/a NOT YET
+;; exec (exec d s . p) (query-tuples s d)
+;; exec (exec t . p) n/a
+
+;; set to 'pg or 'sqlite3
+;; (define dbi:type 'sqlite3) ;; or 'pg
+;; (dbi:open 'sqlite3 (list (cons 'dbname fullname)))
+
+;;======================================================================
+;; D B I
+;;======================================================================
+(module dbi
+ (open db-dbtype db-conn for-each-row get-one get-one-row get-rows
+ exec close escape-string mk-db now database? with-transaction fold-row
+ prepare map-row convert prepare-exec get-res
+
+ ;; TODO: These don't really belong here. Also, the naming is not
+ ;; consistent with the usual Scheme conventions.
+ pgdatetime-get-year pgdatetime-get-month pgdatetime-get-day
+ pgdatetime-get-hour pgdatetime-get-minute pgdatetime-get-second
+ pgdatetime-get-microsecond
+ pgdatetime-set-year! pgdatetime-set-month! pgdatetime-set-day!
+ pgdatetime-set-hour! pgdatetime-set-minute! pgdatetime-set-second!
+ pgdatetime-set-microsecond!
+
+ lazy-bool)
+
+(import (chicken base) (chicken process) (chicken file) (chicken time) (chicken string) (chicken format) (chicken time posix) scheme srfi-1 srfi-13)
+(import (chicken condition) autoload sql-null)
+
+(define-record-type db
+ (make-db dbtype dbconn)
+ db?
+ (dbtype db-dbtype db-dbtype-set!)
+ (dbconn db-conn db-conn-set!))
+
+(define (missing-egg type eggname)
+ (lambda _
+ (error (printf
+ "Cannot access ~A databases. Please install the ~S egg and try again." type eggname))))
+
+;; (define (sqlite3:statement? h) #f) ;; dummy - hope it gets clobbered if sqlite3 gets loaded
+
+;; TODO: Make a convenience macro for this?
+(define sqlite3-missing (missing-egg 'sqlite3 "sqlite3"))
+(autoload sqlite3
+ (open-database sqlite3:open-database sqlite3-missing)
+ (for-each-row sqlite3:for-each-row sqlite3-missing)
+ (execute sqlite3:execute sqlite3-missing)
+ (with-transaction sqlite3:with-transaction sqlite3-missing)
+ (finalize! sqlite3:finalize! sqlite3-missing)
+ (make-busy-timeout sqlite3:make-busy-timeout sqlite3-missing)
+ (set-busy-handler! sqlite3:set-busy-handler! sqlite3-missing)
+ (database? sqlite3:database? sqlite3-missing)
+ (prepare sqlite3:prepare sqlite3-missing)
+ (fold-row sqlite3:fold-row sqlite3-missing)
+ (map-row sqlite3:map-row sqlite3-missing)
+ (statement? sqlite3:statement? sqlite3-missing))
+
+(define sql-de-lite-missing (missing-egg 'sql-de-lite "sql-de-lite"))
+(autoload sql-de-lite
+ (open-database sql:open-database sql-de-lite-missing)
+ (close-database sql:close-database sql-de-lite-missing)
+ (for-each-row sql:for-each-row sql-de-lite-missing)
+ (fold-rows sql:fold-rows sql-de-lite-missing)
+ (exec sql:exec sql-de-lite-missing)
+ (fetch-value sql:fetch-value sql-de-lite-missing)
+ (with-transaction sql:with-transaction sql-de-lite-missing)
+ (finalize! sql:finalize! sql-de-lite-missing)
+ (make-busy-timeout sql:make-busy-timeout sql-de-lite-missing)
+ (set-busy-handler! sql:set-busy-handler! sql-de-lite-missing)
+ (query sql:query sql-de-lite-missing)
+ (sql sql:sql sql-de-lite-missing))
+
+(define pg-missing (missing-egg 'pg "postgresql"))
+(autoload postgresql
+ (connect pg:connect pg-missing)
+ (row-for-each pg:row-for-each pg-missing)
+ (with-transaction pg:with-transaction pg-missing)
+ (query pg:query pg-missing)
+ ;;(escape-string pg:escape-string pg-missing)
+ (disconnect pg:disconnect pg-missing)
+ (connection? pg:connection? pg-missing)
+ (row-fold pg:row-fold pg-missing)
+ (row-map pg:row-map pg-missing)
+ (affected-rows pg:affected-rows pg-missing)
+ (result? pg:result? pg-missing))
+
+(define mysql-missing (missing-egg 'mysql "mysql-client"))
+(autoload mysql-client
+ (make-mysql-connection mysql:make-connection mysql-missing)
+ (mysql-null? mysql:mysql-null? mysql-missing))
+
+(define (open dbtype dbinit)
+ (make-db
+ dbtype
+ (case dbtype
+ ((sqlite3) (sqlite3:open-database (alist-ref 'dbname dbinit)))
+ ((sql-de-lite) (sql:open-database (alist-ref 'dbname dbinit)))
+ ((pg) (pg:connect dbinit))
+ ((mysql) (mysql:make-connection (alist-ref 'host dbinit)
+ (alist-ref 'user dbinit)
+ (alist-ref 'password dbinit)
+ (alist-ref 'dbname dbinit)
+ port: (alist-ref 'port dbinit)))
+ (else (error "Unsupported dbtype " dbtype)))))
+
+(define (convert dbh)
+ (cond
+ ((database? dbh) dbh)
+ ((sqlite3:database? dbh) (make-db 'sqlite3 dbh))
+ ((pg:connection? dbh) (make-db 'pg dbh))
+ ((not mysql:mysql-null?) (make-db 'mysql dbh))
+ (else (error "Unsupported database handle " dbh))))
+
+(define (for-each-row proc dbh stmt . params)
+ (let ((dbtype (db-dbtype dbh))
+ (conn (db-conn dbh)))
+ (case dbtype
+ ((sqlite3) (sqlite3:for-each-row
+ (lambda (first . remaining)
+ (let ((tuple (list->vector (cons first remaining))))
+ (proc tuple)))
+ conn
+ (apply sqlparam stmt params)))
+ ((sql-de-lite)(apply sql:query (sql:for-each-row
+ (lambda (row)
+ (proc (list->vector row))))
+ (sql:sql conn stmt)
+ params))
+ ((pg) (pg:row-for-each
+ (lambda (tuple)
+ (proc (list->vector tuple)))
+ (pg:query conn (apply sqlparam stmt params))))
+ ((mysql) (let* ((replaced-sql (apply sqlparam stmt params))
+ (fetcher (conn replaced-sql)))
+ (fetcher (lambda (tuple)
+ (proc (list->vector tuple))))))
+ (else (error "Unsupported dbtype " dbtype)))))
+
+;; common idiom is to seek a single value, #f if no match
+;; NOTE: wish to return first found. Do the set only if not set
+(define (get-one dbh stmt . params)
+ (let ((dbtype (db-dbtype dbh))
+ (conn (db-conn dbh)))
+ (case dbtype
+ ((sql-de-lite)
+ (apply sql:query sql:fetch-value (sql:sql conn stmt) params))
+ (else
+ (let ((res #f))
+ (apply for-each-row
+ (lambda (row)
+ (if (not res)
+ (set! res (vector-ref row 0))))
+ dbh
+ stmt
+ params)
+ res)))))
+
+;; common idiom is to seek a single value, #f if no match
+;; NOTE: wish to return first found. Do the set only if not set
+(define (get-one-row dbh stmt . params)
+ (let ((res #f))
+ (apply for-each-row
+ (lambda (row)
+ (if (not res)
+ (set! res row)))
+ dbh
+ stmt
+ params)
+ res))
+
+;; common idiom is to seek a list of rows, '() if no match
+(define (get-rows dbh stmt . params)
+ (let ((res '()))
+ (apply for-each-row
+ (lambda (row)
+ (set! res (cons row res)))
+ dbh
+ stmt
+ params)
+ (reverse res)))
+
+(define (exec dbh stmt . params)
+ (let ((dbtype (db-dbtype dbh))
+ (conn (db-conn dbh))
+ (junk #f))
+ (case dbtype
+ ((sqlite3) (apply sqlite3:execute conn stmt params))
+ ((sql-de-lite)(apply sql:exec (sql:sql conn stmt) params))
+ ((pg) (pg:query conn (apply sqlparam stmt params)))
+ ((mysql) (conn (apply sqlparam stmt params)))
+ (else (error "Unsupported dbtype " dbtype)))))
+
+(define (with-transaction dbh proc)
+ (let ((dbtype (db-dbtype dbh))
+ (conn (db-conn dbh)))
+ (case dbtype
+ ((sql-de-lite)(sql:with-transaction conn proc))
+ ((sqlite3) (sqlite3:with-transaction
+ conn
+ (lambda () (proc))))
+ ((pg) (pg:with-transaction
+ conn (lambda () (proc))))
+ ((mysql)
+ (conn "START TRANSACTION")
+ (conn proc)
+ (conn "COMMIT"))
+ (else (error "Unsupported dbtype " dbtype)))))
+
+(define (prepare dbh stmt)
+ (let ((dbtype (db-dbtype dbh))
+ (conn (db-conn dbh)))
+ (case dbtype
+ ((sql-de-lite) dbh) ;; nop?
+ ((sqlite3) (sqlite3:prepare conn stmt))
+ ((pg) (exec dbh stmt) (cons (cons dbh (cadr (string-split stmt))) '()))
+ ((mysql) (print "WIP"))
+ (else (error "Unsupported dbtype" dbtype)))))
+
+(define (fold-row proc init dbh stmt . params) ;; expecting (proc init/prev res)
+ (let ((dbtype (db-dbtype dbh))
+ (conn (db-conn dbh)))
+ (case dbtype
+ ((sql-de-lite) (apply sql:query (sql:fold-rows proc init)
+ (sql:sql conn stmt) params))
+ ((sqlite3) (let ((newproc (lambda (prev . rem)
+ (proc rem prev))))
+ (apply sqlite3:fold-row newproc init conn stmt params))) ;; (fold-row PROC INIT DATABASE SQL . PARAMETERS)
+ ((pg) (pg:row-fold proc init (exec dbh stmt params)))
+ ((mysql) (fold proc '() (get-rows dbh stmt)))
+ (else (error "Unsupported dbtype" dbtype)))))
+
+(define (map-row proc init dbh stmt . params)
+ (let ((dbtype (db-dbtype dbh))
+ (conn (db-conn dbh)))
+ (case dbtype
+ ((sqlite3) (apply sqlite3:map-row proc conn stmt params))
+ ((pg) (pg:row-map proc (exec dbh stmt params)))
+ ((mysql) (map proc (get-rows dbh stmt)))
+ (else (error "Unsupported dbtype" dbtype)))))
+
+(define (prepare-exec stmth . params)
+ (if (sqlite3:statement? stmth)
+ (apply sqlite3:execute stmth params))
+ (if (pair? stmth)
+ (let* ((dbh (car (car stmth)))
+ (dbtype (db-dbtype dbh))
+ (conn (db-conn dbh))
+ (stmth-name (string->symbol (cdr (car stmth)))))
+ (apply pg:query conn stmth-name params))))
+
+(define (get-res handle option)
+ (if (pg:result? handle)
+ (case option
+ ((affected-rows) (pg:affected-rows handle)))))
+
+(define (close dbh)
+ (cond
+ ((database? dbh)
+ (let ((dbtype (db-dbtype dbh))
+ (conn (db-conn dbh)))
+ (case dbtype
+ ((sql-de-lite) (sql:close-database conn))
+ ((sqlite3) (sqlite3:finalize! conn))
+ ((pg) (pg:disconnect conn))
+ ((mysql) (void)) ; The mysql-client egg doesn't support closing...
+ (else (error "Unsupported dbtype " dbtype)))))
+ ((pair? dbh)
+ (let ((stmt (conc "DEALLOCATE " (cdr (car dbh)) ";")))
+ (exec (car (car dbh)) stmt)))
+ ((sqlite3:statement? dbh) ;; do this last so that *IF* it is a proper dbh it will be closed above and the sqlite3:statement? will not be called
+ (sqlite3:finalize! dbh))
+
+ ))
+
+;;======================================================================
+;; D B M I S C
+;;======================================================================
+
+(define (escape-string str)
+ (let ((parts (split-string str "'")))
+ (string-intersperse parts "''")))
+;; (pg:escape-string val)))
+
+;; convert values to appropriate strings
+;;
+(define (sqlparam-val->string val)
+ (cond
+ ((list? val)(string-intersperse (map conc val) ",")) ;; (a b c) => a,b,c
+ ((string? val)(string-append "'" (escape-string val) "'"))
+ ((sql-null? val) "NULL")
+ ((number? val)(number->string val))
+ ((symbol? val)(sqlparam-val->string (symbol->string val)))
+ ((boolean? val)
+ (if val "TRUE" "FALSE")) ;; should this be "TRUE" or 1?
+ ;; should this be "FALSE" or 0 or NULL?
+ ((vector? val) ;; 'tis a date NB// 5/29/2011 - this is badly borked BUGGY!
+ (sqlparam-val->string (time->string (seconds->local-time (current-seconds)))))
+ (else
+ (error "sqlparam: unknown type for value: " val)
+ "")))
+
+;; (sqlparam "INSERT INTO foo(name,age) VALUES(?,?);" "bob" 20)
+;; NB// 1. values only!!
+;; 2. terminating semicolon required (used as part of logic)
+;;
+;; a=? 1 (number) => a=1
+;; a=? 1 (string) => a='1'
+;; a=? #f => a=FALSE
+;; a=? a (symbol) => a=a
+;;
+(define (sqlparam query . args)
+ (let* ((query-parts (string-split query "?"))
+ (num-parts (length query-parts))
+ (num-args (length args)))
+ (if (not (= (+ num-args 1) num-parts))
+ (error "ERROR, sqlparam: wrong number of arguments or missing semicolon, " num-args " for query " query)
+ (if (= num-args 0) query
+ (let loop ((section (car query-parts))
+ (tail (cdr query-parts))
+ (result "")
+ (arg (car args))
+ (argtail (cdr args)))
+ (let* ((valstr (sqlparam-val->string arg))
+ (newresult (string-append result section valstr)))
+ (if (null? argtail) ;; we are done
+ (string-append newresult (car tail))
+ (loop
+ (car tail)
+ (cdr tail)
+ newresult
+ (car argtail)
+ (cdr argtail)))))))))
+
+;; a poorly written but non-broken split-string
+;;
+(define (split-string strng delim)
+ (if (eq? (string-length strng) 0) (list strng)
+ (let loop ((head (make-string 1 (car (string->list strng))))
+ (tail (cdr (string->list strng)))
+ (dest '())
+ (temp ""))
+ (cond ((equal? head delim)
+ (set! dest (append dest (list temp)))
+ (set! temp ""))
+ ((null? head)
+ (set! dest (append dest (list temp))))
+ (else (set! temp (string-append temp head)))) ;; end if
+ (cond ((null? tail)
+ (set! dest (append dest (list temp))) dest)
+ (else (loop (make-string 1 (car tail)) (cdr tail) dest temp))))))
+
+(define (database? dbh)
+ (if (db? dbh)
+ (let ((dbtype (db-dbtype dbh))
+ (conn (db-conn dbh)))
+ (case dbtype
+ ((sqlite3) (if (sqlite3:database? conn) #t #f))
+ ((sql-de-lite) #t) ;; don't know how to test for database
+ ((pg) (if (pg:connection? conn) #t #f))
+ ((mysql) #t)
+ (else (error "Unsupported dbtype " dbtype)))) #f))
+
+;;======================================================================
+;; Convienence routines
+;;======================================================================
+
+;; make a db from a list of statements or open it if it already exists
+(define (mk-db path file stmts)
+ (let* ((fname (conc path "/" file))
+ (dbexists (file-exists? fname))
+ (dbh (if dbexists (open 'sqlite3 (list (cons 'dbname fname))) #f)))
+ (if (not dbexists)
+ (begin
+ (system (conc "mkdir -p " path)) ;; create the path
+ (set! dbh (open 'sqlite3 (list (cons 'dbname fname))))
+ (for-each
+ (lambda (sqry)
+ (exec dbh sqry))
+ stmts)))
+ (sqlite3:set-busy-handler!
+ (db-conn dbh) (sqlite3:make-busy-timeout 1000000))
+ dbh))
+
+(define (now dbh)
+ (let ((dbtype (db-dbtype dbh)))
+ (case dbtype
+ ((sqlite3) "datetime('now')")
+ ;; Standard SQL
+ (else "now()"))))
+
+(define (make-pgdatetime)(make-vector 7))
+(define (pgdatetime-get-year vec) (vector-ref vec 0))
+(define (pgdatetime-get-month vec) (vector-ref vec 1))
+(define (pgdatetime-get-day vec) (vector-ref vec 2))
+(define (pgdatetime-get-hour vec) (vector-ref vec 3))
+(define (pgdatetime-get-minute vec) (vector-ref vec 4))
+(define (pgdatetime-get-second vec) (vector-ref vec 5))
+(define (pgdatetime-get-microsecond vec) (vector-ref vec 6))
+(define (pgdatetime-set-year! vec val)(vector-set! vec 0 val))
+(define (pgdatetime-set-month! vec val)(vector-set! vec 1 val))
+(define (pgdatetime-set-day! vec val)(vector-set! vec 2 val))
+(define (pgdatetime-set-hour! vec val)(vector-set! vec 3 val))
+(define (pgdatetime-set-minute! vec val)(vector-set! vec 4 val))
+(define (pgdatetime-set-second! vec val)(vector-set! vec 5 val))
+(define (pgdatetime-set-microsecond! vec val)(vector-set! vec 6 val))
+
+;; takes postgres date or timestamp
+(define (pg-date->string pgdate)
+ (conc (pgdatetime-get-month pgdate) "/"
+ (pgdatetime-get-day pgdate) "/"
+ (pgdatetime-get-year pgdate)))
+
+;; takes postgres date or timestamp
+(define (pg-datetime->string pgdate)
+ (conc (pgdatetime-get-month pgdate) "/"
+ (pgdatetime-get-day pgdate) "/"
+ (pgdatetime-get-year pgdate) " "
+ (pgdatetime-get-hour pgdate) ":"
+ (pgdatetime-get-minute pgdate)`))
+
+
+
+;; map to 0 or 1 from a range of values
+;; #f => 0
+;; #t => 1
+;; "0" => 0
+;; "1" => 1
+;; FALSE => 0
+;; TRUE => 1
+;; anything else => 1
+(define (lazy-bool val)
+ (case val
+ ((#f) 0)
+ ((#t) 1)
+ ((0) 0)
+ ((1) 1)
+ (else
+ (cond
+ ((string? val)
+ (let ((nval (string->number val)))
+ (if nval
+ (lazy-bool nval)
+ (cond
+ ((string=? val "FALSE") 0)
+ ((string=? val "TRUE") 1)
+ (else 1)))))
+ ((symbol? val)
+ (lazy-bool (symbol->string val)))
+ (else 1)))))
+)
ADDED dbi/dbi.setup
Index: dbi/dbi.setup
==================================================================
--- /dev/null
+++ dbi/dbi.setup
@@ -0,0 +1,11 @@
+;; Copyright 2007-2018, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+
+;;;; dbi.setup
+(standard-extension 'dbi "0.5")
ADDED dbi/example.scm
Index: dbi/example.scm
==================================================================
--- /dev/null
+++ dbi/example.scm
@@ -0,0 +1,69 @@
+;;; dbi: Minimal gasket to postgresql, sqlite3 and mysql
+;;;
+;; Copyright (C) 2007-2016 Matt Welland
+;; Redistribution and use in source and binary forms, with or without
+;; modification, is permitted.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
+;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+;; DAMAGE.
+
+;; WARNING: This example is basically useless, I'll rewrite it one of these days ....
+
+(require-library margs dbi)
+
+(define help "help me")
+
+(define remargs (args:get-args
+ (argv)
+ (list "-inf")
+ (list "-h")
+ args:arg-hash
+ 0))
+
+;; define DBPATH in setup.scm
+(include "setup.scm")
+
+(define (ftf:mk-db)
+ (let* ((fname (conc DBPATH "/ftfplan.db"))
+ (dbexists (file-exists? fname))
+ (dbh (if dbexists (dbi:open 'sqlite3 (list (cons 'dbname fname))) #f)))
+ (if (not dbexists)
+ (begin
+ ;; (print "fullname: " fullname)
+ (system (conc "mkdir -p " DBPATH)) ;; create the path
+ (set! dbh (dbi:open 'sqlite3 (list (cons 'dbname fname))))
+ (for-each
+ (lambda (sqry)
+ ;; (print sqry)
+ (dbi:exec dbh sqry))
+ ;; types: 0 text, 1 jpg, 2 png, 3 svg, 4 spreadsheet, 5 audio, 6 video :: better specs to come...
+ (list
+ "CREATE TABLE pics (id INTEGER PRIMARY KEY,name TEXT,dat_id INTEGER,thumb_dat_id INTEGER,created_on INTEGER,owner_id INTEGER);"
+ "CREATE TABLE dats (id INTEGER PRIMARY KEY,md5sum TEXT,dat BLOB,type INTEGER);"
+ ;; on every modification a new tiddlers entry is created. When displaying the tiddlers do:
+ ;; select where created_on < somedate order by created_on desc limit 1
+ "CREATE TABLE tiddlers (id INTEGER PRIMARY KEY,wiki_id INTEGER,name TEXT,rev INTEGER,dat_id INTEGER,created_on INTEGER,owner_id INTEGER);"
+ ;; rev and tag only utilized when user sets a tag. All results from a select as above for tiddlers are set to the tag
+ "CREATE TABLE revs (id INTEGER PRIMARY KEY,tag TEXT);"
+ ;; wikis is here for when postgresql support is added or if a sub wiki is created.
+ "CREATE TABLE wikis (id INTEGER PRIMARY KEY,key_name TEXT,title TEXT,created_on INTEGER);"))
+ ))
+ dbh))
+
+(define db (ftf:mk-db))
+
+(dbi:exec db "INSERT INTO pics (name,owner_id) VALUES ('bob',1);")
+(dbi:for-each-row (lambda (row)(print "Name: " (vector-ref row 0) ", owner_id: " (vector-ref row 1)))
+ db
+ "SELECT name,owner_id FROM pics;")
+
Index: diff-report.scm
==================================================================
--- diff-report.scm
+++ diff-report.scm
@@ -14,18 +14,19 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-(declare (unit diff-report))
-(declare (uses common))
-(declare (uses rmt))
-
-(include "common_records.scm")
-(use matchable)
-(use fmt)
-(use ducttape-lib)
+;; (declare (unit diff-report))
+;; (declare (uses common))
+;; (declare (uses rmt))
+;;
+;; (include "common_records.scm")
+;; (use matchable)
+;; (use fmt)
+;; (use ducttape-lib)
+
(define css "")
(define (diff:tests-mindat->hash tests-mindat)
(let* ((res (make-hash-table)))
(for-each
Index: ducttape/ducttape-lib.scm
==================================================================
--- ducttape/ducttape-lib.scm
+++ ducttape/ducttape-lib.scm
@@ -49,19 +49,21 @@
*this-exe-dir*
*this-exe-name*
*this-exe-fullpath*
)
- (import scheme chicken extras ports data-structures )
- (use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339)
+ (import scheme chicken.base chicken.port chicken.process chicken.io chicken.pathname chicken.process-context chicken.time chicken.process chicken.condition chicken.time.posix chicken.process-context.posix chicken.format chicken.file.posix)
+ (import regex ansi-escape-sequences test srfi-1 chicken.irregex slice srfi-13 rfc3339)
;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process*
- (use directory-utils uuid-lib filepath srfi-19 ) ; linenoise
+ ;;(import directory-utils uuid-lib filepath srfi-19 ) ; linenoise
+ (import directory-utils filepath srfi-19 ) ; linenoise
;; plugs a hole in posix-extras in latter chicken versions
- (use posix-extras pathname-expand files)
+ (import pathname-expand chicken.file chicken.string)
(define ##sys#expand-home-path pathname-expand)
- (define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) ))
+ (define (realpath x) (print "Path: " x) (normalize-pathname (pathname-expand (or x "/dev/null")) ))
+ ;;(define (realpath x) (pathname-expand (or x "/dev/null")))
;; (include "mimetypes.scm") ; provides ext->mimetype
;; (include "workweekdate.scm")
;; gathered from macosx:
@@ -841,14 +843,14 @@
("avi" . "video/x-msvideo")
("movie" . "video/x-sgi-movie")
("smv" . "video/x-smv")
("ice" . "x-conference/x-cooltalk")))
-(use srfi-19)
-(use test)
+(import srfi-19)
+(import test)
;;(use format)
-(use regex)
+(import regex)
;(declare (unit wwdate))
;; utility procedures to convert among
;; different ways to express date (wwdate, seconds since epoch, isodate)
;;
;; samples:
@@ -1058,11 +1060,11 @@
(if (null? rest-path-items)
#f
(let* ((this-dir (car rest-path-items))
(next-rest (cdr rest-path-items))
(candidate (conc this-dir "/" exe)))
- (if (file-execute-access? candidate)
+ (if (file-executable? candidate)
candidate
(loop next-rest)))))))
@@ -1247,15 +1249,15 @@
(let ((num-debug-level (runs-ok (string->number raw-debug-level))))
(if (integer? num-debug-level)
(begin
(let ((new-num-debug-level (- num-debug-level 1)))
(if (> new-num-debug-level 0) ;; decrement
- (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level))
- (unsetenv "DUCTTAPE_DEBUG_LEVEL")))
+ (set-environment-variable! "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level))
+ (unset-environment-variable! "DUCTTAPE_DEBUG_LEVEL")))
num-debug-level) ; it was set and > 0, mode is value
(begin
- (unsetenv "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it
+ (unset-environment-variable! "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it
#f))) ; value was invalid, mode is f
#f)))) ; var not set, mode is f
(define ducttape-debug-mode (if (ducttape-debug-level) #t #f))
@@ -1360,11 +1362,11 @@
(user (or (get-environment-variable "USER") "nouser"))
(host (or (get-environment-variable "HOST") "nohost")))
(if logfile
(begin
(ducttape-log-file logfile)
- (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file))))
+ (set-environment-variable! "DUCTTAPE_LOG_FILE" (ducttape-log-file))))
(ducttape-append-logfile 'note (format #f "START - pid=~A ppid=~A argv=(~A) pwd=~A user=~A host=~A" pid ppid argv pwd user host) #t)))
;; log exit code
(define (set-ducttape-log-exit-handler)
@@ -1522,11 +1524,13 @@
(define (sendmail-proc sendmail-port)
(define (wl line-str)
(write-line line-str sendmail-port))
(define (get-uuid)
- (string-upcase (uuid->string (uuid-generate))))
+(print "ERROR in ducttape lib")
+ "foo")
+ ;;(string-upcase (uuid->string (uuid-generate))))
(let ((mailpart-uuid (get-uuid))
(mailpart-body-uuid (get-uuid)))
(define (boundary)
@@ -1702,40 +1706,40 @@
;; --quiet
(let ((quiet-opts (skim-cmdline-opts-noarg-by-regex "--?quiet")))
(if (not (null? quiet-opts))
(begin
- (setenv "DUCTTAPE_QUIET_MODE" "1")
+ (set-environment-variable! "DUCTTAPE_QUIET_MODE" "1")
(ducttape-quiet-mode "1"))))
;; --silent
(let ((silent-opts (skim-cmdline-opts-noarg-by-regex "--?silent")))
(if (not (null? silent-opts))
(begin
- (setenv "DUCTTAPE_SILENT_MODE" "1")
+ (set-environment-variable! "DUCTTAPE_SILENT_MODE" "1")
(ducttape-silent-mode "1"))))
;; -color
(let ((color-opts (skim-cmdline-opts-noarg-by-regex "--?colou?r(ize)?")))
(if (not (null? color-opts))
(begin
- (setenv "DUCTTAPE_COLORIZE" "1")
+ (set-environment-variable! "DUCTTAPE_COLORIZE" "1")
(ducttape-color-mode "1"))))
;; -nocolor
(let ((nocolor-opts (skim-cmdline-opts-noarg-by-regex "--?nocolou?r(ize)?")))
(if (not (null? nocolor-opts))
(begin
- (unsetenv "DUCTTAPE_COLORIZE" )
+ (unset-environment-variable! "DUCTTAPE_COLORIZE" )
(ducttape-color-mode #f))))
;; -logfile
(let ((logfile-opts (skim-cmdline-opts-withargs-by-regex "--?log(-?file)?")))
(if (not (null? logfile-opts))
(begin
(ducttape-log-file (car (reverse logfile-opts)))
- (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file)))))
+ (set-environment-variable! "DUCTTAPE_LOG_FILE" (ducttape-log-file)))))
;; -d -dd -d#
(let ((debug-opts (skim-cmdline-opts-noarg-by-regex "-d(d*|\\d+)"))
(initial-debuglevel (if (ducttape-debug-level) (ducttape-debug-level) 0) ))
(if (not (null? debug-opts))
@@ -1750,19 +1754,19 @@
(ds (string-match "-(d+)" curopt))
(dnum (string-match "-d(\\d+)" curopt)))
(cond
(ds (loop restopts (+ debuglevel (string-length (cadr ds)))))
(dnum (loop restopts (string->number (cadr dnum)))))))))
- (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level))))))
+ (set-environment-variable! "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level))))))
;; -dp / --debug-pattern
(let ((debugpat-opts (skim-cmdline-opts-withargs-by-regex "--?(debug-pattern|dp)")))
(if (not (null? debugpat-opts))
(begin
(ducttape-debug-regex-filter (string-join debugpat-opts "|"))
- (setenv "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter))))))
+ (set-environment-variable! "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter))))))
;;; following code commented out; side effects not wanted on startup
;; immediately activate logfile (will be noop if logfile disabled)
;;(ducttape-activate-logfile)
Index: env.scm
==================================================================
--- env.scm
+++ env.scm
@@ -16,13 +16,13 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;======================================================================
-(declare (unit env))
+;; (declare (unit env))
-(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
+;; (use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
(define (env:open-db fname)
(let* ((db-exists (common:file-exists? fname))
(db (open-database fname)))
(if (not db-exists)
Index: ezsteps.scm
==================================================================
--- ezsteps.scm
+++ ezsteps.scm
@@ -17,27 +17,27 @@
;; along with Megatest. If not, see .
;;
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-(use srfi-1 posix regex srfi-69 directory-utils call-with-environment-variables posix-extras
- z3 csv typed-records pathname-expand matchable)
-
-(declare (unit ezsteps))
-(declare (uses db))
-(declare (uses common))
-(declare (uses items))
-(declare (uses runconfig))
-;; (declare (uses sdb))
-;; (declare (uses filedb))
-
-(include "common_records.scm")
-(include "key_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
-
-
+;; (use srfi-1 posix regex srfi-69 directory-utils call-with-environment-variables posix-extras
+;; z3 csv typed-records pathname-expand matchable)
+;;
+;; (declare (unit ezsteps))
+;; (declare (uses db))
+;; (declare (uses common))
+;; (declare (uses items))
+;; (declare (uses runconfig))
+;; ;; (declare (uses sdb))
+;; ;; (declare (uses filedb))
+;;
+;; (include "common_records.scm")
+;; (include "key_records.scm")
+;; (include "db_records.scm")
+;; (include "run_records.scm")
+;;
+;;
;;(rmt:get-test-info-by-id run-id test-id) -> testdat
;; TODO: deprecate me in favor of ezsteps.scm
;;
(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
Index: gen-data-for-graph.scm
==================================================================
--- gen-data-for-graph.scm
+++ gen-data-for-graph.scm
@@ -31,21 +31,21 @@
(lambda ()
(loop ((for m (up-from (/ one-year-ago 60) (to (/ now 60))))) ;; days of the year
(let ((thetime (* m 60))
(thehour (round (/ m 60))))
(let loop ((lastsec -1)
- (sec (random 60))
+ (sec (pseudo-random-integer 60))
(count 0))
(if (> sec lastsec)
(exec (sql db "INSERT INTO alldat (event_time,var,val) VALUES (?,?,?)")
(+ thetime sec) ;; (* sec 60))
"stuff"
(if (even? thehour)
- (random 1000)
- (random 6))))
+ (pseudo-random-integer 1000)
+ (pseudo-random-integer 6))))
(if (< count 20)
- (loop (max sec lastsec)(random 60)(+ count 1))))))))
+ (loop (max sec lastsec)(pseudo-random-integer 60)(+ count 1))))))))
(close-database db)
;; (with-transaction
@@ -55,18 +55,18 @@
;; (print "Day: " d)
;; (loop ((for h (up-from 1 (to 24))))
;; (loop ((for m (up-from 1 (to 60))))
;; (let ((thetime (+ beginning-2016 (* 365 24 60 60)(* h 60 60)(* m 60))))
;; (let loop ((lastsec -1)
-;; (sec (random 60))
+;; (sec (pseudo-random-integer 60))
;; (count 0))
;; (if (> sec lastsec)
;; (exec (sql db "INSERT INTO alldat (event_time,var,val) VALUES (?,?,?)")
;; (+ thetime sec) ;; (* sec 60))
;; "stuff"
;; (if (even? h)
-;; (random 100)
-;; (random 6))))
+;; (pseudo-random-integer 100)
+;; (pseudo-random-integer 6))))
;; (if (< count 20)
-;; (loop (max sec lastsec)(random 60)(+ count 1))))))))))
+;; (loop (max sec lastsec)(pseudo-random-integer 60)(+ count 1))))))))))
;;
;; (close-database db)
Index: genexample.scm
==================================================================
--- genexample.scm
+++ genexample.scm
@@ -16,14 +16,14 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;======================================================================
-(declare (unit genexample))
-(use posix regex matchable)
-
-(include "db_records.scm")
+;; (declare (unit genexample))
+;; (use posix regex matchable)
+;;
+;; (include "db_records.scm")
(define genexample:example-logpro
#<.
-(require-extension (srfi 18) extras tcp s11n)
-
-
-(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras)
-
-(use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)
-
+;; (require-extension (srfi 18) extras tcp s11n)
+;;
+;;
+;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras)
+;;
+;; (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)
+;;
;; Configurations for server
(tcp-buffer-size 2048)
(max-connections 2048)
-(declare (unit http-transport))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tests))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-(declare (uses server))
-;; (declare (uses daemon))
-(declare (uses portlogger))
-(declare (uses rmt))
-
-(include "common_records.scm")
-(include "db_records.scm")
-(include "js-path.scm")
+;; (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
Index: items.scm
==================================================================
--- items.scm
+++ items.scm
@@ -19,14 +19,14 @@
;; (define itemdat '((ripeness "green ripe overripe")
;; (temperature "cool medium hot")
;; (season "summer winter fall spring")))
-(declare (unit items))
-(declare (uses common))
-
-(include "common_records.scm")
+;; (declare (unit items))
+;; (declare (uses common))
+;;
+;; (include "common_records.scm")
;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
(let ((res '()))
(if (not hierdepth)
Index: keys.scm
==================================================================
--- keys.scm
+++ keys.scm
@@ -19,18 +19,18 @@
;;======================================================================
;; Run keys, these are used to hierarchially organise tests and run areas
;;======================================================================
-(use sqlite3 srfi-1 posix regex regex-case srfi-69)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit keys))
-(declare (uses common))
-
-(include "key_records.scm")
-(include "common_records.scm")
+;; (use sqlite3 srfi-1 posix regex regex-case srfi-69)
+;; (import (prefix sqlite3 sqlite3:))
+;;
+;; (declare (unit keys))
+;; (declare (uses common))
+;;
+;; (include "key_records.scm")
+;; (include "common_records.scm")
(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
(string-intersperse keys ","))
(define (args:usage . a) #f)
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -19,28 +19,28 @@
;;======================================================================
;; launch a task - this runs on the originating host, tests themselves
;;
;;======================================================================
-(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3
- call-with-environment-variables csv)
-(use typed-records pathname-expand matchable)
-
-(import (prefix base64 base64:))
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit launch))
-(declare (uses subrun))
-(declare (uses common))
-(declare (uses configf))
-(declare (uses db))
-(declare (uses ezsteps))
-
-(include "common_records.scm")
-(include "key_records.scm")
-(include "db_records.scm")
-(include "megatest-fossil-hash.scm")
+;; (use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3
+;; call-with-environment-variables csv)
+;; (use typed-records pathname-expand matchable)
+;;
+;; (import (prefix base64 base64:))
+;; (import (prefix sqlite3 sqlite3:))
+;;
+;; (declare (unit launch))
+;; (declare (uses subrun))
+;; (declare (uses common))
+;; (declare (uses configf))
+;; (declare (uses db))
+;; (declare (uses ezsteps))
+;;
+;; (include "common_records.scm")
+;; (include "key_records.scm")
+;; (include "db_records.scm")
+;; (include "megatest-fossil-hash.scm")
;;======================================================================
;; ezsteps
;;======================================================================
@@ -307,11 +307,11 @@
;; no point in sticking around. Exit now. But run end of run before exiting?
(launch:end-of-run-check run-id)
(exit)))
(if (hash-table-ref/default misc-flags 'keep-going #f)
(begin
- (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses
+ (thread-sleep! 3) ;; (+ 3 (pseudo-random-integer 6))) ;; add some jitter to the call home time to spread out the db accesses
(if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
(loop (calc-minutes)
(or new-cpu-load cpu-load)
(or new-disk-free disk-free)
(if do-sync (current-seconds) last-sync)))))))
@@ -357,11 +357,11 @@
#f
(if (substring-index "/" runscript)
runscript ;; use unadultered if contains slashes
(let ((fulln (conc work-area "/" runscript)))
(if (and (common:file-exists? fulln)
- (file-execute-access? fulln))
+ (file-executable? fulln))
fulln
runscript))))) ;; assume it is on the path
(check-work-area (lambda ()
;; NFS might not have propagated the directory meta data to the run host - give it time if needed
(let loop ((count 0))
@@ -614,11 +614,11 @@
(if (args:get-arg "-xterm")
(set! fullrunscript "xterm")
(if (and fullrunscript
(common:file-exists? fullrunscript)
- (not (file-execute-access? fullrunscript)))
+ (not (file-executable? fullrunscript)))
(system (conc "chmod ug+x " fullrunscript))))
;; We are about to actually kick off the test
;; so this is a good place to remove the records for
;; any previous runs
@@ -628,11 +628,11 @@
(tconfig-tmpfile (conc tconfig-fname ".tmp"))
(tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
(scripts (configf:get-section tconfig "scripts")))
;; create .testconfig file
(configf:write-alist tconfig tconfig-tmpfile)
- (file-move tconfig-tmpfile tconfig-fname #t)
+ (move-file tconfig-tmpfile tconfig-fname #t)
(delete-file* ".final-status")
;; extract scripts from testconfig and write them to files in test run dir
(for-each
(lambda (scriptdat)
@@ -639,11 +639,11 @@
(match scriptdat
((name content)
(with-output-to-file name
(lambda ()
(print content)
- (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu)))))
+ (set-file-permissions! name (bitwise-ior perm/irwxg perm/irwxu)))))
(else
(debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\""))))
scripts))
;;
(let* ((m (make-mutex))
@@ -913,11 +913,11 @@
#f
(car cachefiles))) ;; (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash)))
(rccachef (if (null? cachefiles)
#f
(cdr cachefiles)))) ;; (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))
- ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-write-access? cachedir) (not (common:in-running-test?)))))
+ ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-writable? cachedir) (not (common:in-running-test?)))))
(set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource
;;(BB> "launch:setup-body -- cachefiles="cachefiles)
(cond
;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME
((and (not force-reread)
@@ -1094,11 +1094,11 @@
(set! *configstatus* 'fulldata)))
;; if have -append-config then read and append here
(let ((cfname (args:get-arg "-append-config")))
(if (and cfname
- (file-read-access? cfname))
+ (file-readable? cfname))
(read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special.
*toppath*)))
(define (get-best-disk confdat testconfig)
Index: margs.scm
==================================================================
--- margs.scm
+++ margs.scm
@@ -14,11 +14,11 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
-(declare (unit margs))
+;; (declare (unit margs))
;; (declare (uses common))
(define args:arg-hash (make-hash-table))
(define (args:get-arg arg . default)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -14,55 +14,194 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
+(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 "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
+ matchable
+ md5
+ message-digest
+ queues
+ regex
+ regex-case
+ sql-de-lite
+ stack
+ typed-records
+ s11n
+ sparse-vectors
+ sxml-serializer
+ sxml-modifications
+ system-information
+ z3
+
+ srfi-1
+ srfi-4
+ srfi-18
+ srfi-13
+ srfi-98
+ srfi-69
+
+ ;; local modules
+ mutils
+ csv-xml
+ ducttape-lib
+
+ )
+
;; (include "common.scm")
(include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
-
-(declare (uses common))
-;; (declare (uses megatest-version))
-(declare (uses margs))
-(declare (uses runs))
-(declare (uses launch))
-(declare (uses server))
-(declare (uses client))
-(declare (uses tests))
-(declare (uses genexample))
-;; (declare (uses daemon))
-(declare (uses db))
-;; (declare (uses dcommon))
-
-(declare (uses tdb))
-(declare (uses mt))
-(declare (uses api))
-(declare (uses tasks)) ;; only used for debugging.
-(declare (uses env))
-(declare (uses diff-report))
+(define setenv set-environment-variable!)
+(define unsetenv unset-environment-variable!)
+
+;; (declare (uses common))
+;; ;; (declare (uses megatest-version))
+;; (declare (uses margs))
+;; (declare (uses runs))
+;; (declare (uses launch))
+;; (declare (uses server))
+;; (declare (uses client))
+;; (declare (uses tests))
+;; (declare (uses genexample))
+;; ;; (declare (uses daemon))
+;; (declare (uses db))
+;; ;; (declare (uses dcommon))
+;;
+;; (declare (uses tdb))
+;; (declare (uses mt))
+;; (declare (uses api))
+;; (declare (uses tasks)) ;; only used for debugging.
+;; (declare (uses env))
+;; (declare (uses diff-report))
;; (declare (uses ftail))
;; (import ftail)
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
+(include "test_records.scm")
(include "megatest-fossil-hash.scm")
-(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
- readline apropos json http-client directory-utils typed-records
- http-client srfi-18 extras format)
+(import (prefix dbi dbi:))
+(import stml2)
+(import pkts)
+
+(include "common.scm")
+(include "configf.scm")
+(include "margs.scm")
+(include "process.scm")
+(include "keys.scm")
+(include "db.scm")
+(include "rmt.scm")
+(include "runs.scm")
+(include "launch.scm")
+(include "server.scm")
+(include "client.scm")
+(include "tests.scm")
+(include "items.scm")
+(include "subrun.scm")
+(include "genexample.scm")
+(include "tdb.scm")
+(include "mt.scm")
+(include "api.scm")
+(include "tasks.scm")
+(include "ezsteps.scm")
+(include "env.scm")
+(include "diff-report.scm")
+(include "cgisetup/models/pgdb.scm")
+(include "runconfig.scm")
+(include "archive.scm")
+(include "ods.scm")
+(include "http-transport.scm")
+
+;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
+;; readline apropos json http-client directory-utils typed-records
+;; http-client srfi-18 extras format)
;; Added for csv stuff - will be removed
;;
-(use sparse-vectors)
+;; (use sparse-vectors)
+;;
+;; (require-library mutils)
-(require-library mutils)
+;; copied from egg call-with-environment-variables
+;;
+(define (call-with-environment-variables variables thunk)
+ #;@("Sets up environment variable via dynamic-wind which are taken down after thunk."
+ (variables "An alist of the form {{'((\"var\" . \"value\") ...)}}")
+ (thunk "The thunk to execute with a modified environment"))
+ (let ((pre-existing-variables
+ (map (lambda (var-value)
+ (let ((var (car var-value)))
+ (cons var (get-environment-variable var))))
+ variables)))
+ (dynamic-wind
+ (lambda () (void))
+ (lambda ()
+;; (use posix)
+ (for-each (lambda (var-value)
+ (setenv (car var-value) (cdr var-value)))
+ variables)
+ (thunk))
+ (lambda ()
+ (for-each (lambda (var-value)
+ (let ((var (car var-value))
+ (value (cdr var-value)))
+ (if value
+ (setenv var value)
+ (unsetenv var))))
+ pre-existing-variables)))))
+
+
(define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file
(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file
;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
@@ -72,11 +211,11 @@
(load debugcontrolf)))
;; usage logging, careful with this, it is not designed to deal with all real world challenges!
;;
(if (and *usage-log-file*
- (file-write-access? *usage-log-file*))
+ (file-writable? *usage-log-file*))
(with-output-to-file
*usage-log-file*
(lambda ()
(print
(if *usage-use-seconds*
@@ -1000,11 +1139,11 @@
(conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))
#f))
(cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
(if (and cfgf
(common:file-exists? cfgf)
- (file-write-access? cfgf)
+ (file-writable? cfgf)
(common:use-cache?))
(configf:read-alist cfgf)
(let* ((keys (rmt:get-keys))
(target (common:args-get-target))
(key-vals (if target (keys:target->keyval keys target) #f))
@@ -1017,11 +1156,11 @@
key-vals))
;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
(runconfig:read (conc *toppath* "/runconfigs.config") target #f))))
(if (and rundir ;; have all needed variabless
(directory-exists? rundir)
- (file-write-access? rundir))
+ (file-writable? rundir))
(begin
(if (not (common:in-running-test?))
(configf:write-alist data cfgf))
;; force re-read of megatest.config - this resolves circular references between megatest.config
(launch:setup force-reread: #t)
@@ -1683,11 +1822,11 @@
;; (print "runs:")
;; (pp runs)
;(print "sheets: ")
;; (pp sheets)
(if (eq? dmode 'ods)
- (let* ((tempdir (conc "/tmp/" (current-user-name) "/" (random 10000) "_" (current-process-id)))
+ (let* ((tempdir (conc "/tmp/" (current-user-name) "/" (pseudo-random-integer 10000) "_" (current-process-id)))
(outputfile (or (args:get-arg "-o") "out.ods"))
(ouf (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
outputfile
(begin
(debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
@@ -2331,11 +2470,11 @@
;;======================================================================
;; Start a repl
;;======================================================================
;; fakeout readline
-(include "readline-fix.scm")
+;; (include "readline-fix.scm")
(when (args:get-arg "-diff-rep")
(when (and
(not (args:get-arg "-diff-html"))
@@ -2378,25 +2517,25 @@
(repl))
(else
(begin
(set! *db* dbstruct)
- (import extras) ;; might not be needed
+ ;; (import extras) ;; might not be needed
;; (import csi)
- (import readline)
+ ;; (import readline)
(import apropos)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
- (if *use-new-readline*
- (begin
- (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines])
- (current-input-port (make-readline-port "megatest> ")))
- (begin
- (gnu-history-install-file-manager
- (string-append
- (or (get-environment-variable "HOME") ".") "/.megatest_history"))
- (current-input-port (make-gnu-readline-port "megatest> "))))
+ ;; (if *use-new-readline*
+ ;; (begin
+ ;; (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines])
+ ;; (current-input-port (make-readline-port "megatest> ")))
+ ;; (begin
+ ;; (gnu-history-install-file-manager
+ ;; (string-append
+ ;; (or (get-environment-variable "HOME") ".") "/.megatest_history"))
+ ;; (current-input-port (make-gnu-readline-port "megatest> "))))
(if (args:get-arg "-repl")
(repl)
(load (args:get-arg "-load")))
;; (db:close-all dbstruct) <= taken care of by on-exit call
)
@@ -2550,5 +2689,6 @@
(case *globalexitstatus*
((0)(exit 0))
((1)(exit 1))
((2)(exit 2))
(else (exit 3)))))
+)
Index: mt.scm
==================================================================
--- mt.scm
+++ mt.scm
@@ -15,29 +15,29 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit mt))
-(declare (uses db))
-(declare (uses common))
-(declare (uses items))
-(declare (uses runconfig))
-(declare (uses tests))
-(declare (uses server))
-(declare (uses runs))
-(declare (uses rmt))
-;; (declare (uses filedb))
-
-(include "common_records.scm")
-(include "key_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
-(include "test_records.scm")
+;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables)
+;; (import (prefix sqlite3 sqlite3:))
+;;
+;; (declare (unit mt))
+;; (declare (uses db))
+;; (declare (uses common))
+;; (declare (uses items))
+;; (declare (uses runconfig))
+;; (declare (uses tests))
+;; (declare (uses server))
+;; (declare (uses runs))
+;; (declare (uses rmt))
+;; ;; (declare (uses filedb))
+;;
+;; (include "common_records.scm")
+;; (include "key_records.scm")
+;; (include "db_records.scm")
+;; (include "run_records.scm")
+;; (include "test_records.scm")
;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
;; here.
;;======================================================================
@@ -155,14 +155,14 @@
event-time
))
(prev-nbfake-log (get-environment-variable "NBFAKE_LOG")))
(setenv "NBFAKE_LOG" (conc (cond
((and (directory-exists? test-rundir)
- (file-write-access? test-rundir))
+ (file-writable? test-rundir))
test-rundir)
((and (directory-exists? *toppath*)
- (file-write-access? *toppath*))
+ (file-writable? *toppath*))
*toppath*)
(else (conc "/tmp/" (current-user-name))))
"/" logname))
(debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG"))
;; (call-with-environment-variables
@@ -285,11 +285,11 @@
(let loop ((hed (car test-dirs))
(tal (cdr test-dirs)))
;; Setting MT_LINKTREE here is almost certainly unnecessary.
(let ((tconfig-file (conc hed "/" test-name "/testconfig")))
(if (and (common:file-exists? tconfig-file)
- (file-read-access? tconfig-file))
+ (file-readable? tconfig-file))
(let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
(old-link-tree (get-environment-variable "MT_LINKTREE")))
(if link-tree-path (setenv "MT_LINKTREE" link-tree-path))
(let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]
(hash-table-set! *testconfigs* test-name newtcfg)
Index: mutils/mutils.scm
==================================================================
--- mutils/mutils.scm
+++ mutils/mutils.scm
@@ -12,22 +12,37 @@
;;
(module mutils
*
- (import chicken scheme
+ (import scheme
+
+ chicken.base
+ chicken.file
+ chicken.file.posix
+ chicken.port
+ chicken.process
+ chicken.process-context
+ chicken.random
+ chicken.condition
+ chicken.io
+ chicken.time
+ chicken.string
+
;; data-structures posix
srfi-1
;; srfi-13
srfi-69
- ports
- extras
+ srfi-98
+
regex
- posix
- data-structures
matchable
+ sparse-vectors
+ system-information
+
)
+
(define (mutils:hierhash-ref hh . keys)
(if (null? keys)
#f
(let loop ((ht hh)
@@ -90,12 +105,10 @@
(if (or (string-match comment l)
(string-match blank l))
(loop (read-line fh) res)
(loop (read-line fh) (cons l res)))))))
-(use sparse-vectors)
-
;; this is a simple two dimensional sparse array
;; ONLY TWO DIMENSIONS!!! SEE ARRAY-LIB IF YOUR NEEDS ARE GREATER!!
;;
(define (mutils:make-sparse-array)
@@ -189,12 +202,13 @@
;;======================================================================
;; Other utils
;;======================================================================
(define (check-write-create fpath)
- (and (file-write-access? fpath)
- (let ((fname (conc fpath "/.junk-" (current-seconds) "-" (random 10000))))
+ (and (file-writable? fpath)
+ (let ((fname (conc fpath "/.junk-" (current-seconds) "-"
+ (pseudo-random-integer 10000))))
;;(print "trying to create/remove " fname)
(handle-exceptions
exn
#f
(begin
Index: ods.scm
==================================================================
--- ods.scm
+++ ods.scm
@@ -14,13 +14,13 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-(use csv-xml regex)
-(declare (unit ods))
-(declare (uses common))
+;; (use csv-xml regex)
+;; (declare (unit ods))
+;; (declare (uses common))
(define ods:dirs
'("Configurations2"
"Configurations2/toolpanel"
"Configurations2/menubar"
Index: pkts/pkts.scm
==================================================================
--- pkts/pkts.scm
+++ pkts/pkts.scm
@@ -162,12 +162,13 @@
;; utility procs
increment-string ;; used to get indexes for strings in ref pkts
make-report ;; make a .dot file
)
-(import chicken scheme data-structures posix srfi-1 regex srfi-13 srfi-69 ports extras)
-(use crypt sha1 message-digest (prefix dbi dbi:) typed-records)
+(import (chicken base) scheme (chicken process) (chicken time posix) (chicken io) (chicken file))
+(import chicken.process-context.posix (chicken string) (chicken time) (chicken sort) (chicken file posix) (chicken condition) srfi-1 regex srfi-13 srfi-69 (chicken port) )
+(import crypt sha1 message-digest (prefix dbi dbi:) typed-records)
;;======================================================================
;; DATA MANIPULATION UTILS
;;======================================================================
@@ -695,11 +696,11 @@
(cond
((not (file-exists? pktsdir))
(print "ERROR: packets directory " pktsdir " does not exist."))
((not (directory? pktsdir))
(print "ERROR: packets directory path " pktsdir " is not a directory."))
- ((not (file-read-access? pktsdir))
+ ((not (file-readable? pktsdir))
(print "ERROR: packets directory path " pktsdir " is not readable."))
(else
;; (print "INFO: Loading packets found in " pktsdir)
(let ((pkts (glob (conc pktsdir "/*.pkt"))))
(for-each
Index: portlogger.scm
==================================================================
--- portlogger.scm
+++ portlogger.scm
@@ -34,11 +34,11 @@
(sqlite3:open-database fname)
(begin
(system (conc "rm -f " fname))
(sqlite3:open-database fname))))
(handler (sqlite3:make-busy-timeout 136000))
- (canwrite (file-write-access? fname)))
+ (canwrite (file-writable? fname)))
;; (db-init (lambda ()
;; (sqlite3:execute
;; db
;; "CREATE TABLE IF NOT EXISTS ports (
;; port INTEGER PRIMARY KEY,
@@ -130,11 +130,11 @@
(string->number val))
(string->number val)
32768)))
(portnum (or (portlogger:get-prev-used-port db)
(+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range
- (random (- 64000 lowport))))))
+ (pseudo-random-integer (- 64000 lowport))))))
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db")
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
Index: process.scm
==================================================================
--- process.scm
+++ process.scm
@@ -20,12 +20,12 @@
;;======================================================================
;; Process convience utils
;;======================================================================
-(use regex directory-utils)
-(declare (unit process))
+;; (use regex directory-utils)
+;; (declare (unit process))
(define (process:conservative-read port)
(let loop ((res ""))
(if (not (eof-object? (peek-char port)))
(loop (conc res (read-char port)))
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -16,16 +16,16 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
;;======================================================================
-(use format typed-records) ;; RADT => purpose of json format??
-
-(declare (unit rmt))
-(declare (uses api))
-(declare (uses http-transport))
-(include "common_records.scm")
+;; (use format typed-records) ;; RADT => purpose of json format??
+;;
+;; (declare (unit rmt))
+;; (declare (uses api))
+;; (declare (uses http-transport))
+;; (include "common_records.scm")
;; (declare (uses rmtmod))
;; (import rmtmod)
;;
@@ -371,11 +371,11 @@
(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
(let* ((qry-is-write (not (member cmd api:read-only-queries)))
(db-file-path (db:dbfile-path)) ;; 0))
(dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t)))
- (read-only (not (file-write-access? db-file-path)))
+ (read-only (not (file-writable? db-file-path)))
(start (current-milliseconds))
(resdat (if (not (and read-only qry-is-write))
(let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))))
(handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
exn ;; This is an attempt to detect that situation and recover gracefully
@@ -395,11 +395,11 @@
(debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
(if (not success)
(if (> remretries 0)
(begin
(debug:print-error 0 *default-log-port* "local query failed. Trying again.")
- (thread-sleep! (/ (random 5000) 1000)) ;; some random delay
+ (thread-sleep! (/ (pseudo-random-integer 5000) 1000)) ;; some random delay
(rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1)))
(begin
(debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up")
#f))
(begin
@@ -974,11 +974,11 @@
(define (rmtmod:calc-ro-mode runremote *toppath*)
(if (and runremote
(remote-ro-mode-checked runremote))
(remote-ro-mode runremote)
(let* ((dbfile (conc *toppath* "/megatest.db"))
- (ro-mode (not (file-write-access? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
+ (ro-mode (not (file-writable? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
(if runremote
(begin
(remote-ro-mode-set! runremote ro-mode)
(remote-ro-mode-checked-set! runremote #t)
ro-mode)
Index: runconfig.scm
==================================================================
--- runconfig.scm
+++ runconfig.scm
@@ -18,16 +18,16 @@
;;======================================================================
;; read a config file, loading only the section pertinent
;; to this run field1val/field2val/field3val ...
;;======================================================================
-(use format directory-utils)
-
-(declare (unit runconfig))
-(declare (uses common))
-
-(include "common_records.scm")
+;; (use format directory-utils)
+;;
+;; (declare (unit runconfig))
+;; (declare (uses common))
+;;
+;; (include "common_records.scm")
(define (runconfig:read fname target environ-patt)
(let ((ht (make-hash-table)))
(if target (hash-table-set! ht target '()))
(read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f))))
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -15,31 +15,31 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18)
- posix-extras directory-utils pathname-expand typed-records format sxml-serializer
- sxml-modifications matchable)
-
-(declare (unit runs))
-(declare (uses db))
-(declare (uses common))
-(declare (uses items))
-(declare (uses runconfig))
-(declare (uses tests))
-(declare (uses server))
-(declare (uses mt))
-(declare (uses archive))
-;; (declare (uses filedb))
-
-(include "common_records.scm")
-(include "key_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
-(include "test_records.scm")
-
+;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18)
+;; posix-extras directory-utils pathname-expand typed-records format sxml-serializer
+;; sxml-modifications matchable)
+;;
+;; (declare (unit runs))
+;; (declare (uses db))
+;; (declare (uses common))
+;; (declare (uses items))
+;; (declare (uses runconfig))
+;; (declare (uses tests))
+;; (declare (uses server))
+;; (declare (uses mt))
+;; (declare (uses archive))
+;; ;; (declare (uses filedb))
+;;
+;; (include "common_records.scm")
+;; (include "key_records.scm")
+;; (include "db_records.scm")
+;; (include "run_records.scm")
+;; (include "test_records.scm")
+;;
;; (include "debugger.scm")
;; use this struct to facilitate refactoring
;;
@@ -128,11 +128,11 @@
(endt (+ startt duration)))
((or proc runs:parallel-runners-mgmt) rdat)
(let loop ()
(let* ((wstart (current-seconds)))
(if (< wstart endt)
- (let* ((work-time (random 10)))
+ (let* ((work-time (pseudo-random-integer 10)))
#;(debug:print-info 0 *default-log-port* "working for " work-time
" seconds. Total work: " rtime ", elapsed time: " (- wstart startt))
(thread-sleep! work-time)
(set! rtime (+ rtime work-time))
((or proc runs:parallel-runners-mgmt) rdat)
@@ -508,11 +508,11 @@
(keyvals (keys:target->keyval keys target))
(run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name)))
;; (deferred '()) ;; delay running these since they have a waiton clause
(runconfigf (conc *toppath* "/runconfigs.config"))
(dbfile (conc *toppath* "/megatest.db"))
- (readonly-mode (not (file-write-access? dbfile)))
+ (readonly-mode (not (file-writable? dbfile)))
(test-records (make-hash-table))
;; need to process runconfigs before generating these lists
(all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
(all-test-names #f) ;; (hash-table-keys all-tests-registry))
(test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts))
@@ -2342,11 +2342,11 @@
(keep-records (args:get-arg "-keep-records")) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode".
(test-records '())) ;; for tasks that we wish to operate on all tests in one fell swoop
(let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs))
(dbfile (conc *toppath* "/megatest.db"))
- (readonly-mode (not (file-write-access? dbfile))))
+ (readonly-mode (not (file-writable? dbfile))))
(when (and readonly-mode
(member action write-access-actions))
(debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .")
(exit 1)))
@@ -2565,11 +2565,11 @@
(substring-index run-name rundir)
(tests:glob-like-match (conc "%/" target "/%") rundir)
)
(begin
(set! lasttpath (db:test-get-rundir new-test-dat)) ;; remember this path for run removal
- (set! lastrealpath (remove-last-path-directory (resolve-pathname lasttpath)))
+ (set! lastrealpath (remove-last-path-directory (realpath lasttpath)))
(hash-table-set! run-paths-hash lastrealpath 1)
(runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
)
(begin
(debug:print 2 *default-log-port* "Not removing directory " rundir " because either it doesn't exist or has a bad name")
@@ -2733,11 +2733,11 @@
((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f)))
(debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
(if (and real-dir
(> (string-length real-dir) 5)
(common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc.
- (let* ((realpath (resolve-pathname run-dir)))
+ (let* ((realpath (realpath run-dir)))
(debug:print-info 1 *default-log-port* "Recursively removing " realpath)
(if (common:file-exists? realpath)
(runs:safe-delete-test-dir realpath)
(debug:print 0 *default-log-port* "WARNING: test dir " realpath " appears to not exist or is not readable")))
(if real-dir
@@ -2959,12 +2959,11 @@
'(*TOP*
(*PI* xml "version='1.0'")
(testsuite)))
(define (runs:update-junit-test-reporter-xml run-id)
- (let* (
- (junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml"))
+ (let* ((junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml"))
(junit-test-report-dir (configf:lookup *configdat* "runs" "junit-test-report-dir"))
(xml-dir (if (and junit-test-reporter (equal? junit-test-reporter "yes" ))
(if junit-test-report-dir
junit-test-report-dir
(conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")))
@@ -3003,33 +3002,33 @@
(test-state (vector-ref test 3))
(comment (vector-ref test 14))
(test-status (vector-ref test 4))
(exc-msg (conc "No bucket for State " test-state " Status " test-status))
(new-doc (cond
- ((member test-state (list "RUNNING" ))
- ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc))
- ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED"))
- ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc))
- ((member test-status (list "PASS" "WARN" "WAIVED"))
- ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc))
- ((member test-status (list "FAIL" "CHECK"))
- ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc))
- ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
- ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc))
- ((member test-status (list "SKIP"))
- ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc))
- (else
- (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status))
- ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc))))
- (new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
- (+ error-cnt 1)
- error-cnt))
- (new-fail-cnt (if (member test-status (list "FAIL" "CHECK"))
- (+ fail-cnt 1)
- fail-cnt)))
+ ((member test-state (list "RUNNING" ))
+ ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc))
+ ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED"))
+ ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc))
+ ((member test-status (list "PASS" "WARN" "WAIVED"))
+ ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc))
+ ((member test-status (list "FAIL" "CHECK"))
+ ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc))
+ ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
+ ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc))
+ ((member test-status (list "SKIP"))
+ ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc))
+ (else
+ (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status))
+ ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc))))
+ (new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED"))
+ (+ error-cnt 1)
+ error-cnt))
+ (new-fail-cnt (if (member test-status (list "FAIL" "CHECK"))
+ (+ fail-cnt 1)
+ fail-cnt)))
(if (null? tail)
- (let* ((final-doc ((sxml-modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc)))
+ (let* ((final-doc ((modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc)))
(debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt)
(handle-exceptions
exn
(let* ((msg ((condition-property-accessor 'exn 'message) exn)))
(debug:print 0 *default-log-port* (conc "WARNING: Failed to update file" xml-path". Message:" msg ", exn=" exn)))
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -14,30 +14,30 @@
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;;
-(require-extension (srfi 18) extras tcp s11n)
-
-(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest
- directory-utils posix-extras matchable)
-
-(use spiffy uri-common intarweb http-client spiffy-request-vars)
-
-(declare (unit server))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-;; (declare (uses synchash))
-(declare (uses http-transport))
-;;(declare (uses rpc-transport))
-(declare (uses launch))
-;; (declare (uses daemon))
-
-(include "common_records.scm")
-(include "db_records.scm")
+;; (require-extension (srfi 18) extras tcp s11n)
+;;
+;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest
+;; directory-utils posix-extras matchable)
+;;
+;; (use spiffy uri-common intarweb http-client spiffy-request-vars)
+;;
+;; (declare (unit server))
+;;
+;; (declare (uses common))
+;; (declare (uses db))
+;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
+;; ;; (declare (uses synchash))
+;; (declare (uses http-transport))
+;; ;;(declare (uses rpc-transport))
+;; (declare (uses launch))
+;; ;; (declare (uses daemon))
+;;
+;; (include "common_records.scm")
+;; (include "db_records.scm")
(define (server:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
@@ -154,11 +154,11 @@
(begin
(debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
(setenv "TARGETHOST" target-host)))
(setenv "TARGETHOST_LOGF" logfile)
- (thread-sleep! (/ (random 5000) 1000)) ;; add about a random (up to 5 seconds) initial delay. It seems pretty common that many running tests request a server at the same time
+ (thread-sleep! (/ (pseudo-random-integer 5000) 1000)) ;; add about a random (up to 5 seconds) initial delay. It seems pretty common that many running tests request a server at the same time
;; (common:wait-for-normalized-load load-limit " delaying server start due to load" target-host) ;; do not try starting servers on an already overloaded machine, just wait forever
#;(common:wait-for-homehost-load load-limit (conc " delaying server start due to load on homehost. limit is " load-limit))
(system (conc "nbfake " cmdln))
(unsetenv "TARGETHOST_LOGF")
(if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
@@ -219,11 +219,11 @@
;; if the directory exists continue to get the list
;; otherwise attempt to create the logs dir and then
;; continue
(if (if (directory-exists? (conc areapath "/logs"))
'()
- (if (file-write-access? areapath)
+ (if (file-writable? areapath)
(begin
(condition-case
(create-directory (conc areapath "/logs") #t)
(exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
(exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn)))
@@ -230,11 +230,11 @@
(directory-exists? (conc areapath "/logs")))
'()))
;; Get the list of server logs that do not contain "exiting". Ignore logs for servers that have exited.
(let* ((server-logs-cmd (conc "grep -iL exiting " areapath "/logs/server-*-*.log"))
- (server-logs (string-split (string-chomp (call-with-input-pipe server-logs-cmd read-all))))
+ (server-logs (string-split (string-chomp (call-with-input-pipe server-logs-cmd read-string))))
(num-serv-logs (length server-logs)))
(if (or (null? server-logs) (= num-serv-logs 0))
(let ()
(debug:print 1 *default-log-port* "There are no servers running")
'()
@@ -308,11 +308,11 @@
(< (- now mod-time) 16) ;; still alive - file touched in last 16 seconds
(or (not (configf:lookup *configdat* "server" "runtime")) ;; skip if not set
(< (- now start-time)
(+ (- (string->number (configf:lookup *configdat* "server" "runtime"))
180)
- (random 360)))) ;; under one hour running time +/- 180
+ (pseudo-random-integer 360)))) ;; under one hour running time +/- 180
))
#f))
srvlst)
(lambda (a b)
(< (list-ref a 3)
@@ -331,11 +331,11 @@
(define (server:get-rand-best areapath)
(let ((srvrs (server:get-best (server:get-list areapath))))
(if (and (list? srvrs)
(not (null? srvrs)))
(let* ((len (length srvrs))
- (idx (random len)))
+ (idx (pseudo-random-integer len)))
(list-ref srvrs idx))
#f)))
(define (server:record->id servr)
(handle-exceptions
@@ -410,11 +410,11 @@
(run-delay (+ (case call-num
((0) 0)
((1) 20)
((2) 300)
(else 600))
- (random 5))) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously
+ (pseudo-random-integer 5))) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously
(lock-file (conc areapath "/logs/server-start.lock")))
(if (> (- (current-seconds) when-run) run-delay)
(let* ((start-flag (conc areapath "/logs/server-start-last")))
(common:simple-file-lock-and-wait lock-file expire-time: 15)
(debug:print-info 0 *default-log-port* "server:kind-run: touching " start-flag)
@@ -455,11 +455,11 @@
(servers (server:get-best (server:get-list areapath))))
(if (or (and servers
(null? servers))
(not servers)
(and (list? servers)
- (< (length servers) (random ns)))) ;; somewhere between 0 and numservers
+ (< (length servers) (pseudo-random-integer ns)))) ;; somewhere between 0 and numservers
#f
(let loop ((hed (car servers))
(tal (cdr servers)))
(let ((res (server:check-server hed)))
(if res
Index: stml2/cookie.scm
==================================================================
--- stml2/cookie.scm
+++ stml2/cookie.scm
@@ -45,11 +45,11 @@
;; (declare (unit cookie))
(module cookie
*
-(import chicken scheme data-structures extras srfi-13 ports posix)
+(import (chicken base) scheme queues srfi-13 (chicken port) (chicken io)(chicken file) (chicken format) (chicken string) (chicken time posix))
(require-extension srfi-1 srfi-13 srfi-14 regex)
;; (use srfi-1 srfi-13 srfi-14 regex)
;; (declare (export parse-cookie-string construct-cookie-string))
Index: stml2/stml2.scm
==================================================================
--- stml2/stml2.scm
+++ stml2/stml2.scm
@@ -12,17 +12,17 @@
;; (declare (unit stml))
(module stml2
*
-(import chicken scheme data-structures extras srfi-13 ports posix srfi-69 files srfi-1)
+(import (chicken random) (chicken base) (chicken string) (chicken time) scheme queues srfi-13 (chicken port) (chicken io) (chicken file) srfi-69 srfi-1 (chicken condition) (chicken time posix) (chicken process-context posix) (chicken pathname) (chicken blob) (chicken format) (chicken process) (chicken process-context))
(import cookie)
-(use (prefix dbi dbi:) (prefix crypt c:) typed-records)
+(import (prefix dbi dbi:) (prefix crypt c:) typed-records)
;; (declare (uses misc-stml))
-(use regex)
+(import regex)
;; The (usually global) sdat contains everything about the session
;;
(defstruct sdat
;; database
@@ -421,11 +421,11 @@
;; (s:get-key 'n 1) => "n99e1882" n=number 99e is the week number since 1970, remainder is random
;; (s:key->val "n1882") => 1
;;
;; first letter is a type: n=number, s=string, b=boolean
(define (s:get-key key-type val)
- (let ((mkrandstr (lambda (innum)(number->string (random innum) 16)))
+ (let ((mkrandstr (lambda (innum)(number->string (pseudo-random-integer innum) 16)))
(week (number->string (quotient (current-seconds) (* 7 24 60 60)) 16)))
(let loop ((siz 1000)
(key (conc key-type week (mkrandstr 100)))
(num 0))
(if (s:session-var-get key) ;; have a collision
@@ -649,11 +649,11 @@
#;(define (session:get-nth-char nth)
(substring session:valid-chars nth (+ nth 1)))
#;(define (session:get-rand-char)
- (session:get-nth-char (random session:num-valid-chars)))
+ (session:get-nth-char (pseudo-random-integer session:num-valid-chars)))
#;(define (session:make-rand-string len)
(let loop ((res "")
(n 1))
(if (> n len) res
@@ -664,11 +664,11 @@
;;
#;(define (session:generic-make-rand-string len seed-string)
(let ((num-chars (string-length seed-string)))
(let loop ((res "")
(n 1))
- (let ((char-num (random num-chars)))
+ (let ((char-num (pseudo-random-integer num-chars)))
(if (> n len) res
(loop (string-append res (substring seed-string char-num (+ char-num 1)))
(+ n 1)))))))
;; Rely on crypt egg's default settings being secure enough, accept
@@ -1429,11 +1429,11 @@
(define (session:get-nth-char nth)
(substring session:valid-chars nth (+ nth 1)))
(define (session:get-rand-char)
- (session:get-nth-char (random session:num-valid-chars)))
+ (session:get-nth-char (pseudo-random-integer session:num-valid-chars)))
(define (session:make-rand-string len)
(let loop ((res "")
(n 1))
(if (> n len) res
@@ -1444,11 +1444,11 @@
;;
(define (session:generic-make-rand-string len seed-string)
(let ((num-chars (string-length seed-string)))
(let loop ((res "")
(n 1))
- (let ((char-num (random num-chars)))
+ (let ((char-num (pseudo-random-integer num-chars)))
(if (> n len) res
(loop (string-append res (substring seed-string char-num (+ char-num 1)))
(+ n 1)))))))
@@ -1707,11 +1707,11 @@
;; The 'auto method will distribute dbs across the disk using hash
;; of user host and user. TODO
;; (if (eq? dbfname 'auto) ;; This is the auto assignment of a db based on hash of IP
(let ((dbpath (pathname-directory dbfname))) ;; do a couple sanity checks here to make setting up easier
(if debugmode (session:log self "INFO: setting up for sqlite3 db access to " dbfname))
- (if (not (file-write-access? dbpath))
+ (if (not (file-writable? dbpath))
(session:log self "WARNING: Cannot write to " dbpath)
(if debugmode (session:log self "INFO: " dbpath " is writeable")))
(if (file-exists? dbfname)
(begin
;; (session:log self "setting dbexists to #t")
Index: subrun.scm
==================================================================
--- subrun.scm
+++ subrun.scm
@@ -16,30 +16,30 @@
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see .
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18)
- posix-extras directory-utils pathname-expand typed-records format
- call-with-environment-variables)
-(declare (unit subrun))
-;;(declare (uses runs))
-(declare (uses db))
-(declare (uses common))
-;;(declare (uses items))
-;;(declare (uses runconfig))
-;;(declare (uses tests))
-;;(declare (uses server))
-(declare (uses mt))
-;;(declare (uses archive))
-;; (declare (uses filedb))
-
-;(include "common_records.scm")
-;;(include "key_records.scm")
-(include "db_records.scm") ;; provides db:test-get-id
-;;(include "run_records.scm")
-;;(include "test_records.scm")
+;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18)
+;; posix-extras directory-utils pathname-expand typed-records format
+;; call-with-environment-variables)
+;; (declare (unit subrun))
+;; ;;(declare (uses runs))
+;; (declare (uses db))
+;; (declare (uses common))
+;; ;;(declare (uses items))
+;; ;;(declare (uses runconfig))
+;; ;;(declare (uses tests))
+;; ;;(declare (uses server))
+;; (declare (uses mt))
+;; ;;(declare (uses archive))
+;; ;; (declare (uses filedb))
+;;
+;; ;(include "common_records.scm")
+;; ;;(include "key_records.scm")
+;; (include "db_records.scm") ;; provides db:test-get-id
+;; ;;(include "run_records.scm")
+;; ;;(include "test_records.scm")
(define (subrun:subrun-test-initialized? test-run-dir)
(if (and (common:file-exists? (conc test-run-dir "/subrun-area") )
(common:file-exists? (conc test-run-dir "/testconfig.subrun") ))
#t
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -16,18 +16,18 @@
;; along with Megatest. If not, see .
;;
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit tasks))
-(declare (uses db))
-(declare (uses rmt))
-(declare (uses common))
-(declare (uses pgdb))
+;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format)
+;; (import (prefix sqlite3 sqlite3:))
+;;
+;; (declare (unit tasks))
+;; (declare (uses db))
+;; (declare (uses rmt))
+;; (declare (uses common))
+;; (declare (uses pgdb))
;; (import pgdb) ;; pgdb is a module
(include "task_records.scm")
(include "db_records.scm")
@@ -107,25 +107,25 @@
(debug:print 5 *default-log-port* " exn=" (condition->list exn))))
(let* ((dbpath (db:dbfile-path )) ;; (tasks:get-task-db-path))
(dbfile (conc dbpath "/monitor.db"))
(avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away
(exists (common:file-exists? dbpath))
- (write-access (file-write-access? dbpath))
+ (write-access (file-writable? dbpath))
(mdb (cond ;; what the hek is *toppath* doing here?
- ((and (string? *toppath*)(file-write-access? *toppath*))
+ ((and (string? *toppath*)(file-writable? *toppath*))
(sqlite3:open-database dbfile))
- ((file-read-access? dbpath) (sqlite3:open-database dbfile))
+ ((file-readable? dbpath) (sqlite3:open-database dbfile))
(else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath))
(handler (sqlite3:make-busy-timeout 36000)))
(if (and exists
(not write-access))
(set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
(sqlite3:set-busy-handler! mdb handler)
(db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;"))
;; (if (or (and (not exists)
- ;; (file-write-access? *toppath*))
- ;; (not (file-read-access? dbpath)))
+ ;; (file-writable? *toppath*))
+ ;; (not (file-readable? dbpath)))
;; (begin
;;
;; TASKS QUEUE MOVED TO main.db
;;
;; (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
Index: tdb.scm
==================================================================
--- tdb.scm
+++ tdb.scm
@@ -20,27 +20,27 @@
;;======================================================================
;; Database access
;;======================================================================
-(require-extension (srfi 18) extras tcp)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
-(import (prefix sqlite3 sqlite3:))
-(import (prefix base64 base64:))
-
-(declare (unit tdb))
-(declare (uses common))
-(declare (uses keys))
-(declare (uses ods))
-(declare (uses client))
-(declare (uses mt))
-(declare (uses db))
-
-(include "common_records.scm")
-(include "db_records.scm")
-(include "key_records.scm")
-(include "run_records.scm")
+;; (require-extension (srfi 18) extras tcp)
+;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
+;; (import (prefix sqlite3 sqlite3:))
+;; (import (prefix base64 base64:))
+;;
+;; (declare (unit tdb))
+;; (declare (uses common))
+;; (declare (uses keys))
+;; (declare (uses ods))
+;; (declare (uses client))
+;; (declare (uses mt))
+;; (declare (uses db))
+;;
+;; (include "common_records.scm")
+;; (include "db_records.scm")
+;; (include "key_records.scm")
+;; (include "run_records.scm")
;;======================================================================
;;
;; T E S T D A T A B A S E S
;;
@@ -57,14 +57,14 @@
;;
(define (open-test-db work-area)
(debug:print-info 11 *default-log-port* "open-test-db " work-area)
(if (and work-area
(directory? work-area)
- (file-read-access? work-area))
+ (file-readable? work-area))
(let* ((dbpath (conc work-area "/testdat.db"))
(dbexists (common:file-exists? dbpath))
- (work-area-writeable (file-write-access? work-area))
+ (work-area-writeable (file-writable? work-area))
(db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem
exn
(begin
(print-call-chain (current-error-port))
(debug:print 2 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
@@ -73,12 +73,12 @@
(sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access
(if (or work-area-writeable
dbexists)
(sqlite3:open-database dbpath)
(sqlite3:open-database ":memory:"))))
- (tdb-writeable (and (file-write-access? work-area)
- (file-write-access? dbpath)))
+ (tdb-writeable (and (file-writable? work-area)
+ (file-writable? dbpath)))
(handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
136000))))
(if (and tdb-writeable
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -20,31 +20,31 @@
;;======================================================================
;; Tests
;;======================================================================
-(declare (unit tests))
-(declare (uses lock-queue))
-(declare (uses db))
-(declare (uses tdb))
-(declare (uses common))
-;; (declare (uses dcommon)) ;; needed for the steps processing
-(declare (uses items))
-(declare (uses runconfig))
-;; (declare (uses sdb))
-(declare (uses server))
-;;(declare (uses stml2))
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
-(import (prefix sqlite3 sqlite3:))
-(require-library stml)
-
-(include "common_records.scm")
-(include "key_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
-(include "test_records.scm")
+;; (declare (unit tests))
+;; (declare (uses lock-queue))
+;; (declare (uses db))
+;; (declare (uses tdb))
+;; (declare (uses common))
+;; ;; (declare (uses dcommon)) ;; needed for the steps processing
+;; (declare (uses items))
+;; (declare (uses runconfig))
+;; ;; (declare (uses sdb))
+;; (declare (uses server))
+;; ;;(declare (uses stml2))
+;;
+;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
+;; (import (prefix sqlite3 sqlite3:))
+;; (require-library stml)
+;;
+;; (include "common_records.scm")
+;; (include "key_records.scm")
+;; (include "db_records.scm")
+;; (include "run_records.scm")
+;; (include "test_records.scm")
(include "js-path.scm")
(define (init-java-script-lib)
(set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js"))
)
@@ -559,11 +559,11 @@
0)
(file-modification-time lockf)))
;; we started since current re-gen in flight, delay a little and try again
(begin
(debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it")
- (thread-sleep! (+ 5 (random 5))) ;; delay between 5 and 10 seconds
+ (thread-sleep! (+ 5 (pseudo-random-integer 5))) ;; delay between 5 and 10 seconds
(loop (common:simple-file-lock lockf))))))))))
(define (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename)
(let ((counts (make-hash-table))
(statecounts (make-hash-table))
@@ -1214,11 +1214,11 @@
(let* ((targ-path (string-intersperse p "/"))
(full-path (conc linktree "/" targ-path))
(run-name (car (reverse p))))
(if (and (common:file-exists? full-path)
(directory? full-path)
- (file-write-access? full-path))
+ (file-writable? full-path))
(s:a run-name 'href (conc targ-path "/run-summary.html"))
(begin
(debug:print 0 *default-log-port* "INFO: Can't create " targ-path "/run-summary.html")
(conc run-name " (Not able to create summary at " targ-path ")")))))))))))
(close-output-port oup)
@@ -1253,11 +1253,11 @@
(tests-htree (common:list->htree tests-tree-dat))
(html-dir (conc linktree "/" (string-intersperse run-dir "/")))
(html-path (conc html-dir "/run-summary.html"))
(oup (if (and (common:file-exists? html-dir)
(directory? html-dir)
- (file-write-access? html-dir))
+ (file-writable? html-dir))
(open-output-file html-path)
#f)))
;; (print "run-dir: " run-dir ", tests-tree-dat: " tests-tree-dat)
(if oup
(begin
@@ -1285,11 +1285,11 @@
alt-file
std-file))
(run-name (car (reverse p))))
(if (and (not (common:file-exists? full-targ))
(directory? full-targ)
- (file-write-access? full-targ))
+ (file-writable? full-targ))
(tests:summarize-test
run-id
(rmt:get-test-id run-id test-name item-path)))
(if (common:file-exists? full-targ)
(s:a run-name 'href html-file)
@@ -1418,11 +1418,11 @@
(let* ((test-dat (rmt:get-test-info-by-id run-id test-id))
(out-dir (db:test-get-rundir test-dat))
(status-file (conc out-dir "/.final-status"))
)
;; first verify we are able to write the output file
- (if (not (file-write-access? out-dir))
+ (if (not (file-writable? out-dir))
(debug:print 0 *default-log-port* "ERROR: cannot write .final-status to " out-dir)
(let*
((outp (open-output-file status-file))
(status (db:test-get-status test-dat))
(state (db:test-get-state test-dat)))
@@ -1436,11 +1436,11 @@
(define (tests:summarize-test run-id test-id)
(let* ((test-dat (rmt:get-test-info-by-id run-id test-id))
(out-dir (db:test-get-rundir test-dat))
(out-file (conc out-dir "/test-summary.html")))
;; first verify we are able to write the output file
- (if (not (file-write-access? out-dir))
+ (if (not (file-writable? out-dir))
(debug:print 0 *default-log-port* "ERROR: cannot write test-summary.html to " out-dir)
(let* (;; (steps-dat (rmt:get-steps-for-test run-id test-id))
(test-name (db:test-get-testname test-dat))
(item-path (db:test-get-item-path test-dat))
(full-name (db:test-make-full-name test-name item-path))
@@ -1595,11 +1595,11 @@
(conc *toppath* "/tests/" test-name)))
(test-configf (conc test-path "/testconfig"))
(testexists (let loopa ((tries-left 30))
(cond
(
- (and (common:file-exists? test-configf)(file-read-access? test-configf))
+ (and (common:file-exists? test-configf)(file-readable? test-configf))
#t)
(
(common:file-exists? test-configf)
(debug:print 0 *default-log-port* "WARNING: Cannot read testconfig file: "test-configf)
#f)
@@ -1619,11 +1619,11 @@
#f)))
(if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
(if tcfg (hash-table-set! *testconfigs* test-full-name tcfg))
(if (and testexists
cache-file
- (file-write-access? cache-path)
+ (file-writable? cache-path)
allow-write-cache)
(let ((tpath (conc cache-path "/.testconfig")))
(debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath)
(if (and tcfg (not (common:in-running-test?)))
(configf:write-alist tcfg tpath))))
@@ -1728,11 +1728,11 @@
(let ((res (read-lines)))
;; (delete-file temp-path)
res))))))
(define (tests:write-dot-file test-records fname sizex sizey)
- (if (file-write-access? (pathname-directory fname))
+ (if (file-writable? (pathname-directory fname))
(with-output-to-file fname
(lambda ()
(map print (tests:tests->dot test-records sizex sizey))))))
(define (tests:tests->dot test-records sizex sizey)
Index: vg.scm
==================================================================
--- vg.scm
+++ vg.scm
@@ -379,20 +379,20 @@
b))
;; Obsolete function
;;
(define (vg:generate-color)
- (vg:rgb->number (random 255)
- (random 255)
- (random 255)))
+ (vg:rgb->number (pseudo-random-integer 255)
+ (pseudo-random-integer 255)
+ (pseudo-random-integer 255)))
;; Need to return a string of random iup-color for graph
;;
(define (vg:generate-color-rgb)
- (conc (number->string (random 255)) " "
- (number->string (random 255)) " "
- (number->string (random 255))))
+ (conc (number->string (pseudo-random-integer 255)) " "
+ (number->string (pseudo-random-integer 255)) " "
+ (number->string (pseudo-random-integer 255))))
(define (vg:iup-color->number iup-color)
(apply vg:rgb->number (map string->number (string-split iup-color))))
;;======================================================================
DELETED widgets.scm
Index: widgets.scm
==================================================================
--- widgets.scm
+++ /dev/null
@@ -1,208 +0,0 @@
-;; Copyright 2006-2017, Matthew Welland.
-;;
-;; This file is part of Megatest.
-;;
-;; Megatest is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; Megatest is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with Megatest. If not, see .
-
-(require-library srfi-4 iup)
-(import srfi-4 iup
- ;; iup-pplot
- iup-glcanvas) ;; iup-web
-
-(define (popup dlg . args)
- (apply show dlg #:modal? 'yes args)
- (destroy! dlg))
-
-(define (properties ih)
- (popup (element-properties-dialog ih))
- 'default)
-
-(define dlg
- (dialog
- (vbox
- (hbox ; headline
- (fill)
- (frame (label " Inspect control and dialog classes "
- fontsize: 15))
- (fill)
- margin: '0x0)
-
- (label "")
- (label "Dialogs" fontsize: 12)
- (hbox
- (button "dialog"
- action: (lambda (self) (properties (dialog (vbox)))))
- (button "color-dialog"
- action: (lambda (self) (properties (color-dialog))))
- (button "file-dialog"
- action: (lambda (self) (properties (file-dialog))))
- (button "font-dialog"
- action: (lambda (self) (properties (font-dialog))))
- (button "message-dialog"
- action: (lambda (self) (properties (message-dialog))))
- (fill)
- margin: '0x0)
- (hbox
- (button "layout-dialog"
- action: (lambda (self) (properties (layout-dialog))))
- (button "element-properties-dialog"
- action: (lambda (self)
- (properties
- (element-properties-dialog (create 'user)))))
- (fill)
- margin: '0x0)
-
- (label "")
- (label "Composition widgets" fontsize: 12)
- (hbox
- (button "fill"
- action: (lambda (self) (properties (fill))))
- (button "hbox"
- action: (lambda (self) (properties (hbox))))
- (button "vbox"
- action: (lambda (self) (properties (vbox))))
- (button "zbox"
- action: (lambda (self) (properties (zbox))))
- (button "radio"
- action: (lambda (self) (properties (radio (vbox)))))
- (button "normalizer"
- action: (lambda (self) (properties (normalizer))))
- (button "cbox"
- action: (lambda (self) (properties (cbox))))
- (button "sbox"
- action: (lambda (self) (properties (sbox (vbox)))))
- (button "split"
- action: (lambda (self) (properties (split (vbox) (vbox)))))
- (fill)
- margin: '0x0)
-
- (label "")
- (label "Standard widgets" fontsize: 12)
- (hbox
- (button "button"
- action: (lambda (self) (properties (button))))
- (button "canvas"
- action: (lambda (self) (properties (canvas))))
- (button "frame"
- action: (lambda (self) (properties (frame))))
- (button "label"
- action: (lambda (self) (properties (label))))
- (button "listbox"
- action: (lambda (self) (properties (listbox))))
- (button "progress-bar"
- action: (lambda (self) (properties (progress-bar))))
- (button "spin"
- action: (lambda (self) (properties (spin))))
- (fill)
- margin: '0x0)
- (hbox
- (button "tabs"
- action: (lambda (self) (properties (tabs))))
- (button "textbox"
- action: (lambda (self) (properties (textbox))))
- (button "toggle"
- action: (lambda (self) (properties (toggle))))
- (button "treebox"
- action: (lambda (self) (properties (treebox))))
- (button "valuator"
- action: (lambda (self) (properties (valuator ""))))
- (fill)
- margin: '0x0)
-
- (label "")
- (label "Additional widgets" fontsize: 12)
- (hbox
- (button "cells"
- action: (lambda (self) (properties (cells))))
- (button "color-bar"
- action: (lambda (self) (properties (color-bar))))
- (button "color-browser"
- action: (lambda (self) (properties (color-browser))))
- (button "dial"
- action: (lambda (self) (properties (dial ""))))
- (button "matrix"
- action: (lambda (self) (properties (matrix))))
- (fill)
- margin: '0x0)
- (hbox
- #;(button "pplot"
- action: (lambda (self) (properties (pplot))))
- (button "glcanvas"
- action: (lambda (self) (properties (glcanvas))))
- ;; (button "web-browser"
- ;; action: (lambda (self) (properties (web-browser))))
- (fill)
- margin: '0x0)
-
- (label "")
- (label "Menu widgets" fontsize: 12)
- (hbox
- (button "menu"
- action: (lambda (self) (properties (menu))))
- (button "menu-item"
- action: (lambda (self) (properties (menu-item))))
- (button "menu-separator"
- action: (lambda (self) (properties (menu-separator))))
- (fill)
- margin: '0x0)
-
- (label "")
- (label "Images" fontsize: 12)
- (hbox
- (button "image/palette"
- action: (lambda (self)
- (properties
- (image/palette 1 1 (u8vector->blob (u8vector 0))))))
- (button "image/rgb"
- action: (lambda (self)
- (properties
- (image/rgb 1 1 (u8vector->blob (u8vector 0))))))
- (button "image/rgba"
- action: (lambda (self)
- (properties
- (image/rgba 1 1 (u8vector->blob (u8vector 0))))))
- (button "image/file"
- action: (lambda (self)
- (properties
- ;; same attributes as image/palette
- (image/palette 1 1 (u8vector->blob (u8vector 0))))))
- ;; needs a file in current directory
- ;(image/file "chicken.ico")))) ; ok
- ;(image/file "chicken.png")))) ; doesn't work
- (fill)
- margin: '0x0)
-
- (label "")
- (label "Other widgets" fontsize: 12)
- (hbox
- (button "clipboard"
- action: (lambda (self) (properties (clipboard))))
- (button "timer"
- action: (lambda (self) (properties (timer))))
- (button "spinbox"
- action: (lambda (self) (properties (spinbox (vbox)))))
- (fill)
- margin: '0x0)
-
- (fill)
- (button "E&xit"
- expand: 'horizontal
- action: (lambda (self) 'close))
- )
- margin: '15x15
- title: "Iup inspector"))
-
-(show dlg)
-(main-loop)
-(exit 0)