Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -29,18 +29,18 @@ cgisetup/models/pgdb.scm # server.scm http-transport.scm client.scm rmt.scm # module source files -MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \ +MSRCFILES = dbfile.scm mtargs.scm commonmod.scm dbmod.scm \ configfmod.scm servermod.scm clientmod.scm rmtmod.scm \ - artifacts.scm apimod.scm + artifacts.scm apimod.scm # debugprint.scm all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut # dbmod.import.o is just a hack here -mofiles/dbfile.o mofiles/clientmod.o mofiles/dbmod.o mofiles/rmtmod.o : mofiles/debugprint.o mofiles/commonmod.o # dbmod.import.o +mofiles/dbfile.o mofiles/clientmod.o mofiles/dbmod.o mofiles/rmtmod.o : mofiles/commonmod.o # dbmod.import.o mofiles/debugprint.o db.o : dbmod.import.o mofiles/debugprint.o : mofiles/mtargs.o mofiles/servermod.o : mofiles/artifacts.o mofiles/rmtmod.o : mofiles/apimod.o @@ -175,11 +175,11 @@ monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.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 api.o : mofiles/dbmod.o mofiles/dbfile.o mofiles/debugprint.o mofiles/commonmod.o dbmod.import.o +db.o api.o : mofiles/dbmod.o mofiles/dbfile.o mofiles/commonmod.o dbmod.import.o # mofiles/debugprint.o # tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -26,16 +26,17 @@ (declare (uses rmtmod)) (declare (uses db)) (declare (uses dbmod)) (declare (uses dbfile)) (declare (uses tasks)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (import dbmod) (import dbfile) (import rmtmod - debugprint) + ;; debugprint + ) (define *db-write-mutexes* (make-hash-table)) ;; These are called by the server on recipt of /api calls ;; - keep it simple, only return the actual result of the call, i.e. no meta info here Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -21,16 +21,16 @@ (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)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (include "common_records.scm") (include "db_records.scm") -(import debugprint) +;; (import debugprint) ;;====================================================================== ;; ;;====================================================================== Index: clientmod.scm ================================================================== --- clientmod.scm +++ clientmod.scm @@ -25,11 +25,11 @@ ;; spiffy-request-vars uri-common intarweb directory-utils) (declare (unit clientmod)) (declare (uses servermod)) (declare (uses artifacts)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (module clientmod * (import scheme @@ -40,11 +40,11 @@ srfi-18 typed-records artifacts servermod - debugprint + ;; debugprint ) (defstruct con ;; client connection (hdir #f) ;; this is the directory sdir/serverhost.serverpid (sdir #f) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -27,14 +27,15 @@ pkts (prefix dbi dbi:) ) (declare (unit common)) (declare (uses commonmod)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (import commonmod - debugprint) + ;; debugprint + ) (include "common_records.scm") ;; (require-library margs) Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -23,11 +23,11 @@ (use srfi-69) (module commonmod * -(import scheme chicken data-structures extras files) +(import scheme chicken data-structures extras files ports) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 md5 message-digest regex srfi-1) @@ -218,11 +218,160 @@ (let ((adat (get-section cfgdat "areas"))) (map (lambda (entry) `(,(car entry) . ,(val->alist (cadr entry)))) adat))) + +;;====================================================================== +;; debugprint +;;====================================================================== + +;;====================================================================== +;; debug stuff +;;====================================================================== + +(define verbosity (make-parameter '())) +(define *default-log-port* (current-error-port)) +(define debug:print-logger (make-parameter #f)) ;; set to a proc to call on every logging print + +(define (debug:setup debug debug-noprop) + (let ((debugstr (or debug ;; (args:get-arg "-debug") + debug-noprop ;; (args:get-arg "-debug-noprop") + (get-environment-variable "MT_DEBUG_MODE")))) + (verbosity (debug:calc-verbosity debugstr 'q)) + (debug:check-verbosity (verbosity) debugstr) + ;; if we were handed a bad verbosity rule then we will override it with 1 and continue + (if (not (verbosity))(verbosity 1)) + (if (and (not debug-noprop) ;; (args:get-arg "-debug-noprop") + (or debug ;; (args:get-arg "-debug") + (not (get-environment-variable "MT_DEBUG_MODE")))) + (setenv #;set-environment-variable! "MT_DEBUG_MODE" (if (list? (verbosity)) + (string-intersperse (map conc (verbosity)) ",") + (conc (verbosity))))))) + +;; check verbosity, #t is ok +(define (debug:check-verbosity verbosity vstr) + (if (not (or (number? verbosity) + (list? verbosity))) + (begin + (print "ERROR: Invalid debug value \"" vstr "\"") + #f) + #t)) + +;;====================================================================== +;; (define (debug:print . params) #f) +;; (define (debug:print-info . params) #f) +;; +;; (define (set-functions dbgp dbgpinfo) +;; (set! debug:print dbgp) +;; (set! debug:print-info dbgpinfo)) + +;;====================================================================== +;; this was cached based on results from profiling but it turned out the profiling +;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching +;; in for now but can probably take it out later. +;; +(define (debug:calc-verbosity vstr arg) ;; arg is 'v (verbose) or 'q (quiet) + (let* ((res (cond + ((number? vstr) vstr) + ((not (string? vstr)) 1) + ;; ((string-match "^\\s*$" vstr) 1) + (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) + (cond + ((> (length debugvals) 1) debugvals) + ((> (length debugvals) 0)(car debugvals)) + (else 1)))) + ((eq? arg 'v) 2) ;; verbose + ((eq? arg 'q) 0) ;; quiet + (else 1)))) + (verbosity res) + res)) + +;;====================================================================== +;; check verbosity, #t is ok +#;(define (debug-check-verbosity verbosity vstr) + (if (not (or (number? verbosity) + (list? verbosity))) + (begin + (print "ERROR: Invalid debug value \"" vstr "\"") + #f) + #t)) + +(define (debug:debug-mode n) + (let* ((vb (verbosity))) + (cond + ((and (number? vb) ;; number number + (number? n)) + (<= n vb)) + ((and (list? vb) ;; list number + (number? n)) + (member n vb)) + ((and (list? vb) ;; list list + (list? n)) + (not (null? (lset-intersection! eq? vb n)))) + ((and (number? vb) + (list? n)) + (member vb n)) + (else #f)))) + +(define (debug:handle-remote-logging params) + (if (debug:print-logger) ;; NOTE: turn params into string to keep things simple for now + ((debug:print-logger)(conc "REMOTE ("(get-host-name)", pid="(current-process-id)") " + (string-intersperse (map conc params) " ") "; " + (string-intersperse (command-line-arguments) " "))))) + +(define debug:enable-timestamp (make-parameter #t)) + +(define (debug:timestamp) + (if (debug:enable-timestamp) + (conc (time->string + (seconds->local-time (current-seconds)) "%H:%M:%S") " ") + "")) + + (define (debug:print n e . params) + (if (debug:debug-mode n) + (with-output-to-port (or e (current-error-port)) + (lambda () + ;; (if *logging* + ;; (db:log-event (apply conc params)) + (apply print (debug:timestamp) params) + ;; (debug:handle-remote-logging params) + ))) + #t ;; only here to make remote stuff happy. It'd be nice to fix that ... + ) + +(define (debug:print-error n e . params) + ;; normal print + (if (debug:debug-mode n) + (with-output-to-port (if (port? e) e (current-error-port)) + (lambda () + (apply print "ERROR: " (debug:timestamp) params) + ;; (debug:handle-remote-logging (cons "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: " (debug:timestamp) params) + )))) + +(define (debug:print-info n e . params) + (if (debug:debug-mode n) + (with-output-to-port (if (port? e) e (current-error-port)) + (lambda () + (apply print "INFO: (" n ") "(debug:timestamp) params) ;; res) + ;; (debug:handle-remote-logging (cons "INFO: " params)) + )))) + +(define (debug:print-warn n e . params) + (if (debug:debug-mode n) + (with-output-to-port (if (port? e) e (current-error-port)) + (lambda () + (apply print "WARN: (" n ") " (debug:timestamp) params) ;; res) + ;; (debug:handle-remote-logging (cons "WARN: " params)) + )))) ;;====================================================================== ;; misc stuff ;;====================================================================== ) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -25,15 +25,15 @@ (use regex regex-case matchable) ;; directory-utils) (declare (unit configf)) (declare (uses process)) (declare (uses env)) (declare (uses keys)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (include "common_records.scm") -(import debugprint) +;; (import debugprint) ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) (if toppath (let ((cfname (conc toppath "/" configname))) Index: configfmod.scm ================================================================== --- configfmod.scm +++ configfmod.scm @@ -18,11 +18,11 @@ ;;====================================================================== (declare (unit configfmod)) (declare (uses mtargs)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) ;; (declare (uses keysmod)) (module configfmod * @@ -44,11 +44,11 @@ ;; chicken.sort ;; chicken.string ;; chicken.time ;; chicken.eval ;; - debugprint +;; debugprint (prefix mtargs args:) ;; pkts ;; keysmod ;; ;; (prefix base64 base64:) Index: dashboard-context-menu.scm ================================================================== --- dashboard-context-menu.scm +++ dashboard-context-menu.scm @@ -39,18 +39,18 @@ (declare (uses rmtmod)) (declare (uses ezsteps)) ;; (declare (uses sdb)) ;; (declare (uses filedb)) (declare (uses subrun)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") -(import debugprint) +;; (import debugprint) (define (dboard:launch-testpanel run-id test-id) (let* ((dboardexe (common:find-local-megatest "dashboard")) (cmd (conc dboardexe " -test " run-id "," test-id Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -38,17 +38,17 @@ (declare (uses rmtmod)) (declare (uses ezsteps)) ;; (declare (uses sdb)) ;; (declare (uses filedb)) (declare (uses subrun)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") -(import debugprint) +;; (import debugprint) ;;====================================================================== ;; C O M M O N ;;====================================================================== Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -45,21 +45,21 @@ (declare (uses dashboard-context-menu)) (declare (uses vg)) (declare (uses subrun)) (declare (uses mt)) (declare (uses dbfile)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "megatest-version.scm") (include "megatest-fossil-hash.scm") (include "vg_records.scm") -(import debugprint) +;; (import debugprint) (dbfile:db-init-proc db:initialize-main-db) (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version @@ -573,11 +573,11 @@ (define (get-curr-sort) (vector-ref *tests-sort-options* *tests-sort-reverse*)) ;;====================================================================== -(debug:setup) +(debug:setup (args:get-arg "-debug")(args:get-arg "-debug-noprop")) ;; (define uidat #f) (define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) (define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -46,12 +46,13 @@ matchable files) (declare (unit db)) (declare (uses common)) +(declare (uses commonmod)) (declare (uses dbmod)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (declare (uses dbfile)) (declare (uses keys)) (declare (uses ods)) ;; (declare (uses client)) (declare (uses mt)) @@ -64,11 +65,13 @@ (define *number-of-writes* 0) (define *number-non-write-queries* 0) (import dbmod dbfile - debugprint) + commonmod + ;; debugprint + ) ;; record for keeping state,status and count for doing roll-ups in ;; iterated tests ;; (defstruct dbr:counts Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -17,11 +17,11 @@ ;; along with Megatest. If not, see . ;;====================================================================== (declare (unit dbfile)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (declare (uses commonmod)) (module dbfile * @@ -37,11 +37,11 @@ stack files ports commonmod - debugprint + ;; debugprint ) ;;====================================================================== ;; R E C O R D S ;;====================================================================== Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -17,11 +17,12 @@ ;; along with Megatest. If not, see . ;;====================================================================== (declare (unit dbmod)) -(declare (uses debugprint)) +(declare (uses commonmod)) +;; (include "debugprint.scm") (module dbmod * (import scheme @@ -34,11 +35,11 @@ extras (prefix base64 base64:) message-digest regex - debugprint + commonmod ;; debugprint ) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -28,14 +28,14 @@ (declare (unit dcommon)) (declare (uses gutils)) (declare (uses db)) (declare (uses commonmod)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (import commonmod - debugprint + ;; debugprint ) ;; (declare (uses synchash)) (include "megatest-version.scm") (include "common_records.scm") Index: diff-report.scm ================================================================== --- diff-report.scm +++ diff-report.scm @@ -17,17 +17,17 @@ ;; (declare (unit diff-report)) (declare (uses common)) (declare (uses rmtmod)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (include "common_records.scm") (use matchable) (use fmt) (use ducttape-lib) -(import debugprint) +;; (import debugprint) (define css "") (define (diff:tests-mindat->hash tests-mindat) (let* ((res (make-hash-table))) Index: env.scm ================================================================== --- env.scm +++ env.scm @@ -17,15 +17,15 @@ ;; along with Megatest. If not, see . ;;====================================================================== (declare (unit env)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables) -(import debugprint) +;; (import debugprint) (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 @@ -25,20 +25,20 @@ (declare (unit ezsteps)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) ;; (declare (uses sdb)) ;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") -(import debugprint) +;; (import debugprint) ;;(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: genexample.scm ================================================================== --- genexample.scm +++ genexample.scm @@ -17,14 +17,14 @@ ;; along with Megatest. If not, see . ;;====================================================================== (declare (unit genexample)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (use posix regex matchable) -(import debugprint) +;; (import debugprint) (include "db_records.scm") (define genexample:example-logpro #<. ;;====================================================================== (declare (unit servermod)) (declare (uses artifacts)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (use md5 message-digest posix typed-records extras) (module servermod * @@ -37,11 +37,11 @@ typed-records data-structures artifacts - debugprint + ;; debugprint ) (defstruct srv (areapath #f) (host #f) Index: subrun.scm ================================================================== --- subrun.scm +++ subrun.scm @@ -27,17 +27,17 @@ ;;(declare (uses tests)) ;;(declare (uses server)) (declare (uses mt)) ;;(declare (uses archive)) ;; (declare (uses filedb)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (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) -(import debugprint) +;; (import debugprint) ;(include "common_records.scm") ;;(include "key_records.scm") (include "db_records.scm") ;; provides db:test-get-id ;;(include "run_records.scm") Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -25,14 +25,14 @@ (declare (uses dbfile)) (declare (uses db)) (declare (uses rmtmod)) (declare (uses common)) (declare (uses pgdb)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (import dbfile - debugprint + ;; debugprint ) ;; (import pgdb) ;; pgdb is a module (include "db_records.scm") Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -32,18 +32,18 @@ (declare (uses keys)) (declare (uses ods)) (declare (uses clientmod)) (declare (uses mt)) (declare (uses db)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") -(import debugprint) +;; (import debugprint) ;;====================================================================== ;; ;; T E S T D A T A B A S E S ;; Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -32,13 +32,13 @@ (declare (uses items)) (declare (uses runconfig)) ;; (declare (uses sdb)) (declare (uses servermod)) ;;(declare (uses stml2)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) -(import debugprint) +;; (import debugprint) (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) (import (prefix sqlite3 sqlite3:)) (import commonmod) (require-library stml) Index: tree.scm ================================================================== --- tree.scm +++ tree.scm @@ -33,18 +33,18 @@ (declare (uses gutils)) (declare (uses db)) ;; (declare (uses server)) ;; (declare (uses synchash)) (declare (uses dcommon)) -(declare (uses debugprint)) +;; (declare (uses debugprint)) (include "megatest-version.scm") (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") -(import debugprint) +;; (import debugprint) ;;====================================================================== ;; T R E E S T U F F ;;======================================================================