Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -17,25 +17,26 @@ # rm .o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less SHELL=/bin/bash PREFIX=$(PWD) CSCOPTS= INSTALL=install -SRCFILES = common.scm items.scm launch.scm \ +SRCFILES = items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm filedb.scm tdb.scm \ client.scm mt.scm \ - ezsteps.scm lock-queue.scm sdb.scm \ + ezsteps.scm lock-queue.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 db.scm common.scm +# sdb.scm \ +# module source files, NOTE: do not put ftail in this list yet! +MSRCFILES = mtdb.scm mtcommon.scm -# mtest module source files actually used by mtest building -MTMSRCFILES = ftail.scm +# mtest module source files actually used by mtest building +MTMSRCFILES = # 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 \ @@ -49,11 +50,11 @@ MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o)) MTMOFILES = $(addprefix mofiles/,$(MTMSRCFILES:%.scm=%.o)) mofiles/%.o : src/%.scm mkdir -p mofiles - cd mofiles;csc $(CSCOPTS) -J -c ../src/$*.scm -o $*.o + csc $(CSCOPTS) -J -c $< -o mofiles/$*.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}') @@ -69,24 +70,21 @@ 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.scm $(MTMOFILES) megatest-fossil-hash.scm - cp mofiles/ftail.import.scm . - csc $(CSCOPTS) $(OFILES) $(MTMOFILES) megatest.scm -o mtest - +mtest: $(OFILES) readline-fix.scm megatest.scm $(MTMOFILES) megatest-fossil-hash.scm common.o + csc $(CSCOPTS) $(OFILES) $(MTMOFILES) common.o megatest.scm -o mtest 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 $(MOFILES) - cd mofiles;csc $(CSCOPTS) -I .. $(addprefix ../,$(OFILES)) ../mtut.scm -o mtut - cp mofiles/mtut . +mtut: megatest-fossil-hash.scm megatest-version.o configf.o margs.o mtut.scm $(MOFILES) + csc $(CSCOPTS) $(MOFILES) megatest-version.o configf.o margs.o mtut.scm -o mtut TCMTOBJS = \ api.o \ archive.o \ cgisetup/models/pgdb.o \ @@ -144,19 +142,19 @@ # 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 : 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 monitor.o runs-for-ref.o runs.o tests.o : key_records.scm common.o +db.o ezsteps.o keys.o launch.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.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 +mofiles/mtdb.o : mofiles/mtcommon.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 @@ -296,11 +294,11 @@ $(MTQA_FOSSIL) : fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL) clean : - rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o + rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o *import.scm #====================================================================== # Make the records files #====================================================================== @@ -339,12 +337,10 @@ deploytarg/dboard : $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg mv deploytarg/deploytarg deploytarg/dboard -# DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \ -# megatest-version.o tdb.o ods.o mt.o keys.o datashare-testing/sd : datashare.scm $(OFILES) csc $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd datashare-testing/sdat: sharedat.scm $(OFILES) csc $(CSCOPTS) sharedat.scm $(OFILES) -o datashare-testing/sdat DELETED bin/sleeprunner Index: bin/sleeprunner ================================================================== --- bin/sleeprunner +++ /dev/null @@ -1,22 +0,0 @@ -#!/bin/bash - -# 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 . - -if [[ $SLEEPRUNNER == "" ]];then -SLEEPRUNNER=0 -fi - -echo "nbfake $@ &> /dev/null" | at now + $SLEEPRUNNER minutes &> /dev/null Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -51,12 +51,12 @@ (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) +;; (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") Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -25,21 +25,22 @@ (use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) srfi-18 extras format pkts regex regex-case (prefix dbi dbi:) nanomsg) -(declare (uses common)) +(declare (uses mtcommon)) (declare (uses megatest-version)) (declare (uses margs)) (declare (uses configf)) -(declare (uses db)) ;; WARNING: This is NOT the db from megatest/db.scm, is it src/db.scm +(declare (uses mtdb)) ;; 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:)) +(import (prefix mtdb db:)) +(import (prefix mtcommon common:)) ;; stuff for the mapper and checker functions ;; (define *target-mappers* (make-hash-table)) (define *runname-mappers* (make-hash-table)) DELETED src/common.scm Index: src/common.scm ================================================================== --- src/common.scm +++ /dev/null @@ -1,289 +0,0 @@ -;====================================================================== -;; 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))) - -) DELETED src/db.scm Index: src/db.scm ================================================================== --- src/db.scm +++ /dev/null @@ -1,105 +0,0 @@ -;====================================================================== -;; 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/mtcommon.scm Index: src/mtcommon.scm ================================================================== --- /dev/null +++ src/mtcommon.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 mtcommon)) + +(module mtcommon + ( + 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/mtdb.scm Index: src/mtdb.scm ================================================================== --- /dev/null +++ src/mtdb.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 mtdb)) +(declare (uses mtcommon)) + +(module mtdb + ( + get-db-tmp-area + ) + +(import scheme chicken data-structures extras (prefix mtcommon 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))) + + +)