ADDED attic/records-vs-vectors-vs-coops.scm Index: attic/records-vs-vectors-vs-coops.scm ================================================================== --- /dev/null +++ attic/records-vs-vectors-vs-coops.scm @@ -0,0 +1,110 @@ +;; 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 . + +;; (include "vg.scm") + +;; (declare (uses vg)) + +(use foof-loop defstruct coops) + +(defstruct obj type fill-color angle) + +(define (make-vg:obj)(make-vector 3)) +(define-inline (vg:obj-get-type vec) (vector-ref vec 0)) +(define-inline (vg:obj-get-fill-color vec) (vector-ref vec 1)) +(define-inline (vg:obj-get-angle vec) (vector-ref vec 2)) +(define-inline (vg:obj-set-type! vec val)(vector-set! vec 0 val)) +(define-inline (vg:obj-set-fill-color! vec val)(vector-set! vec 1 val)) +(define-inline (vg:obj-set-angle! vec val)(vector-set! vec 2 val)) + +(use simple-exceptions) +(define vgs:obj-exn (make-exception "wrong record type, expected vgs:obj." 'assert)) +(define (make-vgs:obj)(let ((v (make-vector 4)))(vector-set! v 0 'vgs:obj) v)) +(define-inline (vgs:obj-type vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 1)(raise (vgs:obj-exn 'vgs:obj-type 'xpr)))) +(define-inline (vgs:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 2)(raise (vgs:obj-exn 'vgs:obj-fill-color 'xpr)))) +(define-inline (vgs:obj-angle vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 3)(raise (vgs:obj-exn 'vgs:obj-angle 'xpr)))) +(define-inline (vgs:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 1 val)(raise (vgs:obj-exn 'type)))) +(define-inline (vgs:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 2 val)(raise (vgs:obj-exn 'fill-color)))) +(define-inline (vgs:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 3 val)(raise (vgs:obj-exn 'angle)))) + +(define-class () + ((type) + (fill-color) + (angle))) + + +;; first use raw vectors +(print "Using vectors") +(time + (loop ((for r (up-from 0 (to 255)))) + (loop ((for g (up-from 0 (to 255)))) + (loop ((for b (up-from 0 (to 255)))) + (let ((obj (make-vg:obj))) + (vg:obj-set-type! obj 'abc) + (vg:obj-set-fill-color! obj "green") + (vg:obj-set-angle! obj 135) + (let ((a (vg:obj-get-type obj)) + (b (vg:obj-get-fill-color obj)) + (c (vg:obj-get-angle obj))) + obj)))))) + +;; first use raw vectors with safe mode +(print "Using vectors (safe mode)") +(time + (loop ((for r (up-from 0 (to 255)))) + (loop ((for g (up-from 0 (to 255)))) + (loop ((for b (up-from 0 (to 255)))) + (let ((obj (make-vgs:obj))) + ;; (badobj (make-vector 20))) + (vgs:obj-type-set! obj 'abc) + (vgs:obj-fill-color-set! obj "green") + (vgs:obj-angle-set! obj 135) + (let ((a (vgs:obj-type obj)) + (b (vgs:obj-fill-color obj)) + (c (vgs:obj-angle obj))) + obj)))))) + +;; first use defstruct +(print "Using defstruct") +(time + (loop ((for r (up-from 0 (to 255)))) + (loop ((for g (up-from 0 (to 255)))) + (loop ((for b (up-from 0 (to 255)))) + (let ((obj (make-obj))) + (obj-type-set! obj 'abc) + (obj-fill-color-set! obj "green") + (obj-angle-set! obj 135) + (let ((a (obj-type obj)) + (b (obj-fill-color obj)) + (c (obj-angle obj))) + obj)))))) + + +;; first use defstruct +(print "Using coops") +(time + (loop ((for r (up-from 0 (to 255)))) + (loop ((for g (up-from 0 (to 255)))) + (loop ((for b (up-from 0 (to 255)))) + (let ((obj (make ))) + (set! (slot-value obj 'type) 'abc) + (set! (slot-value obj 'fill-color) "green") + (set! (slot-value obj 'angle) 135) + (let ((a (slot-value obj 'type)) + (b (slot-value obj 'fill-color)) + (c (slot-value obj 'angle))) + obj)))))) ADDED attic/runs-launch-loop-test.scm Index: attic/runs-launch-loop-test.scm ================================================================== --- /dev/null +++ attic/runs-launch-loop-test.scm @@ -0,0 +1,76 @@ +;; 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 . +;; +(use srfi-69) + +(define (runs:queue-next-hed tal reg n regful) + (if regful + (car reg) + (car tal))) + +(define (runs:queue-next-tal tal reg n regful) + (if regful + tal + (let ((newtal (cdr tal))) + (if (null? newtal) + reg + newtal + )))) + +(define (runs:queue-next-reg tal reg n regful) + (if regful + (cdr reg) + (if (eq? (length tal) 1) + '() + reg))) + +(use trace) +(trace runs:queue-next-hed + runs:queue-next-tal + runs:queue-next-reg) + + +(define tests '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)) + +(define test-registry (make-hash-table)) + +(define n 3) + +(let loop ((hed (car tests)) + (tal (cdr tests)) + (reg '())) + (let* ((reglen (length reg)) + (regful (> reglen n))) + (print "hed=" hed ", length reg=" (length reg) ", (> lenreg n)=" (> (length reg) n)) + (let ((newtal (append tal (list hed)))) ;; used if we are not done with this test + (cond + ((not (hash-table-ref/default test-registry hed #f)) + (hash-table-set! test-registry hed #t) + (print "Registering #" hed) + (if (not (null? tal)) + (loop (runs:queue-next-hed tal reg n regful) + (runs:queue-next-tal tal reg n regful) + (let ((newl (append reg (list hed)))) + (if regful + (cdr newl) + newl))))) + (else + (print "Running #" hed) + (if (not (null? tal)) + (loop (runs:queue-next-hed tal reg n regful) + (runs:queue-next-tal tal reg n regful) + (runs:queue-next-reg tal reg n regful)))))))) ADDED attic/vg-test.scm Index: attic/vg-test.scm ================================================================== --- /dev/null +++ attic/vg-test.scm @@ -0,0 +1,119 @@ +;; 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 . +;; +(use canvas-draw iup foof-loop) +(import canvas-draw-iup) + +(load "vg.scm") + +(define numtorun 1000) +;; (if (> (length (argv)) 1) +;; (string->number (cadr (argv))) +;; 1000)) + + (use trace) + ;; (trace + ;; ;; vg:draw-rect + ;; ;; vg:grow-rect + ;; vg:get-extents-for-objs + ;; vg:components-get-extents + ;; vg:instances-get-extents + ;; vg:get-extents-for-two-rects + ;; canvas-line!) + +(define d1 (vg:drawing-new)) +(define l1 (vg:lib-new)) +(define c1 (vg:comp-new)) +(define c2 (vg:comp-new)) +(define bt1 (vg:make-rect-obj 10 40 20 50 text: "A long piece of text" font: "Helvetica, -10")) + +(let ((r1 (vg:make-rect-obj 20 20 30 30 text: "r1" font: "Helvetica, -20")) + (r2 (vg:make-rect-obj 30 30 60 60 text: "r2" font: "Helvetica, -10")) + (t1 (vg:make-text-obj 60 60 "The middle" font: "Helvetica, -10"))) + (vg:add-objs-to-comp c1 r1 r2 t1 bt1)) + +(loop ((for x (up-from 0 (to 20)))) + (loop ((for y (up-from 0 (to 20)))) + (vg:add-objs-to-comp c1 (vg:make-rect-obj x y (+ x 5)(+ y 5))))) + +(let ((start (current-seconds))) + (let loop ((i 0)) + (vg:add-obj-to-comp c1 (vg:make-rect-obj 0 0 100 100)) + (if (< i numtorun)(loop (+ i 1)))) + (print "Run time: " (- (current-seconds) start))) + +(vg:add-obj-to-comp c1 (vg:make-line-obj 0 0 100 100)) + +;; add the c1 component to lib l1 with name firstcomp +(vg:add-comp-to-lib l1 "firstcomp" c1) +(vg:add-comp-to-lib l1 "secondcomp" c2) + +;; add the l1 lib to drawing with name firstlib +(vg:add-lib d1 "firstlib" l1) + +;; instantiate firstlib/firstcomp as inst1 in drawing d1 at 0,0 +(vg:instantiate d1 "firstlib" "firstcomp" "inst1" 0 0) +(vg:instantiate d1 "firstlib" "firstcomp" "inst2" 200 200) + + +;; (vg:drawing-scalex-set! d1 1.1) +;; (vg:drawing-scaley-set! d1 0.5) + +;; (define xtnts (vg:scale-offset-xy +;; (vg:component-get-extents c1) +;; 1.1 1.1 -2 -2)) + +;; get extents of c1 and put a rectange around it +;; +(define xtnts (apply vg:grow-rect 10 10 (vg:components-get-extents d1 c1))) +(vg:add-objs-to-comp c1 (apply vg:make-rect-obj xtnts)) + +(define bt1xt (vg:obj-get-extents d1 bt1)) +(print "bt1xt: " bt1xt) +(vg:add-objs-to-comp c1 (apply vg:make-rect-obj bt1xt)) + +;; get extents of all objects and put rectangle around it +;; +(define big-xtnts (vg:instances-get-extents d1)) +(vg:add-objs-to-comp c2 (apply vg:make-rect-obj big-xtnts)) +(vg:instantiate d1 "firstlib" "secondcomp" "inst3" 0 0) + +(vg:drawing-scalex-set! d1 1.5) +(vg:drawing-scaley-set! d1 1.5) + +(define cnv #f) +(define the-cnv (canvas + #:size "500x400" + #:expand "YES" + #:scrollbar "YES" + #:posx "0.5" + #:posy "0.5" + #:action (make-canvas-action + (lambda (c xadj yadj) + (set! cnv c))))) + +(show + (dialog + (vbox + the-cnv))) + +(vg:drawing-cnv-set! d1 cnv) +(vg:draw d1 #t) + +;; (canvas-rectangle! cnv 10 100 10 80) + +(main-loop) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -1687,15 +1687,17 @@ (min (max (/ (expt r1 (* r2 s2 ratio)) s1) 0) 30)) (else (debug:print 0 *default-log-port* "BAD exp-params, should be \"r1 r2 s1 s2\" but got " paramstr) 30))))) -(define (common:print-delay-table) - (let loop ((x 0)) - (print x "," (common:get-delay x 1)) - (if (< x 2) - (loop (+ x 0.1))))) +;; -mrw- this appears to not be used +;; +;; (define (common:print-delay-table) +;; (let loop ((x 0)) +;; (print x "," (common:get-delay x 1)) +;; (if (< x 2) +;; (loop (+ x 0.1))))) (define (get-cpu-load #!key (remote-host #f)) (car (common:get-cpu-load remote-host))) ;;====================================================================== @@ -2500,23 +2502,23 @@ ((directory? p)(hash-table-set! directories p #t)) (else (case (vector-ref rule 1) ((keep)(hash-table-set! keepers p rule)) ((remove) - (print "Removing file " p) + (debug:print 0 *default-log-port* "Removing file " p) (delete-file p)) ((compress) - (print "Compressing file " p) + (debug:print 0 *default-log-port* "Compressing file " p) (system (conc compress " " p))) (else - (print "No match for file " p)))))))) + (debug:print 0 *default-log-port* "No match for file " p)))))))) (if remove-empty (for-each (lambda (d) (if (null? (glob (conc d "/.*")(conc d "/*"))) (begin - (print "Removing empty directory " d) + (debug:print 0 *default-log-port* "Removing empty directory " d) (delete-directory d)))) (sort (hash-table-keys directories) (lambda (a b)(> (string-length a)(string-length b)))))) )) ;;====================================================================== Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -165,11 +165,11 @@ (let ((outres (string-intersperse res "\n"))) (debug:print-info 4 *default-log-port* "shell result:\n" outres) outres) - (begin + (begin ;; why is this printing to error-port and not using debug:print? -mrw- (with-output-to-port (current-error-port) (lambda () (print "ERROR: " cmd " returned bad exit code " status))) "")))) Index: dashboard-context-menu.scm ================================================================== --- dashboard-context-menu.scm +++ dashboard-context-menu.scm @@ -319,11 +319,11 @@ (lambda () (if scheme-match (begin (handle-exceptions exn - (print "error with custom menu scheme, exn=" exn) + (debug:print 0 *default-log-port* "error with custom menu scheme, exn=" exn) (begin ;;(BB> "gonna eval it!") (eval (with-input-from-string (cadr scheme-match) read))))) (common:run-a-command command-line with-vars: #t)))))))) #f))) Index: dashboard-guimonitor.scm ================================================================== --- dashboard-guimonitor.scm +++ dashboard-guimonitor.scm @@ -74,21 +74,22 @@ (iup:hbox (iup:button "Start" #:expand "HORIZONTAL" #:action (lambda (obj) (tasks:add-from-params tdb "run" keys key-params var-params) - (print "Launch Run"))) + ;; (print "Launch Run") + )) (iup:button "Remove" #:expand "HORIZONTAL" #:action (lambda (obj) - (print "Remove Run") + ;; (print "Remove Run") (tasks:add-from-params tdb "remove" keys key-params var-params) )) (iup:button "Rollup" #:expand "HORIZONTAL" #:action (lambda (obj) - (print "Rollup Run") + ;; (print "Rollup Run") (tasks:add-from-params tdb "rollup" keys key-params var-params))))) (iup:frame #:title "Misc" (iup:hbox (iup:button "Quit" Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -707,12 +707,12 @@ " -archive save-remove -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) ))))) (cond - ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1))) - ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) + ((not testdat)(begin (debug:print 0 *default-log-port* "ERROR: bad test info for " test-id)(exit 1))) + ((not rundat)(begin (debug:print 0 *default-log-port* "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) (else ;; (test-set-status! db run-id test-name state status itemdat) (set! self ; (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES" #:title testfullname @@ -757,11 +757,11 @@ (let* ((mtrx-rc (conc lin ":" 6)) (fname (iup:attribute obj mtrx-rc)) (stepname (iup:attribute obj (conc lin ":" 1))) (comment (iup:attribute obj (conc lin ":" 7)))) (case col - ((7) (print "Comment from step "stepname": "comment)) + ((7) (debug:print 0 *default-log-port* "Comment from step "stepname": "comment)) ((8) (ezsteps:spawn-run-from testdat stepname #t)) ((9) (ezsteps:spawn-run-from testdat stepname #f)) (else (view-a-log fname)))))))) ;; (let loop ((count 0)) ;; (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count)) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -810,11 +810,11 @@ (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) (if (or (null? tal) (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update (begin - (if (> elapsed-time 2)(print "WARNING: timed out in update-testdat " elapsed-time "s")) + (if (> elapsed-time 2)(debug:print 0 *default-log-port* "WARNING: timed out in update-testdat " elapsed-time "s")) (dboard:tabdat-allruns-set! tabdat new-res) maxtests) (if (> (dboard:rundat-run-data-offset run-struct) 0) (loop run tal new-res newmaxtests) ;; not done getting data for this run (loop (car tal)(cdr tal) new-res newmaxtests))))))) @@ -1723,11 +1723,11 @@ #:expand "HORIZONTAL" #:value 1 #:action (lambda (obj tstate) (debug:catch-and-dump (lambda () - (print "tstate: " tstate) + ;; (print "tstate: " tstate) (if (eq? tstate 0) (dboard:tabdat-compact-layout-set! tabdat #f) (dboard:tabdat-compact-layout-set! tabdat #t)) (dboard:tabdat-last-filter-str-set! tabdat "") ) @@ -2160,11 +2160,11 @@ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (debug:print 0 *default-log-port* "ERROR: failed call procedure " viewgen ", with; tab-num=" tab-num ", view-name=" view-name ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") (set! success #f)) - (print "Adding tab " view-name " with proc " viewgen) + (debug:print 0 *default-log-port* "Adding tab " view-name " with proc " viewgen) ;; (iup:child-add! tabs (set! result-child ((eval (string->symbol viewgen)) commondat tabs tab-num view-name views-cfgdat *configdat*)))) ;; and finally set the updater (if success @@ -3504,11 +3504,11 @@ (vg:add-obj-to-comp cmp ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) (vg:make-line-obj curr-tval last-yval curr-tval next-yval line-color: graph-color))) - (print "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) + (debug:print 0 *default-log-port* "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) next) #f ;; (vector tstart minval minval) dat) )))))) ;; for each data point in the series (hash-table-keys alldat))))) @@ -3665,11 +3665,11 @@ (cons obj test-objs)))))) ;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time) ;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration) (if (> item-num 50) (if (eq? 0 (modulo item-num 50)) - (print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests"))) + (debug:print 0 *default-log-port* "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests"))) ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration) (let ((newdoneruns (cons rundat doneruns))) (if (null? tidstal) (if iterated (let* ((xtents (vg:get-extents-for-objs drawing new-test-objs)) @@ -3690,11 +3690,11 @@ (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) ))))) ;; If it is an iterated test put box around it now. (if (not (null? tests-tal)) (if #f ;; (> (- (current-seconds) update-start-time) 5) - (print "drawing runs taking too long") + (debug:print 0 *default-log-port* "drawing runs taking too long") (if (dboard:tabdat-layout-update-ok tabdat) (testsloop (car tests-tal)(cdr tests-tal)(+ test-num 1)) (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) ))))) ;; placeholder box @@ -3730,11 +3730,11 @@ (dboard:rundat-data-changed-set! rundat #f) (dboard:tabdat-not-done-runs-set! tabdat '()) (dboard:tabdat-done-runs-set! tabdat allruns)) (if #f ;; (> (- (current-seconds) update-start-time) 5) (begin - (print "drawing runs taking too long.... have " (length runtal) " remaining") + (debug:print 0 *default-log-port* "drawing runs taking too long.... have " (length runtal) " remaining") ;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here! ;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t)) (dboard:tabdat-not-done-runs-set! tabdat runtal)) (begin (if (dboard:tabdat-layout-update-ok tabdat) @@ -3788,11 +3788,11 @@ ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== (define (main) - (print "Starting dashboard main") + ;; (print "Starting dashboard main") (let* ((mtdb-path (conc *toppath* "/.megatest/main.db")) (target (args:get-arg "-target")) (commondat (dboard:commondat-make))) (if target @@ -3802,11 +3802,11 @@ ) ) (if (not (launch:setup)) (begin - (print "Failed to find megatest.config, exiting") + (debug:print 0 *default-log-port* "Failed to find megatest.config, exiting") (exit 1) ) ) (if (not (common:on-homehost?)) @@ -3867,17 +3867,17 @@ (mutex-lock! (dboard:commondat-update-mutex commondat)) (dboard:commondat-updating-set! commondat #f) (mutex-unlock! (dboard:commondat-update-mutex commondat))) )) 1)))) - (print "Starting updaters") + ;; (debug:print 0 *default-log-port* "Starting updaters") (let ((th1 (make-thread (lambda () (thread-sleep! 1) (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab ) "update buttons once")) (th2 (make-thread iup:main-loop "Main loop"))) - (print "Starting main loop") + ;; (print "Starting main loop") (thread-start! th2) (thread-join! th2) ) ) ) @@ -3905,11 +3905,11 @@ (begin (for-each (lambda (var) ;; (display " ")(display var) (if (get-environment-variable var) (begin - (print "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") + (debug:print 0 *default-log-port* "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") (exit 1)))) '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME")) ) ) @@ -3916,11 +3916,11 @@ (setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD")) (if (not (null? remargs)) (if remargs (begin - (print "Unrecognised arguments: " (string-intersperse remargs " ")) + (debug:print 0 *default-log-port* "Unrecognised arguments: " (string-intersperse remargs " ")) (exit) ) (begin (print help) (exit) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -201,158 +201,10 @@ (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) -;; open an sql database inside a file lock -;; returns: db existed-prior-to-opening -;; RA => Returns a db handler; sets the lock if opened in writable mode -;; -;; (define *db-open-mutex* (make-mutex)) -;; -#;(define (db:lock-create-open fname initproc) - (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local - (raw-fname (pathname-file fname)) - (dir-writable (file-write-access? parent-dir)) - (file-exists (common:file-exists? fname)) - (file-write (if file-exists - (file-write-access? fname) - dir-writable ))) - ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped. - (if file-write ;; dir-writable - (condition-case - (let* ((lockfname (conc fname ".lock")) - (readyfname (conc parent-dir "/.ready-" raw-fname)) - (readyexists (common:file-exists? readyfname))) - (if (not readyexists) - (common:simple-file-lock-and-wait lockfname)) - (let ((db (sqlite3:open-database fname))) - (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) - (sqlite3:execute db "PRAGMA synchronous = 0;") - (if (and (configf:lookup *configdat* "setup" "tmp_mode") (string-match "^/tmp/.*" fname)) - (begin - ;;(print "DEBUG: Setting tmp_mode for " fname) - (sqlite3:execute db (configf:lookup *configdat* "setup" "tmp_mode")) - ) - ) - (if (and (configf:lookup *configdat* "setup" "nfs_mode") (not (string-match "^/tmp/.*" fname))) - (begin - ;;(print "DEBUG: Setting nfs_mode for " fname) - (sqlite3:execute db (configf:lookup *configdat* "setup" "nfs_mode")) - ) - ) - (if (and (not (or (configf:lookup *configdat* "setup" "tmp_mode") (configf:lookup *configdat* "setup" "nfs_mode"))) - (configf:lookup *configdat* "setup" "use-wal") - (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp - (sqlite3:execute db "PRAGMA journal_mode=WAL;") - (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode.")) - (if (not file-exists) - (initproc db)) - (if (not readyexists) - (begin - (common:simple-file-release-lock lockfname) - (with-output-to-file - readyfname - (lambda () - (print "Ready at " - (seconds->year-work-week/day-time - (current-seconds))))))) - db)) - (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) - (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) - (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) - (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) - (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) - - (condition-case - (begin - (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) - (let ((db (sqlite3:open-database fname))) - (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000)) - (sqlite3:execute db "PRAGMA synchronous = 0;") - ;; (mutex-unlock! *db-open-mutex*) - db)) - (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) - (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) - (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) - (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) - (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) - ))) - -;; This routine creates the db if not already present. It is only called if the db is not already opened -;; -#;(define (db:open-db dbstruct run-id #!key (areapath #f)(do-sync #t)) - (let* ((subdb (dbfile:get-subdb dbstruct run-id)) - (tmpdb-stack (dbr:subdb-dbstack subdb))) - (if (stack? tmpdb-stack) - (db:get-subdb tmpdb-stack run-id) ;; get previously opened db (will create new db handle if all in the stack are already used - (let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10)) - (dbpath (db:dbfile-path)) ;; path to tmp db area - (dbname (db:run-id->dbname run-id)) - (dbexists (common:file-exists? dbpath)) - (mtdbfname (conc *toppath* "/"dbname)) - (mtdbexists (common:file-exists? mtdbfname)) - (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbfname) #f)) - (mtdb (db:open-megatest-db mtdbfname)) - ;; the reference db for syncing - (refdbfname (conc dbpath "/"dbname"_ref")) - (refndb (db:open-megatest-db refdbfname)) - ;; (mtdbpath (dbr:dbdat-dbfile mtdb)) - ;; the tmpdb - (tmpdbfname (conc dbpath"/"dbname)) ;; /tmp//.db/[main|1,2...].db - (tmpdb (db:open-megatest-db tmpdbfname)) ;; lock-create-open dbpath db:initialize-main-db)) - (dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) - (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) - - (write-access (file-write-access? mtdbfname)) - - ;; (mtdbmodtime (if mtdbexists - ;; (common:lazy-sqlite-db-modification-time mtdbpath) - ;; #f)) ; moving this before db:open-megatest-db is - ;; called. if wal mode is on -WAL and -shm file get - ;; created with causing the tmpdbmodtime timestamp - ;; always greater than mtdbmodtime (tmpdbmodtime (if - ;; dbfexists (common:lazy-sqlite-db-modification-time - ;; tmpdbfname) #f)) if wal mode is on -WAL and -shm - ;; file get created when db:open-megatest-db is - ;; called. modtimedelta will always be < 10 so db in - ;; tmp not get synced (tmpdbmodtime (if dbfexists - ;; (db:get-last-update-time (car tmpdb)) #f)) (fmt - ;; (file-modification-time tmpdbfname)) - - (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime)))) - - (when write-access - (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_tests_trigger") - (sqlite3:execute (dbr:dbdat-dbh mtdb) "drop trigger if exists update_runs_trigger")) - - ;; (print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db")) - ;; (debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access) - (if (and dbexists (not write-access)) - (begin - (set! *db-write-access* #f) - (dbr:subdb-read-only-set! subdb #t))) - (dbr:subdb-mtdb-set! subdb mtdb) - (dbr:subdb-tmpdb-set! subdb tmpdb) - (dbr:subdb-dbstack-set! subdb (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ? - (stack-push! (dbr:subdb-dbstack subdb) tmpdb) ;; olddb is already a (cons db path) - (dbr:subdb-refndb-set! subdb refndb) - (if (and (or (not dbfexists) - (and modtimedelta - (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back - do-sync) - (begin - (debug:print 1 *default-log-port* "filling db " (dbr:dbdat-dbfile tmpdb) " with data \n from " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) - (db:sync-tables (db:sync-all-tables-list subdb) #f mtdb refndb tmpdb) - ;; touch tmp db to avoid wal mode wierdness - (set! (file-modification-time tmpdbfname) (current-seconds)) - (debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.") - ) - (debug:print 4 *default-log-port* " db, " (dbr:dbdat-dbfile tmpdb) " already exists or fresh enough, not propogating data from\n " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) ) - ;; (db:multi-db-sync subdb 'old2new)) ;; migrate data from megatest.db automatically - tmpdb)))) - (define (db:get-last-update-time db) (let ((last-update-time #f)) (sqlite3:for-each-row (lambda (lup) @@ -434,11 +286,11 @@ ;; (else ;; ((equal? fname "megatest.db") ;; this file can be regenerated if needed (handle-exceptions exn (begin - (print "Problems trying to repair the db, exn=" exn) + (debug:print 0 *default-debug-port* "Problems trying to repair the db, exn=" exn) ;; (db:move-and-recreate-db dbdat) (if (> numtries 0) (db:repair-db dbdat numtries: (- numtries 1)) #f) (debug:print 0 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.") @@ -859,55 +711,10 @@ (if sync-needed (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id)) (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago"))) res)) -;; keeping it around for debugging purposes only -#;(define (open-run-close-no-exception-handling proc idb . params) - (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) - (print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...") - (exit) - (if (or *db-write-access* - (not #t)) ;; was: (member proc * db:all-write-procs *))) - (let* ((db (cond - ((pair? idb) (dbr:dbdat-dbh idb)) - ((sqlite3:database? idb) idb) - ((not idb) (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore")) - ((procedure? idb) (idb)) - (else (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore")))) - (res #f)) - (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! dbstruct)) - (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling END" ) - res) - #f)) - -#;(define (open-run-close-exception-handling proc idb . params) - (handle-exceptions - exn - (let ((sleep-time (random 30)) - (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) - (case err-status - ((busy) - (thread-sleep! sleep-time)) - (else - (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 5 *default-log-port* "exn=" (condition->list exn)) - (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) - (print-call-chain (current-error-port)) - (thread-sleep! sleep-time) - (debug:print-info 0 *default-log-port* "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) - (apply open-run-close-exception-handling proc idb params)) - (apply open-run-close-no-exception-handling proc idb params))) - -;; (define open-run-close -#;(define open-run-close open-run-close-exception-handling) - ;; open-run-close-no-exception-handling -;; open-run-close-exception-handling) -;;) - (define (db:initialize-main-db db) (when (not *configinfo*) (launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f. (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... @@ -920,11 +727,11 @@ (let ((keyn key)) (if (member (string-downcase keyn) (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour")) (begin - (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.") + (debug:print 0 *default-log-port* "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.") (exit 1))))) keys) (sqlite3:with-transaction db (lambda () @@ -4665,107 +4472,10 @@ (debug:print-info 13 *default-log-port* "rosync called, " res " records transferred.")))) (loop (current-seconds))) #t))) (debug:print-info 0 *default-log-port* "Exiting readonly-watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" mtpath="golden-mtpath))) -;;====================================================================== -;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage -#;(define (common:watchdog) - (debug:print-info 13 *default-log-port* "common:watchdog entered.") - (if (launch:setup) - (if (common:on-homehost?) - (let ((dbstruct (db:setup #t))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;; #t))) - (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct) - (cond - ((dbr:dbstruct-read-only dbstruct) - (debug:print-info 13 *default-log-port* "loading read-only watchdog") - (common:readonly-watchdog dbstruct)) - (else - (debug:print-info 13 *default-log-port* "loading writable-watchdog.") - (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "delta-sync"))) ;; "delta-sync"))) ;; "brute-force-sync"))) - (cond - ((equal? syncer "brute-force-sync") - (server:writable-watchdog-bruteforce dbstruct)) - ((equal? syncer "delta-sync") - (server:writable-watchdog-deltasync dbstruct)) - ((equal? syncer "copy-sync") - (server:writable-watchdog-copysync dbstruct)) - (else - (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are copy-sync, brute-force-sync and delta-sync.") - (exit 1))) - ;;(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] Syncer started (method="syncer")") - ))) - (debug:print-info 13 *default-log-port* "watchdog done.")) - (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost")))) - - -#;(define (db:do-sync no-sync-db) - (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "delta-sync")) - (dbstruct (db:setup #t))) - - (debug:print 0 *default-log-port* "db:do-sync: sync-method: " syncer) - (cond - ((equal? syncer "brute-force-sync") - (db:run-lock-and-sync no-sync-db)) - ((equal? syncer "delta-sync") - (debug:print 0 *default-log-port* "db:do-sync: db:multi-db-sync" ) - (let* ( - (tmpdbpth (dbr:dbstruct-tmppath dbstruct)) - (lockfile (conc tmpdbpth ".lock")) - (locked (common:simple-file-lock lockfile)) - (res (if locked - ;; sync all dbs for this area - - - - - (db:all-db-sync dbstruct) - #f - ) - ) - ) - (if res - (begin - (common:simple-file-release-lock lockfile) - (print "db:do-sync: Synced " res " records to megatest.db") - ) - (print "db:do-sync: Skipping sync, there is a sync in progress.") - ) - ) - ) - ((equal? syncer "copy-sync") - (db:run-lock-and-sync *no-sync-db*)) - (else - (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are copy-sync, brute-force-sync and delta-sync.") - (exit 1) - ) - ) - ) -) - - - - -#;(define (server:writable-watchdog-bruteforce dbstruct) - (thread-sleep! 1) ;; delay for startup - #;(let* ((do-a-sync (server:get-bruteforce-syncer dbstruct)) - (final-sync (server:get-bruteforce-syncer dbstruct fork-to-background: #t persist-until-sync: #t))) - (when (and (not (args:get-arg "-sync-to-megatest.db")) ;; conditions under which we do not run the sync - (args:get-arg "-server")) - - (let loop () - (do-a-sync) - (if (not *time-to-exit*) (loop))) ;; keep going unless time to exit - - ;; time to exit, close the no-sync db here - (final-sync) - - (if (common:low-noise-print 30) - (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) - )))) - ) - ;; Get a lock from the no-sync-db for the from-db, then copy the from-db to the to-db, otherwise return #f (define (db:lock-and-sync no-sync-db from-db to-db) (assert (not *db-sync-in-progress*) "FATAL: db:lock-and-sync called while a sync is in progress.") Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -522,11 +522,11 @@ (let* ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) "")) (command (conc "cd " rundir ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) - (print "Command =" command) + ;; (print "Command =" command) (common:without-vars command "MT_.*")) (message-window (conc "Directory " rundir " not found")))))) (xterm) @@ -550,11 +550,11 @@ #:numcol 1 #:numlin (length key-vals) #:numcol-visible 1 #:numlin-visible (length key-vals) #:click-cb (lambda (obj lin col status) - (print "obj: " obj " lin: " lin " col: " col " status: " status))))) + (debug:print 0 *default-log-port* "obj: " obj " lin: " lin " col: " col " status: " status))))) ;; (iup:attribute-set! keys-matrix "0:0" "Run Keys") (iup:attribute-set! keys-matrix "WIDTH0" 0) (iup:attribute-set! keys-matrix "0:1" "Key Name") ;; (iup:attribute-set! keys-matrix "WIDTH1" "100") ;; fill in keys @@ -800,22 +800,23 @@ (iup:attribute fd "VALUE")) (iup:destroy! fd)))) ;; (lambda (obj) ;; (iup:show (iup:file-dialog)) ;; (print "File->open " obj))) - (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) + ;; (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) - (iup:menu-item "Tools" (iup:menu - (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) - ;; (iup:menu-item "Show dialog" #:action (lambda (obj) - ;; (show message-window - ;; #:modal? #t - ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current - ;; ;; #:x 'mouse - ;; ;; #:y 'mouse - ;; ) - )))) +;; (iup:menu-item "Tools" (iup:menu +;; (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) +;; ;; (iup:menu-item "Show dialog" #:action (lambda (obj) +;; ;; (show message-window +;; ;; #:modal? #t +;; ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current +;; ;; ;; #:x 'mouse +;; ;; ;; #:y 'mouse +;; ;; ) +;; )) + )) ;;====================================================================== ;; CANVAS STUFF FOR TESTS ;;====================================================================== @@ -1357,11 +1358,10 @@ (let* ((status (vector-ref hed 3)) (val (vector-ref hed (- colnum 1))) (bgcolor (cond ((member (conc status) '("" "-" "#")) running-color) - ((member (conc status) '("0" 0)) white) (else test-status-color))) ; (else failcolor))) (mtrx-rc (conc rownum ":" colnum))) Index: diff-report.scm ================================================================== --- diff-report.scm +++ diff-report.scm @@ -146,11 +146,11 @@ (define (diff:target+run-name->run-id target run-name) (let* ((keys (rmt:get-keys)) (target-parts (if target (string-split target "/") (map (lambda (x) "%") keys)))) (if (not (eq? (length keys) (length keys))) (begin - (print "Error: Target ("target") item count does not match fields count target tokens="target-parts" fields="keys) + (debug:print 0 *default-log-port* "Error: Target ("target") item count does not match fields count target tokens="target-parts" fields="keys) #f) (let* ((target-map (zip keys target-parts)) (qry-res (rmt:get-runs run-name 1 0 target-map))) (if (eq? 2 (vector-length qry-res)) @@ -384,22 +384,10 @@ (if html-output-file (with-output-to-file html-output-file (lambda () (print html-body)))) (when (and email-recipients-list (> (length email-recipients-list) 0)) (sendmail (string-join email-recipients-list ",") email-subject html-body use_html: #t)) html-body)) - - - - - -;; (let* ((src-run-name "all57") -;; (dest-run-name "all60") -;; (src-run-id (diff:run-name->run-id src-run-name)) -;; (dest-run-id (diff:run-name->run-id dest-run-name)) -;; (to-list (list "bjbarcla"))) -;; (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: "/tmp/bjbarcla/zippy.html") -;; ) (define (do-diff-report src-target src-runname dest-target dest-runname html-file to-list-raw) (let* (;;(src-target "nope%") ;;(src-runname "all57") ;;(dest-target "%") @@ -410,16 +398,16 @@ (to-list (if (string? to-list-raw) (string-split to-list-raw ",:") #f)) ) (cond ((not src-run-id) - (print "No match for source target/runname="src-target"/"src-runname) - (print "Cannot proceed.") + (debug:print 0 *default-log-port* "No match for source target/runname="src-target"/"src-runname) + (debug:print 0 *default-log-port* "Cannot proceed.") #f) ((not dest-run-id) - (print "No match for source target/runname="dest-target"/"dest-runname) - (print "Cannot proceed.") + (debug:print 0 *default-log-port* "No match for source target/runname="dest-target"/"dest-runname) + (debug:print 0 *default-log-port* "Cannot proceed.") #f) (else (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: html-file))))) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -167,11 +167,11 @@ ;; get_next_port goes here (http-transport:try-start-server ipaddrstr (portlogger:open-run-close portlogger:find-port))) (begin - (print "ERROR: Tried and tried but could not start the server")))) + (debug:print 0 *default-log-port* "ERROR: Tried and tried but could not start the server")))) ;; any error in following steps will result in a retry (set! *server-info* (list ipaddrstr portnum)) (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum) ;; This starts the spiffy server ;; NEED WAY TO SET IP TO #f TO BIND ALL Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -439,16 +439,16 @@ (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (if (eq? signum signal/stop) (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting.")) (set! *time-to-exit* #t) - (print "Received signal " signum ", cleaning up before exit (set this test to COMPLETED/ABORT) . Please wait...") + (debug:print 0 *default-log-port* "Received signal " signum ", cleaning up before exit (set this test to COMPLETED/ABORT) . Please wait...") (let ((th1 (make-thread (lambda () - (print "set test to COMPLETED/ABORT begin.") + (debug:print 0 *default-log-port* "set test to COMPLETED/ABORT begin.") (rmt:test-set-state-status run-id test-id "COMPLETED" "ABORT" "received kill signal") - (print "set test to COMPLETED/ABORT complete.") - (print "Killed by signal " signum ". Exiting") + (debug:print 0 *default-log-port* "set test to COMPLETED/ABORT complete.") + (debug:print 0 *default-log-port* "Killed by signal " signum ". Exiting") (exit 1)))) (th2 (make-thread (lambda () (thread-sleep! 20) (debug:print 0 *default-log-port* "Done") (exit 4))))) @@ -1653,11 +1653,11 @@ #:append)) (debug:print 2 *default-log-port* "Launching completed, updating db") (debug:print 2 *default-log-port* "Launch results: " launch-results) (if (not launch-results) (begin - (print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now") + (debug:print 0 *default-log-port* "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now") ;; (sqlite3:finalize! db) ;; good ole "exit" seems not to work ;; (_exit 9) ;; but this hack will work! Thanks go to Alan Post of the Chicken email list ;; NB// Is this still needed? Should be safe to go back to "exit" now? Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -95,20 +95,19 @@ (if (and *usage-log-file* (file-write-access? *usage-log-file*)) (with-output-to-file *usage-log-file* (lambda () - (print - (if *usage-use-seconds* - (current-seconds) - (time->string - (seconds->local-time (current-seconds)) - "%Yww%V.%w %H:%M:%S")) - " " - (current-user-name) " " - (current-directory) " " - "\"" (string-intersperse (argv) " ") "\"")) + (print (if *usage-use-seconds* + (current-seconds) + (time->string + (seconds->local-time (current-seconds)) + "%Yww%V.%w %H:%M:%S")) + " " + (current-user-name) " " + (current-directory) " " + "\"" (string-intersperse (argv) " ") "\"")) #:append)) ;; Disabled help items ;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s) ;; from prior runs with same keys @@ -717,18 +716,17 @@ (save-environment-as-files (args:get-arg "-env2file")) (set! *didsomething* #t))) (if (args:get-arg "-list-disks") (let ((toppath (launch:setup))) - (print - (string-intersperse - (map (lambda (x) - (string-intersperse - x - " => ")) - (common:get-disks *configdat*)) - "\n")) + (print (string-intersperse + (map (lambda (x) + (string-intersperse + x + " => ")) + (common:get-disks *configdat*)) + "\n")) (set! *didsomething* #t))) ;; csv processing record (define (make-refdb:csv) (vector @@ -2498,12 +2496,12 @@ 'new2old) #f))) (if res (begin (common:simple-file-release-lock lockfile) - (print "Synced " res " records to megatest.db")) - (print "Skipping sync, there is a sync in progress.")) + (debug:print 0 *default-log-port* "Synced " res " records to megatest.db")) + (debug:print 0 *default-log-port* "Skipping sync, there is a sync in progress.")) (set! *didsomething* #t))) (if (args:get-arg "-sync-to") (let ((toppath (launch:setup))) (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to")) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -416,11 +416,13 @@ #:numcol 1 #:numlin 4 #:numcol-visible 1 #:numlin-visible 4 #:click-cb (lambda (obj lin col status) - (print "obj: " obj " lin: " lin " col: " col " status: " status)))) + #f + ;;(print "obj: " obj " lin: " lin " col: " col " status: " status) + ))) (test-info-matrix (iup:matrix #:expand "YES" #:numcol 1 #:numlin 7 #:numcol-visible 1 @@ -555,11 +557,12 @@ (let* ((run-path (tree:node->path obj id)) (test-id (tree-path->test-id (cdr run-path)))) ;; (if test-id ;; (hash-table-set! (dboard:data-curr-test-ids *data*) ;; window-id test-id)) - (print "path: " (tree:node->path obj id) " test-id: " test-id)))))) + ;; (print "path: " (tree:node->path obj id) " test-id: " test-id) + ))))) (iup:attribute-set! tb "VALUE" "0") (iup:attribute-set! tb "NAME" "Runs") ;;(iup:attribute-set! tb "ADDEXPANDED" "NO") ;; (dboard:data-tests-tree-set! *data* tb) tb) @@ -663,11 +666,13 @@ #:numcol 100 #:numlin 100 #:numcol-visible 7 #:numlin-visible 7 #:click-cb (lambda (obj lin col status) - (print "obj: " obj " lin: " lin " col: " col " status: " status))))) + #f + ;; (print "obj: " obj " lin: " lin " col: " col " status: " status) + )))) (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES") (iup:attribute-set! runs-matrix "WIDTH0" "100") ;; (dboard:data-runs-matrix-set! *data* runs-matrix) Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -85,11 +85,11 @@ (define (process:cmd-run-proc-each-line cmd proc . params) ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) (handle-exceptions exn (begin - (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) + (debug:print 0 *default-log-port* "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 5 *default-log-port* "exn=" (condition->list exn)) #f) (let-values (((fh fho pid) (if (null? params) (process cmd) DELETED records-vs-vectors-vs-coops.scm Index: records-vs-vectors-vs-coops.scm ================================================================== --- records-vs-vectors-vs-coops.scm +++ /dev/null @@ -1,110 +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 . - -;; (include "vg.scm") - -;; (declare (uses vg)) - -(use foof-loop defstruct coops) - -(defstruct obj type fill-color angle) - -(define (make-vg:obj)(make-vector 3)) -(define-inline (vg:obj-get-type vec) (vector-ref vec 0)) -(define-inline (vg:obj-get-fill-color vec) (vector-ref vec 1)) -(define-inline (vg:obj-get-angle vec) (vector-ref vec 2)) -(define-inline (vg:obj-set-type! vec val)(vector-set! vec 0 val)) -(define-inline (vg:obj-set-fill-color! vec val)(vector-set! vec 1 val)) -(define-inline (vg:obj-set-angle! vec val)(vector-set! vec 2 val)) - -(use simple-exceptions) -(define vgs:obj-exn (make-exception "wrong record type, expected vgs:obj." 'assert)) -(define (make-vgs:obj)(let ((v (make-vector 4)))(vector-set! v 0 'vgs:obj) v)) -(define-inline (vgs:obj-type vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 1)(raise (vgs:obj-exn 'vgs:obj-type 'xpr)))) -(define-inline (vgs:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 2)(raise (vgs:obj-exn 'vgs:obj-fill-color 'xpr)))) -(define-inline (vgs:obj-angle vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 3)(raise (vgs:obj-exn 'vgs:obj-angle 'xpr)))) -(define-inline (vgs:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 1 val)(raise (vgs:obj-exn 'type)))) -(define-inline (vgs:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 2 val)(raise (vgs:obj-exn 'fill-color)))) -(define-inline (vgs:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 3 val)(raise (vgs:obj-exn 'angle)))) - -(define-class () - ((type) - (fill-color) - (angle))) - - -;; first use raw vectors -(print "Using vectors") -(time - (loop ((for r (up-from 0 (to 255)))) - (loop ((for g (up-from 0 (to 255)))) - (loop ((for b (up-from 0 (to 255)))) - (let ((obj (make-vg:obj))) - (vg:obj-set-type! obj 'abc) - (vg:obj-set-fill-color! obj "green") - (vg:obj-set-angle! obj 135) - (let ((a (vg:obj-get-type obj)) - (b (vg:obj-get-fill-color obj)) - (c (vg:obj-get-angle obj))) - obj)))))) - -;; first use raw vectors with safe mode -(print "Using vectors (safe mode)") -(time - (loop ((for r (up-from 0 (to 255)))) - (loop ((for g (up-from 0 (to 255)))) - (loop ((for b (up-from 0 (to 255)))) - (let ((obj (make-vgs:obj))) - ;; (badobj (make-vector 20))) - (vgs:obj-type-set! obj 'abc) - (vgs:obj-fill-color-set! obj "green") - (vgs:obj-angle-set! obj 135) - (let ((a (vgs:obj-type obj)) - (b (vgs:obj-fill-color obj)) - (c (vgs:obj-angle obj))) - obj)))))) - -;; first use defstruct -(print "Using defstruct") -(time - (loop ((for r (up-from 0 (to 255)))) - (loop ((for g (up-from 0 (to 255)))) - (loop ((for b (up-from 0 (to 255)))) - (let ((obj (make-obj))) - (obj-type-set! obj 'abc) - (obj-fill-color-set! obj "green") - (obj-angle-set! obj 135) - (let ((a (obj-type obj)) - (b (obj-fill-color obj)) - (c (obj-angle obj))) - obj)))))) - - -;; first use defstruct -(print "Using coops") -(time - (loop ((for r (up-from 0 (to 255)))) - (loop ((for g (up-from 0 (to 255)))) - (loop ((for b (up-from 0 (to 255)))) - (let ((obj (make ))) - (set! (slot-value obj 'type) 'abc) - (set! (slot-value obj 'fill-color) "green") - (set! (slot-value obj 'angle) 135) - (let ((a (slot-value obj 'type)) - (b (slot-value obj 'fill-color)) - (c (slot-value obj 'angle))) - obj)))))) DELETED runs-launch-loop-test.scm Index: runs-launch-loop-test.scm ================================================================== --- runs-launch-loop-test.scm +++ /dev/null @@ -1,76 +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 . -;; -(use srfi-69) - -(define (runs:queue-next-hed tal reg n regful) - (if regful - (car reg) - (car tal))) - -(define (runs:queue-next-tal tal reg n regful) - (if regful - tal - (let ((newtal (cdr tal))) - (if (null? newtal) - reg - newtal - )))) - -(define (runs:queue-next-reg tal reg n regful) - (if regful - (cdr reg) - (if (eq? (length tal) 1) - '() - reg))) - -(use trace) -(trace runs:queue-next-hed - runs:queue-next-tal - runs:queue-next-reg) - - -(define tests '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)) - -(define test-registry (make-hash-table)) - -(define n 3) - -(let loop ((hed (car tests)) - (tal (cdr tests)) - (reg '())) - (let* ((reglen (length reg)) - (regful (> reglen n))) - (print "hed=" hed ", length reg=" (length reg) ", (> lenreg n)=" (> (length reg) n)) - (let ((newtal (append tal (list hed)))) ;; used if we are not done with this test - (cond - ((not (hash-table-ref/default test-registry hed #f)) - (hash-table-set! test-registry hed #t) - (print "Registering #" hed) - (if (not (null? tal)) - (loop (runs:queue-next-hed tal reg n regful) - (runs:queue-next-tal tal reg n regful) - (let ((newl (append reg (list hed)))) - (if regful - (cdr newl) - newl))))) - (else - (print "Running #" hed) - (if (not (null? tal)) - (loop (runs:queue-next-hed tal reg n regful) - (runs:queue-next-tal tal reg n regful) - (runs:queue-next-reg tal reg n regful)))))))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -100,16 +100,15 @@ (thread-sleep! 2)) (begin (if (runs:lownoise "runners-softlock-nowait" 360) (debug:print-info 0 *default-log-port* "No runners in flight, updating softlock")) (let* ((ouf (open-output-file my-lock-file))) - (with-output-to-port ouf - (lambda ()(print (current-seconds)))) + (with-output-to-port ouf (lambda ()(print (current-seconds)))) (close-output-port ouf)))) (runs:dat-last-fuel-check-set! rdat (current-seconds)))))) -;; Fourth try, do accounting through time +;; Fourth try, do accounting through time.... ;; (define (runs:parallel-runners-mgmt rdat) (let ((time-to-check (configf:lookup-number *configdat* "runners" "time-to-check" default: 10)) ;; 28 (time-to-wait (configf:lookup-number *configdat* "runners" "time-to-wait" default: 30)) (now-time (current-seconds))) @@ -228,13 +227,12 @@ (begin (debug:print 0 *default-log-port* "FATAL: *configdat* was inaccessible! This should never happen. Retried " count " times. Message: " msg) (debug:print 0 *default-log-port* "Call chain:") (with-output-to-port *default-log-port* - - (lambda () - (print "*configdat* is >>"*configdat*"<<") + (lambda () + (print "*configdat* is >>"*configdat*"<<") (pp *configdat*) (pp call-chain))) (exit 1)))) ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1.5") @@ -559,15 +557,15 @@ ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (set! *time-to-exit* #t) - (print "Received signal " signum ", cleaning up before exit. Please wait...") + (debug:print 0 *default-log-port* "Received signal " signum ", cleaning up before exit. Please wait...") (let ((th1 (make-thread (lambda () ;; (let ((tdbdat (tasks:open-db))) (rmt:tasks-set-state-given-param-key task-key "killed") ;; ) - (print "Killed by signal " signum ". Exiting") + (debug:print 0 *default-log-port* "Killed by signal " signum ". Exiting") (thread-sleep! 3) (exit)))) (th2 (make-thread (lambda () (thread-sleep! 5) (debug:print 0 *default-log-port* "Done") @@ -803,19 +801,19 @@ (debug:print-info 4 *default-log-port* "test-records=" (hash-table->alist test-records)) (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) (if (> (length (hash-table-keys test-records)) 0) (let* ((keep-going #t) (run-queue-retries 5) - #;(th1 (make-thread (lambda () - (handle-exceptions - exn - (begin - (print-call-chain) - (print " message: " ((condition-property-accessor 'exn 'message) exn))) - (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests - (any->number reglen) all-tests-registry))) - "runs:run-tests-queue")) + ;; (th1 (make-thread (lambda () + ;; (handle-exceptions + ;; exn + ;; (begin + ;; (print-call-chain) + ;; (print " message: " ((condition-property-accessor 'exn 'message) exn))) + ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests + ;; (any->number reglen) all-tests-registry))) + ;; "runs:run-tests-queue")) (th2 (make-thread (lambda () ;; BBQ: why are we visiting ALL runs here? ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ... (let ((run-ids (rmt:get-all-run-ids))) (for-each (lambda (run-id) (if keep-going @@ -2214,11 +2212,11 @@ (if (runs:dat-wait-for-jobs-function runsdat) ((runs:dat-wait-for-jobs-function runsdat) testdat-rec)) (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) (begin - (print "ERROR: Failed to launch the test. Exiting as soon as possible") + (debug:print 0 *default-log-port* "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; (process-signal (current-process-id) signal/kill)) ) ;; wait again here? )))))) @@ -2737,13 +2735,13 @@ ;; special case - archive get (if (equal? (args:get-arg "-archive") "get") (archive:bup-get-data "get" #f #f test-records rp-mutex bup-mutex)) (if (or (equal? (args:get-arg "-archive") "save") (equal? (args:get-arg "-archive") "save-remove")) (begin - (print "db archive started") + (debug:print 0 *default-log-port* "db archive started") (archive:megatest-db target runnamepatt) - (print "db archived"))) + (debug:print 0 *default-log-port* "db archived"))) ) #t ) (define (runs:remove-test-directory test mode) ;; remove-data-only) @@ -2908,11 +2906,11 @@ (fld (car key)) (val (configf:lookup test-conf "test_meta" fld))) ;; (debug:print 5 *default-log-port* "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin - (print "Updating " test-name " " fld " to " val) + (debug:print 0 *default-log-port* "Updating " test-name " " fld " to " val) (rmt:testmeta-update-field test-name fld val))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) ;; find tests with matching tags, tagpatt is a string "tagpatt1,tagpatt2%, ..." ;; Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -255,11 +255,11 @@ (current-process-id) (get-host-name)) (let ((deadlist '())) (sqlite3:for-each-row (lambda (id pid host last-update delta) - (print "Going to delete stale record for monitor with pid " pid " on host " host " last updated " delta " seconds ago") + (debug:print 0 *default-log-port* "Going to delete stale record for monitor with pid " pid " on host " host " last updated " delta " seconds ago") (set! deadlist (cons id deadlist))) mdb "SELECT id,pid,hostname,last_update,strftime('%s','now')-last_update AS delta FROM monitors WHERE delta > 700;") (sqlite3:execute mdb (conc "DELETE FROM monitors WHERE id IN ('" (string-intersperse (map conc deadlist) "','") "');"))) ) @@ -266,11 +266,11 @@ (define (tasks:register-monitor db port) (let* ((pid (current-process-id)) (hostname (get-host-name)) (userinfo (user-information (current-user-id))) (username (car userinfo))) - (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username) + (debug:print 0 *default-log-port* "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username) (sqlite3:execute db "INSERT INTO monitors (pid,start_time,last_update,hostname,username) VALUES (?,strftime('%s','now'),strftime('%s','now'),?,?);" pid hostname username))) (define (tasks:get-num-alive-monitors mdb) (let ((res 0)) @@ -664,11 +664,11 @@ "%")) (run-times (rmt:get-run-times run-patt target-patt ))) (if (eq? (length run-times) 0) (begin - (print "Data not found!!") + (debug:print 0 *default-log-port* "Data not found!!") (exit))) (if (equal? (args:get-arg "-dumpmode") "json") (task:print-runtime-as-json run-times) (if (equal? (args:get-arg "-dumpmode") "csv") (task:print-runtime run-times ",") @@ -710,28 +710,28 @@ #f)) (test-times (rmt:get-test-times runname target ))) (if (not runname) (begin - (print "Error: Missing argument -runname") + (debug:print 0 *default-log-port* "Error: Missing argument -runname") (exit))) (if (string-contains runname "%") (begin - (print "Error: Invalid runname, '%' not allowed (" runname ") ") + (debug:print 0 *default-log-port* "Error: Invalid runname, '%' not allowed (" runname ") ") (exit))) (if (not target) (begin - (print "Error: Missing argument -target") + (debug:print 0 *default-log-port* "Error: Missing argument -target") (exit))) (if (string-contains target "%") (begin - (print "Error: Invalid target, '%' not allowed (" target ") ") + (debug:print 0 *default-log-port* "Error: Invalid target, '%' not allowed (" target ") ") (exit))) (if (eq? (length test-times) 0) (begin - (print "Data not found!!") + (debug:print 0 *default-log-port* "Data not found!!") (exit))) (if (equal? (args:get-arg "-dumpmode") "json") (task:print-testtime-as-json test-times) (if (equal? (args:get-arg "-dumpmode") "csv") (task:print-testtime test-times ",") @@ -801,11 +801,11 @@ (begin (debug:print-info 1 *default-log-port* "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f) (if (handle-exceptions exn (begin (print-call-chain) - (print ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) #f) (pgdb:insert-run dbh spec-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time)) @@ -928,11 +928,11 @@ (begin (debug:print-info 4 *default-log-port* "Inserting test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id) (if (handle-exceptions exn (begin (print-call-chain) - (print ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) #f) (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type last-update)) ;(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info) (begin @@ -1041,11 +1041,11 @@ ;; get runs changed since last sync ;; (define (tasks:sync-test-data dbh cached-info area-info) ;; (let* (( (define (tasks:sync-to-postgres configdat dest) - (print "In sync") + ;; (print "In sync") (let* ((dbh (pgdb:open configdat dbname: dest)) (area-info (pgdb:get-area-by-path dbh *toppath*)) (cached-info (make-hash-table)) (start (current-seconds)) (test-patt (if (args:get-arg "-testpatt") @@ -1057,15 +1057,15 @@ (run-name (if (args:get-arg "-runname") (args:get-arg "-runname") #f))) (if (and target (not run-name)) (begin - (print "Error: Provide runname") + (debug:print 0 *default-log-port* "Error: Provide runname") (exit 1))) (if (and (not target) run-name) (begin - (print "Error: Provide target") + (debug:print 0 *default-log-port* "Error: Provide target") (exit 1))) ;(print "123") ;(exit 1) (for-each (lambda (dtype) (hash-table-set! cached-info dtype (make-hash-table))) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -556,11 +556,11 @@ (let ((my-start-time (current-seconds)) (lockf (conc outputfilename ".lock"))) (let loop ((have-lock (common:simple-file-lock lockf))) (if have-lock (let ((script (configf:lookup *configdat* "testrollup" test-name))) - (print "Obtained lock for " outputfilename) + (debug:print 0 *default-log-port* "Obtained lock for " outputfilename) (rmt:set-state-status-and-roll-up-items run-id test-name "" #f #f #f) (if script (system (conc script " > " outputfilename " & ")) (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename)) (common:simple-file-release-lock lockf) @@ -570,11 +570,11 @@ ;; didn't get the lock, check to see if current update started later than this ;; update, if so we can exit without doing any work (if (> my-start-time (handle-exceptions exn (begin - (print "failed to get mod time on " lockf ", exn=" exn) + (debug:print 0 *default-log-port* "failed to get mod time on " lockf ", exn=" exn) 0) (file-modification-time lockf))) ;; we started since current re-gen in flight, delay a little and try again (begin (debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it") @@ -613,11 +613,11 @@ comment) "" "")))) (if (list? testdat) testdat (begin - (print "ERROR: failed to get records with rmt:test-get-records-for-index-file run-id=" run-id "test-name=" test-name) + (debug:print 0 *default-log-port* "ERROR: failed to get records with rmt:test-get-records-for-index-file run-id=" run-id "test-name=" test-name) '()))) (print "
") ;; Print out stats for status (set! tot 0) Index: tree.scm ================================================================== --- tree.scm +++ tree.scm @@ -85,11 +85,11 @@ (cond ((not (equal? top (iup:attribute obj "TITLE0"))) - (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) + (debug:print 0 *default-log-port* "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) ((null? nodelst)) (else (let loop ((hed (car nodelst)) (tal (cdr nodelst)) (depth 1) @@ -131,11 +131,11 @@ (loop (+ currnode 1) newpath))))) (define (tree:delete-node obj top node-path) ;; node-path is a list of strings (let ((id (tree:find-node obj (cons top node-path)))) - (print "Found node to remove " id " for path " top " " node-path) + (debug:print 0 *default-log-port* "Found node to remove " id " for path " top " " node-path) (iup:attribute-set! obj (conc "DELNODE" id) "SELECTED"))) #| (let* ((tb (iup:treebox DELETED vg-test.scm Index: vg-test.scm ================================================================== --- vg-test.scm +++ /dev/null @@ -1,119 +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 . -;; -(use canvas-draw iup foof-loop) -(import canvas-draw-iup) - -(load "vg.scm") - -(define numtorun 1000) -;; (if (> (length (argv)) 1) -;; (string->number (cadr (argv))) -;; 1000)) - - (use trace) - ;; (trace - ;; ;; vg:draw-rect - ;; ;; vg:grow-rect - ;; vg:get-extents-for-objs - ;; vg:components-get-extents - ;; vg:instances-get-extents - ;; vg:get-extents-for-two-rects - ;; canvas-line!) - -(define d1 (vg:drawing-new)) -(define l1 (vg:lib-new)) -(define c1 (vg:comp-new)) -(define c2 (vg:comp-new)) -(define bt1 (vg:make-rect-obj 10 40 20 50 text: "A long piece of text" font: "Helvetica, -10")) - -(let ((r1 (vg:make-rect-obj 20 20 30 30 text: "r1" font: "Helvetica, -20")) - (r2 (vg:make-rect-obj 30 30 60 60 text: "r2" font: "Helvetica, -10")) - (t1 (vg:make-text-obj 60 60 "The middle" font: "Helvetica, -10"))) - (vg:add-objs-to-comp c1 r1 r2 t1 bt1)) - -(loop ((for x (up-from 0 (to 20)))) - (loop ((for y (up-from 0 (to 20)))) - (vg:add-objs-to-comp c1 (vg:make-rect-obj x y (+ x 5)(+ y 5))))) - -(let ((start (current-seconds))) - (let loop ((i 0)) - (vg:add-obj-to-comp c1 (vg:make-rect-obj 0 0 100 100)) - (if (< i numtorun)(loop (+ i 1)))) - (print "Run time: " (- (current-seconds) start))) - -(vg:add-obj-to-comp c1 (vg:make-line-obj 0 0 100 100)) - -;; add the c1 component to lib l1 with name firstcomp -(vg:add-comp-to-lib l1 "firstcomp" c1) -(vg:add-comp-to-lib l1 "secondcomp" c2) - -;; add the l1 lib to drawing with name firstlib -(vg:add-lib d1 "firstlib" l1) - -;; instantiate firstlib/firstcomp as inst1 in drawing d1 at 0,0 -(vg:instantiate d1 "firstlib" "firstcomp" "inst1" 0 0) -(vg:instantiate d1 "firstlib" "firstcomp" "inst2" 200 200) - - -;; (vg:drawing-scalex-set! d1 1.1) -;; (vg:drawing-scaley-set! d1 0.5) - -;; (define xtnts (vg:scale-offset-xy -;; (vg:component-get-extents c1) -;; 1.1 1.1 -2 -2)) - -;; get extents of c1 and put a rectange around it -;; -(define xtnts (apply vg:grow-rect 10 10 (vg:components-get-extents d1 c1))) -(vg:add-objs-to-comp c1 (apply vg:make-rect-obj xtnts)) - -(define bt1xt (vg:obj-get-extents d1 bt1)) -(print "bt1xt: " bt1xt) -(vg:add-objs-to-comp c1 (apply vg:make-rect-obj bt1xt)) - -;; get extents of all objects and put rectangle around it -;; -(define big-xtnts (vg:instances-get-extents d1)) -(vg:add-objs-to-comp c2 (apply vg:make-rect-obj big-xtnts)) -(vg:instantiate d1 "firstlib" "secondcomp" "inst3" 0 0) - -(vg:drawing-scalex-set! d1 1.5) -(vg:drawing-scaley-set! d1 1.5) - -(define cnv #f) -(define the-cnv (canvas - #:size "500x400" - #:expand "YES" - #:scrollbar "YES" - #:posx "0.5" - #:posy "0.5" - #:action (make-canvas-action - (lambda (c xadj yadj) - (set! cnv c))))) - -(show - (dialog - (vbox - the-cnv))) - -(vg:drawing-cnv-set! d1 cnv) -(vg:draw d1 #t) - -;; (canvas-rectangle! cnv 10 100 10 80) - -(main-loop)