Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -28,11 +28,14 @@
ezsteps.scm lock-queue.scm sdb.scm \
rmt.scm api.scm subrun.scm \
portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm
# module source files
-MSRCFILES = ftail.scm
+MSRCFILES = ftail.scm db.scm common.scm
+
+# mtest module source files actually used by mtest building
+MTMSRCFILES = ftail.scm
# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
@@ -42,14 +45,15 @@
OFILES = $(SRCFILES:%.scm=%.o)
GOFILES = $(GUISRCF:%.scm=%.o)
MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
+MTMOFILES = $(addprefix mofiles/,$(MTMSRCFILES:%.scm=%.o))
-mofiles/%.o : %.scm
+mofiles/%.o : src/%.scm
mkdir -p mofiles
- csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
+ cd mofiles;csc $(CSCOPTS) -J -c ../src/$*.scm -o $*.o
ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}')
@@ -65,22 +69,24 @@
PNGFILES = $(shell cd docs/manual;ls *png)
#all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard
all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut
-mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o
- csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o mtest
+mtest: $(OFILES) readline-fix.scm megatest.scm $(MTMOFILES) megatest-fossil-hash.scm
+ cp mofiles/ftail.import.scm .
+ csc $(CSCOPTS) $(OFILES) $(MTMOFILES) megatest.scm -o mtest
-dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES)
- csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) -o dboard
+dboard : $(OFILES) $(GOFILES) dashboard.scm $(MTMOFILES)
+ csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MTMOFILES) -o dboard
ndboard : newdashboard.scm $(OFILES) $(GOFILES)
csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard
-mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm
- csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut
+mtut: $(OFILES) megatest-fossil-hash.scm mtut.scm $(MOFILES)
+ cd mofiles;csc $(CSCOPTS) -I .. $(addprefix ../,$(OFILES)) ../mtut.scm -o mtut
+ cp mofiles/mtut .
TCMTOBJS = \
api.o \
archive.o \
cgisetup/models/pgdb.o \
@@ -99,11 +105,10 @@
megatest-version.o \
ods.o \
portlogger.o \
process.o \
rmt.o \
- rpc-transport.o \
runconfig.o \
runs.o \
server.o \
tasks.o \
tdb.o \
@@ -137,20 +142,22 @@
# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm
# csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl
# Special dependencies for the includes
tests.o db.o launch.o runs.o dashboard-tests.o dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o \
-archive.o megatest.o : db_records.scm
+archive.o : db_records.scm
tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm
-db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
+db.o ezsteps.o keys.o launch.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm common.o
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
-megatest.o : megatest-fossil-hash.scm
+# megatest.o : megatest-fossil-hash.scm
rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm
common_records.scm : altdb.scm
vg.o dashboard.o : vg_records.scm
dcommon.o : run_records.scm
+mofiles/db.o : mofiles/common.o
+
# Temporary while transitioning to new routine
# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm
megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -26,11 +26,11 @@
(prefix sqlite3 sqlite3:)
pkts (prefix dbi dbi:)
)
(declare (unit common))
-
+(declare (uses configf))
(include "common_records.scm")
;; (require-library margs)
;; (include "margs.scm")
@@ -708,18 +708,20 @@
(pathname-file *toppath*)
#f))) ;; (pathname-file (current-directory)))))
(define common:get-area-name common:get-testsuite-name)
+;; get-db-tmp-area is improved/replicated src/db.scm
+;;
(define (common:get-db-tmp-area . junk)
(if *db-cache-path*
*db-cache-path*
(if *toppath* ;; common:get-create-writeable-dir
(handle-exceptions
exn
(begin
- (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
+ (debug:print-error 0 *default-log-port* "Couldn't create path to /tmp/ area")
(exit 1))
(let ((dbpath (common:get-create-writeable-dir
(list (conc "/tmp/" (current-user-name)
"/megatest_localdb/"
(common:get-testsuite-name) "/"
@@ -1394,27 +1396,10 @@
;;
(define (common:lazy-convert inval)
(let* ((as-num (if (string? inval)(string->number inval) #f)))
(or as-num inval)))
-;; convert string a=1; b=2; c=a silly thing; d=
-;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
-;;
-(define (common:val->alist val #!key (convert #f))
- (let ((val-list (string-split-fields ";\\s*" val #:infix)))
- (if val-list
- (map (lambda (x)
- (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
- (case (length f)
- ((0) `(,#f)) ;; null string case
- ((1) `(,(string->symbol (car f))))
- ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f)))
- (if convert (common:lazy-convert inval) inval))))
- (else f))))
- val-list)
- '())))
-
;;======================================================================
;; S Y S T E M S T U F F
;;======================================================================
;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
@@ -1642,11 +1627,11 @@
;; go through the hosts from least recently used to most recently used, pick the first that meets the load criteral from the
;; [host-rules] section.
;;
(define (common:get-least-loaded-host hosts-raw host-type configdat)
(let* ((rdat (configf:lookup configdat "host-rules" host-type))
- (rules (common:val->alist (or rdat "") convert: #t)) ;; maxnload, maxnjobs, maxjobrate
+ (rules (configf:val->alist (or rdat "") convert: #t)) ;; maxnload, maxnjobs, maxjobrate
(maxnload (common:alist-ref/default 'maxnload rules 1.5)) ;; max normalized load
(maxnjobs (common:alist-ref/default 'maxnjobs rules 1.5)) ;; max normalized number of jobs
(maxjobrate (common:alist-ref/default 'maxjobrate rules (/ 1 6))) ;; max rate of submitting jobs to a given host in jobs/second
(hosts (filter (lambda (x)
(string-match (regexp "^\\S+$") x))
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -22,10 +22,11 @@
;; Config file handling
;;======================================================================
(use regex regex-case) ;; directory-utils)
(declare (unit configf))
+(declare (uses common))
(declare (uses process))
(declare (uses env))
(declare (uses keys))
(include "common_records.scm")
@@ -242,10 +243,45 @@
(hash-table-set! ht section (config:assoc-safe-add (hash-table-ref ht section) key val metadata: meta))))
vars)))))
(hash-table-keys ht))))
ht)
+;;======================================================================
+;; Extended config lines, allows storing more hierarchial data in the config lines
+;; ABC a=1; b=hello world; c=a
+;;
+;; NOTE: implementation is quite limited. You currently cannot have
+;; semicolons in your string values.
+;;======================================================================
+
+;; convert string a=1; b=2; c=a silly thing; d=
+;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
+;;
+(define (configf:val->alist val #!key (convert #f))
+ (let ((val-list (string-split-fields ";\\s*" val #:infix)))
+ (if val-list
+ (map (lambda (x)
+ (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
+ (case (length f)
+ ((0) `(,#f)) ;; null string case
+ ((1) `(,(string->symbol (car f))))
+ ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f)))
+ (if convert (common:lazy-convert inval) inval))))
+ (else f))))
+ val-list)
+ '())))
+
+;; I don't want configf to turn into a weak yaml format but this extention is really useful
+;;
+(define (configf:section->val-alist cfgdat section-name #!key (convert #f))
+ (let ((section (configf:get-section cfgdat section-name)))
+ (map (lambda (item)
+ (let ((key (car item))
+ (val (cadr item))) ;; BUG IN WAIT. sections are not returned as proper alists, should fix this.
+ (cons key (configf:val->alist val convert: convert))))
+ section)))
+
;; read a config file, returns hash table of alists
;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)
;; allow-system:
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -29,15 +29,17 @@
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
-;; (declare (uses rmt))
+(declare (uses db)) ;; WARNING: This is NOT the db from megatest/db.scm, is it src/db.scm
(include "megatest-fossil-hash.scm")
(require-library stml)
+
+(import (prefix db db:))
;; stuff for the mapper and checker functions
;;
(define *target-mappers* (make-hash-table))
(define *runname-mappers* (make-hash-table))
@@ -304,12 +306,10 @@
(define (megatest-param->mtutil-param param)
(let* ((mapping-alist (common:get-param-mapping flavor: 'switch-symbol)))
(alist-ref (string->symbol param) mapping-alist eq? param)
param))
-(define val->alist common:val->alist)
-
(define (push-run-spec torun contour runkey spec)
(configf:section-var-set! torun contour runkey
(cons spec
(or (configf:lookup torun contour runkey)
'()))))
@@ -666,11 +666,11 @@
;;
(define (create-run-pkt mtconf action area runkey target runname mode-patt
tag-expr pktsdir reason contour sched dbdest append-conf
runtrans)
(let* ((good-val (lambda (inval)(and inval (string? inval)(not (string-null? inval)))))
- (area-dat (common:val->alist (or (configf:lookup mtconf "areas" area) "")))
+ (area-dat (configf:val->alist (or (configf:lookup mtconf "areas" area) "")))
(area-path (alist-ref 'path area-dat))
;; (area-xlatr (alist-ref 'targtrans area-dat))
;; (xlatr-key (if area-xlatr (string->symbol area-xlatr) #f))
(new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f))
(mapper (if callname (hash-table-ref/default *runname-mappers* callname #f) #f)))
@@ -765,11 +765,11 @@
(len-key (length keyparts))
(ruletype (if (> len-key 1)(cadr keyparts) #f))
(action (if (> len-key 2)(caddr keyparts) #f))
(optional (if (> len-key 3)(cadddr keyparts) #f))
;; (val-list (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params
- (val-alist (common:val->alist val))
+ (val-alist (configf:val->alist val))
(runname (make-runname "" ""))
(runtrans (alist-ref 'runtrans val-alist))
;; these may or may not be defined and not all are used in each handler type in the case below
(run-name (alist-ref 'run-name val-alist))
@@ -1010,11 +1010,11 @@
;; now have to run populated
(for-each
(lambda (contour)
(let* ((cval (or (configf:lookup mtconf "contours" contour) ""))
- (cval-alist (common:val->alist cval)) ;; BEWARE ... NOT the same val-alist as above!
+ (cval-alist (configf:val->alist cval)) ;; BEWARE ... NOT the same val-alist as above!
(areas (val-alist->areas cval-alist))
(selector (alist-ref 'selector cval-alist))
(mode-tag (and selector (string-split-fields "/" selector #:infix)))
(mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)))
(tag-expr (and mode-tag (if (null? mode-tag) #f (car mode-tag)))))
@@ -1028,11 +1028,11 @@
(lambda (runkeydat)
(for-each
(lambda (area)
(if (area-allowed? area areas runkey contour mode-patt) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...)
(let* ((aval (or (configf:lookup mtconf "areas" area) ""))
- (aval-alist (common:val->alist aval))
+ (aval-alist (configf:val->alist aval))
(runname (alist-ref 'runname runkeydat))
(runtrans (alist-ref 'runtrans runkeydat))
(reason (alist-ref 'message runkeydat))
(sched (alist-ref 'sched runkeydat))
@@ -1210,11 +1210,11 @@
((run remove rerun rerun-clean rerun-all set-ss archive kill list)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(area (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section
(areasec (if area (configf:lookup mtconf "areas" area) #f))
- (areadat (if areasec (common:val->alist areasec) #f))
+ (areadat (if areasec (configf:val->alist areasec) #f))
(area-path (if areadat (alist-ref 'path areadat) #f))
(pktsdirs (configf:lookup mtconf "setup" "pktsdirs"))
(pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f))
(adjargs (hash-table-copy args:arg-hash))
(new-ss (args:get-arg "-new")))
@@ -1349,16 +1349,24 @@
(print "received " instr ", running \"" script " " instr "\"")
(system (conc script " '" instr "'"))
(nn-send rep "ok")
(loop (nn-recv rep))))
(print "ERROR: Port " portnum " already in use. Try another port")))))))
- ((gather) ;; gather all area db's into /tmp/$USER_megatest/alldbs
+ ((gatherdb) ;; gather all area db's into /tmp/$USER_megatest/alldbs
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
- (areas (get-area-names mtconf)))
- (print "areas: " areas)))
-
+ ;; (areas (get-area-names mtconf))
+ (areas (configf:section->val-alist mtconf "areas")))
+ (for-each
+ (lambda (area)
+ (let* ((area-name (car area))
+ (area-info (cdr area))
+ (area-path (alist-ref 'path area-info)))
+ (print "Area: " area)
+ (print " path: " area-path)))
+ areas)))
+
(else
(let ((all-actions (sort (map conc (delete-duplicates (append *other-actions* (map car *action-keys*)))) string<=?)))
(print "unrecognised action: \"" *action* "\", try one of; \"" (string-intersperse all-actions "\", \"") "\"")))
)) ;; the end
ADDED src/common.scm
Index: src/common.scm
==================================================================
--- /dev/null
+++ src/common.scm
@@ -0,0 +1,289 @@
+;======================================================================
+;; Copyright 2006-2016, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+;;
+;;======================================================================
+
+;; NOTE: This is the db module, long term it will replace db.scm.
+;; WARN: This module conflicts with db.scm as it uses sql-de-lite
+
+(declare (unit common))
+
+(module common
+ (
+ get-create-writeable-dir
+ print-error
+ print-info
+ log-event
+ debug-setup
+ debug-mode
+ check-verbosity
+ calc-verbosity
+ )
+
+(import scheme chicken data-structures extras posix ports)
+(use (prefix sql-de-lite sql:) posix typed-records format srfi-1 srfi-69)
+
+(defstruct ctrldat
+ (port (current-error-port))
+ (verbosity 1)
+ (vcache (make-hash-table))
+ (logging #f) ;; keep the flag and the db handle separate to enable overriding
+ (logdb #f) ;; might need to make this a stack of handles for threaded access
+ (toppath #f) ;;
+ )
+
+(define *log* (make-ctrldat))
+
+;; this was cached based on results from profiling but it turned out the profiling
+;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
+;; in for now but can probably take it out later.
+;;
+(define (calc-verbosity vstr args)
+ (or (hash-table-ref/default (ctrldat-vcache *log*) vstr #f)
+ (let ((res (cond
+ ((number? vstr) vstr)
+ ((not (string? vstr)) 1)
+ ;; ((string-match "^\\s*$" vstr) 1)
+ (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ",")))))
+ (cond
+ ((> (length debugvals) 1) debugvals)
+ ((> (length debugvals) 0)(car debugvals))
+ (else 1))))
+ ((hash-table-exists? args "-v") 2)
+ ((hash-table-exists? args "-q") 0)
+ (else 1))))
+ (hash-table-set! (ctrldat-vcache *log*) vstr res)
+ res)))
+
+;; check verbosity, #t is ok
+(define (check-verbosity verbosity vstr)
+ (if (not (or (number? verbosity)
+ (list? verbosity)))
+ (begin
+ (print "ERROR: Invalid debug value \"" vstr "\"")
+ #f)
+ #t))
+
+(define (debug-mode n)
+ (let* ((verbosity (ctrldat-verbosity *log*)))
+ (cond
+ ((and (number? verbosity) ;; number number
+ (number? n))
+ (<= n verbosity))
+ ((and (list? verbosity) ;; list number
+ (number? n))
+ (member n verbosity))
+ ((and (list? verbosity) ;; list list
+ (list? n))
+ (not (null? (lset-intersection! eq? verbosity n))))
+ ((and (number? verbosity)
+ (list? n))
+ (member verbosity n)))))
+
+(define (debug-setup args)
+ (let* ((debugstr (or (hash-table-ref/default args "-debug" #f)
+ (get-environment-variable "MT_DEBUG_MODE")))
+ (verbosity (calc-verbosity debugstr args)))
+ ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
+ (if (not (check-verbosity verbosity debugstr))
+ (set! verbosity 1))
+ (ctrldat-verbosity-set! *log* verbosity)
+ (if (or (hash-table-exists? args "-debug")
+ (not (get-environment-variable "MT_DEBUG_MODE")))
+ (setenv "MT_DEBUG_MODE" (if (list? verbosity)
+ (string-intersperse (map conc verbosity) ",")
+ (conc verbosity))))))
+
+(define (debug-print n e . params)
+ (if (debug-mode n)
+ (with-output-to-port (or e (current-error-port))
+ (lambda ()
+ (if (ctrldat-logging *log*)
+ (log-event (apply conc params))
+ (apply print params)
+ )))))
+
+;; ;; Brandon's debug printer shortcut (indulge me :)
+;; (define *BB-process-starttime* (current-milliseconds))
+;; (define (BB> . in-args)
+;; (let* ((stack (get-call-chain))
+;; (location "??"))
+;; (for-each
+;; (lambda (frame)
+;; (let* ((this-loc (vector-ref frame 0))
+;; (temp (string-split (->string this-loc) " "))
+;; (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
+;; (if (equal? this-func "BB>")
+;; (set! location this-loc))))
+;; stack)
+;; (let* ((color-on "\x1b[1m")
+;; (color-off "\x1b[0m")
+;; (dp-args
+;; (append
+;; (list 0 *default-log-port*
+;; (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") )
+;; in-args)))
+;; (apply debug:print dp-args))))
+;;
+;; (define *BBpp_custom_expanders_list* (make-hash-table))
+;;
+;;
+;;
+;; ;; register hash tables with BBpp.
+;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
+;; (cons hash-table? hash-table->alist))
+;;
+;; ;; test name converter
+;; (define (BBpp_custom_converter arg)
+;; (let ((res #f))
+;; (for-each
+;; (lambda (custom-type-name)
+;; (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
+;; (custom-type-test (car custom-type-info))
+;; (custom-type-converter (cdr custom-type-info)))
+;; (when (and (not res) (custom-type-test arg))
+;; (set! res (custom-type-converter arg)))))
+;; (hash-table-keys *BBpp_custom_expanders_list*))
+;; (if res (BBpp_ res) arg)))
+;;
+;; (define (BBpp_ arg)
+;; (cond
+;; ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
+;; ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
+;; ((hash-table? arg)
+;; (let ((al (hash-table->alist arg)))
+;; (BBpp_ (cons HASH_TABLE: al))))
+;; ((null? arg) '())
+;; ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
+;; ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
+;; (else (BBpp_custom_converter arg))))
+;;
+;; ;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
+;; (define (BBpp arg)
+;; (pp (BBpp_ arg)))
+;;
+;; ;(use define-macro)
+;; (define-syntax inspect
+;; (syntax-rules ()
+;; [(_ x)
+;; ;; (with-output-to-port (current-error-port)
+;; (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
+;; ;; )
+;; ]
+;; [(_ x y ...) (begin (inspect x) (inspect y ...))]))
+
+(define (print-error n e . params)
+ ;; normal print
+ (if (debug-mode n)
+ (with-output-to-port (if (port? e) e (current-error-port))
+ (lambda ()
+ (if (ctrldat-logging *log*)
+ (log-event (apply conc params))
+ ;; (apply print "pid:" (current-process-id) " " params)
+ (apply print "ERROR: " params)
+ ))))
+ ;; pass important messages to stderr
+ (if (and (eq? n 0)(not (eq? e (current-error-port))))
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (apply print "ERROR: " params)
+ ))))
+
+(define (print-info n e . params)
+ (if (debug-mode n)
+ (with-output-to-port (if (port? e) e (current-error-port))
+ (lambda ()
+ (if (ctrldat-logging *log*)
+ (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params))))
+ (log-event res))
+ (apply print "INFO: (" n ") " params) ;; res)
+ )))))
+
+;; if a value is printable (i.e. string or number) return the value
+;; else return an empty string
+(define-inline (printable val)
+ (if (or (number? val)(string? val)) val ""))
+
+;;======================================================================
+;; L O G G I N G D B
+;;======================================================================
+
+(define (open-logging-db toppath)
+ (let* ((dbpath (conc (if toppath (conc toppath "/") "") "logging.db")) ;; fname)
+ (dbexists (file-exists? dbpath))
+ (db (sql:open-database dbpath))
+ (handler (sql:busy-timeout 136000))) ;; remove argument to override
+ (sql:set-busy-handler! db handler)
+ (if (not dbexists)
+ (sql:exec (sql:sql db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);")))
+ (sql:exec (sql:sql db "PRAGMA synchronous = 0;"))
+ db))
+
+(define (log-local-event toppath . loglst)
+ (let ((logline (apply conc loglst)))
+ (log-event logline)))
+
+(define (log-event toppath logline)
+ (let ((db (open-logging-db toppath)))
+ (sql:exec
+ (sql:sql db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);")
+ logline
+ (current-directory)
+ (string-intersperse (argv) " ")
+ (current-process-id))
+ logline))
+
+;;======================================================================
+;; paths and directories
+;;======================================================================
+
+;; return first path that can be created or already exists and is writable
+;;
+(define (get-create-writeable-dir dirs)
+ (if (null? dirs)
+ #f
+ (let loop ((hed (car dirs))
+ (tal (cdr dirs)))
+ (let ((res (or (and (directory? hed)
+ (file-write-access? hed)
+ hed)
+ (handle-exceptions
+ exn
+ (begin
+ ;; (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.")
+ (print "INFO: could not create " hed ", this might cause problems down the road.")
+ #f)
+ (create-directory hed #t)))))
+ (if (and (string? res)
+ (directory? res))
+ res
+ (if (null? tal)
+ #f
+ (loop (car tal)(cdr tal))))))))
+
+(define old-file-exists? file-exists?)
+
+(define (file-exists? path-string)
+ ;; this avoids stack dumps. NOTE: The issues that triggered this approach might have been fixed TODO: test and remove if possible
+ ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
+ (handle-exceptions
+ exn
+ #f
+ (file-exists? path-string)))
+
+)
ADDED src/db.scm
Index: src/db.scm
==================================================================
--- /dev/null
+++ src/db.scm
@@ -0,0 +1,105 @@
+;======================================================================
+;; Copyright 2006-2016, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+;;
+;;======================================================================
+
+;; NOTE: This is the db module, long term it will replace db.scm.
+;; WARN: This module conflicts with db.scm as it uses sql-de-lite
+
+(declare (unit db))
+(declare (uses common))
+
+(module db
+ (
+ get-db-tmp-area
+ )
+
+(import scheme chicken data-structures extras (prefix common common:))
+(use (prefix sql-de-lite sql) posix typed-records)
+
+(define *default-log-port* (current-error-port))
+
+;;======================================================================
+;; Database access
+;;======================================================================
+
+
+;;======================================================================
+;; R E C O R D S
+;;======================================================================
+
+;; areas
+;; run.db
+;; runs => 1.db, 2.db ...
+
+;; each db entry is a pair ( db . dbfilepath )
+;; I propose this record evolves into the area record
+;;
+(defstruct dbr:dbstruct
+ (tmpdb #f)
+ (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack
+ (mtdb #f)
+ (refndb #f)
+ (homehost #f) ;; not used yet
+ (on-homehost #f) ;; not used yet
+ (read-only #f)
+ ) ;; goal is to converge on one struct for an area but for now it is too confusing
+
+
+;; record for keeping state,status and count for doing roll-ups in
+;; iterated tests
+;;
+(defstruct dbr:counts
+ (state #f)
+ (status #f)
+ (count 0))
+
+;;======================================================================
+;; SQLITE3 HELPERS
+;;======================================================================
+
+
+(define (general-sql-de-lite-error-dump exn stmt . params)
+ (let ((err-status ((condition-property-accessor 'sql-de-lite 'status #f) exn))) ;; RADT ... how does this work?
+ ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
+ (print "err-status: " err-status)
+ (common:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
+ (print-call-chain (current-error-port))))
+
+;;======================================================================
+;; Manage the /tmp/ db mirror area
+;;======================================================================
+
+(define (get-db-tmp-area area-path area-name)
+ (let ((dbdir (conc "/tmp/" (current-user-name)
+ "/megatest_localdb/"
+ area-name "/"
+ (string-translate area-path "/" "."))))
+ (if area-path ;; common:get-create-writeable-dir
+ (handle-exceptions
+ exn
+ (begin
+ (common:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
+ (exit 1))
+ (let ((dbpath (common:get-create-writeable-dir
+ (list dbdir)))) ;; #t))))
+ dbpath))
+ #f)))
+
+
+)
ADDED src/ftail.scm
Index: src/ftail.scm
==================================================================
--- /dev/null
+++ src/ftail.scm
@@ -0,0 +1,108 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(declare (unit ftail))
+
+(module ftail
+ (
+ open-tail-db
+ tail-write
+ tail-get-fid
+ file-tail
+ )
+
+(import scheme chicken data-structures extras)
+(use (prefix sqlite3 sqlite3:) posix typed-records)
+
+(define (open-tail-db )
+ (let* ((basedir (create-directory (conc "/tmp/" (current-user-name))))
+ (dbpath (conc basedir "/megatest_logs.db"))
+ (dbexists (file-exists? dbpath))
+ (db (sqlite3:open-database dbpath))
+ (handler (sqlite3:make-busy-timeout 136000)))
+ (sqlite3:set-busy-handler! db handler)
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
+ (if (not dbexists)
+ (begin
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+ ))
+ db))
+
+(define (tail-write db fid lines)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (for-each
+ (lambda (line)
+ (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line))
+ lines))))
+
+(define (tail-get-fid db fname)
+ (let ((fid (handle-exceptions
+ exn
+ #f
+ (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname))))
+ (if fid
+ fid
+ (begin
+ (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname)
+ (tail-get-fid db fname)))))
+
+(define (file-tail fname #!key (db-in #f))
+ (let* ((inp (open-input-file fname))
+ (db (or db-in (open-tail-db)))
+ (fid (tail-get-fid db fname)))
+ (let loop ((inl (read-line inp))
+ (lines '())
+ (lastwr (current-seconds)))
+ (if (eof-object? inl)
+ (let ((timed-out (> (- (current-seconds) lastwr) 60)))
+ (if timed-out (tail-write db fid (reverse lines)))
+ (sleep 1)
+ (if timed-out
+ (loop (read-line inp) '() (current-seconds))
+ (loop (read-line inp) lines lastwr)))
+ (let* ((savelines (> (length lines) 19)))
+ ;; (print inl)
+ (if savelines (tail-write db fid (reverse lines)))
+ (loop (read-line inp)
+ (if savelines
+ '()
+ (cons inl lines))
+ (if savelines
+ (current-seconds)
+ lastwr)))))))
+
+;; offset -20 means get last 20 lines
+;;
+(define (tail-get-lines db fid offset count)
+ (if (> offset 0)
+ (sqlite3:map-row (lambda (id line)
+ (vector id line))
+ db
+ "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count)
+ (reverse ;; get N from the end
+ (sqlite3:map-row (lambda (id line)
+ (vector id line))
+ db
+ "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset)))))
+
+)