Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -1,8 +1,8 @@
 # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
 # rm <files>.o ; make install CSCOPTS='-profile' ; ... ;  chicken-profile | less
-
+SHELL=/bin/bash
 PREFIX=$(PWD)
 CSCOPTS=
 INSTALL=install
 SRCFILES = common.scm items.scm launch.scm \
    ods.scm runconfig.scm server.scm configf.scm \

DELETED batchsim/Makefile
Index: batchsim/Makefile
==================================================================
--- batchsim/Makefile
+++ /dev/null
@@ -1,8 +0,0 @@
-RUN=default.scm
-
-all : batchsim
-	./batchsim $(RUN)
-
-batchsim : batchsim.scm
-	csc batchsim.scm
-

DELETED batchsim/batchsim.scm
Index: batchsim/batchsim.scm
==================================================================
--- batchsim/batchsim.scm
+++ /dev/null
@@ -1,417 +0,0 @@
-(use ezxdisp srfi-18)
-
-(define *ezx* (ezx-init 650 650 "Batch simulator"))
-(require-library ezxgui)
-(define *green*  (make-ezx-color 0 1 0)) 
-(define *black*  (make-ezx-color 0 0 0))
-(define *grey*   (make-ezx-color 0.1 0.1 0.1))
-(define *blue*   (make-ezx-color 0 0 1)) 
-(define *cyan*   (make-ezx-color 0 1 1))
-(define *green*  (make-ezx-color 0 1 0))
-(define *purple* (make-ezx-color 1 0 1))
-(define *red*    (make-ezx-color 1 0 0))
-(define *white*  (make-ezx-color 1 1 1))
-(define *yellow* (make-ezx-color 1 1 0))
-
-(define *user-colors-palette*
-  (list 
-   *green*
-   *blue*
-   *cyan*
-   *purple*
-   *red*
-   *yellow*
-   *black*))
-
-(define *dark-green* (get-color "dark-green"))
-(define *brown*      (get-color "brown"))
-
-(ezx-select-layer *ezx* 1)
-(ezx-wipe-layer *ezx* 1)
-
-;; (ezx-str-2d *ezx* 30 30 "Hello" *white*)
-;; (ezx-fillrect-2d *ezx* 100 100 120 120 *brown*)
-(ezx-redraw *ezx*)
-
-(define *last-draw* (current-milliseconds))
-(define *draw-delta* 40) ;; milliseconds between drawing
-
-(define (wait-for-next-draw-time)
-  (let* ((cm    (current-milliseconds))
-	 (delta (- *draw-delta* (- cm *last-draw*))))
-    (if (> delta 0)
-	(thread-sleep! (/ delta 1000)))
-    (set! *last-draw* (current-milliseconds))))
-
-(include "events.scm")
-
-;; System spec (to be moved into loaded file)
-;;
-;;                           x  y  w gap  x-min x-max
-(define *cpu-grid* (vector  500 50 15  2  500   600))
-(define (make-cpu:grid)(make-vector 6))
-(define *queues* (make-hash-table)) ;; name -> (list (list user duration num-cpus num-gigs) ... )
-(define *cpus* (make-hash-table)) ;; cpu-name => (vector user job-len num-cpu mem x-loc y-loc)
-(define *obj-locations* (make-hash-table)) ;; name -> (x y layer)
-(define *queue-spec*
-  (vector
-   80  ;; start-x
-   300 ;; start-y
-   300 ;; delta-y how far to next queue
-   15  ;; height
-   400 ;; length
-   ))
-(define *use-log* #f)
-(define *job-log-scale* 10)
-
-;;======================================================================
-;; CPU
-;;======================================================================
-
-(define-record cpu name num-cores mem job x y)
-
-;;======================================================================
-;; CPU Pool
-;;======================================================================
-
-(define-record pool name x y w h gap boxw cpus delta nrows ncols cpunum)
-
-(define (new-pool name x y nrows ncols gap boxw)
-  (let* ((delta (+ gap boxw))
-	 ;; (nrows (quotient h (+ gap delta)))
-	 ;; (ncols (quotient w (+ gap delta)))
-	 (w     (+ gap (* nrows delta)))
-	 (h     (+ gap (* ncols delta)))
-	 (cpus  (make-vector (* nrows ncols) #f))
-	 (npool (make-pool name x y w h gap boxw cpus delta nrows ncols 0)))
-    npool))
-
-(define (pool:add-cpu pool name num-cores mem)
-  (let* ((cpu (make-cpu name num-cores mem #f #f #f)))
-    (vector-set! (pool-cpus pool)(pool-cpunum pool) cpu)
-    (pool-cpunum-set! pool (+ 1 (pool-cpunum pool)))
-    cpu))
-
-(define (pool:draw ezx pool)
-  (let ((nrows (pool-nrows pool))
-	(ncols (pool-ncols pool))
-	(x     (pool-x     pool))
-	(y     (pool-y     pool))
-	(w     (pool-w     pool))
-	(h     (pool-h     pool))
-	(gap   (pool-gap   pool))
-	(boxw  (pool-boxw  pool))
-	(delta (pool-delta pool))
-	(cpus  (pool-cpus  pool)))
-    (ezx-select-layer ezx 1)
-    ;(ezx-wipe-layer   ezx 1)
-    ;; draw time at upper right
-    (ezx-str-2d ezx x y (pool-name pool) *black*)
-    (ezx-rect-2d ezx x y (+ x w)(+ y h) *black* 1)
-    (let loop ((row    0)
-	       (col    0)
-	       (cpunum 0))
-      (let* ((cpu  (vector-ref cpus cpunum))
-	     (xval (+ x gap (* row delta)))
-	     (yval (+ y gap (* col delta))))
-	(if cpu
-	    (begin
-	      (cpu-x-set! cpu xval)
-	      (cpu-y-set! cpu yval))
-	    (vector-set! cpus cpunum (make-cpu (conc cpunum) 1 1 #f xval yval)))
-	;; (print "box at " xval ", " yval)
-	(ezx-rect-2d ezx xval yval (+ xval boxw) (+ yval boxw) *grey* 1)
-	(if (< col (- ncols 1))
-	    (loop row (+ col 1)(+ cpunum 1))
-	    (if (< row (- nrows 1))
-		(loop (+ row 1) 0 (+ cpunum 1))))))
-    (ezx-redraw ezx)))
-	       
-
-;;======================================================================
-;; Users
-;;======================================================================
-
-(define *user-colors* (make-hash-table))
-
-(define (get-user-color user)
-  (let ((color (hash-table-ref/default *user-colors* user #f)))
-    (if color
-	color
-	(let* ((color-num (+ (length (hash-table-keys *user-colors*)) 1))
-	       (color     (list-ref *user-colors-palette* color-num)))
-	  (hash-table-set! *user-colors* user color)
-	  color))))
-
-;;======================================================================
-;; Job Queues
-;;======================================================================
-
-;; jobs
-
-(define (make-queue:job)(make-vector 4))
-(define-inline (queue:job-get-user       vec)    (vector-ref  vec 0))
-(define-inline (queue:job-get-duration   vec)    (vector-ref  vec 1))
-(define-inline (queue:job-get-num-cpu    vec)    (vector-ref  vec 2))
-(define-inline (queue:job-get-num-gigs   vec)    (vector-ref  vec 3))
-(define-inline (queue:job-set-user!      vec val)(vector-set! vec 0 val))
-(define-inline (queue:job-set-duration!  vec val)(vector-set! vec 1 val))
-(define-inline (queue:job-set-num-cpu!   vec val)(vector-set! vec 2 val))
-(define-inline (queue:job-set-num-gigs!  vec val)(vector-set! vec 3 val))
-
-;; add a job to the queue
-;;
-(define (add-job queue-name user duration num-cpu num-gigs)
-  (let* ((queue-dat (hash-table-ref/default *queues* queue-name '()))
-	 (new-queue (append 
-		     queue-dat
-		     (list (vector user duration num-cpu num-gigs)))))
-  (hash-table-set! *queues* queue-name new-queue)
-  (draw-queue-jobs queue-name)))
-
-;; peek for jobs to do in queue
-;;
-(define (peek-job queue-name)
-  (let ((queue (hash-table-ref/default *queues* queue-name '())))
-    (if (null? queue)
-	#f
-	(car queue))))
-
-;; take job from queue
-;;
-(define (take-job queue-name)
-  (let ((queue (hash-table-ref/default *queues* queue-name '())))
-    (if (null? queue)
-	#f
-	(begin
-	  (hash-table-set! *queues* queue-name (cdr queue))
-	  (draw-queue-jobs queue-name)
-	  (car queue)))))
-
-;;======================================================================
-;; CPUs
-;;======================================================================
-
-(define (make-cpu:dat)(make-vector 6 #f))
-(define-inline (cpu:dat-get-user      vec)    (vector-ref  vec 0))
-(define-inline (cpu:dat-get-job-len   vec)    (vector-ref  vec 1))
-(define-inline (cpu:dat-get-num-cpu   vec)    (vector-ref  vec 2))
-(define-inline (cpu:dat-get-mem       vec)    (vector-ref  vec 3))
-(define-inline (cpu:dat-get-x         vec)    (vector-ref  vec 4))
-(define-inline (cpu:dat-get-y         vec)    (vector-ref  vec 5))
-(define-inline (cpu:dat-set-user!     vec val)(vector-set! vec 0 val))
-(define-inline (cpu:dat-set-job-len!  vec val)(vector-set! vec 1 val))
-(define-inline (cpu:dat-set-num-cpu!  vec val)(vector-set! vec 2 val))
-(define-inline (cpu:dat-set-mem!      vec val)(vector-set! vec 3 val))
-(define-inline (cpu:dat-set-x!        vec val)(vector-set! vec 4 val))
-(define-inline (cpu:dat-set-y!        vec val)(vector-set! vec 5 val))
-
-(define-inline (cpu:grid-get-x        vec)    (vector-ref  vec 0))
-(define-inline (cpu:grid-get-y        vec)    (vector-ref  vec 1))
-(define-inline (cpu:grid-get-w        vec)    (vector-ref  vec 2))
-(define-inline (cpu:grid-get-gap      vec)    (vector-ref  vec 3))
-(define-inline (cpu:grid-get-x-min    vec)    (vector-ref  vec 4))
-(define-inline (cpu:grid-get-x-max    vec)    (vector-ref  vec 5))
-(define-inline (cpu:grid-set-x!       vec val)(vector-set! vec 0 val))
-(define-inline (cpu:grid-set-y!       vec val)(vector-set! vec 1 val))
-(define-inline (cpu:grid-set-w!       vec val)(vector-set! vec 2 val))
-(define-inline (cpu:grid-set-gap!     vec val)(vector-set! vec 3 val))
-(define-inline (cpu:grid-set-x-min!   vec val)(vector-set! vec 4 val))
-(define-inline (cpu:grid-set-x-max!   vec val)(vector-set! vec 5 val))
-
-(define (add-cpu name num-cores mem)
-  (let ((x     (cpu:grid-get-x     *cpu-grid*))
-	(y     (cpu:grid-get-y     *cpu-grid*))
-	(delta (+ (cpu:grid-get-w  *cpu-grid*)(cpu:grid-get-gap *cpu-grid*)))
-	(x-max (cpu:grid-get-x-max *cpu-grid*)))
-    (hash-table-set! *cpus* name (vector #f #f num-cores mem x y))
-    (if (> x x-max)
-	(begin
-	  (cpu:grid-set-x! *cpu-grid* (cpu:grid-get-x-min *cpu-grid*))
-	  (cpu:grid-set-y! *cpu-grid* (+ y delta)))
-	(cpu:grid-set-x! *cpu-grid* (+ x delta)))))
-
-;; draw grey box for each cpu on layer 2
-;; jobs are drawn on layer 1
-;;
-(define (draw-cpus) ;; call once after init'ing all cpus
-  (ezx-select-layer *ezx* 1)
-  (ezx-wipe-layer   *ezx* 1)
-  ;; draw time at upper right
-  (ezx-str-2d *ezx* 20 20 (seconds->h:m:s *now*) *black*)
-  (for-each
-   (lambda (cpu)
-     (let ((x (cpu:dat-get-x cpu))
-	   (y (cpu:dat-get-y cpu))
-	   (w (cpu:grid-get-w *cpu-grid*)))
-       (ezx-rect-2d *ezx* x y (+ x w) (+ y w) *grey* 1)))
-   (hash-table-values *cpus*))
-  (ezx-redraw *ezx*))
-
-(define (draw-jobs)
-  ;; (draw-cpus)
-  (ezx-select-layer *ezx* 2)
-  (ezx-wipe-layer   *ezx* 2)
-  (for-each
-   (lambda (cpu)
-     (let* ((x (cpu:dat-get-x cpu))
-	    (y (cpu:dat-get-y cpu))
-	    (w (cpu:grid-get-w *cpu-grid*))
-	    (u (cpu:dat-get-user cpu)))
-       (if u ;; job running if not #f
-	   (let ((color (get-user-color u)))
-	     (ezx-fillrect-2d *ezx* (+ x 2)(+ 2 y)(+ x 9) (+ y 9) color)))))
-   (hash-table-values *cpus*))
-  (ezx-redraw *ezx*))
-
-(define (end-job cpu-name user)
-  (let ((cpu (hash-table-ref/default *cpus* cpu-name #f)))
-    (if cpu
-	(let ((curr-user (cpu:dat-get-user cpu))) ;; if it is a user name then job is not done - error
-	  (if (or (not curr-user)
-		  (not (equal? curr-user user)))
-	      (print "ERROR: cpu " cpu-name " not running job for " user "!")
-	      (begin
-		(cpu:dat-set-user!    cpu #f)
-		(cpu:dat-set-job-len! cpu #f)
-		(draw-jobs)))) ;; hash-table-set! *cpus* cpu-name (make-cpu:dat))))
-	(print "ERROR: no cpu " cpu-name " found. Ensure it is registered before addressing it."))))
-
-(define (run-job cpu-name job)
-  (let* ((user    (queue:job-get-user     job))
-	 (job-len (queue:job-get-duration job))
-	 (cpu     (hash-table-ref/default *cpus* cpu-name #f)))
-    (if cpu
-	(let ((curr-user (cpu:dat-get-user cpu))) ;; if it is a user name then job is not done - error
-	  (if curr-user
-	      (begin
-		(print "ERROR: cpu already busy! Adding more jobs not supported yet. " cpu-name)
-		#f)
-	      (begin
-		(cpu:dat-set-user!    cpu user)
-		(cpu:dat-set-job-len! cpu job-len)
-		(draw-jobs)
-		(hash-table-set! *cpus* cpu-name cpu)
-		(event (+ *now* job-len) (lambda ()(end-job cpu-name user)))
-		#t)))
-	#f)))
-    
-(define (get-cpu)
-  (let ((all-cpus (hash-table-keys *cpus*)))
-    (if (null? all-cpus) 
-	#f
-	(let loop ((hed (car all-cpus))
-		   (tal (cdr all-cpus)))
-	  (if (cpu:dat-get-user (hash-table-ref/default *cpus* hed '(#f #f))) ;; if user is #f then cpu is available
-	      (if (null? tal)
-		  #f
-		  (loop (car tal)(cdr tal)))
-	      hed)))))
-  
-;;======================================================================
-;; Animation
-;;======================================================================
-
-;; make-vector-record  queue spec x y delta-y height length
-(define (make-queue:spec)(make-vector 5))
-(define-inline (queue:spec-get-x         vec)    (vector-ref  vec 0))
-(define-inline (queue:spec-get-y         vec)    (vector-ref  vec 1))
-(define-inline (queue:spec-get-delta-y   vec)    (vector-ref  vec 2))
-(define-inline (queue:spec-get-height    vec)    (vector-ref  vec 3))
-(define-inline (queue:spec-get-length    vec)    (vector-ref  vec 4))
-(define-inline (queue:spec-set-x!        vec val)(vector-set! vec 0 val))
-(define-inline (queue:spec-set-y!        vec val)(vector-set! vec 1 val))
-(define-inline (queue:spec-set-delta-y!  vec val)(vector-set! vec 2 val))
-(define-inline (queue:spec-set-height!   vec val)(vector-set! vec 3 val))
-(define-inline (queue:spec-set-length!   vec val)(vector-set! vec 4 val))
-
-;; queues are drawn on layer 3 but boxes (jobs) are drawn on the numbered layer
-;;
-(define (draw-queues)
-  (let* ((text-offset 3)
-	 (queue-names (sort (hash-table-keys *queues*) string>=?))
-	 (start-x (vector-ref *queue-spec* 0))
-	 (text-x  (+ start-x text-offset))
-	 (delta-y (vector-ref *queue-spec* 1))
-	 (delta-x (vector-ref *queue-spec* 2))
-	 (height  (vector-ref *queue-spec* 3))
-	 (length  (vector-ref *queue-spec* 4))
-	 (end-x   (+ start-x length)))
-    (ezx-select-layer *ezx* 3)
-    (ezx-wipe-layer   *ezx* 3)
-    (let loop ((y       (vector-ref *queue-spec* 1))
-	       (qname   (car queue-names))
-	       (tail    (cdr queue-names))
-	       (layer   4))
-      (print "Drawing queue at x=" start-x ", y=" y)
-      (ezx-fillrect-2d  *ezx* start-x y end-x (+ y height) *brown*)
-      (ezx-str-2d       *ezx* text-x (- (+ y height) text-offset) qname *white*)
-      (hash-table-set! *obj-locations* qname (list start-x y layer))
-      (if (not (null? tail))
-	  (loop (+ y height delta-y)
-		(car tail)
-		(cdr tail)
-		(+  layer 1))))
-    (ezx-redraw *ezx*)))
-
-;; compress queue data to (vector user count) list
-;;
-(define (draw-queue-compress-queue-data queue-dat)
-  (let loop ((hed  (car queue-dat))
-	     (tal  (cdr queue-dat))
-	     (curr #f) ;; (vector name count)
-	     (res  '()))
-    (let ((user (queue:job-get-user hed)))
-      (cond
-       ((not curr) ;; first time through only?
-	(if (null? tal)
-	    (append res (list (vector user 1)))
-	    (loop (car tal)(cdr tal)(vector user 1) res)))
-       ((equal? (vector-ref curr 0) user) 
-	(vector-set! curr 1 (+ (vector-ref curr 1) 1))
-	(if (null? tal)
-	    (append res (list curr))
-	    (loop (car tal)(cdr tal) curr res)))
-       (else ;; names are different, add curr to queue and create new curr
-	(let ((newcurr (vector user 1)))
-	  (if (null? tal)
-	      (append res (list newcurr))
-	      (loop (car tal)(cdr tal) newcurr (append res (list curr))))))))))
-
-;; draw jobs for a given queue
-;;
-(define (draw-queue-jobs queue-name)
-  (let* ((queue-dat (hash-table-ref/default *queues*        queue-name #f))  ;; list of jobs in the queue
-	 (obj-spec  (hash-table-ref/default *obj-locations* queue-name #f)))  ;; x, y etc. of the drawn queue
-    (if obj-spec
-	(let ((origin-x  (list-ref obj-spec 0))
-	      (origin-y  (list-ref obj-spec 1))
-	      (bar-width 10)
-	      (queue-len (queue:spec-get-length *queue-spec*))
-	      (layer     (list-ref obj-spec 2)))
-	  (ezx-select-layer *ezx* layer)
-	  (ezx-wipe-layer   *ezx* layer)
-	  (if (not (null? queue-dat))
-	      (let ((res (draw-queue-compress-queue-data queue-dat)))
-		(if (not (null? res))
-		    (let loop ((hed (car res))
-			       (tal (cdr res))
-			       (x2   (+ origin-x queue-len)))
-		      (let* ((user (vector-ref hed 0))
-			     (h    (let ((numjobs (vector-ref hed 1)))
-				     (if *use-log*
-					 (inexact->exact (round (log (+ 1 (* *job-log-scale* numjobs)))))
-					 numjobs)))
-			     (x1   (- x2  bar-width))
-			     (y2   (- origin-y h)))
-			;; (print "x1 " x1 ", origin-y " origin-y ", x2 " x2 ", y2 " y2)
-			(ezx-fillrect-2d *ezx* x1 y2 x2 origin-y (get-user-color user))
-			(if (not (null? tal))
-			    (loop (car tal)(cdr tal) x1)))))
-		(ezx-redraw *ezx*)))))))
-	  
-(let* ((args  (argv))
-       (fname (if (> (length args) 1)
-		  (cadr args)
- 		  "default.scm")))
-  (load (if (file-exists? fname) fname "default.scm")))

DELETED batchsim/default.scm
Index: batchsim/default.scm
==================================================================
--- batchsim/default.scm
+++ /dev/null
@@ -1,133 +0,0 @@
-;; run sim for four hours
-;;
-(define *end-time* (* 60 50))
-
-;; create the cpus
-;;
-(let loop ((count 200))
-  (add-cpu (conc "cpu_" count) 1 1)
-  (if (>= count 0)(loop (- count 1))))
-
-(draw-cpus)
-
-(define *pool1* (new-pool "generic" 100 100 100 100 2 10))
-(let loop ((count 10))
-  (pool:add-cpu *pool1* (conc count) 1 1)
-  (if (> count 0)
-      (loop (- count 1))))
-
-(pool:draw *ezx* *pool1*)
-
-;; init the queues
-;;
-(hash-table-set! *queues* "normal" '())
-(hash-table-set! *queues* "quick"  '())
-(draw-queues)
-
-;; user k adds 200 jobs at time zero
-;;
-(event *start-time*
-       (lambda ()
-	 (let loop ((count 300)) ;; add 500 jobs
-	   (add-job "normal" "k" 600 1 1)
-	   (if (>= count 0)(loop (- count 1))))))
-
-;; one minute in user m runs ten jobs
-;;
-(event (+ 600 *start-time*)
-       (lambda ()
-	 (let loop ((count 300)) ;; add 100 jobs
-	   (add-job "normal" "m" 600 1 1)
-	   (if (> count 0)(loop (- count 1))))))
-
-;; every minute user j runs ten jobs
-;;
-(define *user-j-jobs* 300)
-(event (+ 600 *start-time*)
-       (lambda ()
-	 (let f ()
-	   (schedule 60)
-	   (if (> *user-j-jobs* 0)
-	       (begin
-		 (let loop ((count 5)) ;; add 100 jobs
-		   (add-job "quick" "j" 600 1 1)
-		   (if (> count 0)(loop (- count 1))))
-		 (set! *user-j-jobs* (- *user-j-jobs* 5))))
-	   (if (and (not *done*)
-		    (> *user-j-jobs* 0))
-	       (f))))) ;; Megatest user running 200 jobs
-
-;; every minute user j runs ten jobs
-;;
-(define *user-j-jobs* 300)
-(event (+ 630 *start-time*)
-       (lambda ()
-	 (let f ()
-	   (schedule 60)
-	   (if (> *user-j-jobs* 0)
-	       (begin
-		 (let loop ((count 5)) ;; add 100 jobs
-		   (add-job "quick" "n" 600 1 1)
-		   (if (> count 0)(loop (- count 1))))
-		 (set! *user-j-jobs* (- *user-j-jobs* 5))))
-	   (if (and (not *done*)
-		    (> *user-j-jobs* 0))
-	       (f))))) ;; Megatest user running 200 jobs
-
-;; ;;
-;; (event *start-time*
-;;        (lambda ()
-;; 	 (let f ((count 200))
-;; 	   (schedule 10)
-;; 	   (add-job "normal" "t" 60 1 1)
-;; 	   (if (and (not *done*)
-;; 		    (>= count 0))
-;; 	       (f (- count 1))))))
-
-;; every 3 seconds check for available machines and launch a job
-;;
-(event *start-time*
-       (lambda ()
-	 (let f ()
-	   (schedule 3)
-	   (let ((queue-names (random-sort (hash-table-keys *queues*))))
-	     (let loop ((cpu   (get-cpu))
-			(count (+ (length queue-names) 4))
-			(qname (car queue-names))
-			(remq  (cdr queue-names)))
-	       (if (and cpu
-			(> count 0))
-		   (begin
-		     (if (peek-job qname) ;; any jobs to do in normal queue
-			 (let ((job (take-job qname)))
-			   (run-job cpu job)))
-		     (loop (get-cpu)
-			   (- count 1)
-			   (if (null? remq)
-			       (car queue-names)
-			       (car remq))
-			   (if (null? remq)
-			       (cdr queue-names)
-			       (cdr remq)))))))
-	   (if (not *done*)(f)))))
-
-;; screen updates
-;;
-(event *start-time* (lambda ()
-		      (let f ()
-			(schedule 60) ;; update the screen every 60 seconds of sim time
-			(draw-cpus) ;; (print "Now: " *now* " queue: " (hash-table->alist *queues*))
-			(wait-for-next-draw-time)
-			(if (not *done*) (f)))))
-
-
-;; end the simulation
-;;
-(event *end-time*
-       (lambda () 
-	 (set! *event-list* '())
-	 (set! *done* #t)))
-
-(start)
-;; (exit 0)
-

DELETED batchsim/events.scm
Index: batchsim/events.scm
==================================================================
--- batchsim/events.scm
+++ /dev/null
@@ -1,79 +0,0 @@
-
-;;======================================================================
-;; Event Processing and Simulator
-;;======================================================================
-
-;; The global event list
-(define *event-list* '())
-(define *start-time* 0)
-(define *end-time*   (* 60 60 4)) ;; four hours
-(define *now*        *start-time*)
-(define *done*       #f)
-
-(define (random-sort l)
-  (sort l
-        (lambda (x y)
-          (equal? 0 (random 2))))) 
-				    
-;; Each item in the event list is a list of a scheduled time and the thunk
-;; (time thunk). Sort the list so that the next event is the earliest.
-;;
-(define event-sort
-  (lambda (@a @b)
-    (< (car @a)(car @b))))
-
-(define event
-  (lambda ($time $thunk)  ;; add a sort based on scheduled time here -- improve later
-                          ;; to use an insert algorythm.
-    (set! *event-list* (sort (cons (list $time $thunk) *event-list*) event-sort))))
-
-(define start
-  (lambda ()
-    (let ((next (car *event-list*)))
-      (set! *event-list* (cdr *event-list*))
-      (set! *now* (car next))      
-      (if (not *done*) ;; note that the second item in the list is the thunk
-	  ((car (cdr next)))))))
-
-(define pause
-  (lambda ()
-    (call/cc 
-     (lambda (k)
-       (event (lambda () (k #f)))
-       (start)))))
-
-(define schedule
-  (lambda ($time)
-    (call/cc 
-     (lambda (k)
-       (event (+ *now* $time) (lambda () (k #f)))
-       (start)))))
-
-;; (event (lambda () (let f () (pause) (display "h") (f))))
-
-(define years->seconds
-  (lambda ($yrs)
-    (* $yrs 365 24 3600)))
-
-(define weeks->seconds
-  (lambda ($wks)
-    (* $wks 7 24 3600)))
-
-(define days->seconds
-  (lambda ($days)
-    (* $days 24 3600)))
-
-(define months->seconds
-  (lambda ($months)
-    (* $months (/ 365 12) 24 3600)))
-
-(define seconds->date
-  (lambda ($seconds)
-    (posix-strftime "%D" (posix-localtime (inexact->exact $seconds)))))
-
-(define (seconds->h:m:s seconds)
-  (let* ((hours   (quotient seconds 3600))
-	 (rem1    (- seconds (* hours 3600)))
-	 (minutes (quotient rem1 60))
-	 (rem-sec (- rem1 (* minutes 60))))
-    (conc hours "h " minutes "m " rem-sec "s")))

DELETED batchsim/testing.scm
Index: batchsim/testing.scm
==================================================================
--- batchsim/testing.scm
+++ /dev/null
@@ -1,135 +0,0 @@
-;; run sim for four hours
-;;
-(define *end-time* (* 60 50))
-
-;; create the cpus
-;;
-(let loop ((count 200))
-  (add-cpu (conc "cpu_" count) 1 1)
-  (if (>= count 0)(loop (- count 1))))
-
-;; (draw-cpus)
-
-(define *pool1* (new-pool "generic" 20 20 12 80 2 4))
-(let loop ((count 10))
-  (pool:add-cpu *pool1* (conc count) 1 1)
-  (if (> count 0)
-      (loop (- count 1))))
-
-(pool:draw *ezx* *pool1*)
-
-;; ;; init the queues
-;; ;;
-;; (hash-table-set! *queues* "normal" '())
-;; (hash-table-set! *queues* "quick"  '())
-;; (draw-queues)
-;; 
-;; ;; user k adds 200 jobs at time zero
-;; ;;
-;; (event *start-time*
-;;        (lambda ()
-;; 	 (let loop ((count 300)) ;; add 500 jobs
-;; 	   (add-job "normal" "k" 600 1 1)
-;; 	   (if (>= count 0)(loop (- count 1))))))
-;; 
-;; ;; one minute in user m runs ten jobs
-;; ;;
-;; (event (+ 600 *start-time*)
-;;        (lambda ()
-;; 	 (let loop ((count 300)) ;; add 100 jobs
-;; 	   (add-job "normal" "m" 600 1 1)
-;; 	   (if (> count 0)(loop (- count 1))))))
-;; 
-;; ;; every minute user j runs ten jobs
-;; ;;
-;; (define *user-j-jobs* 300)
-;; (event (+ 600 *start-time*)
-;;        (lambda ()
-;; 	 (let f ()
-;; 	   (schedule 60)
-;; 	   (if (> *user-j-jobs* 0)
-;; 	       (begin
-;; 		 (let loop ((count 5)) ;; add 100 jobs
-;; 		   (add-job "quick" "j" 600 1 1)
-;; 		   (if (> count 0)(loop (- count 1))))
-;; 		 (set! *user-j-jobs* (- *user-j-jobs* 5))))
-;; 	   (if (and (not *done*)
-;; 		    (> *user-j-jobs* 0))
-;; 	       (f))))) ;; Megatest user running 200 jobs
-;; 
-;; ;; every minute user j runs ten jobs
-;; ;;
-;; (define *user-j-jobs* 300)
-;; (event (+ 630 *start-time*)
-;;        (lambda ()
-;; 	 (let f ()
-;; 	   (schedule 60)
-;; 	   (if (> *user-j-jobs* 0)
-;; 	       (begin
-;; 		 (let loop ((count 5)) ;; add 100 jobs
-;; 		   (add-job "quick" "n" 600 1 1)
-;; 		   (if (> count 0)(loop (- count 1))))
-;; 		 (set! *user-j-jobs* (- *user-j-jobs* 5))))
-;; 	   (if (and (not *done*)
-;; 		    (> *user-j-jobs* 0))
-;; 	       (f))))) ;; Megatest user running 200 jobs
-;; 
-;; ;; ;;
-;; ;; (event *start-time*
-;; ;;        (lambda ()
-;; ;; 	 (let f ((count 200))
-;; ;; 	   (schedule 10)
-;; ;; 	   (add-job "normal" "t" 60 1 1)
-;; ;; 	   (if (and (not *done*)
-;; ;; 		    (>= count 0))
-;; ;; 	       (f (- count 1))))))
-;; 
-;; ;; every 3 seconds check for available machines and launch a job
-;; ;;
-;; (event *start-time*
-;;        (lambda ()
-;; 	 (let f ()
-;; 	   (schedule 3)
-;; 	   (let ((queue-names (random-sort (hash-table-keys *queues*))))
-;; 	     (let loop ((cpu   (get-cpu))
-;; 			(count (+ (length queue-names) 4))
-;; 			(qname (car queue-names))
-;; 			(remq  (cdr queue-names)))
-;; 	       (if (and cpu
-;; 			(> count 0))
-;; 		   (begin
-;; 		     (if (peek-job qname) ;; any jobs to do in normal queue
-;; 			 (let ((job (take-job qname)))
-;; 			   (run-job cpu job)))
-;; 		     (loop (get-cpu)
-;; 			   (- count 1)
-;; 			   (if (null? remq)
-;; 			       (car queue-names)
-;; 			       (car remq))
-;; 			   (if (null? remq)
-;; 			       (cdr queue-names)
-;; 			       (cdr remq)))))))
-;; 	   (if (not *done*)(f)))))
-;; 
-;; ;; screen updates
-;; ;;
-(event *start-time* (lambda ()
-		      (let f ()
-			(schedule 60) ;; update the screen every 60 seconds of sim time
-			;; (draw-cpus) ;; (print "Now: " *now* " queue: " (hash-table->alist *queues*))
-			(pool:draw *ezx* *pool1*)
-
-			(wait-for-next-draw-time)
-			(if (not *done*) (f)))))
-;; 
-;; 
-;; ;; end the simulation
-;; ;;
-(event *end-time*
-       (lambda () 
-	 (set! *event-list* '())
-	 (set! *done* #t)))
-;; 
-(start)
-;; ;; (exit 0)
-;; 

Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -461,10 +461,13 @@
     (map common:to-alist (hash-table->alist dat)))
    (else
     (if dat
 	dat
 	""))))
+
+(define (common:alist-ref/default key alist default)
+  (or (alist-ref key alist) default))
 
 (define (common:low-noise-print waitval . keys)
   (let* ((key      (string-intersperse (map conc keys) "-" ))
 	 (lasttime (hash-table-ref/default *common:denoise* key 0))
 	 (currtime (current-seconds)))
@@ -1363,10 +1366,33 @@
 		    new-rownames
 		    new-colnames
 		    (if (> curr-rownum rownum) curr-rownum rownum)
 		    (if (> curr-colnum colnum) curr-colnum colnum)
 		    ))))))
+
+;; if it looks like a number -> convert it to a number, else return it
+;;
+(define (common:lazy-convert inval)
+  (let* ((as-num (if (string? inval)(string->number inval) #f)))
+    (or as-num inval)))
+
+;; convert string a=1; b=2; c=a silly thing; d=
+;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
+;;
+(define (common:val->alist val #!key (convert #f))
+  (let ((val-list (string-split-fields ";\\s*" val #:infix)))
+    (if val-list
+	(map (lambda (x)
+	       (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
+		 (case (length f)
+		   ((0) `(,#f))  ;; null string case
+		   ((1) `(,(string->symbol (car f))))
+		   ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f)))
+							 (if convert (common:lazy-convert inval) inval))))
+		   (else f))))
+	     val-list)
+	'())))
 
 ;;======================================================================
 ;; S Y S T E M   S T U F F
 ;;======================================================================
 
@@ -1426,77 +1452,114 @@
 ;; 		      (let ((newval (string->number (cadr match))))
 ;; 			(if (number? newval)
 ;; 			    (set! cpu-load newval))))))
 ;; 	      (car load-res))
 ;;     cpu-load))
+
+;; get values from cached info from dropping file in logs dir
+;;  e.g. key is host and dtype is normalized-load
+;;
+(define (common:get-cached-info key dtype #!key (age 5))
+  (let* ((fullpath (conc *toppath* "/logs/" key "-" dtype ".log")))
+    (if (and (file-exists? fullpath)
+	     (file-read-access? fullpath))
+	(handle-exceptions
+	 exn
+	 #f
+	 (debug:print 2 *default-log-port* "reading file " fullpath)
+	 (let ((real-age (- (current-seconds)(file-change-time fullpath)))) 
+	   (if (< real-age age)
+	       (with-input-from-file fullpath read)
+	       (begin
+		 (debug:print 2 *default-log-port* "file " fullpath " is too old (" real-age" seconds)to trust, skipping reading it")
+		 #f))))
+	(begin
+	  (debug:print 2 *default-log-port* "not reading file " fullpath)
+	  #f))))
+ 
+(define (common:write-cached-info key dtype dat)
+  (let* ((fullpath (conc *toppath* "/logs/" key "-" dtype ".log")))
+    (handle-exceptions
+     exn
+     #f
+     (with-output-to-file fullpath (lambda ()(pp dat))))))
 
 ;; get cpu load by reading from /proc/loadavg, return all three values
 ;;
 (define (common:get-cpu-load remote-host)
-  (if remote-host
-      (map (lambda (res)
-	     (if (eof-object? res) 9e99 res))
-	   (with-input-from-pipe 
-	    (conc "ssh " remote-host " cat /proc/loadavg")
-	    (lambda ()(list (read)(read)(read)))))
-      (with-input-from-file "/proc/loadavg" 
-	(lambda ()(list (read)(read)(read))))))
+  (let* ((actual-hostname (or remote-host (get-host-name))))
+    (or (common:get-cached-info actual-hostname "cpu-load")
+	(let ((result (if remote-host
+			  (map (lambda (res)
+				 (if (eof-object? res) 9e99 res))
+			       (with-input-from-pipe 
+				   (conc "ssh " remote-host " cat /proc/loadavg")
+				 (lambda ()(list (read)(read)(read)))))
+			  (with-input-from-file "/proc/loadavg" 
+			    (lambda ()(list (read)(read)(read)))))))
+	  (common:write-cached-info actual-hostname "cpu-load" result)
+	  result))))
 
 ;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads
 ;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc.
 ;;  keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load
 ;;
 (define (common:get-normalized-cpu-load remote-host)
-  (let ((data (if remote-host
-                  (with-input-from-pipe 
-                   (conc "ssh " remote-host " cat /proc/loadavg;cat /proc/cpuinfo;echo end")
-                   read-lines)
-                  (append 
-                   (with-input-from-file "/proc/loadavg" 
-                     read-lines)
-                   (with-input-from-file "/proc/cpuinfo"
-                     read-lines)
-                   (list "end"))))
-        (load-rx  (regexp "^([\\d\\.]+)\\s+([\\d\\.]+)\\s+([\\d\\.]+)\\s+.*$"))
-        (proc-rx  (regexp "^processor\\s+:\\s+(\\d+)\\s*$"))
-        (core-rx  (regexp "^core id\\s+:\\s+(\\d+)\\s*$"))
-        (phys-rx  (regexp "^physical id\\s+:\\s+(\\d+)\\s*$"))
-        (max-num  (lambda (p n)(max (string->number p) n))))
-    ;; (print "data=" data)
-    (if (null? data) ;; something went wrong
-        #f
-        (let loop ((hed      (car data))
-                   (tal      (cdr data))
-                   (loads    #f)
-                   (proc-num 0)  ;; processor includes threads
-                   (phys-num 0)  ;; physical chip on motherboard
-                   (core-num 0)) ;; core
-          ;; (print hed ", " loads ", " proc-num ", " phys-num ", " core-num)
-          (if (null? tal) ;; have all our data, calculate normalized load and return result
-              (let* ((act-proc (+ proc-num 1))
-                     (act-phys (+ phys-num 1))
-                     (act-core (+ core-num 1))
-                     (adj-proc-load (/ (car loads) act-proc))
-                     (adj-core-load (/ (car loads) act-core)))
-                (append (list (cons 'adj-proc-load adj-proc-load)
-                              (cons 'adj-core-load adj-core-load))
-                        (list (cons '1m-load (car loads))
-                              (cons '5m-load (cadr loads))
-                              (cons '15m-load (caddr loads)))
-                        (list (cons 'proc act-proc)
-                              (cons 'core act-core)
-                              (cons 'phys act-phys))))
-              (regex-case
-               hed
-               (load-rx  ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num))
-               (proc-rx  ( x p         ) (loop (car tal)(cdr tal) loads           (max-num p proc-num) phys-num core-num))
-               (phys-rx  ( x p         ) (loop (car tal)(cdr tal) loads           proc-num (max-num p phys-num) core-num))
-               (core-rx  ( x c         ) (loop (car tal)(cdr tal) loads           proc-num phys-num (max-num c core-num)))
-               (else 
-                (begin
-                  ;; (print "NO MATCH: " hed)
-                  (loop (car tal)(cdr tal) loads proc-num phys-num core-num)))))))))
+  (let ((actual-host (or remote-host (get-host-name)))) ;; #f is localhost
+    (or (common:get-cached-info actual-host "normalized-load")
+	(let ((data (if remote-host
+			(with-input-from-pipe 
+			    (conc "ssh " remote-host " cat /proc/loadavg;cat /proc/cpuinfo;echo end")
+			  read-lines)
+			(append 
+			 (with-input-from-file "/proc/loadavg" 
+			   read-lines)
+			 (with-input-from-file "/proc/cpuinfo"
+			   read-lines)
+			 (list "end"))))
+	      (load-rx  (regexp "^([\\d\\.]+)\\s+([\\d\\.]+)\\s+([\\d\\.]+)\\s+.*$"))
+	      (proc-rx  (regexp "^processor\\s+:\\s+(\\d+)\\s*$"))
+	      (core-rx  (regexp "^core id\\s+:\\s+(\\d+)\\s*$"))
+	      (phys-rx  (regexp "^physical id\\s+:\\s+(\\d+)\\s*$"))
+	      (max-num  (lambda (p n)(max (string->number p) n))))
+	  ;; (print "data=" data)
+	  (if (null? data) ;; something went wrong
+	      #f
+	      (let loop ((hed      (car data))
+			 (tal      (cdr data))
+			 (loads    #f)
+			 (proc-num 0)  ;; processor includes threads
+			 (phys-num 0)  ;; physical chip on motherboard
+			 (core-num 0)) ;; core
+		;; (print hed ", " loads ", " proc-num ", " phys-num ", " core-num)
+		(if (null? tal) ;; have all our data, calculate normalized load and return result
+		    (let* ((act-proc (+ proc-num 1))
+			   (act-phys (+ phys-num 1))
+			   (act-core (+ core-num 1))
+			   (adj-proc-load (/ (car loads) act-proc))
+			   (adj-core-load (/ (car loads) act-core))
+			   (result
+			    (append (list (cons 'adj-proc-load adj-proc-load)
+					  (cons 'adj-core-load adj-core-load))
+				    (list (cons '1m-load (car loads))
+					  (cons '5m-load (cadr loads))
+					  (cons '15m-load (caddr loads)))
+				    (list (cons 'proc act-proc)
+					  (cons 'core act-core)
+					  (cons 'phys act-phys)))))
+		      (common:write-cached-info actual-host "normalized-load" result)
+		      result)
+		  (regex-case
+		   hed
+		   (load-rx  ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num))
+		   (proc-rx  ( x p         ) (loop (car tal)(cdr tal) loads           (max-num p proc-num) phys-num core-num))
+		   (phys-rx  ( x p         ) (loop (car tal)(cdr tal) loads           proc-num (max-num p phys-num) core-num))
+		   (core-rx  ( x c         ) (loop (car tal)(cdr tal) loads           proc-num phys-num (max-num c core-num)))
+		   (else 
+		    (begin
+		      ;; (print "NO MATCH: " hed)
+		      (loop (car tal)(cdr tal) loads proc-num phys-num core-num)))))))))))
 
 (define (common:unix-ping hostname)
   (let ((res (system (conc "ping -c 1 " hostname " > /dev/null"))))
     (eq? res 0)))
 
@@ -1503,16 +1566,16 @@
 ;; ideally put all this info into the db, no need to preserve it across moving homehost
 ;;
 ;; return list of
 ;;  ( reachable? cpuload update-time )
 (define (common:get-host-info hostname)
-  (let* ((loadinfo (rmt:get-latest-host-load hostname))
-         (load (car loadinfo))
-         (load-sample-time (cdr loadinfo))
-         (load-sample-age (- (current-seconds) load-sample-time))
-         (loadinfo-timeout-seconds 20)
-         (host-last-update-timeout-seconds 10)
+  (let* ((loadinfo                         (rmt:get-latest-host-load hostname)) ;; if this host happens to have been recently used by a test reuse the load data
+         (load                             (car loadinfo))
+         (load-sample-time                 (cdr loadinfo))
+         (load-sample-age                  (- (current-seconds) load-sample-time))
+         (loadinfo-timeout-seconds         6) ;; this was 20 seconds, seems way too lax. Switch to 6 seconds
+         (host-last-update-timeout-seconds 4)
          (host-rec (hash-table-ref/default *host-loads* hostname #f))
          )
     (cond
      ((< load-sample-age loadinfo-timeout-seconds)
       (list #t
@@ -1524,14 +1587,18 @@
             (host-last-update host-rec)
             (host-last-cpuload host-rec )))
      ((common:unix-ping hostname)
       (list #t
             (current-seconds)
-            (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname))))
+            (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) ;; this is cheaper than you might think. get-normalized-cpu-load is cached for up to 5 seconds
      (else
-      (list #f 0 -1)))))
-    
+      (list #f 0 -1) ;; bad host, don't use!
+      ))))
+
+;; see defstruct host at top of file.
+;;    host: reachable last-update last-used last-cpuload
+;;
 (define (common:update-host-loads-table hosts-raw)
   (let* ((hosts (filter (lambda (x)
                           (string-match (regexp "^\\S+$") x))
                         hosts-raw)))
     (for-each
@@ -1549,37 +1616,74 @@
          (host-reachable-set!    rec is-reachable)
          (host-last-update-set!  rec last-reached-time)
          (host-last-cpuload-set! rec load)))
      hosts)))
 
-(define (common:get-least-loaded-host hosts-raw)
-  (let* ((hosts (filter (lambda (x)
-                          (string-match (regexp "^\\S+$") x))
-                        hosts-raw))
-         (best-host #f)
+;; go through the hosts from least recently used to most recently used, pick the first that meets the load criteral from the
+;; [host-rules] section.
+;;
+(define (common:get-least-loaded-host hosts-raw host-type configdat)
+  (let* ((rdat       (configf:lookup configdat "host-rules" host-type))
+	 (rules      (common:val->alist (or rdat "") convert: #t))   ;; maxnload, maxnjobs, maxjobrate
+	 (maxnload   (common:alist-ref/default 'maxnload rules 1.5)) ;; max normalized load
+	 (maxnjobs   (common:alist-ref/default 'maxnjobs rules 1.5)) ;; max normalized number of jobs
+	 (maxjobrate (common:alist-ref/default 'maxjobrate rules (/ 1 6))) ;; max rate of submitting jobs to a given host in jobs/second
+	 (hosts      (filter (lambda (x)
+			       (string-match (regexp "^\\S+$") x))
+			     hosts-raw))
+         ;; (best-host #f)
+	 (get-rec    (lambda (hostname)
+		       ;; (print "get-rec hostname=" hostname)
+		       (let ((h (hash-table-ref/default *host-loads* hostname #f)))
+			 (if h
+			     h
+			     (let ((h (make-host)))
+			       (hash-table-set! *host-loads* hostname h)
+			       h)))))
          (best-load 99999)
-         (curr-time (current-seconds)))
-    (common:update-host-loads-table hosts)
-    (for-each
-     (lambda (hostname)
-       (let* ((rec
-               (let ((h (hash-table-ref/default *host-loads* hostname #f)))
-                 (if h
-                     h
-                     (let ((h (make-host)))
-                       (hash-table-set! *host-loads* hostname h)
-                       h))))
-              (reachable (host-reachable rec))
-              (load      (host-last-cpuload   rec)))
-         (cond
-          ((not reachable) #f)
-          ((< (+ load (/ (random 250) 1000))         ;; add a random factor to keep from getting in a rut
-              (+ best-load (/ (random 250) 1000))  )
-           (set! best-load load)
-           (set! best-host hostname)))))
-     hosts)
-    best-host))
+         (curr-time (current-seconds))
+	 (get-hosts-sorted (lambda (hosts)
+			     (sort hosts (lambda (a b)
+					   (let ((a-rec (get-rec a))
+						 (b-rec (get-rec b)))
+					     ;; (print "a=" a " a-rec=" a-rec " host-last-used=" (host-last-used a-rec))
+					     ;; (print "b=" b " b-rec=" b-rec " host-last-used=" (host-last-used b-rec))
+					     (< (host-last-used a-rec)
+						(host-last-used b-rec))))))))
+    (debug:print 0 *default-log-port* "INFO: hosts-sorted=" (get-hosts-sorted hosts))
+    (if (null? hosts)
+	#f ;; no hosts to select from. All done and giving up now.
+	(let ((hosts-sorted (get-hosts-sorted hosts)))
+	  (common:update-host-loads-table hosts)
+	  (let loop ((hostname  (car hosts-sorted))
+		     (tal       (cdr hosts-sorted))
+		     (best-host #f))
+	    (let* ((rec       (get-rec hostname))
+		   (reachable (host-reachable     rec))
+		   (load      (host-last-cpuload  rec))
+		   (last-used (host-last-used     rec))
+		   (delta     (- curr-time last-used))
+		   (job-rate  (if (> delta 0)
+				  (/ 1 delta)
+				  999)) ;; jobs per second
+		   (new-best  
+		    (cond
+		     ((not reachable)
+		      (debug:print 0 *default-log-port* "Skipping host " hostname " as it cannot be reached.")
+		      best-host)
+		     ((and (< load maxnload)        ;; load is acceptable
+			   (< job-rate maxjobrate)) ;; job rate is acceptable
+		      (set! best-load load)
+		      hostname)
+		     (else best-host))))
+	      (debug:print 0 *default-log-port* "INFO: Trying host " hostname " with load " load ", last used " delta " seconds ago, with job-rate " job-rate " for running a test." )
+	      (if new-best
+		  (begin ;; found a host, return it
+		    (debug:print 0 *default-log-port* "INFO: Found host: " new-best " load: " load " last-used: " delta " seconds ago, with job-rate: " job-rate)
+		    (host-last-used-set! rec curr-time)
+		    new-best)
+		  (if (null? tal) #f (loop (car tal)(cdr tal) best-host)))))))))
 
 (define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f))
   (let* ((loadavg (common:get-cpu-load remote-host))
 	 (numcpus (if (< 1 numcpus-in) ;; not possible
 		      (common:get-num-cpus remote-host)
@@ -1586,21 +1690,22 @@
 		      numcpus-in))
 	 (maxload (max maxload-in 0.5)) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
 	 (first   (car loadavg))
 	 (next    (cadr loadavg))
 	 (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1
-	 (loadjmp (- first next)))
+	 (loadjmp (- first next))
+         (adjwait (+ (random 10)(/ (- 1000 count) 10) waitdelay))) ;; add some randomness to the time to break any alignment where netbatch dumps many jobs to machines simultaneously
     (cond
      ((and (> first adjload)
 	   (> count 0))
-      (debug:print-info 0 *default-log-port* "server start delayed " waitdelay " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg ""))
-      (thread-sleep! waitdelay)
+      (debug:print-info 0 *default-log-port* "server start delayed " adjwait " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg ""))
+      (thread-sleep! adjwait)
       (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
      ((and (> loadjmp numcpus)
 	   (> count 0))
-      (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg ""))
-      (thread-sleep! waitdelay)
+      (debug:print-info 0 *default-log-port* "waiting " adjwait " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg ""))
+      (thread-sleep! adjwait)
       (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host)))))
 
 (define (common:wait-for-homehost-load maxload msg)
   (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local.
                      #f
@@ -1608,24 +1713,30 @@
          (hh     (if hh-dat (car hh-dat) #f))
          (numcpus (common:get-num-cpus hh)))
     (common:wait-for-normalized-load maxload msg hh)))
 
 (define (common:get-num-cpus remote-host)
-  (let ((proc (lambda ()
-		(let loop ((numcpu 0)
-			   (inl    (read-line)))
-		  (if (eof-object? inl)
-		      numcpu
-		      (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl)
-				(+ numcpu 1)
-				numcpu)
-			    (read-line)))))))
-    (if remote-host
-	(with-input-from-pipe 
-	 (conc "ssh " remote-host " cat /proc/cpuinfo")
-	 proc)
-	(with-input-from-file "/proc/cpuinfo" proc))))
+  (let* ((actual-host (or remote-host (get-host-name))))
+    (or (common:get-cached-info actual-host "num-cpus" age: 86400) ;; hosts had better not be changing the number of cpus too often!
+	(let* ((proc   (lambda ()
+			 (let loop ((numcpu 0)
+				    (inl    (read-line)))
+			   (if (eof-object? inl)
+			       (begin
+				 (common:write-cached-info remote-host "num-cpus" numcpu)
+				 numcpu)
+			       (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl)
+					 (+ numcpu 1)
+					 numcpu)
+				     (read-line))))))
+	       (result (if remote-host
+			   (with-input-from-pipe 
+			       (conc "ssh " remote-host " cat /proc/cpuinfo")
+			     proc)
+			   (with-input-from-file "/proc/cpuinfo" proc))))
+	  (common:write-cached-info actual-host "num-cpus" result)
+	  result))))
 
 ;; wait for normalized cpu load to drop below maxload
 ;;
 (define (common:wait-for-normalized-load maxload msg remote-host)
   (let ((num-cpus (common:get-num-cpus remote-host)))
@@ -2332,10 +2443,16 @@
 ;; 
 ;; [host-types]
 ;; general #MTLOWESTLOAD #{g hosts allhosts}
 ;; arm     #MTLOWESTLOAD #{g hosts arm}
 ;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo
+;;
+;; [host-rules]
+;; # maxnload   => max normalized load
+;; # maxnjobs   => max jobs per cpu
+;; # maxjobrate => max jobs per second
+;; general maxnload=1.1; maxnjobs=1.2; maxjobrate=0.1 
 ;; 
 ;; [launchers]
 ;; envsetup general
 ;; xor/%/n 4C16G
 ;; % nbgeneral
@@ -2362,12 +2479,23 @@
 			(let ((launcher (configf:lookup configdat "host-types" host-type)))
 			  (if launcher
 			      (let* ((launcher-parts (string-split launcher))
 				     (launcher-exe   (car launcher-parts)))
 				(if (equal? launcher-exe "#MTLOWESTLOAD") ;; this is our special case, we will find the lowest load and craft a nbfake commandline
-				    (let ((targ-host (common:get-least-loaded-host (cdr launcher-parts))))
-				      (conc "remrun " targ-host))
+				    (let host-loop ((targ-host (common:get-least-loaded-host (cdr launcher-parts) host-type configdat))
+						    (count     100))
+				      (if targ-host
+					  (conc "remrun " targ-host)
+					  (if (> count 0)
+					      (begin
+						(debug:print 0 *default-log-port* "INFO: Waiting for a host for host-type " host-type)
+						(thread-sleep! (- 101 count))
+						(host-loop (common:get-least-loaded-host (cdr launcher-parts) host-type configdat)
+							   (- count 1)))
+					      (begin
+						(debug:print 0 *default-log-port* "FATAL: Failed to find a host from #MTLOWESTLOAD for host-type " host-type)
+						(exit)))))
 				    launcher))
 			      (begin
 				(debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type)
 				(if (null? tal)
 				    fallback-launcher

Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -2087,11 +2087,12 @@
 ;; 
 (define (dashboard:runs-summary commondat tabdat #!key (tab-num #f))
   (let* ((update-mutex (dboard:commondat-update-mutex commondat))
 	 (tb      (iup:treebox
 		   #:value 0
-		   #:name "Runs"
+		   ;;#:name "Runs"
+                   #:title "Runs" ;;  was #:name -- iup 3.19 changed this... "Changed: [DEPRECATED REMOVED] removed the old attribute NAMEid from IupTree to avoid conflict with the common attribute NAME. Use the TITLEid attribute."
 		   #:expand "YES"
 		   #:addexpanded "YES"
 		   #:selection-cb
 		   (lambda (obj id state)
 		     (debug:catch-and-dump

DELETED dbwars/NOTES
Index: dbwars/NOTES
==================================================================
--- dbwars/NOTES
+++ /dev/null
@@ -1,31 +0,0 @@
-Before using prepare:
-
-matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert
-Adding 1047 test3 item/39 host0-0.3-200000-240-this one sucks eh? (added 51886 records so far)
-Adding 1122 test5 item/52 host2-0.2-200000-120-this is a good one eh? (added 78889 records so far)
-Adding 1050 test7 item/31 host1-0.1-100000-120-this is a good one eh? (added 110641 records so far)
-create-tests ran register-test 144000 times in 41.0 seconds
-
-After using prepare:
-
-matt@xena:/tmp/megatest/dbwars$ csc sqlite3-test.scm && ./sqlite3-test insert
-Adding 1082 test4 item/74 host1-0.3-100000-120-this is a good one eh? (added 61281 records so far)
-Adding 1138 test7 item/43 host2-0.3-200000-120-this is a good one eh? (added 109001 records so far)
-Adding 1023 test9 item/00 host0-0.2-100000-240-this one sucks eh? (added 143878 records so far)
-create-tests ran register-test 144000 times in 38.0 seconds
-
-After moving the prepare outside the call (so it isn't done each time):
-
-matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert
-Adding 1042 test4 item/59 host0-0.3-200000-120-this is a good one eh? (added 63401 records so far)
-Adding 1011 test6 item/40 host0-0.1-200000-120-this one sucks eh? (added 94906 records so far)
-Adding 1076 test9 item/34 host1-0.2-200000-120-just eh, eh? (added 139035 records so far)
-create-tests ran register-test 144000 times in 33.0 seconds
-
-Using sql-de-lite with very similar code:
-
-matt@xena:/tmp/megatest/dbwars$ ./sql-de-lite-test insert
-Adding 1029 test4 item/53 host0-0.2-200000-240- (added 64252 records so far)
-Adding 1134 test7 item/64 host2-0.3-100000-240-this is a good one eh? (added 105973 records so far)
-create-tests ran register-test 144000 times in 31.0 seconds
-

DELETED dbwars/sql-de-lite-test.scm
Index: dbwars/sql-de-lite-test.scm
==================================================================
--- dbwars/sql-de-lite-test.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-
-(use sql-de-lite)
-(include "test-common.scm")
-
-(define db (open-database "test.db"))
-
-(exec (sql db test-table-defn))
-(exec (sql db syncsetup))
-
-(define (register-test stmth  run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)
-    (exec 
-     stmth ;; (sql db test-insert)
-     run-id
-     testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time))
-
-(let ((stmth (sql db test-insert)))
-  (create-tests stmth))
-
-(close-database db)

DELETED dbwars/sqlite3-test.scm
Index: dbwars/sqlite3-test.scm
==================================================================
--- dbwars/sqlite3-test.scm
+++ /dev/null
@@ -1,20 +0,0 @@
-
-(use sqlite3)
-(include "test-common.scm")
-
-(define db (open-database "test.db"))
-
-(execute db test-table-defn)
-(execute db syncsetup)
-
-
-(define (register-test stmth run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)
-  (execute stmth
-	   run-id
-	   testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time))
-
-(let ((stmth (prepare db test-insert)))
-  (create-tests stmth)
-  (finalize! stmth))
-
-(finalize! db)

DELETED dbwars/test-common.scm
Index: dbwars/test-common.scm
==================================================================
--- dbwars/test-common.scm
+++ /dev/null
@@ -1,129 +0,0 @@
-(use srfi-18 srfi-69 apropos)
-
-(define args (argv))
-
-(if (not (eq? (length args) 2))
-    (begin
-      (print "Usage: sqlitecompare [insert|update]")
-      (exit 0)))
-
-(define action (string->symbol (cadr args)))
-
-(system "rm -f test.db")
-
-(define test-table-defn
-		 "CREATE TABLE IF NOT EXISTS tests 
-                    (id INTEGER PRIMARY KEY,
-                     run_id     INTEGER,
-                     testname   TEXT,
-                     host       TEXT DEFAULT 'n/a',
-                     cpuload    REAL DEFAULT -1,
-                     diskfree   INTEGER DEFAULT -1,
-                     uname      TEXT DEFAULT 'n/a', 
-                     rundir     TEXT DEFAULT 'n/a',
-                     shortdir   TEXT DEFAULT '',
-                     item_path  TEXT DEFAULT '',
-                     state      TEXT DEFAULT 'NOT_STARTED',
-                     status     TEXT DEFAULT 'FAIL',
-                     attemptnum INTEGER DEFAULT 0,
-                     final_logf TEXT DEFAULT 'logs/final.log',
-                     logdat     BLOB, 
-                     run_duration INTEGER DEFAULT 0,
-                     comment    TEXT DEFAULT '',
-                     event_time TIMESTAMP,
-                     fail_count INTEGER DEFAULT 0,
-                     pass_count INTEGER DEFAULT 0,
-                     archived   INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes
-                     CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path)
-          );")
-
-(define test-insert "INSERT INTO tests  (run_id,testname,host,cpuload,diskfree,uname,rundir,shortdir,item_path,state,status,final_logf,run_duration,comment,event_time)
-                                values (?,     ?,       ?,   ?,      ?,       ?,    ?,     ?,       ?,        ?,    ?,     ?,         ?,           ?,      ?        );")
-(define syncsetup "PRAGMA synchronous = OFF;")
-
-(define tests '("test0" "test1" "test2" "test3" "test4" "test5" "test6" "test7" "test8" "test9"))
-(define items '())
-(for-each 
- (lambda (n)
-   (for-each 
-    (lambda (m)
-      (set! items (cons (conc "item/" n m) items)))
-    '(0 1 2 3 4 5 6 7 8 9)))
- '(0 1 2 3 4 5 6 7 8 9))
-(define hosts '("host0" "host1" "host2")) ;;  "host3" "host4" "host5" "host6" "host7" "host8" "host9"))
-(define cpuloads '(0.1 0.2 0.3))    ;; 0.4 0.5 0.6 0.7 0.8 0.9))
-(define diskfrees '(100000 200000)) ;; 300000 400000 500000 600000 700000 800000 900000))
-(define uname "Linux xena 3.5.0-40-generic #62~precise1-Ubuntu SMP Fri Aug 23 17:59:10 UTC 2013 i686 i686 i386 GNU/Linux")
-(define basedir "/mfs/matt/data/megatest/runs/testing")
-(define final-logf "finallog.html")
-(define run-durations (list 120 240)) ;;  260))
-(define comments '("" "this is a good one eh?" "this one sucks eh?" "just eh, eh?"))
-
-(define run-ids (make-hash-table))
-(define max-run-id 1000)
-
-(define (test-factors->run-id host cpuload diskfree run-duration comment)
-  (let* ((factor (conc host "-" cpuload "-" diskfree "-" run-duration "-" comment))
-	 (run-id (hash-table-ref/default run-ids factor #f)))
-    (if run-id 
-	(list run-id factor)
-	(let ((new-id (+ max-run-id 1)))
-	  (set! max-run-id new-id)
-	  (hash-table-set! run-ids factor new-id)
-	  (list new-id factor)))))
-	  
-
-(define (create-tests stmth)
-  (let ((num-created 0)
-	(last-print  (current-seconds))
-	(start-time  (current-seconds)))
-    (for-each 
-     (lambda (test)
-       (for-each 
-	(lambda (item)
-	  (for-each 
-	   (lambda (host)
-	     (for-each 
-	      (lambda (cpuload)
-		(for-each
-		 (lambda (diskfree)
-		   (for-each 
-		    (lambda (run-duration)
-		      (for-each 
-		       (lambda (comment)
-			 (let* ((run-id-dat (test-factors->run-id host cpuload diskfree run-duration comment))
-				(run-id (car run-id-dat))
-				(factor (cadr run-id-dat))
-				(curr-time (current-seconds)))
-			   (if (> (- curr-time last-print) 10)
-			       (begin
-				 (print "Adding " run-id " " test " " item " " factor " (added " num-created " records so far)")
-				 (set! last-print curr-time)))
-			   (set! num-created (+ num-created 1))
-			   (register-test stmth ;; db  
-					  run-id
-					  test  ;; testname
-					  host
-					  cpuload
-					  diskfree
-					  uname
-					  (conc basedir "/" test "/" item) ;; rundir
-					  (conc test "/" item) ;; shortdir
-					  item   ;; item-path
-					  "NOT_STARTED" ;; state
-					  "NA"          ;; status
-					  final-logf
-					  run-duration
-					  comment
-					  (current-seconds))))
-		       comments))
-		    run-durations))
-		 diskfrees))
-	      cpuloads))
-	   hosts))
-	items))
-     tests)
-    (print "create-tests ran register-test " num-created " times in " (- (current-seconds) start-time) " seconds")))
-
-				   
-			 

DELETED defunct/multi-dboard.scm
Index: defunct/multi-dboard.scm
==================================================================
--- defunct/multi-dboard.scm
+++ /dev/null
@@ -1,801 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2013, Matthew Welland.
-;; 
-;;  This program is made available under the GNU GPL version 2.0 or
-;;  greater. See the accompanying file COPYING for details.
-;; 
-;;  This program is distributed WITHOUT ANY WARRANTY; without even the
-;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-;;  PURPOSE.
-;;======================================================================
-
-(use format numbers sql-de-lite srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
-(require-library iup)
-(import (prefix iup iup:))
-(use canvas-draw)
-
-(declare (uses margs))
-(declare (uses megatest-version))
-(declare (uses gutils))
-(declare (uses tree))
-(declare (uses configf))
-(declare (uses portlogger))
-(declare (uses keys))
-(declare (uses common))
-
-(include "common_records.scm")
-;; (include "db_records.scm")
-;; (include "key_records.scm")
-
-(define help (conc 
-	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
-  version " megatest-version "
-  license GPL, Copyright (C) Matt Welland 2011
-
-Usage: dashboard [options]
-  -h                : this help
-  -group groupname  : display this group of areas
-  -test testid      : control test identified by testid
-  -guimonitor       : control panel for runs
-
-Misc
-  -rows N         : set number of rows
-"))
-
-;; process args
-(define remargs (args:get-args 
-		 (argv)
-		 (list  "-group" ;; display this group of areas
-			"-debug"
-			) 
-		 (list  "-h"
-			"-v"
-			"-q"
-			)
-		 args:arg-hash
-		 0))
-
-(if (args:get-arg "-h")
-    (begin
-      (print help)
-      (exit)))
-
-;; (if (args:get-arg "-host")
-;;     (begin
-;;       (set! (common:get-remote remote) (string-split (args:get-arg "-host" ":")))
-;;       (client:launch))
-;;     (client:launch))
-
-(define *runremote* #f)
-(define *windows* (make-hash-table))
-(define *changed-main* (make-hash-table)) ;; set path/... => #t
-(define *changed-mutex* (make-mutex))     ;; use for all incoming change requests
-(define *searchpatts*   (make-hash-table))
-
-(debug:setup)
-
-(define *tim* (iup:timer))
-(define *ord* #f)
-
-(iup:attribute-set! *tim* "TIME" 300)
-(iup:attribute-set! *tim* "RUN" "YES")
-
-(define (message-window msg)
-  (iup:show
-   (iup:dialog
-    (iup:vbox 
-     (iup:label msg #:margin "40x40")))))
-
-(define (iuplistbox-fill-list lb items . default)
-  (let ((i 1)
-	(selected-item (if (null? default) #f (car default))))
-    (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
-    (for-each (lambda (item)
-		(iup:attribute-set! lb (number->string i) item)
-		(if selected-item
-		    (if (equal? selected-item item)
-			(iup:attribute-set! lb "VALUE" item))) ;; (number->string i))))
-		(set! i (+ i 1)))
-	      items)
-    i))
-
-(define (pad-list l n)(append l (make-list (- n (length l)))))
-
-
-(define (mkstr . x)
-  (string-intersperse (map conc x) ","))
-
-(define (update-search x val)
-  (hash-table-set! *searchpatts* x val))
-
-
-;;======================================================================
-;; R E C O R D S
-;;======================================================================
-
-;; NOTE: Consider switching to defstruct.
-
-;; data for an area (regression or testsuite)
-;;
-(define-record areadat
-  name               ;; area name
-  path               ;; mt run area home
-  configdat          ;; megatest config
-  denoise            ;; focal point for not putting out same messages over and over
-  client-signature   ;; key for client-server conversation
-  remote             ;; hash of all the client side connnections
-  run-keys           ;; target keys for this area
-  runs               ;; used in dashboard, hash of run-ids -> rundat
-  read-only          ;; can I write to this area?
-  monitordb          ;; db handle for monitor.db
-  maindb             ;; db handle for main.db
-  )
-
-;; rundat, basic run data
-;;
-(define-record rundat
-  id                 ;; the run-id
-  target             ;; val1/val2 ... corrosponding to run-keys in areadat
-  runname
-  state              ;; state of the run, symbol 
-  status             ;; status of the run, symbol
-  event-time         ;; when the run was initiated
-  tests              ;; hash of test-id -> testdat, QUESTION: separate by run-id?
-  db                 ;; db handle
-  )
-
-;; testdat, basic test data
-(define-record testdat
-  run-id             ;; what run is this from
-  id                 ;; test id
-  testname           ;; test name
-  itempath           ;; item path
-  state              ;; test state, symbol
-  status             ;; test status, symbol
-  event-time         ;; when the test started
-  duration           ;; how long the test took
-  )
-
-;; general data for the dboard application
-;;
-(define-record data
-  cfgdat             ;; data from ~/.megatest/<group>.dat
-  areas              ;; hash of areaname -> area-rec
-  current-window-id  ;; 
-  current-tab-id     ;; 
-  update-needed      ;; flag to indicate that the tab pointed to by current tab id needs refreshing immediately
-  tabs               ;; hash of tab-id -> areaname (??) should be of type "tab"
-  )
-
-;; all the components of an area display, all fits into a tab but
-;; parts may be swapped in/out as needed
-;;
-(define-record tab
-  tree
-  matrix    ;; the spreadsheet 
-  areadat   ;; the one-structure (one day dbstruct will be put in here)
-  view-path ;; <target/path>/<runname>/...
-  view-type ;; standard, etc.
-  controls  ;; the controls
-  data      ;; all the data kept in sync with db
-  filters   ;; user filters, alist name -> filter record, eventually store these in ~/.megatest/<group>.dat?
-  run-id    ;; the current run-id
-  test-ids  ;; the current test id hash, run-id => test-id
-  command   ;; the command from the entry field
-  headers   ;; hash of header  -> colnum
-  rows      ;; hash of rowname -> rownum
-  )
-
-(define-record filter
-  target    ;; hash of widgets for the target
-  runname   ;; the runname widget
-  testpatt  ;; the testpatt widget
-  )
-
-;;======================================================================
-;; D B
-;;======================================================================
-
-;; These are all using sql-de-lite and independent of area so cannot use stuff 
-;; from db.scm
-
-;; NB// run-id=#f => return dbdir only
-;;
-(define (areadb:dbfile-path areadat run-id)
-  (let* ((cfgdat  (areadat-configdat areadat))
-	 (dbdir   (or (configf:lookup cfgdat "setup" "dbdir")
-		      (conc (configf:lookup cfgdat "setup" "linktree") "/.db")))
-	 (fname   (if run-id
-		      (case run-id
-			((-1) "monitor.db")
-			((0) "main.db")
-			(else (conc run-id ".db")))
-		      #f)))
-    (handle-exceptions
-     exn
-     (begin
-       (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
-       (exit 1))
-     (if (not (directory? dbdir))(create-directory dbdir #t)))
-    (if fname
-	(conc dbdir "/" fname)
-	dbdir)))
-
-;; -1 => monitor.db
-;;  0 => main.db
-;; >1 => <run-id>.db
-;;
-(define (areadb:open areadat run-id)
-  (let* ((runs   (areadat-runs areadat))
-	 (rundat (if (> run-id 0) ;; it is a run
-		     (hash-table-ref/default runs run-id #f)
-		     #f))
-	 (db     (case run-id ;; if already opened, get the db and return it
-		   ((-1) (areadat-monitordb areadat))
-		   ((0)  (areadat-maindb    areadat))
-		   (else (if rundat
-			     (rundat-db rundat)
-			     #f)))))
-    (if db
-	db ;; merely return the already opened db
-	(let* ((dbfile (areadb:dbfile-path areadat run-id)) ;; not already opened, so open it
-	       (db     (if (file-exists? dbfile)
-			   (open-database dbfile)
-			   (begin
-			     (debug:print-error 0 *default-log-port* "I was asked to open " dbfile ", but file does not exist or is not readable.")
-			     #f))))
-	  (case run-id
-	    ((-1)(areadat-monitordb-set! areadat db))
-	    ((0) (areadat-maindb-set!    areadat db))
-	    (else (rundat-db-set!        rundat  db)))
-	  db))))
-
-;; populate the areadat tests info, does NOT fill the tests data itself unless asked
-;;
-(define (areadb:populate-run-info areadat)
-  (let* ((runs   (or (areadat-runs areadat) (make-hash-table)))
-	 (keys   (areadat-run-keys areadat))
-	 (maindb (areadb:open areadat 0)))
-    (if maindb
-	(query (for-each-row (lambda (row)
-			       (let ((id  (list-ref row 0))
-				     (dat (apply make-rundat (append row (list #f #f))))) ;; add placeholders for tests and db
-				 (print row)
-				 (hash-table-set! runs id dat))))
-	       (sql maindb (conc "SELECT id,"
-				 (string-intersperse keys "||'/'||")
-				 ",runname,state,status,event_time FROM runs WHERE state != 'deleted';")))
-	(debug:print-error 0 *default-log-port* "no main.db found at "  (areadb:dbfile-path areadat 0)))
-    areadat))
-
-;; given an areadat and target/runname patt fill up runs data
-;;
-;; ?????/
-
-;; given a list of run-ids refresh/retrieve runs data into areadat
-;;
-(define (areadb:fill-tests areadat #!key (run-ids #f))
-  (let* ((runs   (or (areadat-runs areadat) (make-hash-table))))
-    (for-each
-     (lambda (run-id)
-       (let* ((rundat (hash-table-ref/default runs run-id #f))
-	      (tests  (if (and rundat
-			       (rundat-tests rundat)) ;; re-use existing hash table?
-			  (rundat-tests rundat)
-			  (let ((ht (make-hash-table)))
-			    (rundat-tests-set! rundat ht)
-			    ht)))
-	      (rundb  (areadb:open areadat run-id)))
-	 (query (for-each-row (lambda (row)
-				(let* ((id         (list-ref row 0))
-				       (testname   (list-ref row 1))
-				       (itempath   (list-ref row 2))
-				       (state      (list-ref row 3))
-				       (status     (list-ref row 4))
-				       (eventtim   (list-ref row 5))
-				       (duration   (list-ref row 6)))
-				  (hash-table-set! tests id
-						   (make-testdat run-id id testname itempath state status eventtim duration)))))
-		(sql rundb "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE state != 'DELETED';"))))
-     (or run-ids (hash-table-keys runs)))
-    areadat))
-    
-
-;; initialize and refresh data
-;;		
-(define (dboard:general-updater con port)
-  (for-each
-   (lambda (window-id)
-     ;; (print "Processing for window-id " window-id)
-     (let* ((window-dat     (hash-table-ref *windows* window-id))
-	    (areas          (data-areas     window-dat))
-	    ;; (keys           (areadat-run-keys area-dat))
-	    (tabs           (data-tabs      window-dat))
-	    (tab-ids        (hash-table-keys tabs))
-	    (current-tab    (if (null? tab-ids)
-				#f
-				(hash-table-ref tabs (car tab-ids))))
-	    (current-tree   (if (null? tab-ids) #f (tab-tree   current-tab)))
-	    (current-node   (if (null? tab-ids) 0  (string->number (iup:attribute current-tree "VALUE"))))
-	    (current-path   (if (eq? current-node 0)
-				"Areas"
-				(string-intersperse (tree:node->path current-tree current-node) "/")))
-	    (current-matrix (if (null? tab-ids) #f (tab-matrix current-tab)))
-	    (seen-nodes     (make-hash-table))
-	    (path-changed   (if current-tab
-				(equal? current-path (tab-view-path current-tab))
-				#t)))
-       ;; (debug:print-info 0 *default-log-port* "Current path: " current-path)
-       ;; now for each area in the window gather the data
-       (if path-changed
-	   (begin
-	     (debug:print-info 0 *default-log-port* "clearing matrix - path changed")
-	     (dboard:clear-matrix current-tab)))
-       (for-each
-	(lambda (area-name)
-	  ;; (print "Processing for area-name " area-name)
-	  (let* ((area-dat  (hash-table-ref areas area-name))
-		 (area-path (areadat-path   area-dat))
-		 (runs      (areadat-runs   area-dat)))
-	    (if (hash-table-ref/default *changed-main* area-path 'processed)
-		(begin
-		  (print "Processing " area-dat " for area-name " area-name)
-		  (hash-table-set! *changed-main* area-path #f)
-		  (areadb:populate-run-info area-dat)
-		  (for-each 
-		   (lambda (run-id)
-		     (let* ((run     (hash-table-ref runs run-id))
-			    (target  (rundat-target run))
-			    (runname (rundat-runname run)))
-		       (if current-tree
-			   (let* ((partial-path (append (string-split target "/")(list runname)))
-				  (full-path    (cons area-name partial-path)))
-			     (if (not (hash-table-exists? seen-nodes full-path))
-				 (begin
-				   (print "INFO: Adding node " partial-path " to section " area-name)
-				   (tree:add-node current-tree "Areas" full-path)
-				   (areadb:fill-tests area-dat run-ids: (list run-id))))
-				   (hash-table-set! seen-nodes full-path #t)))))
-		   (hash-table-keys runs))))
-	    (if (or (equal? "Areas" current-path)
-		    (string-match (conc "^Areas/" area-name "(|\\/.*)$") current-path))
-		(dboard:redraw-area area-name area-dat current-tab current-matrix current-path))))
-	(hash-table-keys areas))))
-   (hash-table-keys *windows*)))
-
-;;======================================================================
-;; D A S H B O A R D   D B 
-;;======================================================================
-
-;; All moved to common.scm		
-
-;;======================================================================
-;; T R E E 
-;;======================================================================
-
-;; <area> - <target - ... > - <runname> - <test> - <itempath - ...>
-
-(define (dashboard:tree-browser data adat window-id)
-  ;; (iup:split
-  (let* ((tb      (iup:treebox
-		   #:value 0
-		   #:title "Areas"
-		   #:expand "YES"
-		   #:addexpanded "NO"
-		   #:selection-cb
-		   (lambda (obj id state)
-		     ;; (print "obj: " obj ", id: " id ", state: " state)
-		     (let* ((tree-path (tree:node->path obj id))
-			    (area      (car tree-path))
-			    (areadat-path (cdr tree-path)))
-		       #f
-		       ;; (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))))))
-		       )))))
-    ;; (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))
-
-;;======================================================================
-;; M A I N   M A T R I X
-;;======================================================================
-
-;; General displayer
-;;
-(define (dashboard:main-matrix data adat window-id)
-  (let* (;; (tab-dat         (areadat-
-	 (view-matrix     (iup:matrix
-			   ;; (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f))
-			   #:expand "YES"
-			   ;; #:fittosize "YES"
-			   #:resizematrix "YES"
-			   #:scrollbar "YES"
-			   #:numcol 100
-			   #:numlin 100
-			   #:numcol-visible 3
-			   #:numlin-visible 20
-			   #:click-cb (lambda (obj lin col status)
-					(print "obj: " obj " lin: " lin " col: " col " status: " status " value: " (iup:attribute obj "VALUE"))))))
-    
-    ;; (iup:attribute-set! view-matrix "RESIZEMATRIX" "YES")
-    (iup:attribute-set! view-matrix "WIDTH0" "100")
-    ;; (dboard:data-runs-matrix-set! *data* runs-matrix)
-    ;; (iup:hbox
-    ;;  (iup:frame 
-    ;;   #:title "Runs browser"
-    ;;   (iup:vbox
-    view-matrix))
-
-;;======================================================================
-;; A R E A S
-;;======================================================================
-
-(define (dashboard:init-area data area-name apath)
-  (let* ((mtconf      (dboard:read-mtconf apath))
-	 (area-dat    (let ((ad (make-areadat
-				 area-name ;; area name
-				 apath     ;; path to area
-				 ;; 'http     ;; transport
-				 mtconf    ;; megatest.config
-				 (make-hash-table) ;; denoise hash
-				 #f        ;; client-signature
-				 #f        ;; remote connections
-				 (keys:config-get-fields mtconf) ;; run keys
-				 (make-hash-table) ;; run-id -> (hash of test-ids => dat)
-				 (and (file-exists? apath)(file-write-access? apath)) ;; read-only
-				 #f
-				 #f
-				 )))
-			(hash-table-set! (data-areas data) area-name ad)
-			ad)))
-    area-dat))
-
-;; given the keys for an area and a path from the tree browser
-;; return the level: areas area runs run tests test
-;;
-(define (dboard:get-view-type keys current-path)
-  (let* ((path-parts (string-split current-path "/"))
-	 (path-len   (length path-parts)))
-    (cond
-     ((equal? current-path "Areas")     'areas)
-     ((eq? path-len 2)                  'area)
-     ((<= (+ (length keys) 2) path-len) 'runs)
-     (else                              'run))))
-
-(define (dboard:clear-matrix tab)
-  (if tab
-      (begin
-	(iup:attribute-set! (tab-matrix tab) "CLEARVALUE" "ALL")
-	(tab-headers-set! tab (make-hash-table))
-	(tab-rows-set!    tab (make-hash-table)))))
-
-;; full redraw of a given area
-;;
-(define (dboard:redraw-area area-name area-dat tab-dat current-matrix current-path)
-  (let* ((keys      (areadat-run-keys area-dat))
-	 (runs      (areadat-runs     area-dat))
-	 (headers   (tab-headers   tab-dat))
-	 (rows      (tab-rows      tab-dat))
-	 (used-cols (hash-table-values headers))
-	 (used-rows (hash-table-values rows))
-	 (touched   (make-hash-table)) ;; (vector row col) ==> true, touched cell
-	 (view-type (dboard:get-view-type keys current-path))
-	 (changed   #f)
-	 (state-statuses  (list "PASS" "FAIL" "WARN" "CHECK" "SKIP" "RUNNING" "LAUNCHED")))
-    ;; (debug:print 0 *default-log-port* "current-matrix=" current-matrix)
-    (case view-type
-      ((areas) ;; find row for this area, if not found, create new entry
-       (let* ((curr-rownum (hash-table-ref/default rows area-name #f))
-	      (next-rownum (+ (apply max (cons 0 used-rows)) 1))
-	      (rownum      (or curr-rownum next-rownum))
-	      (coord       (conc rownum ":0")))
-	 (if (not curr-rownum)(hash-table-set! rows area-name rownum))
-	 (if (not (equal? (iup:attribute current-matrix coord) area-name))
-	     (begin
-	       (let loop ((hed  (car state-statuses))
-			  (tal  (cdr state-statuses))
-			  (count 1))
-		 (if (not (equal? (iup:attribute current-matrix (conc "0:" count)) hed))
-		     (iup:attribute-set! current-matrix (conc "0:" count) hed))
-		 (iup:attribute-set! current-matrix (conc rownum ":" count) "0")
-		 (if (not (null? tal))
-		     (loop (car tal)(cdr tal)(+ count 1))))
-	       (debug:print-info 0 *default-log-port* "view-type=" view-type ", rownum=" rownum ", curr-rownum=" curr-rownum ", next-rownum=" next-rownum ", coord=" coord ", area-name=" area-name)
-	       (iup:attribute-set! current-matrix coord area-name)
-	       (set! changed #t))))))
-    (if changed (iup:attribute-set! current-matrix "REDRAW" "ALL"))))
-	     
-
-       
-   ;; (dboard:clear-matrix current-matrix used-cols used-rows touched) ;; clear all
-    
-	
-  
-;;======================================================================
-;; D A S H B O A R D
-;;======================================================================
-
-(define (dashboard:area-panel aname data window-id)
-  (let* ((apath      (configf:lookup (data-cfgdat data) aname "path")) ;;  (hash-table-ref (dboard:data-cfgdat data) area-name))
-	 ;;          (hash-table-ref (dboard:data-cfgdat data) aname))
-	 (area-dat   (dashboard:init-area data aname apath))
-	 (tb         (dashboard:tree-browser data area-dat window-id)) ;; (dboard:areas-tree-browser data)
-	 (ad         (dashboard:main-matrix  data area-dat window-id))
-	 (areas      (data-areas data))
-	 (dboard-dat (make-tab
-		      #f           ;; tree
-		      #f           ;; matrix
-		      area-dat     ;;
-		      #f           ;; view path
-		      'default     ;; view type
-		      #f           ;; controls
-		      (make-hash-table) ;; cached data? not sure how to use this yet :)
-		      #f           ;; filters
-		      #f           ;; the run-id
-		      (make-hash-table) ;; run-id -> test-id, for current test id
-		      ""
-		      (make-hash-table) ;; headername -> colnum
-		      (make-hash-table) ;; rowname    -> rownum
-		      )))
-    (hash-table-set! (data-areas data) aname area-dat) ;; dboard-dat)
-    (hash-table-set! (data-tabs data) window-id dboard-dat)
-    (tab-tree-set!   dboard-dat tb)
-    (tab-matrix-set! dboard-dat ad)
-    (iup:split
-     #:value 200
-     tb ad)))
-
-
-;; Main Panel
-;;
-(define (dashboard:main-panel data window-id)
-  (iup:dialog
-   #:title "Megatest Control Panel"
-;;   #:menu (dcommon:main-menu data)
-   #:shrink "YES"
-   (iup:vbox
-    (let* ((area-names  (hash-table-keys (data-cfgdat data)))
-	   (area-panels (map (lambda (aname)
-			       (dashboard:area-panel aname data window-id))
-			     area-names))
-	   (tabtop      (apply iup:tabs  
-			       #:tabchangepos-cb (lambda (obj curr prev)
-						   (data-current-tab-id-set! data curr)
-						   (data-update-needed-set!  data #t)
-						   (print "Tab is: " curr ", prev was " prev))
-			       area-panels))
-	   (tabs     (data-tabs data)))
-      (if (not (null? area-names))
-	  (let loop ((index 0)
-		     (hed   (car area-names))
-		     (tal   (cdr area-names)))
-	    ;; (hash-table-set! tabs index hed)
-	    (debug:print 0 *default-log-port* "Adding area " hed " with index " index " to dashboard")
-	    (iup:attribute-set! tabtop (conc "TABTITLE" index) hed)
-	    (if (not (null? tal))
-		(loop (+ index 1)(car tal)(cdr tal)))))
-      tabtop))))
-
-
-;;======================================================================
-;; N A N O M S G   S E R V E R
-;;======================================================================
-
-(define (dboard:server-service soc port)
-  (print "server starting")
-  (let loop ((msg-in (nn-recv soc))
-	     (count  0))
-    (if (eq? 0 (modulo count 1000))
-	(print "server received: " msg-in ", count=" count))
-    (cond
-     ;;
-     ;; quit
-     ;;
-     ((equal? msg-in "quit")
-      (nn-send soc "Ok, quitting"))
-     ;;
-     ;; ping
-     ;;
-     ((and (>= (string-length msg-in) 4)
-	   (equal? (substring msg-in 0 4) "ping"))
-      (nn-send soc (conc (current-process-id)))
-      (loop (nn-recv soc)(+ count 1)))
-     ;;
-     ;; main changed
-     ;;
-     ((and (>= (string-length msg-in) 4)
-	   (equal? (substring msg-in 0 4) "main"))
-      (let ((parts (string-split msg-in " ")))
-	(hash-table-set! *changed-main* (cadr parts) #t)
-	(nn-send soc "got it!")))
-     ;;
-     ;; ??
-     ;;
-     (else
-      (nn-send soc "hello " msg-in " you got to the else clause!")))
-    (loop (nn-recv soc)(if (> count 20000000)
-			   0
-			   (+ count 1)))))
-
-(define (dboard:one-time-ping-receive soc port)
-  (let ((msg-in (nn-recv soc)))
-    (if (and (>= (string-length msg-in) 4)
-	     (equal? (substring msg-in 0 4) "ping"))
-	(nn-send soc (conc (current-process-id))))))
-
-(define (dboard:server-start given-port #!key (num-tries 200))
-  (let* ((rep (nn-socket 'rep))
-	 (port (or given-port  (portlogger:main "find")))
-	 (con (conc "tcp://*:" port)))
-    ;; register this connect here ....
-    (nn-bind rep con)
-    (thread-start! 
-     (make-thread (lambda ()
-		    (dboard:one-time-ping-receive rep port))
-		  "one time receive thread"))
-    (if (dboard:ping-self "localhost" port)
-	(begin
-	  (print "INFO: dashboard nanomsg server started on " port)
-	  (values rep port))
-	(begin
-	  (print "WARNING: couldn't create server on port " port)
-	  (portlogger:main "set" "failed")
-	  (if (> num-tries 0)
-	      (dboard:server-start #f (- num-tries 1))
-	      (begin
-		(print "ERROR: failed to start nanomsg server")
-		(values #f #f)))))))
-
-(define (dboard:server-close con port)
-  (nn-close con)
-  (portlogger:main "set" port "released"))
-
-(define (dboard:ping-self host port #!key (return-socket #t))
-  ;; send a random number along with pid and check that we get it back
-  (let* ((req     (nn-socket 'req))
-	 (key     "ping")
-	 (success #f)
-	 (keepwaiting #t)
-	 (ping    (make-thread
-		   (lambda ()
-		     (print "ping: sending string \"" key "\", expecting " (current-process-id))
-		     (nn-send req key)
-		     (let ((result  (nn-recv req)))
-		       (if (equal? (conc (current-process-id)) result)
-			   (begin
-			     (print "ping, success: received \"" result "\"")
-			     (set! success #t))
-			   (begin
-			     (print "ping, failed: received key \"" result "\"")
-			     (set! keepwaiting #f)
-			     (set! success #f)))))
-		   "ping"))
-	 (timeout (make-thread (lambda ()
-				 (let loop ((count 0))
-				   (thread-sleep! 1)
-				   (print "still waiting after " count " seconds...")
-				   (if (and keepwaiting (< count 10))
-				       (loop (+ count 1))))
-				 (if keepwaiting
-				     (begin
-				       (print "timeout waiting for ping")
-				       (thread-terminate! ping))))
-			       "timeout")))
-    (nn-connect req (conc "tcp://" host ":" port))
-    (handle-exceptions
-     exn
-     (begin
-       (print-call-chain)
-       (print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
-       (print "exn=" (condition->list exn))
-       (print "ping failed to connect to " host ":" port))
-     (thread-start! timeout)
-     (thread-start! ping)
-     (thread-join! ping)
-     (if success (thread-terminate! timeout)))
-    (if return-socket
-	(if success req #f)
-	(begin
-	  (nn-close req)
-	  success))))
-
-;;======================================================================
-;; C O N F I G U R A T I O N 
-;;======================================================================
-
-;; Get the configuration file for a group name, if the group name is "default" and it doesn't 
-;; exist, create it and add the current path if it contains megatest.config
-;;
-(define (dboard:get-config group-name)
-  (let* ((fname (conc (getenv "HOME") "/.megatest/" group-name ".dat")))
-    (if (file-exists? fname)
-	(read-config fname (make-hash-table) #t)
-	(if (dboard:create-config fname)
-	    (dboard:get-config group-name)
-	    (make-hash-table)))))
-
-(define (dboard:create-config fname)
-  ;; (handle-exceptions
-  ;;  exn
-  ;;  
-  ;;  #f ;; failed to create - just give up
-   (let* ((dirname       (pathname-directory fname))
-	  (file-name     (pathname-strip-directory fname))
-	  (curr-mtcfgdat (find-config "megatest.config"
-				      toppath: (or (get-environment-variable "MT_RUN_AREA_HOME")(current-directory))))
-	  (curr-mtcfg    (if (and curr-mtcfgdat (not (null? curr-mtcfgdat)))(cadr curr-mtcfgdat) #f))
-	  (curr-mtpath   (if curr-mtcfg (car curr-mtcfgdat) #f)))
-     (if curr-mtpath
-	 (begin
-	   (debug:print-info 0 *default-log-port* "Creating config file " fname)
-	   (if (not (file-exists? dirname))
-	       (create-directory dirname #t))
-	   (with-output-to-file fname
-	     (lambda ()
-	       (let ((aname (pathname-strip-directory curr-mtpath)))
-		 (print "[" aname "]")
-		 (print  "path " curr-mtpath))))
-	   #t)
-	 (begin
-	   (debug:print-info 0 *default-log-port* "Need to create a config but no megatest.config found: " curr-mtcfgdat)
-	   #f))))
-;; )
-
-(define (dboard:read-mtconf apath)
-  (let* ((mtconffile  (conc apath "/megatest.config")))
-    (call-with-environment-variables
-     (list (cons "MT_RUN_AREA_HOME" apath))
-     (lambda ()
-       (read-config mtconffile (make-hash-table) #f)) ;; megatest.config
-     )))
-	 
-
-;;======================================================================
-;; G U I   S T U F F 
-;;======================================================================
-
-;;; main. Theoretically could have multiple windows (each with a group of tags, thus window-id
-;;;
-(define (dboard:make-window window-id)
-  (let* (;; (window-id 0)
-	 (groupn    (or (args:get-arg "-group") "default"))
-	 (cfgdat    (dboard:get-config groupn))
-	 ;; (cfgdat    (if (file-exists? cfname)(read-config cfname (make-hash-table) #t)(make-hash-table)))
-	 (data      (make-data
-		     cfgdat ;; this is the data from ~/.megatest for the selected group
-		     (make-hash-table) ;; areaname -> area-rec
-		     0                 ;; current window id
-		     0                 ;; current tab id
-		     #f                ;; redraw needed for current tab id
-		     (make-hash-table) ;; tab-id -> areaname
-		     )))
-    (hash-table-set! *windows* window-id data)
-    (iup:show (dashboard:main-panel data window-id))
-    (iup:main-loop)))
-
-;; ease debugging by loading ~/.dashboardrc
-(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
-  (if (file-exists? debugcontrolf)
-      (load debugcontrolf)))
-
-(define (main)
-  (let-values 
-      (((con port)(dboard:server-start #f)))
-    (let ((portnum   (if (string? port)(string->number port) port)))
-      ;; got here, monitor/dashboard was started
-      (mddb:register-dashboard portnum)
-      (thread-start! (make-thread (lambda ()(dboard:server-service con portnum)) "server service"))
-      (thread-start! (make-thread (lambda ()
-				    (let loop ()
-				      (dboard:general-updater con portnum)
-				      (thread-sleep! 1)
-				      (loop))) "general updater"))
-      (dboard:make-window 0)
-      (mddb:unregister-dashboard (get-host-name) portnum)
-      (dboard:server-close con port))))
-

DELETED defunct/nmsg-transport.scm
Index: defunct/nmsg-transport.scm
==================================================================
--- defunct/nmsg-transport.scm
+++ /dev/null
@@ -1,358 +0,0 @@
-
-;; Copyright 2006-2012, Matthew Welland.
-;; 
-;;  This program is made available under the GNU GPL version 2.0 or
-;;  greater. See the accompanying file COPYING for details.
-;; 
-;;  This program is distributed WITHOUT ANY WARRANTY; without even the
-;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-;;  PURPOSE.
-
-(require-extension (srfi 18) extras tcp s11n)
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
-(import (prefix sqlite3 sqlite3:))
-
-;; (use nanomsg)
-
-(declare (unit nmsg-transport))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tests))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-(declare (uses server))
-
-(include "common_records.scm")
-(include "db_records.scm")
-
-;; Transition to pub --> sub with pull <-- push
-;;
-;;   1. client sends request to server via push to the pull port
-;;   2. server puts request in queue or processes immediately as appropriate
-;;   3. server puts responses from completed requests into pub port 
-;;
-;; TODO
-;;
-;; Done Tested
-;; [x]  [ ]    1. Add columns pullport pubport to servers table
-;; [x]  [ ]    2. Add rm of monitor.db if older than 11/12/2012 
-;; [x]  [ ]    3. Add create of pullport and pubport with finding of available ports
-;; [x]  [ ]    4. Add client compose of request
-;; [x]  [ ]        - name of client: testname/itempath-test_id-hostname 
-;; [x]  [ ]        - name of request: callname, params
-;; [x]  [ ]        - request key: f(clientname, callname, params)
-;; [x]  [ ]    5. Add processing of subscription hits
-;; [x]  [ ]        - done when get key 
-;; [x]  [ ]        - return results
-;; [x]  [ ]    6. Add timeout processing
-;; [x]  [ ]        - after 60 seconds
-;; [ ]  [ ]            i. check server alive, connect to new if necessary
-;; [ ]  [ ]           ii. resend request
-;; [ ]  [ ]    7. Turn self ping back on
-
-(define (nmsg-transport:make-server-url hostport #!key (bindall #f))
-  (if (not hostport)
-      #f
-      (conc "tcp://" (if bindall "*" (car hostport)) ":" (cadr hostport))))
-
-(define *server-loop-heart-beat* (current-seconds))
-(define *heartbeat-mutex* (make-mutex))
-
-;;======================================================================
-;; S E R V E R
-;;======================================================================
-
-(define (nmsg-transport:run dbstruct hostn run-id server-id #!key (retrynum 1000))
-  (debug:print 2 *default-log-port* "Attempting to start the server ...")
-  (let* ((start-port      (portlogger:open-run-close portlogger:find-port))
-	 (server-thread   (make-thread (lambda ()
-					 (nmsg-transport:try-start-server dbstruct run-id start-port server-id))
-				       "server thread"))
-	 (tdbdat          (tasks:open-db)))
-    (thread-start! server-thread)
-    (thread-sleep! 0.1)
-    (if (nmsg-transport:ping hostn start-port timeout: 2 expected-key: (current-process-id))
-	(let ((interface (if (equal? hostn "-")(get-host-name) hostn)))
-	  (tasks:server-set-interface-port (db:delay-if-busy tdbdat) server-id interface start-port)
-	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
-	  (set! *server-info* (list hostn start-port)) ;; probably not needed anymore? currently used by keep-running
-	  (thread-sleep! 3) ;; give some margin for queries to complete before switching from file based access to server based access
-	  ;; (set! *inmemdb*  dbstruct)
-	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
-	  (thread-start! (make-thread
-			  (lambda ()(nmsg-transport:keep-running server-id run-id))
-			  "keep running"))
-	  (thread-join! server-thread))
-	(if (> retrynum 0)
-	    (begin
-	      (debug:print 0 *default-log-port* "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.")
-	      (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature")
-	      (portlogger:open-run-close portlogger:set-failed start-port)
-	      (nmsg-transport:run dbstruct hostn run-id server-id))
-	    (begin
-	      (debug:print-error 0 *default-log-port* "could not find an open port to start server on. Giving up")
-	      (exit 1))))))
-
-(define (nmsg-transport:try-start-server dbstruct run-id portnum server-id)
-  (let ((repsoc (nn-socket 'rep)))
-    (nn-bind repsoc (conc "tcp://*:" portnum))
-    (let loop ((msg-in (nn-recv repsoc)))
-      (let* ((dat    (db:string->obj msg-in transport: 'nmsg)))
-	(debug:print 0 *default-log-port* "server, received: " dat)
-	(let ((result (api:execute-requests dbstruct dat)))
-	  (debug:print 0 *default-log-port* "server, sending: " result)
-	  (nn-send repsoc (db:obj->string result  transport: 'nmsg)))
-	(loop (nn-recv repsoc))))))
-
-;; all routes though here end in exit ...
-;;
-(define (nmsg-transport:launch run-id)
-  (let* ((tdbdat   (tasks:open-db))
-	 (dbstruct (db:setup run-id))
-	 (hostn    (or (args:get-arg "-server") "-")))
-    (set! *run-id*   run-id)
-    (set! *inmemdb* dbstruct)
-    ;; with nbfake daemonize isn't really needed
-    ;;
-    ;; (if (args:get-arg "-daemonize")
-    ;;     (begin
-    ;;       (daemon:ize)
-    ;;       (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
-    ;;           (begin
-    ;;     	(current-error-port *alt-log-file*)
-    ;;     	(current-output-port *alt-log-file*)))))
-    (if (server:check-if-running run-id)
-	(begin
-	  (debug:print-info 0 *default-log-port* "Server for run-id " run-id " already running")
-	  (exit 0)))
-    (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
-	       (remtries  4))
-      (if (not server-id)
-	  (if (> remtries 0)
-	      (begin
-		(thread-sleep! 2)
-		(if (not (server:check-if-running run-id))
-		    (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)
-			  (- remtries 1))
-		    (begin
-		      (debug:print-info 0 *default-log-port* "Another server took the slot, exiting")
-		      (exit 0))))
-	      (begin
-		;; since we didn't get the server lock we are going to clean up and bail out
-		(debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
-		(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
-		))
-	  ;; locked in a server id, try to start up
-	  (nmsg-transport:run dbstruct hostn run-id server-id))
-      (set! *didsomething* #t)
-      (exit))))
-
-;;======================================================================
-;; S E R V E R   U T I L I T I E S 
-;;======================================================================
-
-(define (nmsg-transport:mk-signature)
-  (message-digest-string (md5-primitive) 
-			 (with-output-to-string
-			   (lambda ()
-			     (write (list (current-directory)
-					  (argv)))))))
-
-;;======================================================================
-;; C L I E N T S
-;;======================================================================
-
-;; ping the server at host:port
-;;   return the open socket if successful (return-socket == #t)
-;;   expect the key expected-key returned in payload
-;;   send our-key or #f as payload
-;;
-(define (nmsg-transport:ping hostn port #!key (timeout 3)(return-socket #t)(expected-key #f)(our-key #f)(socket #f))
-  ;; send a random number along with pid and check that we get it back
-  (let* ((host    (if (or (not hostn)
-			  (equal? hostn "-")) ;; use localhost
-		      (get-host-name)
-		      hostn))
-	 (req     (or socket
-		      (let ((soc (nn-socket 'req)))
-			(nn-connect soc (conc "tcp://" host ":" port))
-			soc)))
-	 (success #t)
-	 (dat     (vector "ping" our-key))
-	 (result  (condition-case 
-		   (nmsg-transport:client-api-send-receive-raw req dat timeout: timeout)
-		   ((timeout)(set! success #f) #f)))
-	 (key     (if success 
-		      (vector-ref result 1)
-		      #f)))
-    (debug:print 0 *default-log-port* "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key))
-    (if (and success
-	     (or (not expected-key) ;; just getting a reply is good enough then
-		 (equal? key expected-key)))
-	(if return-socket
-	    req
-	    (begin
-	      (if (not socket)(nn-close req)) ;; don't want a side effect of closing socket if handed it
-	      #t))
-	(begin
-	  (if (not socket)(nn-close req)) ;; failed to ping, close socket as side effect
-	  #f))))
-
-;; send data to server, wait max of timeout seconds for a response.
-;; return #( success/fail result )
-;;
-;; for effiency it is easier to do the obj->string and string->obj here.
-;;
-(define (nmsg-transport:client-api-send-receive-raw socreq indat #!key (enable-send #t)(timeout 25))
-  (let* ((success     #f)
-	 (result      #f)
-	 (keepwaiting #t)
-	 (dat         (db:obj->string indat transport: 'nmsg))
-	 (send-recv   (make-thread
-		       (lambda ()
-			 (nn-send socreq dat)
-			 (let* ((res (nn-recv socreq)))
-			   (set! success #t)
-			   (set! result (db:string->obj res transport: 'nmsg))))
-		       "send-recv"))
-	 (timeout     (make-thread
-		       (lambda ()
-			 (let loop ((count 0))
-			   (thread-sleep! 1)
-			   (debug:print-info 1 *default-log-port* "send-receive-raw, still waiting after " count " seconds...")
-			   (if (and keepwaiting (< count timeout)) ;; yes, this is very aproximate
-			       (loop (+ count 1))))
-			 (if keepwaiting
-			     (begin
-			       (print "timeout waiting for ping")
-			       (thread-terminate! send-recv))))
-		       "timeout")))
-    ;; replace with condition-case?
-    (handle-exceptions
-     exn
-     (set! result "timeout")
-     (thread-start! timeout)
-     (thread-start! send-recv)
-     (thread-join! send-recv)
-     (if success (thread-terminate! timeout)))
-    ;; raise timeout error if timed out
-    (if success
-	(if (and (vector? result)
-		 (vector-ref result 0)) ;; did it fail at the server?
-	    result                ;; nope, all good
-	    (begin
-	      (debug:print-error 0 *default-log-port* "error occured at server, info=" (vector-ref result 2))
-	      (debug:print 0 *default-log-port* " client call chain:")
-	      (print-call-chain (current-error-port))
-	      (debug:print 0 *default-log-port* " server call chain:")
-	      (pp (vector-ref result 1) (current-error-port))
-	      (signal (vector-ref result 0))))
-	(signal (make-composite-condition
-		 (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))
-
-;; run nmsg-transport:keep-running in a parallel thread to monitor that the db is being 
-;; used and to shutdown after sometime if it is not.
-;;
-(define (nmsg-transport:keep-running server-id run-id)
-  ;; if none running or if > 20 seconds since 
-  ;; server last used then start shutdown
-  ;; This thread waits for the server to come alive
-  (let* ((server-info (let loop ()
-                        (let ((sdat #f))
-                          (mutex-lock! *heartbeat-mutex*)
-                          (set! sdat *server-info*)
-                          (mutex-unlock! *heartbeat-mutex*)
-                          (if sdat 
-			      (begin
-				(debug:print-info 0 *default-log-port* "keep-running got sdat=" sdat)
-				sdat)
-                              (begin
-                                (thread-sleep! 0.5)
-                                (loop))))))
-         (iface       (car server-info))
-         (port        (cadr server-info))
-         (last-access 0)
-	 (tdbdat      (tasks:open-db))
-	 (server-timeout (let ((tmo (configf:lookup  *configdat* "server" "timeout")))
-			   (if (and (string? tmo)
-				    (string->number tmo))
-			       (* 60 60 (string->number tmo))
-			       ;; (* 3 24 60 60) ;; default to three days
-			       (* 60 1)         ;; default to one minute
-			       ;; (* 60 60 25)      ;; default to 25 hours
-			       ))))
-    (print "Keep-running got server pid " server-id ", using iface " iface " and port " port)
-    (let loop ((count 0))
-      (thread-sleep! 4) ;; no need to do this very often
-      ;; NB// sync currently does NOT return queue-length
-      (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1)))
-      ;; (print "Server running, count is " count)
-        (if (< count 1) ;; 3x3 = 9 secs aprox
-            (loop (+ count 1)))
-        
-        (mutex-lock! *heartbeat-mutex*)
-        (set! last-access *last-db-access*)
-        (mutex-unlock! *heartbeat-mutex*)
-	(db:sync-touched *inmemdb* run-id force-sync: #t)
-        (if (and *server-run*
-	       (> (+ last-access server-timeout)
-		  (current-seconds)))
-            (begin
-              (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
-              (loop 0))
-            (begin
-              (debug:print-info 0 *default-log-port* "Starting to shutdown the server.")
-              (set! *time-to-exit* #t)
-	      (db:sync-touched *inmemdb* run-id force-sync: #t)
-              (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running")
-              (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
-              (exit)
-	      ))))))
-
-;;======================================================================
-;; C L I E N T S
-;;======================================================================
-
-(define (nmsg-transport:client-connect iface portnum)
-  (let* ((reqsoc      (nmsg-transport:ping iface portnum return-socket: #t)))
-    (vector iface portnum #f #f #f (current-seconds) reqsoc)))
-
-;; returns result, there is no sucess/fail flag - handled via excpections
-;;
-(define (nmsg-transport:client-api-send-receive run-id connection-info cmd param #!key (remtries 5))
-  ;; NB// In the html version of this routine there is a call to 
-  ;;      tasks:kill-server-run-id when there is an exception
-  (mutex-lock! *http-mutex*)
-  (let* ((packet  (vector cmd param))
-	 (reqsoc  (http-transport:server-dat-get-socket connection-info))
-	 (res     (nmsg-transport:client-api-send-receive-raw reqsoc packet)))
-;;	 (status  (vector-ref rawres 0))
-;;	 (result  (vector-ref rawres 1)))
-    (mutex-unlock! *http-mutex*)
-    res)) ;; (vector status (if status (db:string->obj result transport: 'nmsg) result))))
-	
-;;======================================================================
-;; J U N K 
-;;======================================================================
-
-;; DO NOT USE
-;;
-(define (nmsg-transport:client-signal-handler signum)
-  (handle-exceptions
-   exn
-   (debug:print 0 *default-log-port* " ... exiting ...")
-   (let ((th1 (make-thread (lambda ()
-			     (if (not *received-response*)
-				 (receive-message* *runremote*))) ;; flush out last call if applicable
-			   "eat response"))
-	 (th2 (make-thread (lambda ()
-			     (debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
-			     (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
-			     (debug:print 0 *default-log-port* "       Done.")
-			     (exit 4))
-			   "exit on ^C timer")))
-     (thread-start! th2)
-     (thread-start! th1)
-     (thread-join! th2))))
-

Index: docs/manual/megatest_manual.html
==================================================================
--- docs/manual/megatest_manual.html
+++ docs/manual/megatest_manual.html
@@ -1,10 +1,10 @@
 <!DOCTYPE html>
 <html lang="en">
 <head>
 <meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
-<meta name="generator" content="AsciiDoc 8.6.7">
+<meta name="generator" content="AsciiDoc 8.6.9">
 <title>The Megatest Users Manual</title>
 <style type="text/css">
 /* Shared CSS for AsciiDoc xhtml11 and html5 backends */
 
 /* Default font. */
@@ -84,14 +84,20 @@
   margin-top: 0;
 }
 ul > li     { color: #aaa; }
 ul > li > * { color: black; }
 
-pre {
+.monospaced, code, pre {
+  font-family: "Courier New", Courier, monospace;
+  font-size: inherit;
+  color: navy;
   padding: 0;
   margin: 0;
 }
+pre {
+  white-space: pre-wrap;
+}
 
 #author {
   color: #527bbd;
   font-weight: bold;
   font-size: 1.1em;
@@ -216,11 +222,11 @@
   border-left: 3px solid #dddddd;
   padding-left: 0.5em;
 }
 
 div.imageblock div.content { padding-left: 0; }
-span.image img { border-style: none; }
+span.image img { border-style: none; vertical-align: text-bottom; }
 a.image:visited { color: white; }
 
 dl {
   margin-top: 0.8em;
   margin-bottom: 0.8em;
@@ -412,16 +418,10 @@
 /*
  * xhtml11 specific
  *
  * */
 
-tt {
-  font-family: "Courier New", Courier, monospace;
-  font-size: inherit;
-  color: navy;
-}
-
 div.tableblock {
   margin-top: 1.0em;
   margin-bottom: 1.5em;
 }
 div.tableblock > table {
@@ -451,16 +451,10 @@
 /*
  * html5 specific
  *
  * */
 
-.monospaced {
-  font-family: "Courier New", Courier, monospace;
-  font-size: inherit;
-  color: navy;
-}
-
 table.tableblock {
   margin-top: 1.0em;
   margin-bottom: 1.5em;
 }
 thead, p.tableblock.header {
@@ -536,10 +530,12 @@
 }
 
 @media print {
   body.manpage div#toc { display: none; }
 }
+
+
 @media screen {
   body {
     max-width: 50em; /* approximately 80 characters wide */
     margin-left: 16em;
   }
@@ -868,11 +864,74 @@
 <div class="sect1">
 <h2 id="_road_map">Road Map</h2>
 <div class="sectionbody">
 <div class="paragraph"><p>Note 1: This road-map is still evolving and subject to change without notice.</p></div>
 <div class="sect2">
-<h3 id="_rfc_move_data_into_completed_runs_db">RFC: Move data into completed-runs.db</h3>
+<h3 id="_rfc_m01_add_ability_to_move_runs_to_other_areas">RFC M01: Add ability to move runs to other Areas</h3>
+<div class="paragraph"><p><strong>Purpose</strong>: allow shrinking megatest.db data by moving runs to an alternate
+ Megatest area with same keys.</p></div>
+<div class="paragraph"><p><strong>Method</strong>: extend db sync to take a different megatest area as a destination.</p></div>
+<div class="paragraph"><p><strong>Design</strong>:</p></div>
+<div class="olist arabic"><ol class="arabic">
+<li>
+<p>
+add param -destination [area|path]. when specified runs are copied to new
+  area and removed from local db.
+</p>
+</li>
+<li>
+<p>
+the data move would involve these steps
+</p>
+<div class="olist loweralpha"><ol class="loweralpha">
+<li>
+<p>
+copy the run data to destination area megatest.db
+</p>
+</li>
+<li>
+<p>
+mark the run records as MOVED, do not remove the run data on disk
+</p>
+</li>
+</ol></div>
+</li>
+<li>
+<p>
+accessing the data would be by running dashboard in the satellite area
+</p>
+</li>
+<li>
+<p>
+future versions of Megatest dashboard should support displaying areas in a
+  merged way by adding the area as the topmost variable (i.e. effectively
+  extending the target.
+</p>
+</li>
+<li>
+<p>
+some new controls would be supported in the config
+</p>
+<div class="olist loweralpha"><ol class="loweralpha">
+<li>
+<p>
+[setup] &#8658; allow-runs [no|yes]  &#8656;= used to disallow runs
+</p>
+</li>
+<li>
+<p>
+[automigrate] &#8658; areaname target=%/%/%; runname=%; age=30d &#8656;= automigrate
+   by these criteria for the given area.
+</p>
+</li>
+</ol></div>
+</li>
+</ol></div>
+<div class="paragraph"><p><strong>Branch</strong>: This work is taking place on branch v1.65-reduce-records</p></div>
+</div>
+<div class="sect2">
+<h3 id="_rfc_m02_move_data_into_completed_runs_db">RFC M02: Move data into completed-runs.db</h3>
 <div class="paragraph"><p><strong>Purpose</strong>: shrink megatest.db data to enable lower load and higher performance.</p></div>
 <div class="paragraph"><p><strong>Method</strong>: add a completed-runs.db and automatically move runs data from megatest.db to that db</p></div>
 <div class="paragraph"><p><strong>Design</strong>:</p></div>
 <div class="olist arabic"><ol class="arabic">
 <li>
@@ -926,11 +985,11 @@
 </li>
 </ol></div>
 <div class="paragraph"><p><strong>Branch</strong>: This work is taking place on branch v1.65-reduce-records</p></div>
 </div>
 <div class="sect2">
-<h3 id="_rfc_automatic_homehost_migrations">RFC: Automatic homehost migrations</h3>
+<h3 id="_rfc_m03_automatic_homehost_migrations">RFC M03: Automatic homehost migrations</h3>
 <div class="paragraph"><p><strong>Purpose</strong>: Automatically migrate homehost.</p></div>
 <div class="paragraph"><p><strong>Method</strong>: Check that there are no tests running, launched or remotehoststart in past ½ hour then if not on homehost migrate the db to current host</p></div>
 <div class="paragraph"><p><strong>Design</strong>:</p></div>
 <div class="olist arabic"><ol class="arabic">
 <li>
@@ -2105,11 +2164,11 @@
 COMPLETED/ xterm -e bash -s --</pre>
 </div></div>
 <div class="admonitionblock">
 <table><tr>
 <td class="icon">
-<img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note">
+<img src="/usr/images/icons/note.png" alt="Note">
 </td>
 <td class="content">There is a trailing space after the --</td>
 </tr></table>
 </div>
 <div class="paragraph"><p>There are a number of environment variables available to the trigger script
@@ -2403,10 +2462,11 @@
 </div>
 <div id="footnotes"><hr></div>
 <div id="footer">
 <div id="footer-text">
 Version 1.0<br>
-Last updated 2018-01-30 13:24:43 PST
+Last updated
+ 2018-02-03 21:10:39 MST
 </div>
 </div>
 </body>
 </html>

Index: docs/manual/server.png
==================================================================
--- docs/manual/server.png
+++ docs/manual/server.png
cannot compute difference between binary files

DELETED ducttape/Makefile
Index: ducttape/Makefile
==================================================================
--- ducttape/Makefile
+++ /dev/null
@@ -1,33 +0,0 @@
-help:
-	@echo ""
-	@echo "make targets:"
-	@echo "============="
-	@echo "install      - build and install general_lib egg as icfadm"
-	@echo "test         - run unit tests on ducttape-lib.scm (tests code, not egg)"
-	@echo "eggs-info     - show chicken-install commands to get eggs upon which ducttape-lib depends"
-	@echo "test_example - compile an example scm against installed general_lib egg"
-	@echo "clean        - remove binaries and other build artifacts"
-	@echo ""
-
-clean:
-	rm -f *.so *.import.scm test_ducttape test_example foo *.c *.o
-
-install:
-	chicken-install
-
-test:
-	chicken-install -no-install
-	csc test_ducttape.scm
-
-	./test_ducttape
-	rm -f foo
-
-test_example:
-	@csc test_example.scm
-	@./test_example
-	@rm test_example
-
-eggs-info:
-	@echo chicken-install ansi-escape-sequences
-	@echo chicken-install slice
-	@echo chicken-install rfc3339

DELETED ducttape/README
Index: ducttape/README
==================================================================
--- ducttape/README
+++ /dev/null
@@ -1,8 +0,0 @@
-This directory holds the "ducttape" chicken scheme egg used by megatest.
-
-Run "make test" to ensure this egg works on your system.
-
-Run "make install" as your admin user with chicken on your $PATH to install this egg.
-
-
-

DELETED ducttape/ducttape-lib.meta
Index: ducttape/ducttape-lib.meta
==================================================================
--- ducttape/ducttape-lib.meta
+++ /dev/null
@@ -1,13 +0,0 @@
-;;; ducttape-lib.meta -*- Hen -*-
-
-((egg "ducttape-lib.egg")
- (synopsis "Miscellaneous tool and standard print routines.")
- (category env)
- (author "Brandon Barclay")
- (doc-from-wiki)
- (license "GPL-2")
- ;; srfi-69, posix, srfi-18
- (depends regex)
- (test-depends test)
- ; suspicious - (files "ducttape-lib")
- )

DELETED ducttape/ducttape-lib.scm
Index: ducttape/ducttape-lib.scm
==================================================================
--- ducttape/ducttape-lib.scm
+++ /dev/null
@@ -1,793 +0,0 @@
-(module ducttape-lib
-    (
-     runs-ok
-     ducttape-debug-level
-     ducttape-debug-regex-filter
-     ducttape-silent-mode
-     ducttape-quiet-mode
-     ducttape-log-file
-     ducttape-color-mode
-     iputs-preamble
-     script-name
-     idbg
-     ierr
-     iwarn
-     inote
-     iputs
-     re-match?
-                                        ;     launch-repl
-     keyword-skim
-     skim-cmdline-opts-noarg-by-regex
-     skim-cmdline-opts-withargs-by-regex
-     get-cli-arg
-     get-cli-switch
-     concat-lists
-     ducttape-process-command-line
-     ducttape-append-logfile
-     ducttape-activate-logfile
-     isys
-     do-or-die
-     counter-maker
-     dir-is-writable?
-     mktemp
-     get-tmpdir
-     sendmail
-     find-exe
-
-     zeropad
-     string-leftpad
-     string-rightpad
-     seconds->isodate
-     seconds->wwdate
-     seconds->wwdate-values
-     isodate->seconds
-     isodate->wwdate
-     wwdate->seconds
-     wwdate->isodate
-     current-wwdate
-     current-isodate
-     *this-exe-dir*
-     *this-exe-name*
-     *this-exe-fullpath*
-     )
-
-  (import scheme chicken extras ports data-structures )
-  (use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339)
-  ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process*
-  (use directory-utils uuid-lib filepath srfi-19 ) ; linenoise
-
-    ;; plugs a hole in posix-extras in latter chicken versions
-  (use posix-extras pathname-expand files)
-  (define ##sys#expand-home-path pathname-expand)
-  (define (realpath x) (resolve-pathname  (pathname-expand (or x "/dev/null")) ))
-
-  (include "mimetypes.scm") ; provides ext->mimetype
-  (include "workweekdate.scm")
-  (define ducttape-lib-version 1.00)
-  (define (toplevel-command sym proc) (lambda () #f))
-
-;;;; define some handy globals
-  ;; resolve fullpath to this script or binary.
-  (define (__get-this-script-fullpath #!key (argv (argv)))
-    (let* ((this-script
-            (cond
-             ((and (> (length argv) 2)
-                   (string-match "^(.*/csi|csi)$" (car argv))
-                   (string-match "^-(s|ss|sx|script)$" (cadr argv)))
-              (caddr argv))
-             (else (car argv))))
-           (fullpath (realpath this-script)))
-      fullpath))
-  
-  (define *this-exe-fullpath* (__get-this-script-fullpath))
-  (define *this-exe-dir*      (pathname-directory *this-exe-fullpath*))
-  (define *this-exe-name*     (pathname-strip-directory *this-exe-fullpath*))
-  
-
-;;;; utility procedures
-
-
-  
-  ;; begin credit: megatest's process.scm
-  (define (port->list fh )
-    (if (eof-object? fh) #f
-        (let loop ((curr (read-line fh))
-                   (result '()))
-          (if (not (eof-object? curr))
-              (loop (read-line fh)
-                    (append result (list curr)))
-              result))))
-
-  (define (conservative-read port)
-    (let loop ((res ""))
-      (if (not (eof-object? (peek-char port)))
-          (loop (conc res (read-char port)))
-          res)))
-  ;; end credit: megatest's process.scm
-
-  (define (counter-maker)
-    (let ((acc 0))
-      (lambda ( #!optional (increment 1) )
-        (set! acc (+ increment acc))
-        acc)))
-
-  (define (port->string port #!optional ) ; todo - add newline 
-    (let ((linelist (port->list port)))
-      (if linelist
-          (string-join linelist "\n")
-          "")))
-
-
-  (define (outport->foreach outport foreach-thunk)
-    (let loop ((line (foreach-thunk)))
-      (if line
-          (begin
-            (write-line line outport)
-            (loop (foreach-thunk))
-            )
-          (begin
-            ;;http://bugs.call-cc.org/ticket/766
-            ;;close-[input|output]-port implicitly calling process-wait on process pipe ports. This leads to errors like
-            ;;Error: (process-wait) waiting for child process failed - No child processes: 10872
-            (close-output-port outport)
-            #f))))
-  
-  ;; weird - alist-ref arg order changes signature csc vs. csi... explitly defining.
-  (define (my-alist-ref key alist)
-    (let ((res (assoc key alist)))
-      (if res (cdr res) #f)))
-
-  (define (keyword-skim-alist args alist)
-    (let loop ((result-alist '()) (result-args args) (rest-alist alist))
-      (cond
-       ((null? rest-alist) (values result-alist result-args))
-       (else
-        (let ((keyword (caar rest-alist))
-              (defval (cdar rest-alist)))
-          (let-values (((kwval result-args2)
-                        (keyword-skim
-                         keyword
-                         defval
-                         result-args)))
-            (loop
-             (cons (cons keyword kwval) result-alist)
-             result-args2
-             (cdr rest-alist))))))))
-  
-  (define (isys command . rest-args)
-    (let-values
-        (((opt-alist args)
-          (keyword-skim-alist
-           rest-args
-           '( ( foreach-stdout-thunk: . #f )
-              ( foreach-stdin-thunk: . #f )
-              ( stdin-proc: . #f ) ) )))
-      (let* ((foreach-stdout-thunk
-              (my-alist-ref foreach-stdout-thunk: opt-alist))
-             (foreach-stdin-thunk
-              (my-alist-ref foreach-stdin-thunk: opt-alist))
-             (stdin-proc
-              (if foreach-stdin-thunk
-                  (lambda (port)
-                    (outport->foreach port foreach-stdin-thunk))
-                  (my-alist-ref stdin-proc: opt-alist))))
-
-        ;; TODO: support command is list.
-        
-        (let-values (((stdout stdin pid stderr)
-                      (if (null? args)
-                          (process* command)
-                          (process* command args))))
-          
-                                        ;(if foreach-stdin-thunk
-                                        ;    (set! stdin-proc
-                                        ;          (lambda (port)
-                                        ;            (outport->foreach port foreach-stdin-thunk))))
-          
-          (if stdin-proc
-              (stdin-proc stdin))
-          
-          (let ((stdout-res 
-                 (if foreach-stdout-thunk  ;; don't accumulate stdout if we have a thunk; probably doing this because stdout is BIG so lets not waste memory
-                     (begin
-                       (port-for-each foreach-stdout-thunk (lambda () (read-line stdout)))
-                       "foreach-stdout-thunk ate stdout"
-                       )
-                     (if stdin-proc
-                         "foreach-stdin-thunk/stdin-proc blocks stdout"
-                         (port->string stdout))))
-                (stderr-res
-                 (if stdin-proc
-                     "foreach-stdin-thunk/stdin-proc blocks stdout"
-                     (port->string stderr))))
-
-            ;; if we've used a stdin-proc, we've closed stdin port, which unfortunately causes a wait-pid internally, causing stdout and stderr ports to auto-close.  don't close them again.  (so sad - we lost stdout and stderr contents when we write to stdin)
-            ;; see - http://bugs.call-cc.org/ticket/766
-            (if (not stdin-proc)
-                (close-input-port stdout)
-                (close-input-port stderr))
-            
-            (let-values (((anotherpid normalexit? exitstatus)  (process-wait pid)))
-              (values exitstatus stdout-res stderr-res)))))))
-  
-  (define (do-or-die command   #!key nodie (foreach-stdout #f) (stdin-proc #f))
-    (let-values (((exit-code stdout-str stderr-str) (isys command foreach-stdout-thunk: foreach-stdout stdin-proc: stdin-proc )))
-      (if (equal? 0 exit-code)
-          stdout-str
-          (begin
-            (ierr (conc "Command  > " command " "  "< failed with " exit-code " because: \n" stderr-str) )
-            (if nodie #f (exit exit-code))))))
-
-
-  ;; runs-ok: evaluate expression while suppressing exceptions.
-                                        ;    on caught exception, returns #f
-                                        ;    otherwise, returns expression value
-  (define (runs-ok thunk)
-    (handle-exceptions exn #f (begin (thunk) #t)))
-
-  ;; concat-lists: result list = lista + listb
-  (define (concat-lists lista listb) ;; ok, I just reimplemented append...
-    (foldr cons listb lista))
-  
-
-;;; setup general_lib env var parameters
-
-  ;; show warning/note/error/debug prefixes using ansi colors
-  (define ducttape-color-mode
-    (make-parameter (get-environment-variable "DUCTTAPE_COLORIZE")))
-
-  ;; if defined, has number value.  if number value > 0, show debug messages
-  ;; value should be decremented in subshells -- idea is raising debug level will show debug messages deeper and deeper in process call stack
-  (define ducttape-debug-level
-    (make-parameter
-     (let ( (raw-debug-level (get-environment-variable "DUCTTAPE_DEBUG_LEVEL")) )
-       (if raw-debug-level
-           (let ((num-debug-level (runs-ok (string->number raw-debug-level))))
-             (if (integer? num-debug-level)
-                 (begin
-                   (let ((new-num-debug-level (- num-debug-level 1)))
-                     (if (> new-num-debug-level 0) ;; decrement
-                         (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level))
-                         (unsetenv "DUCTTAPE_DEBUG_LEVEL")))
-                   num-debug-level) ; it was set and > 0, mode is value
-                 (begin
-                   (unsetenv "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it
-                   #f))) ; value was invalid, mode is f
-           #f)))) ; var not set, mode is f
-
-
-  (define ducttape-debug-mode (if (ducttape-debug-level)  #t  #f))
-
-  ;; ducttape-debug-regex-filter suppresses non-matching debug messages
-  (define ducttape-debug-regex-filter
-    (make-parameter
-     (let ((raw-debug-pattern (get-environment-variable "DUCTTAPE_DEBUG_PATTERN")))
-       (if raw-debug-pattern
-           raw-debug-pattern
-           "."))))
-
-  ;; silent mode suppresses Note and Warning type messages
-  (define ducttape-silent-mode
-    (make-parameter (get-environment-variable "DUCTTAPE_SILENT_MODE")))
-
-  ;; quiet mode suppresses Note type messages
-  (define ducttape-quiet-mode
-    (make-parameter (get-environment-variable "DUCTTAPE_QUIET_MODE")))
-
-  ;; if log file is defined, warning/note/error/debug messages are appended
-  ;; to named logfile.
-  (define ducttape-log-file
-    (make-parameter (get-environment-variable "DUCTTAPE_LOG_FILE")))
-
-
-
-
-  
-  
-;;; standard messages printing implementation
-
-                                        ; get the name of the current script/binary being run
-  (define (script-name)
-    (car (reverse (string-split (car (argv)) "/"))))
-
-  (define (ducttape-timestamp)
-    (rfc3339->string (time->rfc3339 (seconds->local-time))))
-
-
-  (define (iputs-preamble msg-type #!optional (suppress-color #f))
-    (let ((do-color (and
-                     (not suppress-color)
-                     (ducttape-color-mode)
-                     (terminal-port? (current-error-port)))))
-      (case msg-type
-        ((note)
-         (if do-color
-             (set-text (list 'fg-green 'bg-black 'bold) "Note:")
-             "Note:"
-             ))
-        ((warn)
-         (if do-color
-             (set-text (list 'fg-yellow 'bg-black 'bold) "Warning:")
-             "Warning:"
-             ))
-        ((err)
-         (if do-color
-             (set-text (list 'fg-red 'bg-black 'bold) "Error:")
-             "Error:"
-             ))
-        ((dbg)
-         (if do-color
-             (set-text (list 'fg-blue 'bg-magenta) "Debug:")
-             "Debug:"
-             )))))
-
-  (define (ducttape-append-logfile msg-type message #!optional (suppress-preamble #f))
-    (let
-        ((txt 
-          (string-join 
-           (list 
-            (ducttape-timestamp) 
-            (script-name)
-            (if suppress-preamble
-                message
-                (string-join  (list (iputs-preamble msg-type #t) message) " ")))
-           " | ")))
-
-      (if (ducttape-log-file)
-          (runs-ok
-           (call-with-output-file (ducttape-log-file)
-             (lambda (output-port)
-               (format output-port "~A ~%" txt)
-               )
-             #:append))
-          #t)))
-
-  (define (ducttape-activate-logfile #!optional (logfile #f))
-    ;; from python ducttape-lib.py
-                                        ; message = "START - pid=%d ppid=%d argv=(%s) pwd=%s user=%s host=%s"%(pid,ppid," ".join("'"+x+"'" for x in sys.argv),os.environ['PWD'],os.getenv('USER','nouser'),os.getenv('HOST','nohost') )
-    (let ((pid (number->string (current-process-id)))
-          (ppid (number->string (parent-process-id)))
-          (argv 
-           (string-join 
-            (map 
-             (lambda (x) 
-               (string-join (list "\"" x "\"")  "" ))
-             (argv))
-            " "))
-          (pwd (or (get-environment-variable "PWD") "nopwd"))
-          (user (or (get-environment-variable "USER") "nouser"))
-          (host (or (get-environment-variable "HOST") "nohost")))
-      (if logfile
-          (begin
-            (ducttape-log-file logfile)
-            (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file))))
-      (ducttape-append-logfile 'note (format #f "START - pid=~A ppid=~A argv=(~A) pwd=~A user=~A host=~A" pid ppid argv pwd user host) #t)))         
-
-
-  ;; log exit code
-  (define (set-ducttape-log-exit-handler)
-    (let ((orig-exit-handler (exit-handler)))
-      (exit-handler 
-       (lambda (exitcode) 
-         (ducttape-append-logfile 'note (format #f "Exit ~A by sys.exit" exitcode) #t)
-         (orig-exit-handler exitcode)))))
-
-
-  (define (idbg first-message  . rest-args)
-    (let* ((debug-level-threshold
-            (if (> (length rest-args) 0) (car rest-args) 1))
-           (message-list
-            (if (> (length rest-args) 1)
-                (cons first-message (cdr rest-args))
-                (list first-message)) )
-           (message (apply conc
-                  (map ->string message-list))))
-
-      (ducttape-append-logfile 'dbg message)
-      (if (ducttape-debug-level)
-          (if (<= debug-level-threshold (ducttape-debug-level))
-              (if (string-search (ducttape-debug-regex-filter) message)
-                  (begin 
-                    (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'dbg) message (script-name))))))))
-
-  (define (ierr message-first  . message-rest)
-    (let* ((message
-            (apply conc
-             (map ->string (cons message-first message-rest)))))
-      (ducttape-append-logfile 'err message)
-      (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'err) message (script-name))))
-
-  (define (iwarn message-first  . message-rest)
-    (let* ((message
-            (apply conc
-             (map ->string (cons message-first message-rest)))))
-      (ducttape-append-logfile 'warn message)
-      (if (not (ducttape-silent-mode))
-          (begin
-            (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'warn) message (script-name))))))
-
-  (define (inote message-first  . message-rest)
-    (let* ((message
-            (apply conc
-             (map ->string (cons message-first message-rest)))))
-      (ducttape-append-logfile 'note message)
-      (if (not (or (ducttape-silent-mode) (ducttape-quiet-mode)))
-          (begin 
-            (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'note) message (script-name))))))
-
-  
-  (define (iputs kind message #!optional (debug-level-threshold 1))
-    (cond
-     ((member kind (string-split "NOTE/Note/note/n/N" "/")) (inote message))
-     ((member kind (string-split "Error/ERROR/error/Err/ERR/err/E/e" "/")) (ierr message))
-     ((member kind
-              (string-split "Warning/WARNING/warning/Warn/WARN/warn/W/w" "/"))
-      (iwarn message))
-     ((member kind (string-split "Debug/DEBUG/debug/Dbg/DBG/dbg/D/d" "/"))
-      (idbg message debug-level-threshold))))
-
-  (define (mkdir-recursive path-so-far hier-list-to-create)
-    (if (null? hier-list-to-create)
-        path-so-far
-        (let* ((next-hier-item (car hier-list-to-create))
-               (rest-hier-items (cdr hier-list-to-create))
-               (path-to-mkdir (string-concatenate (list path-so-far "/" next-hier-item))))
-          (if (runs-ok (lambda () (create-directory path-to-mkdir)))
-              (mkdir-recursive path-to-mkdir rest-hier-items)
-              #f))))
-
-                                        ; ::mkdir-if-not-exists::
-                                        ; make a dir recursively if it does not 
-                                        ; already exist.
-                                        ; on success - returns path
-                                        ; on fail - returns #f
-  (define (mkdirp-if-not-exists the-dir)
-    (let ( (path-list (string-split the-dir "/")))
-      (mkdir-recursive "/" path-list)))
-
-                                        ; ::mkdir-if-not-exists::
-                                        ; make a dir recursively if it does not 
-                                        ; already exist.
-                                        ; on success - returns path
-                                        ; on fail - returns #f
-
-
-  (define (mkdirp-if-not-exists the-dir)
-    (let ( (path-list (string-split the-dir "/")))
-      (mkdir-recursive "/" path-list)))
-
-  (define (dir-is-writable? the-dir)
-    (let ((dummy-file (string-concatenate (list the-dir "/.dummyfile"))))
-      (and
-       (file-exists? the-dir)
-       (cond 
-        ((runs-ok (lambda ()(with-output-to-file dummy-file (lambda () (print "foo")))))
-         (begin
-           (runs-ok (lambda () (delete-file dummy-file) ))
-           the-dir))
-        (else #f)))))
-
-
-  (define (get-tmpdir )
-    (let* ((tmproot
-            (dir-is-writable?
-             (or 
-              (get-environment-variable "TMPDIR") 
-              "/tmp")))
-
-           (user
-            (or
-             (get-environment-variable "USER")
-             "USER_Envvar_not_set"))
-           (tmppath
-            (string-concatenate 
-             (list tmproot "/env21-general-" user ))))
-
-      (dir-is-writable?
-       (mkdirp-if-not-exists
-        tmppath))))
-
-  (define (mktemp
-           #!optional
-           (prefix "general_lib_tmpfile")
-           (dir #f))
-    (let-values
-        (((fd path) 
-          (file-mkstemp 
-           (conc 
-            (if dir  dir  (get-tmpdir))
-            "/" prefix ".XXXXXX"))))
-      (close-output-port (open-output-file* fd))
-      path))
-
-
-
-  ;;http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment
-  ;; write send-email using:
-  ;;   - isys-foreach-stdin-line
-  ;;   - formatting in http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment
-  (define (sendmail to_addr subject body
-                    #!key
-                    (from_addr "admin")
-                    cc_addr
-                    bcc_addr
-                    more-headers
-                    use_html
-                    (attach-files-list '())
-                    (images-with-content-id-alist '())
-                    )
-
-    (define (sendmail-proc sendmail-port)
-      (define (wl line-str)
-        (write-line line-str sendmail-port))
-
-      (define (get-uuid)
-        (string-upcase (uuid->string (uuid-generate))))
-
-      (let ((mailpart-uuid (get-uuid))
-            (mailpart-body-uuid (get-uuid)))
-        
-        (define (boundary)
-          (wl (conc "--" mailpart-uuid)))
-
-        (define (body-boundary)
-          (wl (conc "--" mailpart-body-uuid)))
-
-
-        (define (email-mime-header)
-          (wl (conc "From: " from_addr))
-          (wl (conc "To: " to_addr))
-          (if cc_addr
-              (wl (conc "Cc: " cc_addr)))
-          (if bcc_addr
-              (wl (conc "Bcc: " bcc_addr)))
-          (if more-headers
-              (wl more-headers))
-          (wl (conc "Subject: " subject))
-          (wl "MIME-Version: 1.0")
-          (wl (conc "Content-Type: multipart/mixed; boundary=\"" mailpart-uuid "\""))
-          (wl "")
-          (boundary)
-          (wl (conc "Content-Type: multipart/alternative; boundary=\"" mailpart-body-uuid "\""))
-          (wl "")
-          )
-
-        
-        (define (email-text-body)
-          (body-boundary)
-          (wl "Content-Type: text/plain; charset=ISO-8859-1")
-          (wl "Content-Disposition: inline")
-          (wl "")
-          (wl body)
-          (body-boundary))
-        
-        (define (email-html-body)
-          (body-boundary)
-          (wl "Content-Type: text/plain; charset=ISO-8859-1")
-          (wl "")
-          (wl "You need to enable HTML option for email")
-          (body-boundary)
-          (wl "Content-Type: text/html; charset=ISO-8859-1")
-          (wl "Content-Disposition: inline")
-          (wl "")
-          (wl body)
-          (body-boundary))
-
-        (define (attach-file file #!key (content-id #f))
-          (let* ((filename
-                  (filepath:take-file-name file))
-                 (ext-with-dot
-                  (filepath:take-extension file))
-                 (ext (string-take-right
-                       ext-with-dot
-                       (- (string-length ext-with-dot) 1)))
-                 (mimetype (ext->mimetype ext))
-                 (uuencode-command (conc "uuencode " file " " filename)))
-            (boundary)
-            (wl (conc "Content-Type: " mimetype "; name=\"" filename "\""))
-            (wl "Content-Transfer-Encoding: uuencode")
-            (if content-id
-                (wl (conc "Content-Id: " content-id)))
-            (wl (conc "Content-Disposition: attachment; filename=\"" filename "\""))
-            (wl "")
-            (do-or-die
-             uuencode-command
-             foreach-stdout:
-             (lambda (line)
-               (wl line)))))
-
-        (define (embed-image file+content-id)
-          (let ((file (car file+content-id))
-                (content-id (cdr file+content-id)))
-            (attach-file file content-id: content-id)))
-        
-        ;; send the email
-        (email-mime-header)
-        (if use_html
-            (email-html-body)
-            (email-text-body))
-        (for-each attach-file attach-files-list)
-        (for-each embed-image images-with-content-id-alist)
-        (boundary)
-        (close-output-port sendmail-port)))
-    
-    (do-or-die "/usr/sbin/sendmail -t"
-               stdin-proc: sendmail-proc))
-
-  ;; like shell "which" command
-  (define (find-exe exe)
-    (let* ((path-items
-            (string-split
-             (or
-              (get-environment-variable "PATH") "")
-             ":")))
-
-      (let loop ((rest-path-items path-items))
-        (if (null? rest-path-items)
-            #f
-            (let* ((this-dir (car rest-path-items))
-                   (next-rest (cdr rest-path-items))
-                   (candidate (conc this-dir "/" exe)))
-              (if (file-execute-access? candidate)
-                  candidate
-                  (loop next-rest)))))))
-
-
-;;;; process command line options
-
-  ;; get command line switches (have no subsequent arg; eg. [-foo])
-  ;;  assumes these are switches without arguments
-  ;;  will return list of matches
-  ;;  removes matches from command-line-arguments parameter
-  (define (skim-cmdline-opts-noarg-by-regex switch-pattern)
-    (let* (
-           (irr (irregex switch-pattern))
-           (matches (filter
-                     (lambda (x)
-                       (irregex-match irr x))
-                     (command-line-arguments)))
-           (non-matches (filter
-                         (lambda (x)
-                           (not (member x matches)))
-                         (command-line-arguments))))
-
-      (command-line-arguments non-matches)
-      matches))
-
-  (define (keyword-skim keyword default args #!optional (eqpred equal?))
-    (let loop ( (kwval default) (args-remaining args) (args-to-return '()) )
-      (cond 
-       ((null? args-remaining)
-        (values
-         (if (list? kwval) (reverse kwval) kwval)
-         (reverse args-to-return)))
-       ((and (> (length args-remaining) 1) (eqpred keyword (car args-remaining)))
-        (if (list? default)
-            (if (equal? default kwval)
-                (loop (list (cadr args-remaining)) (cddr args-remaining) args-to-return)
-                (loop (cons (cadr args-remaining) kwval) (cddr args-remaining) args-to-return))
-            (loop (cadr args-remaining) (cddr args-remaining) args-to-return)))
-       (else (loop kwval (cdr args-remaining) (cons (car args-remaining) args-to-return))))))
-
-
-  (define (get-cli-arg arg #!key (default #f) (is-list #f))
-    (let* ((temp    (skim-cmdline-opts-withargs-by-regex arg)))
-      (if (> (length temp) 0)
-          (if is-list
-              temp
-              (car temp))
-          default)))
-
-  (define (get-cli-switch arg)
-    (let ((temp (skim-cmdline-opts-noarg-by-regex arg)))
-      (if (> (length temp) 0)
-          (car temp)
-          #f)))
-  
-
-
-
-  ;; get command line switches (have a subsequent arg; eg. [-foo bar])
-  ;;  assumes these are switches without arguments
-  ;;  will return list of arguments to matches
-  ;;  removes matches from command-line-arguments parameter
-
-  (define (re-match? re str)
-    (irregex-match re str))
-
-  (define (skim-cmdline-opts-withargs-by-regex switch-pattern)
-    (let-values
-        (((result new-cmdline-args)
-          (keyword-skim switch-pattern
-                        '()
-                        (command-line-arguments)
-                        re-match?
-                        )))
-      (command-line-arguments new-cmdline-args)
-      result))
-  
-  
-
-  ;; recognize ducttape-lib command line switches (--quiet, --silent, --color, -d.., -dp.., -logfile)
-  ;;    - reset parameters; reset DUCTTAPE_* env vars to match user specified intent
-  ;;    - mutate (command-line-arguments) parameter to subtract these recognized and handled switches
-  ;;       * beware -- now (argv) and (command-line-arguments) are inconsistent... cannot mutate (argv) alas.  Use (command-line-arguments)
-  ;; WARNING: this defines command line arguments that may clash with your program.  Only call this if you
-  ;; are sure they can coexist.
-  (define (ducttape-process-command-line)
-
-    ;; --quiet
-    (let ((quiet-opts (skim-cmdline-opts-noarg-by-regex "--?quiet")))
-      (if (not (null? quiet-opts))
-          (begin
-            (setenv "DUCTTAPE_QUIET_MODE" "1")
-            (ducttape-quiet-mode "1"))))
-
-    ;; --silent
-    (let ((silent-opts (skim-cmdline-opts-noarg-by-regex "--?silent")))
-      (if (not (null? silent-opts))
-          (begin
-            (setenv "DUCTTAPE_SILENT_MODE" "1")
-            (ducttape-silent-mode "1"))))
-
-    ;; -color
-    (let ((color-opts (skim-cmdline-opts-noarg-by-regex "--?colou?r(ize)?")))
-      (if (not (null? color-opts))
-          (begin
-            (setenv "DUCTTAPE_COLORIZE" "1")
-            (ducttape-color-mode "1"))))
-
-    ;; -nocolor
-    (let ((nocolor-opts (skim-cmdline-opts-noarg-by-regex "--?nocolou?r(ize)?")))
-      (if (not (null? nocolor-opts))
-          (begin
-            (unsetenv "DUCTTAPE_COLORIZE" )
-            (ducttape-color-mode #f))))
-
-    ;; -logfile
-    (let ((logfile-opts (skim-cmdline-opts-withargs-by-regex "--?log(-?file)?")))
-      (if (not (null? logfile-opts))
-          (begin
-            (ducttape-log-file (car (reverse logfile-opts)))
-            (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file)))))
-
-    ;; -d -dd -d#
-    (let ((debug-opts (skim-cmdline-opts-noarg-by-regex "-d(d*|\\d+)"))
-          (initial-debuglevel (if (ducttape-debug-level) (ducttape-debug-level) 0) ))
-      (if (not (null? debug-opts))
-          (begin
-            (ducttape-debug-level
-             (let loop ((opts debug-opts) (debuglevel initial-debuglevel))
-               (if (null? opts)
-                   debuglevel
-                   (let*
-                       ( (curopt (car opts))
-                         (restopts (cdr opts))
-                         (ds (string-match "-(d+)" curopt))
-                         (dnum (string-match "-d(\\d+)" curopt)))
-                     (cond
-                      (ds (loop restopts (+ debuglevel (string-length (cadr ds)))))
-                      (dnum  (loop restopts (string->number (cadr dnum)))))))))
-            (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level))))))
-
-
-    ;; -dp <pat> / --debug-pattern <pat>
-    (let ((debugpat-opts (skim-cmdline-opts-withargs-by-regex "--?(debug-pattern|dp)")))
-      (if (not (null? debugpat-opts))
-          (begin
-            (ducttape-debug-regex-filter (string-join debugpat-opts "|"))
-            (setenv "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter)))))) 
-
-
-  ;;; following code commented out; side effects not wanted on startup
-  ;; immediately activate logfile (will be noop if logfile disabled)
-  ;;(ducttape-activate-logfile)
-  ;;(set-ducttape-log-exit-handler)
-  
-  ;; TODO: hook exception handler so we can log exception before we sign off.
-
-  ;; handle command line immediately; 
-  ;;(process-command-line)                    
-
-
-  ) ; end module

DELETED ducttape/ducttape-lib.setup
Index: ducttape/ducttape-lib.setup
==================================================================
--- ducttape/ducttape-lib.setup
+++ /dev/null
@@ -1,1 +0,0 @@
-(standard-extension 'ducttape-lib '1.0.0)

DELETED ducttape/mimetypes.scm
Index: ducttape/mimetypes.scm
==================================================================
--- ducttape/mimetypes.scm
+++ /dev/null
@@ -1,782 +0,0 @@
-;; gathered from macosx:
-;;   cat /etc/apache2/mime.types | grep -v '^#' | perl -ne 'print "(\"$2\" . \"$1\")\n" if /(\S+)\s+(\S+)/' > mimetypes.scm
-;; + manual manipulation
-
-(define ducttape_ext2mimetype '(("ez" . "application/andrew-inset")
-("aw" . "application/applixware")
-("atom" . "application/atom+xml")
-("atomcat" . "application/atomcat+xml")
-("atomsvc" . "application/atomsvc+xml")
-("ccxml" . "application/ccxml+xml")
-("cdmia" . "application/cdmi-capability")
-("cdmic" . "application/cdmi-container")
-("cdmid" . "application/cdmi-domain")
-("cdmio" . "application/cdmi-object")
-("cdmiq" . "application/cdmi-queue")
-("cu" . "application/cu-seeme")
-("davmount" . "application/davmount+xml")
-("dbk" . "application/docbook+xml")
-("dssc" . "application/dssc+der")
-("xdssc" . "application/dssc+xml")
-("ecma" . "application/ecmascript")
-("emma" . "application/emma+xml")
-("epub" . "application/epub+zip")
-("exi" . "application/exi")
-("pfr" . "application/font-tdpfr")
-("gml" . "application/gml+xml")
-("gpx" . "application/gpx+xml")
-("gxf" . "application/gxf")
-("stk" . "application/hyperstudio")
-("ink" . "application/inkml+xml")
-("ipfix" . "application/ipfix")
-("jar" . "application/java-archive")
-("ser" . "application/java-serialized-object")
-("class" . "application/java-vm")
-("js" . "application/javascript")
-("json" . "application/json")
-("jsonml" . "application/jsonml+json")
-("lostxml" . "application/lost+xml")
-("hqx" . "application/mac-binhex40")
-("cpt" . "application/mac-compactpro")
-("mads" . "application/mads+xml")
-("mrc" . "application/marc")
-("mrcx" . "application/marcxml+xml")
-("ma" . "application/mathematica")
-("mathml" . "application/mathml+xml")
-("mbox" . "application/mbox")
-("mscml" . "application/mediaservercontrol+xml")
-("metalink" . "application/metalink+xml")
-("meta4" . "application/metalink4+xml")
-("mets" . "application/mets+xml")
-("mods" . "application/mods+xml")
-("m21" . "application/mp21")
-("mp4s" . "application/mp4")
-("doc" . "application/msword")
-("mxf" . "application/mxf")
-("bin" . "application/octet-stream")
-("oda" . "application/oda")
-("opf" . "application/oebps-package+xml")
-("ogx" . "application/ogg")
-("omdoc" . "application/omdoc+xml")
-("onetoc" . "application/onenote")
-("oxps" . "application/oxps")
-("xer" . "application/patch-ops-error+xml")
-("pdf" . "application/pdf")
-("pgp" . "application/pgp-encrypted")
-("asc" . "application/pgp-signature")
-("prf" . "application/pics-rules")
-("p10" . "application/pkcs10")
-("p7m" . "application/pkcs7-mime")
-("p7s" . "application/pkcs7-signature")
-("p8" . "application/pkcs8")
-("ac" . "application/pkix-attr-cert")
-("cer" . "application/pkix-cert")
-("crl" . "application/pkix-crl")
-("pkipath" . "application/pkix-pkipath")
-("pki" . "application/pkixcmp")
-("pls" . "application/pls+xml")
-("ai" . "application/postscript")
-("cww" . "application/prs.cww")
-("pskcxml" . "application/pskc+xml")
-("rdf" . "application/rdf+xml")
-("rif" . "application/reginfo+xml")
-("rnc" . "application/relax-ng-compact-syntax")
-("rl" . "application/resource-lists+xml")
-("rld" . "application/resource-lists-diff+xml")
-("rs" . "application/rls-services+xml")
-("gbr" . "application/rpki-ghostbusters")
-("mft" . "application/rpki-manifest")
-("roa" . "application/rpki-roa")
-("rsd" . "application/rsd+xml")
-("rss" . "application/rss+xml")
-("rtf" . "application/rtf")
-("sbml" . "application/sbml+xml")
-("scq" . "application/scvp-cv-request")
-("scs" . "application/scvp-cv-response")
-("spq" . "application/scvp-vp-request")
-("spp" . "application/scvp-vp-response")
-("sdp" . "application/sdp")
-("setpay" . "application/set-payment-initiation")
-("setreg" . "application/set-registration-initiation")
-("shf" . "application/shf+xml")
-("smi" . "application/smil+xml")
-("rq" . "application/sparql-query")
-("srx" . "application/sparql-results+xml")
-("gram" . "application/srgs")
-("grxml" . "application/srgs+xml")
-("sru" . "application/sru+xml")
-("ssdl" . "application/ssdl+xml")
-("ssml" . "application/ssml+xml")
-("tei" . "application/tei+xml")
-("tfi" . "application/thraud+xml")
-("tsd" . "application/timestamped-data")
-("plb" . "application/vnd.3gpp.pic-bw-large")
-("psb" . "application/vnd.3gpp.pic-bw-small")
-("pvb" . "application/vnd.3gpp.pic-bw-var")
-("tcap" . "application/vnd.3gpp2.tcap")
-("pwn" . "application/vnd.3m.post-it-notes")
-("aso" . "application/vnd.accpac.simply.aso")
-("imp" . "application/vnd.accpac.simply.imp")
-("acu" . "application/vnd.acucobol")
-("atc" . "application/vnd.acucorp")
-("air" . "application/vnd.adobe.air-application-installer-package+zip")
-("fcdt" . "application/vnd.adobe.formscentral.fcdt")
-("fxp" . "application/vnd.adobe.fxp")
-("xdp" . "application/vnd.adobe.xdp+xml")
-("xfdf" . "application/vnd.adobe.xfdf")
-("ahead" . "application/vnd.ahead.space")
-("azf" . "application/vnd.airzip.filesecure.azf")
-("azs" . "application/vnd.airzip.filesecure.azs")
-("azw" . "application/vnd.amazon.ebook")
-("acc" . "application/vnd.americandynamics.acc")
-("ami" . "application/vnd.amiga.ami")
-("apk" . "application/vnd.android.package-archive")
-("cii" . "application/vnd.anser-web-certificate-issue-initiation")
-("fti" . "application/vnd.anser-web-funds-transfer-initiation")
-("atx" . "application/vnd.antix.game-component")
-("mpkg" . "application/vnd.apple.installer+xml")
-("m3u8" . "application/vnd.apple.mpegurl")
-("swi" . "application/vnd.aristanetworks.swi")
-("iota" . "application/vnd.astraea-software.iota")
-("aep" . "application/vnd.audiograph")
-("mpm" . "application/vnd.blueice.multipass")
-("bmi" . "application/vnd.bmi")
-("rep" . "application/vnd.businessobjects")
-("cdxml" . "application/vnd.chemdraw+xml")
-("mmd" . "application/vnd.chipnuts.karaoke-mmd")
-("cdy" . "application/vnd.cinderella")
-("cla" . "application/vnd.claymore")
-("rp9" . "application/vnd.cloanto.rp9")
-("c4g" . "application/vnd.clonk.c4group")
-("c11amc" . "application/vnd.cluetrust.cartomobile-config")
-("c11amz" . "application/vnd.cluetrust.cartomobile-config-pkg")
-("csp" . "application/vnd.commonspace")
-("cdbcmsg" . "application/vnd.contact.cmsg")
-("cmc" . "application/vnd.cosmocaller")
-("clkx" . "application/vnd.crick.clicker")
-("clkk" . "application/vnd.crick.clicker.keyboard")
-("clkp" . "application/vnd.crick.clicker.palette")
-("clkt" . "application/vnd.crick.clicker.template")
-("clkw" . "application/vnd.crick.clicker.wordbank")
-("wbs" . "application/vnd.criticaltools.wbs+xml")
-("pml" . "application/vnd.ctc-posml")
-("ppd" . "application/vnd.cups-ppd")
-("car" . "application/vnd.curl.car")
-("pcurl" . "application/vnd.curl.pcurl")
-("dart" . "application/vnd.dart")
-("rdz" . "application/vnd.data-vision.rdz")
-("uvf" . "application/vnd.dece.data")
-("uvt" . "application/vnd.dece.ttml+xml")
-("uvx" . "application/vnd.dece.unspecified")
-("uvz" . "application/vnd.dece.zip")
-("fe_launch" . "application/vnd.denovo.fcselayout-link")
-("dna" . "application/vnd.dna")
-("mlp" . "application/vnd.dolby.mlp")
-("dpg" . "application/vnd.dpgraph")
-("dfac" . "application/vnd.dreamfactory")
-("kpxx" . "application/vnd.ds-keypoint")
-("ait" . "application/vnd.dvb.ait")
-("svc" . "application/vnd.dvb.service")
-("geo" . "application/vnd.dynageo")
-("mag" . "application/vnd.ecowin.chart")
-("nml" . "application/vnd.enliven")
-("esf" . "application/vnd.epson.esf")
-("msf" . "application/vnd.epson.msf")
-("qam" . "application/vnd.epson.quickanime")
-("slt" . "application/vnd.epson.salt")
-("ssf" . "application/vnd.epson.ssf")
-("es3" . "application/vnd.eszigno3+xml")
-("ez2" . "application/vnd.ezpix-album")
-("ez3" . "application/vnd.ezpix-package")
-("fdf" . "application/vnd.fdf")
-("mseed" . "application/vnd.fdsn.mseed")
-("seed" . "application/vnd.fdsn.seed")
-("gph" . "application/vnd.flographit")
-("ftc" . "application/vnd.fluxtime.clip")
-("fm" . "application/vnd.framemaker")
-("fnc" . "application/vnd.frogans.fnc")
-("ltf" . "application/vnd.frogans.ltf")
-("fsc" . "application/vnd.fsc.weblaunch")
-("oas" . "application/vnd.fujitsu.oasys")
-("oa2" . "application/vnd.fujitsu.oasys2")
-("oa3" . "application/vnd.fujitsu.oasys3")
-("fg5" . "application/vnd.fujitsu.oasysgp")
-("bh2" . "application/vnd.fujitsu.oasysprs")
-("ddd" . "application/vnd.fujixerox.ddd")
-("xdw" . "application/vnd.fujixerox.docuworks")
-("xbd" . "application/vnd.fujixerox.docuworks.binder")
-("fzs" . "application/vnd.fuzzysheet")
-("txd" . "application/vnd.genomatix.tuxedo")
-("ggb" . "application/vnd.geogebra.file")
-("ggt" . "application/vnd.geogebra.tool")
-("gex" . "application/vnd.geometry-explorer")
-("gxt" . "application/vnd.geonext")
-("g2w" . "application/vnd.geoplan")
-("g3w" . "application/vnd.geospace")
-("gmx" . "application/vnd.gmx")
-("kml" . "application/vnd.google-earth.kml+xml")
-("kmz" . "application/vnd.google-earth.kmz")
-("gqf" . "application/vnd.grafeq")
-("gac" . "application/vnd.groove-account")
-("ghf" . "application/vnd.groove-help")
-("gim" . "application/vnd.groove-identity-message")
-("grv" . "application/vnd.groove-injector")
-("gtm" . "application/vnd.groove-tool-message")
-("tpl" . "application/vnd.groove-tool-template")
-("vcg" . "application/vnd.groove-vcard")
-("hal" . "application/vnd.hal+xml")
-("zmm" . "application/vnd.handheld-entertainment+xml")
-("hbci" . "application/vnd.hbci")
-("les" . "application/vnd.hhe.lesson-player")
-("hpgl" . "application/vnd.hp-hpgl")
-("hpid" . "application/vnd.hp-hpid")
-("hps" . "application/vnd.hp-hps")
-("jlt" . "application/vnd.hp-jlyt")
-("pcl" . "application/vnd.hp-pcl")
-("pclxl" . "application/vnd.hp-pclxl")
-("sfd-hdstx" . "application/vnd.hydrostatix.sof-data")
-("mpy" . "application/vnd.ibm.minipay")
-("afp" . "application/vnd.ibm.modcap")
-("irm" . "application/vnd.ibm.rights-management")
-("sc" . "application/vnd.ibm.secure-container")
-("icc" . "application/vnd.iccprofile")
-("igl" . "application/vnd.igloader")
-("ivp" . "application/vnd.immervision-ivp")
-("ivu" . "application/vnd.immervision-ivu")
-("igm" . "application/vnd.insors.igm")
-("xpw" . "application/vnd.intercon.formnet")
-("i2g" . "application/vnd.intergeo")
-("qbo" . "application/vnd.intu.qbo")
-("qfx" . "application/vnd.intu.qfx")
-("rcprofile" . "application/vnd.ipunplugged.rcprofile")
-("irp" . "application/vnd.irepository.package+xml")
-("xpr" . "application/vnd.is-xpr")
-("fcs" . "application/vnd.isac.fcs")
-("jam" . "application/vnd.jam")
-("rms" . "application/vnd.jcp.javame.midlet-rms")
-("jisp" . "application/vnd.jisp")
-("joda" . "application/vnd.joost.joda-archive")
-("ktz" . "application/vnd.kahootz")
-("karbon" . "application/vnd.kde.karbon")
-("chrt" . "application/vnd.kde.kchart")
-("kfo" . "application/vnd.kde.kformula")
-("flw" . "application/vnd.kde.kivio")
-("kon" . "application/vnd.kde.kontour")
-("kpr" . "application/vnd.kde.kpresenter")
-("ksp" . "application/vnd.kde.kspread")
-("kwd" . "application/vnd.kde.kword")
-("htke" . "application/vnd.kenameaapp")
-("kia" . "application/vnd.kidspiration")
-("kne" . "application/vnd.kinar")
-("skp" . "application/vnd.koan")
-("sse" . "application/vnd.kodak-descriptor")
-("lasxml" . "application/vnd.las.las+xml")
-("lbd" . "application/vnd.llamagraphics.life-balance.desktop")
-("lbe" . "application/vnd.llamagraphics.life-balance.exchange+xml")
-("123" . "application/vnd.lotus-1-2-3")
-("apr" . "application/vnd.lotus-approach")
-("pre" . "application/vnd.lotus-freelance")
-("nsf" . "application/vnd.lotus-notes")
-("org" . "application/vnd.lotus-organizer")
-("scm" . "application/vnd.lotus-screencam")
-("lwp" . "application/vnd.lotus-wordpro")
-("portpkg" . "application/vnd.macports.portpkg")
-("mcd" . "application/vnd.mcd")
-("mc1" . "application/vnd.medcalcdata")
-("cdkey" . "application/vnd.mediastation.cdkey")
-("mwf" . "application/vnd.mfer")
-("mfm" . "application/vnd.mfmp")
-("flo" . "application/vnd.micrografx.flo")
-("igx" . "application/vnd.micrografx.igx")
-("mif" . "application/vnd.mif")
-("daf" . "application/vnd.mobius.daf")
-("dis" . "application/vnd.mobius.dis")
-("mbk" . "application/vnd.mobius.mbk")
-("mqy" . "application/vnd.mobius.mqy")
-("msl" . "application/vnd.mobius.msl")
-("plc" . "application/vnd.mobius.plc")
-("txf" . "application/vnd.mobius.txf")
-("mpn" . "application/vnd.mophun.application")
-("mpc" . "application/vnd.mophun.certificate")
-("xul" . "application/vnd.mozilla.xul+xml")
-("cil" . "application/vnd.ms-artgalry")
-("cab" . "application/vnd.ms-cab-compressed")
-("xls" . "application/vnd.ms-excel")
-("xlam" . "application/vnd.ms-excel.addin.macroenabled.12")
-("xlsb" . "application/vnd.ms-excel.sheet.binary.macroenabled.12")
-("xlsm" . "application/vnd.ms-excel.sheet.macroenabled.12")
-("xltm" . "application/vnd.ms-excel.template.macroenabled.12")
-("eot" . "application/vnd.ms-fontobject")
-("chm" . "application/vnd.ms-htmlhelp")
-("ims" . "application/vnd.ms-ims")
-("lrm" . "application/vnd.ms-lrm")
-("thmx" . "application/vnd.ms-officetheme")
-("cat" . "application/vnd.ms-pki.seccat")
-("stl" . "application/vnd.ms-pki.stl")
-("ppt" . "application/vnd.ms-powerpoint")
-("ppam" . "application/vnd.ms-powerpoint.addin.macroenabled.12")
-("pptm" . "application/vnd.ms-powerpoint.presentation.macroenabled.12")
-("sldm" . "application/vnd.ms-powerpoint.slide.macroenabled.12")
-("ppsm" . "application/vnd.ms-powerpoint.slideshow.macroenabled.12")
-("potm" . "application/vnd.ms-powerpoint.template.macroenabled.12")
-("mpp" . "application/vnd.ms-project")
-("docm" . "application/vnd.ms-word.document.macroenabled.12")
-("dotm" . "application/vnd.ms-word.template.macroenabled.12")
-("wps" . "application/vnd.ms-works")
-("wpl" . "application/vnd.ms-wpl")
-("xps" . "application/vnd.ms-xpsdocument")
-("mseq" . "application/vnd.mseq")
-("mus" . "application/vnd.musician")
-("msty" . "application/vnd.muvee.style")
-("taglet" . "application/vnd.mynfc")
-("nlu" . "application/vnd.neurolanguage.nlu")
-("ntf" . "application/vnd.nitf")
-("nnd" . "application/vnd.noblenet-directory")
-("nns" . "application/vnd.noblenet-sealer")
-("nnw" . "application/vnd.noblenet-web")
-("ngdat" . "application/vnd.nokia.n-gage.data")
-("n-gage" . "application/vnd.nokia.n-gage.symbian.install")
-("rpst" . "application/vnd.nokia.radio-preset")
-("rpss" . "application/vnd.nokia.radio-presets")
-("edm" . "application/vnd.novadigm.edm")
-("edx" . "application/vnd.novadigm.edx")
-("ext" . "application/vnd.novadigm.ext")
-("odc" . "application/vnd.oasis.opendocument.chart")
-("otc" . "application/vnd.oasis.opendocument.chart-template")
-("odb" . "application/vnd.oasis.opendocument.database")
-("odf" . "application/vnd.oasis.opendocument.formula")
-("odft" . "application/vnd.oasis.opendocument.formula-template")
-("odg" . "application/vnd.oasis.opendocument.graphics")
-("otg" . "application/vnd.oasis.opendocument.graphics-template")
-("odi" . "application/vnd.oasis.opendocument.image")
-("oti" . "application/vnd.oasis.opendocument.image-template")
-("odp" . "application/vnd.oasis.opendocument.presentation")
-("otp" . "application/vnd.oasis.opendocument.presentation-template")
-("ods" . "application/vnd.oasis.opendocument.spreadsheet")
-("ots" . "application/vnd.oasis.opendocument.spreadsheet-template")
-("odt" . "application/vnd.oasis.opendocument.text")
-("odm" . "application/vnd.oasis.opendocument.text-master")
-("ott" . "application/vnd.oasis.opendocument.text-template")
-("oth" . "application/vnd.oasis.opendocument.text-web")
-("xo" . "application/vnd.olpc-sugar")
-("dd2" . "application/vnd.oma.dd2+xml")
-("oxt" . "application/vnd.openofficeorg.extension")
-("pptx" . "application/vnd.openxmlformats-officedocument.presentationml.presentation")
-("sldx" . "application/vnd.openxmlformats-officedocument.presentationml.slide")
-("ppsx" . "application/vnd.openxmlformats-officedocument.presentationml.slideshow")
-("potx" . "application/vnd.openxmlformats-officedocument.presentationml.template")
-("xlsx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet")
-("xltx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.template")
-("docx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.document")
-("dotx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.template")
-("mgp" . "application/vnd.osgeo.mapguide.package")
-("dp" . "application/vnd.osgi.dp")
-("esa" . "application/vnd.osgi.subsystem")
-("pdb" . "application/vnd.palm")
-("paw" . "application/vnd.pawaafile")
-("str" . "application/vnd.pg.format")
-("ei6" . "application/vnd.pg.osasli")
-("efif" . "application/vnd.picsel")
-("wg" . "application/vnd.pmi.widget")
-("plf" . "application/vnd.pocketlearn")
-("pbd" . "application/vnd.powerbuilder6")
-("box" . "application/vnd.previewsystems.box")
-("mgz" . "application/vnd.proteus.magazine")
-("qps" . "application/vnd.publishare-delta-tree")
-("ptid" . "application/vnd.pvi.ptid1")
-("qxd" . "application/vnd.quark.quarkxpress")
-("bed" . "application/vnd.realvnc.bed")
-("mxl" . "application/vnd.recordare.musicxml")
-("musicxml" . "application/vnd.recordare.musicxml+xml")
-("cryptonote" . "application/vnd.rig.cryptonote")
-("cod" . "application/vnd.rim.cod")
-("rm" . "application/vnd.rn-realmedia")
-("rmvb" . "application/vnd.rn-realmedia-vbr")
-("link66" . "application/vnd.route66.link66+xml")
-("st" . "application/vnd.sailingtracker.track")
-("see" . "application/vnd.seemail")
-("sema" . "application/vnd.sema")
-("semd" . "application/vnd.semd")
-("semf" . "application/vnd.semf")
-("ifm" . "application/vnd.shana.informed.formdata")
-("itp" . "application/vnd.shana.informed.formtemplate")
-("iif" . "application/vnd.shana.informed.interchange")
-("ipk" . "application/vnd.shana.informed.package")
-("twd" . "application/vnd.simtech-mindmapper")
-("mmf" . "application/vnd.smaf")
-("teacher" . "application/vnd.smart.teacher")
-("sdkm" . "application/vnd.solent.sdkm+xml")
-("dxp" . "application/vnd.spotfire.dxp")
-("sfs" . "application/vnd.spotfire.sfs")
-("sdc" . "application/vnd.stardivision.calc")
-("sda" . "application/vnd.stardivision.draw")
-("sdd" . "application/vnd.stardivision.impress")
-("smf" . "application/vnd.stardivision.math")
-("sdw" . "application/vnd.stardivision.writer")
-("sgl" . "application/vnd.stardivision.writer-global")
-("smzip" . "application/vnd.stepmania.package")
-("sm" . "application/vnd.stepmania.stepchart")
-("sxc" . "application/vnd.sun.xml.calc")
-("stc" . "application/vnd.sun.xml.calc.template")
-("sxd" . "application/vnd.sun.xml.draw")
-("std" . "application/vnd.sun.xml.draw.template")
-("sxi" . "application/vnd.sun.xml.impress")
-("sti" . "application/vnd.sun.xml.impress.template")
-("sxm" . "application/vnd.sun.xml.math")
-("sxw" . "application/vnd.sun.xml.writer")
-("sxg" . "application/vnd.sun.xml.writer.global")
-("stw" . "application/vnd.sun.xml.writer.template")
-("sus" . "application/vnd.sus-calendar")
-("svd" . "application/vnd.svd")
-("sis" . "application/vnd.symbian.install")
-("xsm" . "application/vnd.syncml+xml")
-("bdm" . "application/vnd.syncml.dm+wbxml")
-("xdm" . "application/vnd.syncml.dm+xml")
-("tao" . "application/vnd.tao.intent-module-archive")
-("pcap" . "application/vnd.tcpdump.pcap")
-("tmo" . "application/vnd.tmobile-livetv")
-("tpt" . "application/vnd.trid.tpt")
-("mxs" . "application/vnd.triscape.mxs")
-("tra" . "application/vnd.trueapp")
-("ufd" . "application/vnd.ufdl")
-("utz" . "application/vnd.uiq.theme")
-("umj" . "application/vnd.umajin")
-("unityweb" . "application/vnd.unity")
-("uoml" . "application/vnd.uoml+xml")
-("vcx" . "application/vnd.vcx")
-("vsd" . "application/vnd.visio")
-("vis" . "application/vnd.visionary")
-("vsf" . "application/vnd.vsf")
-("wbxml" . "application/vnd.wap.wbxml")
-("wmlc" . "application/vnd.wap.wmlc")
-("wmlsc" . "application/vnd.wap.wmlscriptc")
-("wtb" . "application/vnd.webturbo")
-("nbp" . "application/vnd.wolfram.player")
-("wpd" . "application/vnd.wordperfect")
-("wqd" . "application/vnd.wqd")
-("stf" . "application/vnd.wt.stf")
-("xar" . "application/vnd.xara")
-("xfdl" . "application/vnd.xfdl")
-("hvd" . "application/vnd.yamaha.hv-dic")
-("hvs" . "application/vnd.yamaha.hv-script")
-("hvp" . "application/vnd.yamaha.hv-voice")
-("osf" . "application/vnd.yamaha.openscoreformat")
-("osfpvg" . "application/vnd.yamaha.openscoreformat.osfpvg+xml")
-("saf" . "application/vnd.yamaha.smaf-audio")
-("spf" . "application/vnd.yamaha.smaf-phrase")
-("cmp" . "application/vnd.yellowriver-custom-menu")
-("zir" . "application/vnd.zul")
-("zaz" . "application/vnd.zzazz.deck+xml")
-("vxml" . "application/voicexml+xml")
-("wgt" . "application/widget")
-("hlp" . "application/winhlp")
-("wsdl" . "application/wsdl+xml")
-("wspolicy" . "application/wspolicy+xml")
-("7z" . "application/x-7z-compressed")
-("abw" . "application/x-abiword")
-("ace" . "application/x-ace-compressed")
-("dmg" . "application/x-apple-diskimage")
-("aab" . "application/x-authorware-bin")
-("aam" . "application/x-authorware-map")
-("aas" . "application/x-authorware-seg")
-("bcpio" . "application/x-bcpio")
-("torrent" . "application/x-bittorrent")
-("blb" . "application/x-blorb")
-("bz" . "application/x-bzip")
-("bz2" . "application/x-bzip2")
-("cbr" . "application/x-cbr")
-("vcd" . "application/x-cdlink")
-("cfs" . "application/x-cfs-compressed")
-("chat" . "application/x-chat")
-("pgn" . "application/x-chess-pgn")
-("nsc" . "application/x-conference")
-("cpio" . "application/x-cpio")
-("csh" . "application/x-csh")
-("deb" . "application/x-debian-package")
-("dgc" . "application/x-dgc-compressed")
-("dir" . "application/x-director")
-("wad" . "application/x-doom")
-("ncx" . "application/x-dtbncx+xml")
-("dtb" . "application/x-dtbook+xml")
-("res" . "application/x-dtbresource+xml")
-("dvi" . "application/x-dvi")
-("evy" . "application/x-envoy")
-("eva" . "application/x-eva")
-("bdf" . "application/x-font-bdf")
-("gsf" . "application/x-font-ghostscript")
-("psf" . "application/x-font-linux-psf")
-("otf" . "application/x-font-otf")
-("pcf" . "application/x-font-pcf")
-("snf" . "application/x-font-snf")
-("ttf" . "application/x-font-ttf")
-("pfa" . "application/x-font-type1")
-("woff" . "application/x-font-woff")
-("arc" . "application/x-freearc")
-("spl" . "application/x-futuresplash")
-("gca" . "application/x-gca-compressed")
-("ulx" . "application/x-glulx")
-("gnumeric" . "application/x-gnumeric")
-("gramps" . "application/x-gramps-xml")
-("gtar" . "application/x-gtar")
-("hdf" . "application/x-hdf")
-("install" . "application/x-install-instructions")
-("iso" . "application/x-iso9660-image")
-("jnlp" . "application/x-java-jnlp-file")
-("latex" . "application/x-latex")
-("lzh" . "application/x-lzh-compressed")
-("mie" . "application/x-mie")
-("prc" . "application/x-mobipocket-ebook")
-("m3u8" . "application/x-mpegurl")
-("application" . "application/x-ms-application")
-("lnk" . "application/x-ms-shortcut")
-("wmd" . "application/x-ms-wmd")
-("wmz" . "application/x-ms-wmz")
-("xbap" . "application/x-ms-xbap")
-("mdb" . "application/x-msaccess")
-("obd" . "application/x-msbinder")
-("crd" . "application/x-mscardfile")
-("clp" . "application/x-msclip")
-("exe" . "application/x-msdownload")
-("mvb" . "application/x-msmediaview")
-("wmf" . "application/x-msmetafile")
-("mny" . "application/x-msmoney")
-("pub" . "application/x-mspublisher")
-("scd" . "application/x-msschedule")
-("trm" . "application/x-msterminal")
-("wri" . "application/x-mswrite")
-("nc" . "application/x-netcdf")
-("nzb" . "application/x-nzb")
-("p12" . "application/x-pkcs12")
-("p7b" . "application/x-pkcs7-certificates")
-("p7r" . "application/x-pkcs7-certreqresp")
-("rar" . "application/x-rar-compressed")
-("ris" . "application/x-research-info-systems")
-("sh" . "application/x-sh")
-("shar" . "application/x-shar")
-("swf" . "application/x-shockwave-flash")
-("xap" . "application/x-silverlight-app")
-("sql" . "application/x-sql")
-("sit" . "application/x-stuffit")
-("sitx" . "application/x-stuffitx")
-("srt" . "application/x-subrip")
-("sv4cpio" . "application/x-sv4cpio")
-("sv4crc" . "application/x-sv4crc")
-("t3" . "application/x-t3vm-image")
-("gam" . "application/x-tads")
-("tar" . "application/x-tar")
-("tcl" . "application/x-tcl")
-("tex" . "application/x-tex")
-("tfm" . "application/x-tex-tfm")
-("texinfo" . "application/x-texinfo")
-("obj" . "application/x-tgif")
-("ustar" . "application/x-ustar")
-("src" . "application/x-wais-source")
-("der" . "application/x-x509-ca-cert")
-("fig" . "application/x-xfig")
-("xlf" . "application/x-xliff+xml")
-("xpi" . "application/x-xpinstall")
-("xz" . "application/x-xz")
-("z1" . "application/x-zmachine")
-("xaml" . "application/xaml+xml")
-("xdf" . "application/xcap-diff+xml")
-("xenc" . "application/xenc+xml")
-("xhtml" . "application/xhtml+xml")
-("xml" . "application/xml")
-("dtd" . "application/xml-dtd")
-("xop" . "application/xop+xml")
-("xpl" . "application/xproc+xml")
-("xslt" . "application/xslt+xml")
-("xspf" . "application/xspf+xml")
-("mxml" . "application/xv+xml")
-("yang" . "application/yang")
-("yin" . "application/yin+xml")
-("zip" . "application/zip")
-("adp" . "audio/adpcm")
-("au" . "audio/basic")
-("mid" . "audio/midi")
-("mp4a" . "audio/mp4")
-("m4a" . "audio/mp4a-latm")
-("mpga" . "audio/mpeg")
-("oga" . "audio/ogg")
-("s3m" . "audio/s3m")
-("sil" . "audio/silk")
-("uva" . "audio/vnd.dece.audio")
-("eol" . "audio/vnd.digital-winds")
-("dra" . "audio/vnd.dra")
-("dts" . "audio/vnd.dts")
-("dtshd" . "audio/vnd.dts.hd")
-("lvp" . "audio/vnd.lucent.voice")
-("pya" . "audio/vnd.ms-playready.media.pya")
-("ecelp4800" . "audio/vnd.nuera.ecelp4800")
-("ecelp7470" . "audio/vnd.nuera.ecelp7470")
-("ecelp9600" . "audio/vnd.nuera.ecelp9600")
-("rip" . "audio/vnd.rip")
-("weba" . "audio/webm")
-("aac" . "audio/x-aac")
-("aif" . "audio/x-aiff")
-("caf" . "audio/x-caf")
-("flac" . "audio/x-flac")
-("mka" . "audio/x-matroska")
-("m3u" . "audio/x-mpegurl")
-("wax" . "audio/x-ms-wax")
-("wma" . "audio/x-ms-wma")
-("ram" . "audio/x-pn-realaudio")
-("rmp" . "audio/x-pn-realaudio-plugin")
-("wav" . "audio/x-wav")
-("xm" . "audio/xm")
-("cdx" . "chemical/x-cdx")
-("cif" . "chemical/x-cif")
-("cmdf" . "chemical/x-cmdf")
-("cml" . "chemical/x-cml")
-("csml" . "chemical/x-csml")
-("xyz" . "chemical/x-xyz")
-("bmp" . "image/bmp")
-("cgm" . "image/cgm")
-("g3" . "image/g3fax")
-("gif" . "image/gif")
-("ief" . "image/ief")
-("jp2" . "image/jp2")
-("jpeg" . "image/jpeg")
-("ktx" . "image/ktx")
-("pict" . "image/pict")
-("png" . "image/png")
-("btif" . "image/prs.btif")
-("sgi" . "image/sgi")
-("svg" . "image/svg+xml")
-("tiff" . "image/tiff")
-("psd" . "image/vnd.adobe.photoshop")
-("uvi" . "image/vnd.dece.graphic")
-("sub" . "image/vnd.dvb.subtitle")
-("djvu" . "image/vnd.djvu")
-("dwg" . "image/vnd.dwg")
-("dxf" . "image/vnd.dxf")
-("fbs" . "image/vnd.fastbidsheet")
-("fpx" . "image/vnd.fpx")
-("fst" . "image/vnd.fst")
-("mmr" . "image/vnd.fujixerox.edmics-mmr")
-("rlc" . "image/vnd.fujixerox.edmics-rlc")
-("mdi" . "image/vnd.ms-modi")
-("wdp" . "image/vnd.ms-photo")
-("npx" . "image/vnd.net-fpx")
-("wbmp" . "image/vnd.wap.wbmp")
-("xif" . "image/vnd.xiff")
-("webp" . "image/webp")
-("3ds" . "image/x-3ds")
-("ras" . "image/x-cmu-raster")
-("cmx" . "image/x-cmx")
-("fh" . "image/x-freehand")
-("ico" . "image/x-icon")
-("pntg" . "image/x-macpaint")
-("sid" . "image/x-mrsid-image")
-("pcx" . "image/x-pcx")
-("pic" . "image/x-pict")
-("pnm" . "image/x-portable-anymap")
-("pbm" . "image/x-portable-bitmap")
-("pgm" . "image/x-portable-graymap")
-("ppm" . "image/x-portable-pixmap")
-("qtif" . "image/x-quicktime")
-("rgb" . "image/x-rgb")
-("tga" . "image/x-tga")
-("xbm" . "image/x-xbitmap")
-("xpm" . "image/x-xpixmap")
-("xwd" . "image/x-xwindowdump")
-("eml" . "message/rfc822")
-("igs" . "model/iges")
-("msh" . "model/mesh")
-("dae" . "model/vnd.collada+xml")
-("dwf" . "model/vnd.dwf")
-("gdl" . "model/vnd.gdl")
-("gtw" . "model/vnd.gtw")
-("mts" . "model/vnd.mts")
-("vtu" . "model/vnd.vtu")
-("wrl" . "model/vrml")
-("x3db" . "model/x3d+binary")
-("x3dv" . "model/x3d+vrml")
-("x3d" . "model/x3d+xml")
-("manifest" . "text/cache-manifest")
-("appcache" . "text/cache-manifest")
-("ics" . "text/calendar")
-("css" . "text/css")
-("csv" . "text/csv")
-("html" . "text/html")
-("n3" . "text/n3")
-("txt" . "text/plain")
-("dsc" . "text/prs.lines.tag")
-("rtx" . "text/richtext")
-("sgml" . "text/sgml")
-("tsv" . "text/tab-separated-values")
-("t" . "text/troff")
-("ttl" . "text/turtle")
-("uri" . "text/uri-list")
-("vcard" . "text/vcard")
-("curl" . "text/vnd.curl")
-("dcurl" . "text/vnd.curl.dcurl")
-("scurl" . "text/vnd.curl.scurl")
-("mcurl" . "text/vnd.curl.mcurl")
-("sub" . "text/vnd.dvb.subtitle")
-("fly" . "text/vnd.fly")
-("flx" . "text/vnd.fmi.flexstor")
-("gv" . "text/vnd.graphviz")
-("3dml" . "text/vnd.in3d.3dml")
-("spot" . "text/vnd.in3d.spot")
-("jad" . "text/vnd.sun.j2me.app-descriptor")
-("wml" . "text/vnd.wap.wml")
-("wmls" . "text/vnd.wap.wmlscript")
-("s" . "text/x-asm")
-("c" . "text/x-c")
-("f" . "text/x-fortran")
-("java" . "text/x-java-source")
-("opml" . "text/x-opml")
-("p" . "text/x-pascal")
-("nfo" . "text/x-nfo")
-("etx" . "text/x-setext")
-("sfv" . "text/x-sfv")
-("uu" . "text/x-uuencode")
-("vcs" . "text/x-vcalendar")
-("vcf" . "text/x-vcard")
-("3gp" . "video/3gpp")
-("3g2" . "video/3gpp2")
-("h261" . "video/h261")
-("h263" . "video/h263")
-("h264" . "video/h264")
-("jpgv" . "video/jpeg")
-("jpm" . "video/jpm")
-("mj2" . "video/mj2")
-("ts" . "video/mp2t")
-("mp4" . "video/mp4")
-("mpeg" . "video/mpeg")
-("ogv" . "video/ogg")
-("qt" . "video/quicktime")
-("uvh" . "video/vnd.dece.hd")
-("uvm" . "video/vnd.dece.mobile")
-("uvp" . "video/vnd.dece.pd")
-("uvs" . "video/vnd.dece.sd")
-("uvv" . "video/vnd.dece.video")
-("dvb" . "video/vnd.dvb.file")
-("fvt" . "video/vnd.fvt")
-("mxu" . "video/vnd.mpegurl")
-("pyv" . "video/vnd.ms-playready.media.pyv")
-("uvu" . "video/vnd.uvvu.mp4")
-("viv" . "video/vnd.vivo")
-("dv" . "video/x-dv")
-("webm" . "video/webm")
-("f4v" . "video/x-f4v")
-("fli" . "video/x-fli")
-("flv" . "video/x-flv")
-("m4v" . "video/x-m4v")
-("mkv" . "video/x-matroska")
-("mng" . "video/x-mng")
-("asf" . "video/x-ms-asf")
-("vob" . "video/x-ms-vob")
-("wm" . "video/x-ms-wm")
-("wmv" . "video/x-ms-wmv")
-("wmx" . "video/x-ms-wmx")
-("wvx" . "video/x-ms-wvx")
-("avi" . "video/x-msvideo")
-("movie" . "video/x-sgi-movie")
-("smv" . "video/x-smv")
-("ice" . "x-conference/x-cooltalk")))
-
-(define (ext->mimetype ext)
-  (let ((x (assoc ext ducttape_ext2mimetype)))
-   (if x (cdr x) "text/plain")))

DELETED ducttape/sample_ducttape.scm
Index: ducttape/sample_ducttape.scm
==================================================================
--- ducttape/sample_ducttape.scm
+++ /dev/null
@@ -1,4 +0,0 @@
-(include "ducttape-lib.scm")
-(import ducttape-lib)
-(inote "hello world")
-(exit 0)

DELETED ducttape/test_ducttape.scm
Index: ducttape/test_ducttape.scm
==================================================================
--- ducttape/test_ducttape.scm
+++ /dev/null
@@ -1,355 +0,0 @@
-#!/usr/bin/env csi -script
-(use test)
-(include "ducttape-lib.scm")
-(import ducttape-lib)
-(import ansi-escape-sequences)
-(use trace)
-(set! systype (do-or-die (if (file-exists? "/bin/uname") "/bin/uname" "/usr/bin/uname")))
-;(trace skim-cmdline-opts-withargs-by-regex)
-;(trace keyword-skim)
-;(trace re-match?)
-(define (reset-ducttape)
-  (unsetenv "DUCTTAPE_DEBUG_LEVEL")
-  (ducttape-debug-level #f)
-
-  (unsetenv "DUCTTAPE_DEBUG_PATTERN")
-  (ducttape-debug-regex-filter ".")
-
-  (unsetenv "DUCTTAPE_LOG_FILE")
-  (ducttape-log-file #f)
-
-  (unsetenv "DUCTTAPE_SILENT_MODE")
-  (ducttape-silent-mode #f)
-
-  (unsetenv "DUCTTAPE_QUIET_MODE")
-  (ducttape-quiet-mode #f)
-
-  (unsetenv "DUCTTAPE_COLOR_MODE")
-  (ducttape-color-mode #f)
-)
-
-(define (reset-ducttape-with-cmdline-list cmdline-list)
-  (reset-ducttape)
-
-  (command-line-arguments cmdline-list)
-  (ducttape-process-command-line)
-)
-
-
-(define (direct-iputs-test)
-  (ducttape-color-mode #f)
-  (ierr "I'm an error")
-  (iwarn "I'm a warning")
-  (inote "I'm a note")
-
-  (ducttape-debug-level 1)
-  (idbg "I'm a debug statement")
-  (ducttape-debug-level #f)
-  (idbg "I'm a hidden debug statement")
-
-  (ducttape-silent-mode #t)
-  (iwarn "I shouldn't show up")
-  (inote "I shouldn't show up either")
-  (ierr "I should show up 1")
-  (ducttape-silent-mode #f)
-
-  (ducttape-quiet-mode #t)
-  (iwarn "I should show up 2")
-  (inote "I shouldn't show up though")
-  (ierr "I should show up 3")
-  (ducttape-quiet-mode #f)
-
-  (ducttape-debug-level 1)
-  (idbg "foo")
-  (iputs "dbg" "debug message")
-  (iputs "e" "error message")
-  (iputs "w" "warning message")
-  (iputs "n" "note message")
-
-  (ducttape-color-mode #t)
-  (ierr "I'm an error COLOR")
-  (iwarn "I'm a warning COLOR")
-  (inote "I'm a note COLOR")
-  (idbg "I'm a debug COLOR")
-
-
-  )
-
-(define (test-argprocessor-funcs)
-  
-  (test-group
-   "Command line processor utility functions"
-
-   (set! testargs1 '( "-d" "-d" "-d3" "-ddd" "-foo" "fooarg" "-foo" "fooarg2" "-lastArgIsDecoy" "-foo"))
-   (command-line-arguments testargs1)
-   (set! expected_result '("-d" "-d" "-d3" "-ddd"))
-   (set! expected_sideeffect '("-foo" "fooarg" "-foo" "fooarg2" "-lastArgIsDecoy" "-foo"))
-
-   (test "skim-cmdline-opts-noarg-by-regex result" expected_result (skim-cmdline-opts-noarg-by-regex "-d(d+|\\d+)?"))
-   (test "skim-cmdline-opts-noarg-by-regex sideeffect" expected_sideeffect (command-line-arguments))
-
-
-  
-   (command-line-arguments testargs1)
-   (set! expected_result '("fooarg" "fooarg2" ))
-   (set! expected_sideeffect '( "-d" "-d" "-d3" "-ddd" "-lastArgIsDecoy" "-foo"))
-   (test
-    "skim-cmdline-opts-withargs-by-regex result"
-    expected_result
-    (skim-cmdline-opts-withargs-by-regex "--?foo"))
-   
-   (test
-    "skim-cmdline-opts-withargs-by-regex sideeffect"
-    expected_sideeffect
-    (command-line-arguments))
-
-   ))
-
-(define (test-misc)
-  (test-group
-   "misc"
-   (let ((tmpfile (mktemp)))
-     (test-assert "mktemp: temp file created" (file-exists? tmpfile))
-     (if (file-exists? tmpfile)
-         (delete-file tmpfile))
-
-     )))
-
-
-
-(define (test-systemstuff)
-  (test-group
-   "system commands"
-
-   (let-values (((ec o e) (isys (find-exe "true"))))
-     (test-assert "isys: /bin/true should have exit code 0" (equal? ec 0)))
-   (let-values (((ec o e) (isys (find-exe "false"))))
-     (test-assert "isys: /bin/false should have exit code 1" (equal? ec 1)))
-
-   (let-values (((ec o e) (isys "/bin/echo" "foo" "bar" "baz")))
-     (test-assert "isys: /bin/echo should have exit code 0" (equal? ec 0))
-     (test-assert "isys: /bin/echo should have stdout 'foo bar baz'" (equal? o "foo bar baz")))
-   
-   (let-values (((ec o e) (isys "/bin/ls /zzzzz")))
-     (let ((expected-code
-            (if (equal? systype "Darwin") 1 2))
-           (expected-err
-            (if (equal? systype "Darwin")
-                "ls: /zzzzz: No such file or directory"
-                "/bin/ls: cannot access /zzzzz: No such file or directory"))
-
-           )
-       (test "isys: /bin/ls /zzzzz should have exit code 2" expected-code ec)
-       (test "isys: /bin/ls /zzzzz should have empty stdout" "" o)
-       (test
-        "isys: /bin/ls /zzzzz should have stderr"
-        expected-err
-        e))
-     )
-
-   (let-values (((ec o e) (isys "/bin/ls /etc/passwd")))
-     (test "isys: /bin/ls /etc/passwd should have exit code 0" 0 ec)
-     (test "isys: /bin/ls /etc/passwd should have stdout" "/etc/passwd" o)
-     (test
-      "isys: /bin/ls /etc/passwd should have empty stderr"
-      ""
-      e))
-
-      (let ((res (do-or-die "/bin/ls /etc/passwd")))
-        (test
-         "do-or-die: ls /etc/passwd should work"
-         "/etc/passwd" res ))
-
-      (let ((res (do-or-die "/bin/ls /zzzzz" nodie: #t)))
-        (test
-         "do-or-die: ls /zzzzz should die"
-         #f res ))
-
-      ; test reading from process stdout line at a time
-      (let* (
-             (lineno (counter-maker))
-
-             ; print each line with an index
-             (eachline-fn (lambda (line)
-                         (print "GOTLINE " (lineno) "> " line)))
-
-             (res
-              (do-or-die "/bin/ls -l /etc | head; true"
-                         foreach-stdout: eachline-fn )))
-        
-        (test-assert "ls -l /etc should not be empty"
-                     (not (equal? res ""))))
-      ;; test writing to process stdout line at a time
-
-      (let* ((tmpfile (mktemp))
-             (cmd (conc "cat > " tmpfile)))
-        (let-values (((c o e)
-                      (isys cmd stdin-proc:
-                       (lambda (myport)
-                         (write-line "hello" myport)
-                         (write-line "hello2" myport)
-                         (close-output-port myport)))))
-          (test "isys-sp: cat should exit 0" 0 c)
-          (let ((mycmd (conc "cat " tmpfile)))
-            (test "isys-sp: cat output should match input" "hello\nhello2" (do-or-die mycmd)))
-
-          (delete-file tmpfile)
-        ))
-
-      (let* ((tmpfile (mktemp))
-             (cmd (conc "cat > " tmpfile)))
-        (do-or-die cmd stdin-proc:
-                   (lambda (myport)
-                     (write-line "hello" myport)
-                     (write-line "hello2" myport)
-                     (close-output-port myport))
-                   cmd)
-        (test "dod-sp: cat output should match input" "hello\nhello2" (do-or-die (conc "cat " tmpfile)))
-        (delete-file tmpfile))
-
-
-
-      
-
-      (let*
-          ((thefile (conc "/tmp/" (get-environment-variable "USER")  "9-lines"))
-           (counter (counter-maker))
-           (stdin-writer
-            (lambda ()
-              (if (< (counter) 10)
-                  (number->string (counter 0))
-                  #f)))
-            (cmd (conc "cat > " thefile)))
-        (let-values
-            (((c o e)
-              (isys cmd foreach-stdin-thunk: stdin-writer)))
-
-          (test-assert "isys-fsl: cat should return 0" (equal? c 0))
-
-          (test-assert
-           "isys-fsl: cat should have written a file"
-           (file-exists? thefile))
-          
-          (if
-           (file-exists? thefile)
-           (begin
-             (test "isys-fsl: cat file should have right contents" "1\n2\n3\n4\n5\n6\n7\n8\n9" (do-or-die (conc "cat " thefile)))
-             (delete-file thefile)))))
-      
-   ) ; end test-group
-  ) ; end define
-
-   
-(define (test-argprocessor )
-  (test-group
-   "Command line processor parameter settings"
-
-   (reset-ducttape-with-cmdline-list '())
-   (test-assert "(nil) debug mode should be off" (not (ducttape-debug-level)))
-   (test-assert "(nil): debug pattern should be '.'" (equal? "." (ducttape-debug-regex-filter)))
-   (test-assert "(nil): colors should be off" (not (ducttape-color-mode)))
-   (test-assert "(nil): silent mode should be off" (not (ducttape-silent-mode)))
-   (test-assert "(nil): quiet mode should be off" (not (ducttape-quiet-mode)))
-   (test-assert "(nil): logfile should be off" (not (ducttape-log-file)))
-
-   (reset-ducttape-with-cmdline-list '("-d"))
-   (test-assert "-d: debug mode should be on at level 1" (eq? 1 (ducttape-debug-level)))
-
-   (reset-ducttape-with-cmdline-list '("-dd"))
-   (test "-dd: debug level should be 2" 2 (ducttape-debug-level))
-
-   (reset-ducttape-with-cmdline-list '("-ddd"))
-   (test "-ddd: debug level should be 3" 3 (ducttape-debug-level))
-
-   (reset-ducttape-with-cmdline-list '("-d2"))
-   (test "-d2: debug level should be 2" 2 (ducttape-debug-level))
-
-   (reset-ducttape-with-cmdline-list '("-d3"))
-   (test "-d3: debug level should be 3" 3 (ducttape-debug-level))
-
-   (reset-ducttape-with-cmdline-list '("-dp" "foo"))
-   (test "-dp foo: debug pattern should be 'foo'" "foo" (ducttape-debug-regex-filter))
-
-   (reset-ducttape-with-cmdline-list '("--debug-pattern" "foo"))
-   (test "--debug-pattern foo: debug pattern should be 'foo'" "foo" (ducttape-debug-regex-filter))
-
-   (reset-ducttape-with-cmdline-list '("-dp" "foo" "-dp" "bar"))
-   (test "-dp foo -dp bar: debug pattern should be 'foo|bar'"  "foo|bar" (ducttape-debug-regex-filter))
-
-   (reset-ducttape-with-cmdline-list '("--quiet"))
-   (test-assert "-quiet: quiet mode should be active" (ducttape-quiet-mode))
-
-   (reset-ducttape-with-cmdline-list '("--silent"))
-   (test-assert "-silent: silent mode should be active" (ducttape-silent-mode))
-
-   (reset-ducttape-with-cmdline-list '("--color"))
-   (test-assert "-color: color mode should be active" (ducttape-color-mode))
-
-   (reset-ducttape-with-cmdline-list '("--log" "foo"))
-   (test "--log foo: logfile should be 'foo'" "foo" (ducttape-log-file))
-
-))
-
-(define (test-wwdate)
-  (test-group
-   "wwdate conversion tests"
-   (let ((test-table
-          '(("16ww01.5" . "2016-01-01")
-            ("16ww18.5" . "2016-04-29")
-            ("1999ww33.5" . "1999-08-13")
-            ("16ww18.4" . "2016-04-28")
-            ("16ww18.3" . "2016-04-27")
-            ("13ww01.0" . "2012-12-30")
-            ("13ww52.6" . "2013-12-28")
-            ("16ww53.3" . "2016-12-28"))))
-     (for-each
-      (lambda (test-pair)
-        (let ((wwdate (car test-pair))
-              (isodate (cdr test-pair)))
-          (test
-           (conc "(isodate->wwdate "isodate ") => "wwdate)
-           wwdate
-           (isodate->wwdate isodate))
-          
-          (test
-           (conc "(wwdate->isodate "wwdate ")   => "isodate)
-           isodate
-           (wwdate->isodate wwdate))))
-      test-table))))
-
-(define (main)
-  ;; (test <description; #f uses func prototype> <expected result> <thunk>)
-  
-;  (test-group "silly settext group"
-;              (test #f "\x1b[1mfoo\x1b[0m" (set-text (list 'bold) "foo"))
-;              (test "settext bold" "\x1b[1mfoo\x1b[0m" (set-text (list 'bold) "foo"))
-;              )
-
-  ; visually inspect this
-  (direct-iputs-test)
-
-  ; following use unit test test-egg
-  (reset-ducttape)
-  (test-argprocessor-funcs)
-  (reset-ducttape)
-  (test-argprocessor)
-  (test-systemstuff)
-  (test-misc)
-  (test-wwdate)
-  ) ; end main()
-
-(main)
-(sendmail "brandon.j.barclay@intel.com" "6hello subject"  "test body" )
-
-;(let* ((image-file "/nfs/site/home/bjbarcla/megatest-logo.png")
-;       (cid "mtlogo")
-;       (image-alist (list (cons image-file cid)))
-;       (body  (conc "Hello world<br /><img cid:"cid" alt=\"test image\"><br>bye!")))
-
-;  (sendmail "brandon.j.barclay@intel.com" "7hello subject"  body use_html: #t images-with-content-id-alist: image-alist)
-;  (print "sent image mail"))
-;(sendmail "bjbarcla" "2hello subject html"  "test body<h1>hello</h1><i>italics</i>" use_html: #t)
-;(sendmail "bb" "4hello attach subject html"  "<h2>hmm</h2>" use_html: #t attach-files-list: '( "/Users/bb/Downloads/wdmycloud-manual-4779-705103.pdf" ) )
-
-;(launch-repl)
-(test-exit)

DELETED ducttape/test_example.scm
Index: ducttape/test_example.scm
==================================================================
--- ducttape/test_example.scm
+++ /dev/null
@@ -1,3 +0,0 @@
-(use ducttape-lib)
-
-(inote "Hello world")

DELETED ducttape/useargs-example.scm
Index: ducttape/useargs-example.scm
==================================================================
--- ducttape/useargs-example.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-(use ducttape-lib)
-
-(let (
-      (customers (skim-cmdline-opts-withargs-by-regex "--cust(omer)?"))
-      (magicmode (skim-cmdline-opts-noarg-by-regex "--magic"))
-      )
-  (print "your customers are " customers)
-  (if (null? magicmode)
-      (print "no unicorns for you")
-      (print "magic!")
-  )
-  )
-
-(idbg "hello")
-(idbg "hello2" 2)
-(idbg "hello2" 3)
-(inote "note")
-(iwarn "warn")
-(ierr "err")

DELETED ducttape/workweekdate.scm
Index: ducttape/workweekdate.scm
==================================================================
--- ducttape/workweekdate.scm
+++ /dev/null
@@ -1,193 +0,0 @@
-(use srfi-19)
-(use test)
-;;(use format)
-(use regex)
-;(declare (unit wwdate))
-;; utility procedures to convert among
-;; different ways to express date (wwdate, seconds since epoch, isodate)
-;;
-;; samples:
-;; isodate   -> "2016-01-01"
-;; wwdate -> "16ww01.5"
-;; seconds   -> 1451631600
-
-;; procedures provided:
-;; ====================
-;; seconds->isodate
-;; seconds->wwdate
-;;
-;; isodate->seconds
-;; isodate->wwdate
-;;
-;; wwdate->seconds
-;; wwdate->isodate
-
-;; srfi-19 used extensively; this doc is better tha the eggref:
-;; http://srfi.schemers.org/srfi-19/srfi-19.html
-
-;; Author: brandon.j.barclay@intel.com 16ww18.6
-
-(define (date->seconds date)
-  (inexact->exact
-   (string->number
-    (date->string date "~s"))))
-
-(define (seconds->isodate seconds)
-  (let* ((date (seconds->date seconds))
-         (result (date->string date "~Y-~m-~d")))
-    result))
-
-(define (isodate->seconds isodate)
-  "Takes a string input of the form 'YY-MM-DD' or 'YYYY-MM-DD' and returns epoch time; for YY, assume after Y2K"
-  (let* ((numlist (map string->number (string-split isodate "-")))
-        (raw-year (car numlist))
-        (year (if (< raw-year 100) (+ raw-year 2000) raw-year))
-        (month (list-ref numlist 1))
-        (day (list-ref numlist 2))
-        (date (make-date 0 0 0 0 day month year))
-        (seconds (date->seconds date)))
-
-    seconds))
-
-;; adapted from perl Intel::WorkWeek perl module
-;; workweek year consists of numbered weeks starting from week 1
-;;   days of week are numbered starting from 0 on sunday
-;;   weeks begin on sunday- day number 0 and end saturday- day 6
-;;   week 1 is defined as the week containing jan 1 of the year
-;;   workweek year does not match calendar year in workweek 1
-;;     since workweek 1 contains jan1 and workweek begins sunday,
-;;     days prior to jan1 in workweek 1 belong to the next workweek year
-(define (seconds->wwdate-values seconds)
-  (define (date-difference->seconds d1 d2)
-    (- (date->seconds d1) (date->seconds d2)))
-
-  (let* ((thisdate (seconds->date seconds))
-         (thisdow (string->number (date->string thisdate "~w")))
-
-         (year (date-year thisdate))
-         ;; intel workweek 1 begins on sunday of week containing jan1
-         (jan1 (make-date 0 0 0 0 1 1 year))
-         (jan1dow (date-week-day jan1))
-         (ww01 (date-subtract-duration jan1 (seconds->time (* 60 60 24 jan1dow))))
-
-         (ww01_delta_seconds (date-difference->seconds thisdate ww01))
-         (wwnum_initial (inexact->exact (add1 (floor (/ ww01_delta_seconds 24 3600 7) ))))
-         
-         ;; we could be in ww1 of next year
-         (this-saturday (seconds->date
-                         (+ seconds
-                            (* 60 60 24 (- 6 thisdow)))))
-         (this-week-ends-next-year?
-          (> (date-year this-saturday) year))
-         (intelyear
-          (if this-week-ends-next-year?
-              (add1 year)
-              year))
-         (intelweek
-          (if this-week-ends-next-year?
-              1
-              wwnum_initial)))
-   (values intelyear intelweek thisdow)))
-
-(define (string-leftpad in width pad-char)
-  (let* ((unpadded-str (->string in))
-         (padlen_temp (- width (string-length unpadded-str)))
-         (padlen (if (< padlen_temp 0) 0 padlen_temp))
-         (padding (make-string padlen pad-char)))
-    (conc padding unpadded-str)))
-
-(define (string-rightpad in width pad-char)
-  (let* ((unpadded-str (->string in))
-         (padlen_temp (- width (string-length unpadded-str)))
-         (padlen (if (< padlen_temp 0) 0 padlen_temp))
-         (padding (make-string padlen pad-char)))
-    (conc unpadded-str padding)))
-
-(define (zeropad num width)
-  (string-leftpad num width #\0))
-
-(define (seconds->wwdate seconds)
-
-  (let-values (((intelyear intelweek day-of-week-num)
-                (seconds->wwdate-values seconds)))
-    (let ((intelyear-str
-           (zeropad
-            (->string
-             (if (> intelyear 1999)
-                 (- intelyear 2000) intelyear))
-            2))
-          (intelweek-str
-           (zeropad (->string intelweek) 2))
-          (dow-str (->string day-of-week-num)))
-      (conc intelyear-str "ww" intelweek-str "." dow-str))))
-
-(define (isodate->wwdate isodate)
-  (seconds->wwdate
-   (isodate->seconds isodate)))
-
-(define (wwdate->seconds wwdate)
-  (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" wwdate)))
-    (if
-     (not match)
-     #f
-     (let* (
-            (intelyear-raw (string->number (list-ref match 1)))
-            (intelyear (if (< intelyear-raw 100)
-                           (+ intelyear-raw 2000)
-                           intelyear-raw))
-            (intelww (string->number (list-ref match 2)))
-            (dayofweek (string->number (list-ref match 3)))
-
-            (day-of-seconds (* 60 60 24 ))
-            (week-of-seconds (* day-of-seconds 7))
-            
-
-            ;; get seconds at ww1.0
-            (new-years-date (make-date 0 0 0 0 1 1 intelyear))
-            (new-years-seconds
-             (date->seconds new-years-date))
-            (new-years-dayofweek (date-week-day new-years-date))
-            (ww1.0_seconds (- new-years-seconds
-                              (* day-of-seconds
-                                 new-years-dayofweek)))
-            (workweek-adjustment (* week-of-seconds (sub1 intelww)))
-            (weekday-adjustment (* dayofweek day-of-seconds))
-
-            (result (+ ww1.0_seconds workweek-adjustment weekday-adjustment)))
-       result))))
-
-(define (wwdate->isodate wwdate)
-  (seconds->isodate (wwdate->seconds wwdate)))
-
-(define (current-wwdate)
-  (seconds->wwdate (current-seconds)))
-
-(define (current-isodate)
-  (seconds->isodate (current-seconds)))
-
-(define (wwdate-tests)
-  (test-group
-   "date conversion tests"
-   (let ((test-table
-          '(("16ww01.5" . "2016-01-01")
-            ("16ww18.5" . "2016-04-29")
-            ("1999ww33.5" . "1999-08-13")
-            ("16ww18.4" . "2016-04-28")
-            ("16ww18.3" . "2016-04-27")
-            ("13ww01.0" . "2012-12-30")
-            ("13ww52.6" . "2013-12-28")
-            ("16ww53.3" . "2016-12-28"))))
-     (for-each
-      (lambda (test-pair)
-        (let ((wwdate (car test-pair))
-              (isodate (cdr test-pair)))
-          (test
-           (conc "(isodate->wwdate "isodate ") => "wwdate)
-           wwdate
-           (isodate->wwdate isodate))
-          
-          (test
-           (conc "(wwdate->isodate "wwdate ")   => "isodate)
-           isodate
-           (wwdate->isodate wwdate))))
-      test-table))))

DELETED emergency-patches/emergency-patch-1.scm
Index: emergency-patches/emergency-patch-1.scm
==================================================================
--- emergency-patches/emergency-patch-1.scm
+++ /dev/null
@@ -1,203 +0,0 @@
-
-
-;; 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
-;;
-;;    - returns #( flag result )
-;;
-(define (api:execute-requests dbstruct dat)
-  (handle-exceptions
-   exn
-   (let ((call-chain (get-call-chain)))
-     (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat)
-     (print-call-chain (current-error-port))
-     (debug:print 0 *default-log-port* " message: "  ((condition-property-accessor 'exn 'message) exn))       
-     (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
-   (cond
-    ((not (vector? dat))                    ;; it is an error to not receive a vector
-     (vector #f (vector #f "remote must be called with a vector")))
-    ((> *api-process-request-count* 20) ;; 20)
-     (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.")
-     (set! *server-overloaded* #t)
-     (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor!
-    (else  
-     (let* ((cmd-in            (vector-ref dat 0))
-            (cmd               (if (symbol? cmd-in)
-				   cmd-in
-				   (string->symbol cmd-in)))
-            (params            (vector-ref dat 1))
-            (start-t           (current-milliseconds))
-            (readonly-mode     (dbr:dbstruct-read-only dbstruct))
-            (readonly-command  (member cmd api:read-only-queries))
-            (writecmd-in-readonly-mode (and readonly-mode (not readonly-command)))
-            (res    
-             (if writecmd-in-readonly-mode
-                 (conc "attempt to run write command "cmd" on a read-only database")
-                 (case cmd
-                   ;;===============================================
-                   ;; READ/WRITE QUERIES
-                   ;;===============================================
-
-                   ((get-keys-write)                        (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl
-                   
-                   ;; SERVERS
-                   ((start-server)                    (apply server:kind-run params))
-                   ((kill-server)                     (set! *server-run* #f))
-
-                   ;; TESTS
-
-                   ;;((test-set-state-status-by-id)     (apply mt:test-set-state-status-by-id dbstruct params))
-                   ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items.
-                   ((test-set-state-status-by-id)
-
-                    ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
-                    (db:set-state-status-and-roll-up-items
-                     dbstruct
-                     (list-ref params 0) ; run-id
-                     (list-ref params 1) ; test-name
-                     #f                  ; item-path
-                     (list-ref params 2) ; state
-                     (list-ref params 3) ; status
-                     (list-ref params 4) ; comment
-                     ))
-                   
-                   ((delete-test-records)             (apply db:delete-test-records dbstruct params))
-                   ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params))
-                   ((test-set-state-status)           (apply db:test-set-state-status dbstruct params))
-                   ((test-set-top-process-pid)        (apply db:test-set-top-process-pid dbstruct params))
-                   ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params))
-                   ((top-test-set-per-pf-counts)      (apply db:top-test-set-per-pf-counts dbstruct params))
-                   ((test-set-archive-block-id)       (apply db:test-set-archive-block-id dbstruct params))
-
-                   ;; RUNS
-                   ((register-run)                 (apply db:register-run dbstruct params))
-                   ((set-tests-state-status)       (apply db:set-tests-state-status dbstruct params))
-                   ((delete-run)                   (apply db:delete-run dbstruct params))
-                   ((lock/unlock-run)              (apply db:lock/unlock-run dbstruct params))
-                   ((update-run-event_time)        (apply db:update-run-event_time dbstruct params))
-                   ((update-run-stats)             (apply db:update-run-stats dbstruct params))
-                   ((set-var)                      (apply db:set-var dbstruct params))
-                   ((del-var)                      (apply db:del-var dbstruct params))
-
-                   ;; STEPS
-                   ((teststep-set-status!)         (apply db:teststep-set-status! dbstruct params))
-
-                   ;; TEST DATA
-                   ((test-data-rollup)             (apply db:test-data-rollup dbstruct params))
-                   ((csv->test-data)               (apply db:csv->test-data dbstruct params))
-
-                   ;; MISC
-                   ((sync-inmem->db)               (let ((run-id (car params)))
-                                                     (db:sync-touched dbstruct run-id force-sync: #t)))
-                   ((mark-incomplete)              (apply db:find-and-mark-incomplete dbstruct params))
-
-                   ;; TESTMETA
-                   ((testmeta-add-record)       (apply db:testmeta-add-record dbstruct params))
-                   ((testmeta-update-field)     (apply db:testmeta-update-field dbstruct params))
-                   ((get-tests-tags)            (db:get-tests-tags dbstruct))
-
-                   ;; TASKS
-                   ((tasks-add)                 (apply tasks:add dbstruct params))   
-                   ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params))
-                   ((tasks-get-last)            (apply tasks:get-last dbstruct params))
-
-		   ;; NO SYNC DB
-		   ((no-sync-set)               (apply db:no-sync-set         *no-sync-db* params))
-		   ((no-sync-get/default)       (apply db:no-sync-get/default *no-sync-db* params))
-		   ((no-sync-del!)              (apply db:no-sync-del!        *no-sync-db* params))
-		 
-                   ;; ARCHIVES
-                   ;; ((archive-get-allocations)   
-                   ((archive-register-disk)     (apply db:archive-register-disk dbstruct params))
-                   ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
-                   ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
-
-                   ;;======================================================================
-                   ;; READ ONLY QUERIES
-                   ;;======================================================================
-
-                   ;; KEYS
-                   ((get-key-val-pairs)               (apply db:get-key-val-pairs dbstruct params))
-                   ((get-keys)                        (db:get-keys dbstruct))
-                   ((get-key-vals)                    (apply db:get-key-vals dbstruct params))
-                   ((get-target)                      (apply db:get-target dbstruct params))
-                   ((get-targets)                     (db:get-targets dbstruct))
-
-                   ;; ARCHIVES
-                   ((test-get-archive-block-info)     (apply db:test-get-archive-block-info dbstruct params))
-                   
-                   ;; TESTS
-                   ((test-toplevel-num-items)         (apply db:test-toplevel-num-items dbstruct params))
-                   ((get-test-info-by-id)	       (apply db:get-test-info-by-id dbstruct params))
-                   ((test-get-rundir-from-test-id)    (apply db:test-get-rundir-from-test-id dbstruct params))
-                   ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params))
-                   ((get-count-tests-running)         (apply db:get-count-tests-running dbstruct params))
-                   ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
-                   ;; ((delete-test-step-records)        (apply db:delete-test-step-records dbstruct params))
-                   ((get-previous-test-run-record)    (apply db:get-previous-test-run-record dbstruct params))
-                   ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
-                   ((test-get-logfile-info)           (apply db:test-get-logfile-info dbstruct params))
-                   ((test-get-records-for-index-file)  (apply db:test-get-records-for-index-file dbstruct params))
-                   ((get-testinfo-state-status)       (apply db:get-testinfo-state-status dbstruct params))
-                   ((test-get-top-process-pid)        (apply db:test-get-top-process-pid dbstruct params))
-                   ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params))
-                   ((get-prereqs-not-met)             (apply db:get-prereqs-not-met dbstruct params))
-                   ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
-                   ((synchash-get)                    (apply synchash:server-get dbstruct params))
-                   ((get-raw-run-stats)               (apply db:get-raw-run-stats dbstruct params))
-
-                   ;; RUNS
-                   ((get-run-info)                 (apply db:get-run-info dbstruct params))
-                   ((get-run-status)               (apply db:get-run-status dbstruct params))
-                   ((set-run-status)               (apply db:set-run-status dbstruct params))
-                   ((get-tests-for-run)            (apply db:get-tests-for-run dbstruct params))
-                   ((get-test-id)                  (apply db:get-test-id dbstruct params))
-                   ((get-tests-for-run-mindata)    (apply db:get-tests-for-run-mindata dbstruct params))
-                   ((get-runs)                     (apply db:get-runs dbstruct params))
-                   ((get-num-runs)                 (apply db:get-num-runs dbstruct params))
-                   ((get-all-run-ids)              (db:get-all-run-ids dbstruct))
-                   ((get-prev-run-ids)             (apply db:get-prev-run-ids dbstruct params))
-                   ((get-run-ids-matching-target)  (apply db:get-run-ids-matching-target dbstruct params))
-                   ((get-runs-by-patt)             (apply db:get-runs-by-patt dbstruct params))
-                   ((get-run-name-from-id)         (apply db:get-run-name-from-id dbstruct params))
-                   ((get-main-run-stats)           (apply db:get-main-run-stats dbstruct params))
-                   ((get-var)                      (apply db:get-var dbstruct params))
-                   ((get-run-stats)                (apply db:get-run-stats dbstruct params))
-
-                   ;; STEPS
-                   ((get-steps-data)               (apply db:get-steps-data dbstruct params))
-                   ((get-steps-for-test)           (apply db:get-steps-for-test dbstruct params))
-
-                   ;; TEST DATA
-                   ((read-test-data)               (apply db:read-test-data dbstruct params))
-                   ((read-test-data*)              (apply db:read-test-data* dbstruct params))
-
-                   ;; MISC
-                   ((get-latest-host-load)         (apply db:get-latest-host-load dbstruct params))
-                   ((have-incompletes?)            (apply db:have-incompletes? dbstruct params))
-                   ((login)                        (apply db:login dbstruct params))
-                   ((general-call)                 (let ((stmtname   (car params))
-                                                         (run-id     (cadr params))
-                                                         (realparams (cddr params)))
-                                                     (db:general-call dbstruct stmtname realparams)))
-                   ((sdb-qry)                      (apply sdb:qry params))
-                   ((ping)                         (current-process-id))
-		   ((get-changed-record-ids)       (apply db:get-changed-record-ids dbstruct params))
-		   
-                   ;; TESTMETA
-                   ((testmeta-get-record)       (apply db:testmeta-get-record dbstruct params))
-
-                   ;; TASKS 
-                   ((find-task-queue-records)   (apply tasks:find-task-queue-records dbstruct params))
-		   (else
-		    (debug:print 0 *default-log-port* "ERROR: bad api call " cmd)
-		    (conc "ERROR: BAD api call " cmd))))))
-       
-       ;; save all stats
-       (let ((delta-t (- (current-milliseconds)
-			 start-t)))
-	 (hash-table-set! *db-api-call-time* cmd
-			  (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '()))))
-       (if writecmd-in-readonly-mode
-	   (vector #f res)
-           (vector #t res)))))))

DELETED emergency-patches/emergency-patch-2.scm
Index: emergency-patches/emergency-patch-2.scm
==================================================================
--- emergency-patches/emergency-patch-2.scm
+++ /dev/null
@@ -1,311 +0,0 @@
-(include "common_records.scm")
-(include "key_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
-(include "test_records.scm")
-
-(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f))
-  (let* ((loadavg (common:get-cpu-load remote-host))
-	 (first   (car loadavg))
-	 (next    (cadr loadavg))
-	 (adjload (* maxload numcpus))
-	 (loadjmp (- first next)))
-    (cond
-     ((and (> first adjload)
-	   (> count 0))
-      (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload " " (if msg msg ""))
-      (thread-sleep! waitdelay)
-      (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))
-     ((and (> loadjmp numcpus)
-	   (> count 0))
-      (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg ""))
-      (thread-sleep! waitdelay)
-      (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))))))
-
-(define (common:wait-for-homehost-load maxload msg)
-  (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local.
-                     #f
-                     (common:get-homehost)))
-         (hh     (if hh-dat (car hh-dat) #f))
-         (numcpus (common:get-num-cpus hh)))
-    (common:wait-for-normalized-load maxload msg: msg remote-host: hh)))
-
-;; wait for normalized cpu load to drop below maxload
-;;
-(define (common:wait-for-normalized-load maxload #!key (msg #f)(remote-host #f))
-  (let ((num-cpus (common:get-num-cpus remote-host)))
-    (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host)))
-
-;;  hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps)
-(define (runs:process-expanded-tests runsdat testdat)
-  ;; unroll the contents of runsdat and testdat (due to ongoing refactoring).
-  (let* ((hed                    (runs:testdat-hed testdat))
-	 (tal                    (runs:testdat-tal testdat))
-	 (reg                    (runs:testdat-reg testdat))
-	 (reruns                 (runs:testdat-reruns testdat))
-	 (test-name              (runs:testdat-test-name testdat))
-	 (item-path              (runs:testdat-item-path testdat))
-	 (jobgroup               (runs:testdat-jobgroup testdat))
-	 (waitons                (runs:testdat-waitons testdat))
-	 (item-path              (runs:testdat-item-path testdat))
-	 (testmode               (runs:testdat-testmode testdat))
-	 (newtal                 (runs:testdat-newtal testdat))
-	 (itemmaps               (runs:testdat-itemmaps testdat))
-	 (test-record            (runs:testdat-test-record testdat))
-	 (prereqs-not-met        (runs:testdat-prereqs-not-met testdat))
-
-	 (reglen                 (runs:dat-reglen runsdat))
-	 (regfull                (runs:dat-regfull runsdat))
-	 (runname                (runs:dat-runname runsdat))
-	 (max-concurrent-jobs    (runs:dat-max-concurrent-jobs runsdat))
-	 (run-id                 (runs:dat-run-id runsdat))
-	 (test-patts             (runs:dat-test-patts runsdat))
-	 (required-tests         (runs:dat-required-tests runsdat))
-	 (test-registry          (runs:dat-test-registry runsdat))
-	 (registry-mutex         (runs:dat-registry-mutex runsdat))
-	 (flags                  (runs:dat-flags runsdat))
-	 (keyvals                (runs:dat-keyvals runsdat))
-	 (run-info               (runs:dat-run-info runsdat))
-	 (all-tests-registry     (runs:dat-all-tests-registry runsdat))
-	 (run-limits-info        (runs:dat-can-run-more-tests runsdat))
-	 ;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
-	 (have-resources         (car run-limits-info))
-	 (num-running            (list-ref run-limits-info 1))
-	 (num-running-in-jobgroup(list-ref run-limits-info 2)) 
-	 (max-concurrent-jobs    (list-ref run-limits-info 3))
-	 (job-group-limit        (list-ref run-limits-info 4))
-	 ;; (prereqs-not-met        (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
-	 ;; (prereqs-not-met         (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
-	 (fails                  (if (list? prereqs-not-met)
-				      (runs:calc-fails prereqs-not-met)
-				      (begin
-					(debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met)
-					'())))
-	 (non-completed           (filter (lambda (x)             ;; remove hed from not completed list, duh, of course it is not completed!
-					    (not (equal? x hed)))
-					  (runs:calc-not-completed prereqs-not-met)))
-	 (loop-list               (list hed tal reg reruns))
-	 ;; configure the load runner
-	 (numcpus                 (common:get-num-cpus #f))
-	 (maxload                 (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3.0")))         ;; use a non-number string to disable
-         (maxhomehostload         (string->number (or (configf:lookup *configdat* "jobtools" "maxhomehostload") "1.2"))) ;; use a non-number string to disable
-         (waitdelay               (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60"))))
-    (debug:print-info 4 *default-log-port* "have-resources: " have-resources " prereqs-not-met: (" 
-		      (string-intersperse 
-		       (map (lambda (t)
-			      (if (vector? t)
-				  (conc (db:test-get-state t) "/" (db:test-get-status t))
-				  (conc " WARNING: t is not a vector=" t )))
-			    prereqs-not-met)
-		       ", ") ") fails: " fails
-		       "\nregistered? " (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f))
-			    
-
-    
-    (if (and (not (null? prereqs-not-met))
-	     (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60))
-	(debug:print-info 2 *default-log-port* "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", ")))
-
-    ;; Don't know at this time if the test have been launched at some time in the past
-    ;; i.e. is this a re-launch?
-    (debug:print-info 4 *default-log-port* "run-limits-info = " run-limits-info)
-    
-    (cond
-     
-     ;; Check item path against item-patts, 
-     ;;
-     ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run
-      ;; else the run is stuck, temporarily or permanently
-      ;; but should check if it is due to lack of resources vs. prerequisites
-      (debug:print-info 1 *default-log-port* "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts)
-      (if (or (not (null? tal))(not (null? reg)))
-	  (list (runs:queue-next-hed tal reg reglen regfull)
-		(runs:queue-next-tal tal reg reglen regfull)
-		(runs:queue-next-reg tal reg reglen regfull)
-		reruns)
-	  #f))
-     
-     ;; Register tests 
-     ;;
-     ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f))
-      (debug:print-info 4 *default-log-port* "Pre-registering test " test-name "/" item-path " to create placeholder" )
-      ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs
-      (let register-loop ((numtries 15))
-	(rmt:register-test run-id test-name item-path)
-	(if (rmt:get-test-id run-id test-name item-path)
-	    (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done)
-	    (if (> numtries 0)
-		(begin
-		  (thread-sleep! 0.5)
-		  (register-loop (- numtries 1)))
-		(debug:print-error 0 *default-log-port* "failed to register test " (db:test-make-full-name test-name item-path)))))
-      (if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done))
-	  (begin
-	    (rmt:register-test run-id test-name "")
-	    (if (rmt:get-test-id run-id test-name "")
-		(hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))))
-      (runs:shrink-can-run-more-tests-count runsdat)   ;; DELAY TWEAKER (still needed?)
-      (if (and (null? tal)(null? reg))
-	  (list hed tal (append reg (list hed)) reruns)
-	  (list (runs:queue-next-hed tal reg reglen regfull)
-		(runs:queue-next-tal tal reg reglen regfull)
-		;; NB// Here we are building reg as we register tests
-		;; if regfull we must pop the front item off reg
-		(if regfull
-		    (append (cdr reg) (list hed))
-		    (append reg (list hed)))
-		reruns)))
-     
-     ;; At this point hed test registration must be completed.
-     ;;
-     ((eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)
-	   'start)
-      (debug:print-info 0 *default-log-port* "Waiting on test registration(s): "
-			(string-intersperse 
-			 (filter (lambda (x)
-				   (eq? (hash-table-ref/default test-registry x #f) 'start))
-				 (hash-table-keys test-registry))
-			 ", "))
-      (thread-sleep! 0.051)
-      (list hed tal reg reruns))
-     
-     ;; If no resources are available just kill time and loop again
-     ;;
-     ((not have-resources) ;; simply try again after waiting a second
-      (if (runs:lownoise "no resources" 60)
-	  (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ..."))
-      ;; Have gone back and forth on this but db starvation is an issue.
-      ;; wait one second before looking again to run jobs.
-      (thread-sleep! 1)
-      ;; could have done hed tal here but doing car/cdr of newtal to rotate tests
-      (list (car newtal)(cdr newtal) reg reruns))
-     
-     ;; This is the final stage, everything is in place so launch the test
-     ;;
-     ((and have-resources
-	   (or (null? prereqs-not-met)
-	       (and (member 'toplevel testmode) ;;  'toplevel)
-		    (null? non-completed)
-		    (not (member 'exclusive testmode)))))
-      ;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path))
-      ;; we are going to reset all the counters for test retries by setting a new hash table
-      ;; this means they will increment only when nothing can be run
-      (set! *max-tries-hash* (make-hash-table))
-      ;; well, first lets see if cpu load throttling is enabled. If so wait around until the
-      ;; average cpu load is under the threshold before continuing
-      (if maxload ;; only gate if maxload is specified
-          (common:wait-for-cpuload maxload numcpus waitdelay))
-      (if maxhomehostload
-          (common:wait-for-homehost-load maxhomehostload (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload)))
-      
-      (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry)
-      (runs:incremental-print-results run-id)
-      (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running)
-      (runs:shrink-can-run-more-tests-count runsdat)  ;; DELAY TWEAKER (still needed?)
-      ;; (thread-sleep! *global-delta*)
-      (if (or (not (null? tal))(not (null? reg)))
-	  (list (runs:queue-next-hed tal reg reglen regfull)
-		(runs:queue-next-tal tal reg reglen regfull)
-		(runs:queue-next-reg tal reg reglen regfull)
-		reruns)
-	  #f))
-     
-     ;; must be we have unmet prerequisites
-     ;;
-     (else
-      (debug:print 4 *default-log-port* "FAILS: " fails)
-      ;; If one or more of the prereqs-not-met are FAIL then we can issue
-      ;; a message and drop hed from the items to be processed.
-      ;; (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met)
-      (if (and (not (null? prereqs-not-met))
-	       (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60))
-	  (debug:print-info 1 *default-log-port* "waiting on tests; " (string-intersperse 
-						    (runs:mixed-list-testname-and-testrec->list-of-strings 
-						     prereqs-not-met) ", ")))
-      (if (or (null? fails)
-	      (member 'toplevel testmode))
-	  (begin
-	    ;; couldn't run, take a breather
-	    (if  (runs:lownoise "Waiting for more work to do..." 60)
-		 (debug:print-info 0 *default-log-port* "Waiting for more work to do..."))
-	    (thread-sleep! 1)
-	    (list (car newtal)(cdr newtal) reg reruns))
-	  ;; the waiton is FAIL so no point in trying to run hed ever again
-	  (if (or (not (null? reg))(not (null? tal)))
-	      (if (vector? hed)
-		  (begin
-		    (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path
-				 " from the launch list as it has prerequistes that are FAIL")
-		    (let ((test-id (rmt:get-test-id run-id hed "")))
-		      (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))
-		    (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
-		    ;; (thread-sleep! *global-delta*)
-		    ;; This next is for the items
-		    (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f)
-		    (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed)
-		    (list (runs:queue-next-hed tal reg reglen regfull)
-			  (runs:queue-next-tal tal reg reglen regfull)
-			  (runs:queue-next-reg tal reg reglen regfull)
-			  reruns ;; WAS: (cons hed reruns) ;; but that makes no sense?
-			  ))
-		  (let ((nth-try (hash-table-ref/default test-registry hed 0)))
-		    (cond
-		     ((member "RUNNING" (map db:test-get-state prereqs-not-met))
-		      (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60)
-			  (debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet."))
-		      (thread-sleep! 4)
-		      (list (runs:queue-next-hed newtal reg reglen regfull)
-			    (runs:queue-next-tal newtal reg reglen regfull)
-			    (runs:queue-next-reg newtal reg reglen regfull)
-			    reruns))
-		     ((or (not nth-try)
-			  (and (number? nth-try)
-			       (< nth-try 10)))
-		      (hash-table-set! test-registry hed (if (number? nth-try)
-							     (+ nth-try 1)
-							     0))
-		      (if (runs:lownoise (conc "not removing test " hed) 60)
-			  (debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites"))
-		      ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;;  " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
-		      (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
-		      ;; (list hed tal reg reruns)
-		      ;; (list (car newtal)(cdr newtal) reg reruns)
-		      ;; (hash-table-set! test-registry hed 'removed)
-		      (list (runs:queue-next-hed newtal reg reglen regfull)
-			    (runs:queue-next-tal newtal reg reglen regfull)
-			    (runs:queue-next-reg newtal reg reglen regfull)
-			    reruns))
-		     ((symbol? nth-try)
-		      (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW
-			  (if (null? tal)
-			      #f ;; yes, really
-			      (list (car tal)(cdr tal) reg reruns))
-			  (begin
-			    (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60)
-				(debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry."))
-			    (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f)
-			    (hash-table-set! test-registry hed 0)
-			    (list (runs:queue-next-hed newtal reg reglen regfull)
-				  (runs:queue-next-tal newtal reg reglen regfull)
-				  (runs:queue-next-reg newtal reg reglen regfull)
-				  reruns))))
-		     (else
-		      (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60)
-			  (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now."))
-		      ;; (debug:print 0 *default-log-port* "         prereqs: " prereqs-not-met)
-		      (hash-table-set! test-registry hed 'removed)
-		      (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f)
-		      ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug.
-		      (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL
-		      (list (if (null? tal)(car newtal)(car tal))
-			    tal
-			    reg
-			    reruns)))))
-	      ;; can't drop this - maybe running? Just keep trying
-	      (let ((runable-tests (runs:runable-tests prereqs-not-met)))
-		(if (null? runable-tests)
-		    #f   ;; I think we are truly done here
-		    (list (runs:queue-next-hed newtal reg reglen regfull)
-			    (runs:queue-next-tal newtal reg reglen regfull)
-			    (runs:queue-next-reg newtal reg reglen regfull)
-			    reruns)))))))))

DELETED emergency-patches/emergency-patch-3.scm
Index: emergency-patches/emergency-patch-3.scm
==================================================================
--- emergency-patches/emergency-patch-3.scm
+++ /dev/null
@@ -1,81 +0,0 @@
- ;; To build patch:
- ;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; ldd /p/foundry/env/pkgs/megatest/1.64/19/bin/.11/mtest
- ;;        linux-vdso.so.1 =>  (0x00002aaaaaaab000)
- ;;        libchicken.so.7 => /p/foundry/env/pkgs/megatest/1.64/chicken-4.10.0//lib/libchicken.so.7 (0x00002aaaaaaad000)
- ;;        libm.so.6 => /lib64/libm.so.6 (0x00002aaaab0a6000)
- ;;        libdl.so.2 => /lib64/libdl.so.2 (0x00002aaaab31f000)
- ;;        libc.so.6 => /lib64/libc.so.6 (0x00002aaaab523000)
- ;;        /lib64/ld-linux-x86-64.so.2 (0x0000555555554000)
- ;;
- ;;  /p/foundry/env/pkgs/megatest/1.64/chicken-4.10.0/bin/csc -s emergency-patch-3.scm
- ;;
-
-
- ;; to test patch:
- ;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; in .megatestrc, add:
- ;; (if (and (> megatest-version 1.64)
- ;;         (< megatest-version 1.6421))
- ;;   (begin
- ;;      (load "/p/foundry/env/pkgs/megatest/1.64/19/share/epatch-1.so")
- ;;      (load "/p/foundry/env/pkgs/megatest/1.64/19/share/epatch-2.so"))) 
- ;;
-
-
- ;; to productize patch:
- ;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; 
-(use directory-utils regex)
-
-(include "common_records.scm")
-(include "key_records.scm")
-(include "db_records.scm")
-(include "run_records.scm")
-(include "test_records.scm")
-
-;; Given a run id start a server process    ### NOTE ### > file 2>&1 
-;; if the run-id is zero and the target-host is set 
-;; try running on that host
-;;   incidental: rotate logs in logs/ dir.
-;;
-(define  (server:run areapath) ;; areapath is *toppath* for a given testsuite area
-  (let* ((curr-host   (get-host-name))
-         ;; (attempt-in-progress (server:start-attempted? areapath))
-         ;; (dot-server-url (server:check-if-running areapath))
-	 (curr-ip     (server:get-best-guess-address curr-host))
-	 (curr-pid    (current-process-id))
-	 (homehost    (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" ))
-	 (target-host (car homehost))
-	 (testsuite   (common:get-testsuite-name))
-	 (logfile     (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log"))
-	 (cmdln (conc (common:get-megatest-exe)
-		      " -server " (or target-host "-") (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
-							   " -daemonize "
-							   "")
-		      ;; " -log " logfile
-		      " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &")))))
-	 (log-rotate  (make-thread common:rotate-logs  "server run, rotate logs thread"))
-         (load-limit  (configf:lookup-number *configdat* "server" "load-limit" default: 0.9)))
-    ;; we want the remote server to start in *toppath* so push there
-    (push-directory areapath)
-    (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
-    (thread-start! log-rotate)
-    
-    ;; host.domain.tld match host?
-    (if (and target-host 
-	     ;; look at target host, is it host.domain.tld or ip address and does it 
-	     ;; match current ip or hostname
-	     (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
-	     (not (equal? curr-ip target-host)))
-	(begin
-	  (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
-	  (setenv "TARGETHOST" target-host)))
-      
-    (setenv "TARGETHOST_LOGF" logfile)
-    (common:wait-for-normalized-load load-limit " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever
-    (system (conc "nbfake " cmdln))
-    (unsetenv "TARGETHOST_LOGF")
-    (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
-    (thread-join! log-rotate)
-    (pop-directory)))

DELETED fsl-rebase.scm
Index: fsl-rebase.scm
==================================================================
--- fsl-rebase.scm
+++ /dev/null
@@ -1,37 +0,0 @@
-;; given branch and baseline commit generate list of commands to cherry pick commits
-;;
-;;
-;; Usage: fsl-rebase basecommit branch
-;;         
-
-(use regex posix)
-
-(let* ((basecommit (cadr (argv)))
-       (branch     (caddr (argv)))
-       (cmd        (conc "fossil timeline after " basecommit " -n 1000000 -W 0"))
-       (theregex   (conc ;; "^[^\\]]+"
-			 "\\[([a-z0-9]+)\\]\\s+"
-			 "(.*)"
-			 "\\s+\\(.*tags:\\s+" branch 
-			 ;; ".*\\)"
-			 )))
-  (print "basecommit: " basecommit ", branch: " branch ", theregex: " theregex ", cmd: \"" cmd "\"")
-  (with-input-from-pipe
-   cmd
-   (lambda ()
-     (let loop ((inl (read-line))
-		(res '()))
-       (if (not (eof-object? inl))
-	   (let ((have-match (string-search theregex inl)))
-	     (if have-match
-		 (loop (read-line)
-		       (cons (conc "fossil merge --cherrypick " (cadr have-match)
-				   "\nfossil commit -m \"Cherry pick from " (cadr have-match)
-				   ": " (caddr have-match) "\"")
-			     res))
-		 (loop (read-line) res)))
-	   (map print res))))))
-
-;; (print "match: " inl "\n   $1: " (cadr have-match) " $2: " (caddr have-match))
-;; (print "no match: " theregex " " inl))
-;; (loop (read-line))))))))

DELETED iupexamples/graph.scm
Index: iupexamples/graph.scm
==================================================================
--- iupexamples/graph.scm
+++ /dev/null
@@ -1,62 +0,0 @@
-(use iup)
-(import iup-pplot)
-
- 
-
-(define (tl)
-  (let* ((lastx 0)
-	 (lastsample 2)
-	 (plt (pplot 
-	       #:title "MyTitle"
-	       #:marginbottom "65"
-	       #:marginleft   "65"
-	       #:axs_xlabel   "Score" 
-	       #:axs_ylabel "Count"
-	       #:legendshow "YES"
-	       ;; #:axs_xmin    "0"
-	       ;; #:axs_ymin    "0"
-	       #:axs_yautomin "YES"
-	       #:axs_xautomin "YES"
-	       #:axs_xautotick "YES"
-	       #:axs_yautotick "YES"
-	       #:ds_showvalues "YES"
-	       #:size "200x200"
-	       ))
-	 (plt1  (call-with-pplot 
-		 plt
-		 (lambda (x)
-		   (pplot-add! plt 10 100)
-		   (pplot-add! plt 20 120)
-		   (pplot-add! plt 30 200))
-		 #:x-string #f
-		 ))
-	 (plt2  (call-with-pplot 
-		 plt
-		 (lambda (x)
-		   (pplot-add! plt 10 180)
-		   (pplot-add! plt 20 125)
-		   (pplot-add! plt 30 100))
-		 #:x-string #f
-		 ))
-	 (dlg (dialog
-	       (vbox
-		plt
-		(hbox
-		;;  (button "Redraw" size: "50x" action: (lambda (obj)
-		;; 					(redraw plt)))
-		 (button "Quit"   size: "50x" action: (lambda (obj)
-							(exit)))
-		 (button "AddPoint" size: "50x" action: (lambda (obj)
-							  (set! lastx (+ lastx 10))
-							  (set! lastsample (+ lastsample 1))
-							  ;; (attribute-set! plt 'current 0)
-							  (print "lastx: " lastx " lastsample: " lastsample)
-							  (pplot-add! plt lastx (random 300) lastsample 1)
-							  (attribute-set! plt "REDRAW" "1"))))))))
-    (set! lastx 30)
-    (attribute-set! plt 'ds_mode "LINE")
-    ;; (attribute-set! plt 'ds_legend "Yada")
-    (show dlg)
-    (main-loop)))
-
-(tl)

DELETED iupexamples/iupwidgetinfo.scm
Index: iupexamples/iupwidgetinfo.scm
==================================================================
--- iupexamples/iupwidgetinfo.scm
+++ /dev/null
@@ -1,191 +0,0 @@
-#! /usr/bin/env csi
-
-(require-library srfi-4 iup)
-(import srfi-4 iup iup-pplot iup-glcanvas)
-
-(define (popup dlg . args)
-  (apply show dlg #:modal? 'yes args)
-  (destroy! dlg))
-
-(define (properties ih)
-  (popup (element-properties-dialog ih))
-  'default)
-
-(define dlg
-  (dialog
-    (vbox
-      (hbox ; headline
-        (fill)
-        (frame (label " Inspect control and dialog classes "
-                      fontsize: 15))
-        (fill)
-        margin: '0x0)
-
-      (label "") 
-      (label "Dialogs" fontsize: 12)
-      (hbox
-        (button "dialog"
-                action: (lambda (self) (properties (dialog (vbox)))))
-        (button "color-dialog"
-                action: (lambda (self) (properties (color-dialog))))
-        (button "file-dialog"
-                action: (lambda (self) (properties (file-dialog))))
-        (button "font-dialog"
-                action: (lambda (self) (properties (font-dialog))))
-        (button "message-dialog"
-                action: (lambda (self) (properties (message-dialog))))
-        (fill)
-        margin: '0x0)
-      (hbox
-        (button "layout-dialog"
-                action: (lambda (self) (properties (layout-dialog))))
-        (button "element-properties-dialog"
-                action: (lambda (self)
-                          (properties
-                            (element-properties-dialog (create 'user)))))
-        (fill)
-        margin: '0x0)
-
-      (label "") 
-      (label "Composition widgets" fontsize: 12)
-      (hbox
-        (button "fill"
-                action: (lambda (self) (properties (fill))))
-        (button "hbox"
-                action: (lambda (self) (properties (hbox))))
-        (button "vbox"
-                action: (lambda (self) (properties (vbox))))
-        (button "zbox"
-                action: (lambda (self) (properties (zbox))))
-        (button "radio"
-                action: (lambda (self) (properties (radio (vbox)))))
-        (button "normalizer"
-                action: (lambda (self) (properties (normalizer))))
-        (button "cbox"
-                action: (lambda (self) (properties (cbox))))
-        (button "sbox"
-                action: (lambda (self) (properties (sbox (vbox)))))
-        (button "split"
-                action: (lambda (self) (properties (split (vbox) (vbox)))))
-        (fill)
-        margin: '0x0)
-
-      (label "") 
-      (label "Standard widgets" fontsize: 12)
-      (hbox
-        (button "button"
-                action: (lambda (self) (properties (button))))
-        (button "canvas"
-                action: (lambda (self) (properties (canvas))))
-        (button "frame"
-                action: (lambda (self) (properties (frame))))
-        (button "label"
-                action: (lambda (self) (properties (label))))
-        (button "listbox"
-                action: (lambda (self) (properties (listbox))))
-        (button "progress-bar"
-                action: (lambda (self) (properties (progress-bar))))
-        (button "spin"
-                action: (lambda (self) (properties (spin))))
-        (fill)
-        margin: '0x0)
-      (hbox
-        (button "tabs"
-                action: (lambda (self) (properties (tabs))))
-        (button "textbox"
-                action: (lambda (self) (properties (textbox))))
-        (button "toggle"
-                action: (lambda (self) (properties (toggle))))
-        (button "treebox"
-                action: (lambda (self) (properties (treebox))))
-        (button "valuator"
-                action: (lambda (self) (properties (valuator ""))))
-        (fill)
-        margin: '0x0)
-
-      (label "") 
-      (label "Additional widgets" fontsize: 12)
-      (hbox
-        (button "cells"
-                action: (lambda (self) (properties (cells))))
-        (button "color-bar"
-                action: (lambda (self) (properties (color-bar))))
-        (button "color-browser"
-                action: (lambda (self) (properties (color-browser))))
-        (button "dial"
-                action: (lambda (self) (properties (dial ""))))
-        (button "matrix"
-                action: (lambda (self) (properties (matrix))))
-        (fill)
-        margin: '0x0)
-      (hbox
-        (button "pplot"
-                action: (lambda (self) (properties (pplot))))
-        (button "glcanvas"
-                action: (lambda (self) (properties (glcanvas))))
-        (button "web-browser"
-                action: (lambda (self) (properties (web-browser))))
-        (fill)
-        margin: '0x0)
-
-      (label "") 
-      (label "Menu widgets" fontsize: 12)
-      (hbox
-        (button "menu"
-                action: (lambda (self) (properties (menu))))
-        (button "menu-item"
-                action: (lambda (self) (properties (menu-item))))
-        (button "menu-separator"
-                action: (lambda (self) (properties (menu-separator))))
-        (fill)
-        margin: '0x0)
-
-      (label "") 
-      (label "Images" fontsize: 12)
-      (hbox
-        (button "image/palette"
-                action: (lambda (self)
-                          (properties
-                            (image/palette 1 1 (u8vector->blob (u8vector 0))))))
-        (button "image/rgb"
-                action: (lambda (self)
-                          (properties
-                            (image/rgb 1 1 (u8vector->blob (u8vector 0))))))
-        (button "image/rgba"
-                action: (lambda (self)
-                          (properties
-                            (image/rgba 1 1 (u8vector->blob (u8vector 0))))))
-        (button "image/file"
-                action: (lambda (self)
-                          (properties
-                            ;; same attributes as image/palette
-                            (image/palette 1 1 (u8vector->blob (u8vector 0))))))
-                            ;; needs a file in current directory
-                            ;(image/file "chicken.ico")))) ; ok
-                            ;(image/file "chicken.png")))) ; doesn't work
-        (fill)
-        margin: '0x0)
-
-      (label "") 
-      (label "Other widgets" fontsize: 12)
-      (hbox
-        (button "clipboard"
-                action: (lambda (self) (properties (clipboard))))
-        (button "timer"
-                action: (lambda (self) (properties (timer))))
-        (button "spinbox"
-                action: (lambda (self) (properties (spinbox (vbox)))))
-        (fill)
-        margin: '0x0)
-
-      (fill)
-      (button "E&xit"
-              expand: 'horizontal
-              action: (lambda (self) 'close))
-      )
-    margin: '15x15
-    title: "Iup inspector"))
-
-(show dlg)
-(main-loop)
-(exit 0)

DELETED iupexamples/tree.scm
Index: iupexamples/tree.scm
==================================================================
--- iupexamples/tree.scm
+++ /dev/null
@@ -1,145 +0,0 @@
-
-(use test)
-(require-library iup)
-(import (prefix iup iup:))
-
-(define t #f) 
-
-(define tree-dialog
-  (iup:dialog
-   #:title "Tree Test"
-   (let ((t1 (iup:treebox
-	      #:selection_cb (lambda (obj id state)
-			       (print "selection_db with id=" id " state=" state)
-			       (print "USERDATA: " (iup:attribute obj "USERDATA"))
-			       (print "SPECIALDATA: " (iup:attribute obj "SPECIALDATA"))
-			       (print "Depth: " (iup:attribute obj "DEPTH"))
-			       ))))
-     (set! t t1)
-     t1)))
-
-(iup:show tree-dialog)
-
-(map (lambda (elname el)
-       (print "Adding " elname " with value " el)
-       (iup:attribute-set! t elname el)
-       (iup:attribute-set! t "USERDATA" el))
-     '("VALUE" "NAME"    "ADDLEAF" "ADDBRANCH1" "ADDLEAF2"    "VALUE")
-     '("0"     "Figures" "Other"   "triangle"   "equilateral" "4")
-     )
-(map (lambda (attr)
-       (print attr " is " (iup:attribute t attr)))
-     '("KIND1" "PARENT2" "STATE1"))
-
-(define (tree-find-node obj path)
-  ;; start at the base of the tree
-  (if (null? path)
-      #f ;; or 0 ????
-      (let loop ((hed      (car path))
-		 (tal      (cdr path))
-		 (depth    0)
-		 (nodenum  0))
-	;; nodes in iup tree are 100% sequential so iterate over nodenum
-	(if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes
-	    (let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum))))
-		  (node-title (iup:attribute obj (conc "TITLE" nodenum))))
-	      ;; (print 0 "hed: " hed ", depth: " depth ", node-depth: " node-depth ", nodenum: " nodenum ", node-title: " node-title)
-	      (if (and (equal? depth node-depth)
-		       (equal? hed   node-title)) ;; yep, this is the one!
-		  (if (null? tal) ;; end of the line
-		      nodenum
-		      (loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum)))
-		  ;; this is the case where we found part of the hierarchy but not 
-		  ;; all of it, i.e. the node-depth went from deep to less deep
-		  (if (> depth node-depth) ;; (+ 1 node-depth))
-		      #f
-		      (loop hed tal depth (+ nodenum 1)))))
-	    #f))))
-
-;; top is the top node name zeroeth node VALUE=0
-(define (tree-add-node obj top nodelst)
-  (if (not (iup:attribute obj "TITLE0"))
-      (iup:attribute-set! obj "ADDBRANCH0" top))
-  (cond
-   ((not (string=? top (iup:attribute obj "TITLE0")))
-    (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0")))
-   ((null? nodelst))
-   (else
-    (let loop ((hed      (car nodelst))
-	       (tal      (cdr nodelst))
-	       (depth    1)
-	       (pathl    (list top)))
-      ;; Because the tree dialog changes node numbers when
-      ;; nodes are added or removed we must look up nodes
-      ;; each and every time. 0 is the top node so default
-      ;; to that.
-      (let* ((newpath    (append pathl (list hed)))
-	       (parentnode (tree-find-node obj pathl))
-	       (nodenum    (tree-find-node obj newpath)))
-	  ;; (print "newpath: " newpath ", nodenum " nodenum ", hed: " hed ", depth: " depth ", parentnode: " parentnode ", pathl: " pathl)
-	  ;; Add the branch under lastnode if not found
-	  (if (not nodenum)
-	      (begin
-		(iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed)
-		(if (null? tal)
-		    #t
-		    ;; reset to top
-		    (loop (car nodelst)(cdr nodelst) 1 (list top)))) 
-	      (if (null? tal) ;; if null here then this path has already been added
-		  #t
-		  ;; (if nodenum
-		  (loop (car tal)(cdr tal)(+ depth 1) newpath)))))))) ;;  (if nodenum nodenum lastnode)))))))
-	      ;; 	  (loop hed tal depth pathl lastnode)))))))
-
-(define (tree-node->path obj nodenum)
-  ;; (print "\ncurrnode  nodenum  depth  node-depth  node-title   path")
-  (let loop ((currnode 0)
-	     (depth    0)
-	     (path     '()))
-    (let ((node-depth (iup:attribute obj (conc "DEPTH" currnode)))
-	  (node-title (iup:attribute obj (conc "TITLE" currnode))))
-      ;; (display (conc "\n   "currnode "        " nodenum "       " depth "         " node-depth "          " node-title "         " path))
-      (if (> currnode nodenum)
-	  path
-	  (if (not node-depth) ;; #f if we are out of nodes
-	      '()
-	      (let ((ndepth (string->number node-depth)))
-		(if (eq? ndepth depth)
-		    ;; This next is the match condition depth == node-depth
-		    (if (eq? currnode nodenum)
-			(begin
-			  ;; (display " <X>")
-			  (append path (list node-title)))
-			(loop (+ currnode 1)
-			      (+ depth 1)
-			      (append path (list node-title))))
-		    ;; didn't match, reset to base path and keep looking
-		    ;; due to more iup odditys we don't reset to base
-		    (begin 
-		      ;; (display " <L>")
-		      (loop (+ 1 currnode)
-			    2
-			    (append (take path ndepth)(list node-title)))))))))))
-
-(test #f 0  (tree-find-node t '("Figures")))
-(test #f 1  (tree-find-node t '("Figures" "Other")))
-(test #f #f (tree-find-node t '("Figures" "Other"    "equilateral")))
-(test #f 3  (tree-find-node t '("Figures" "triangle" "equilateral")))
-(test #f #t (tree-add-node  t "Figures" '()))
-(test #f #t (tree-add-node  t "Figures" '("a" "b" "c")))
-(test #f 3  (tree-find-node t '("Figures" "a" "b" "c")))
-(test #f #t (tree-add-node  t "Figures" '("d" "b" "c")))
-(test #f 3  (tree-find-node t '("Figures" "d" "b" "c")))
-(test #f 6  (tree-find-node t '("Figures" "a" "b" "c")))
-(test #f #t (tree-add-node  t "Figures" '("a" "e" "c")))
-(test #f 6  (tree-find-node t '("Figures" "a" "e" "c")))
-
-(test #f '("Figures")             (tree-node->path t 0))
-(test #f '("Figures" "d")         (tree-node->path t 1))
-(test #f '("Figures" "d" "b" "c") (tree-node->path t 3))
-(test #f '("Figures" "a")         (tree-node->path t 4))
-(test #f '("Figures" "a" "b" "c")     (tree-node->path t 8)) 
-(test #f '()                      (tree-node->path t 40))
-
-(iup:main-loop)
-

DELETED loadwatch/Makefile
Index: loadwatch/Makefile
==================================================================
--- loadwatch/Makefile
+++ /dev/null
@@ -1,11 +0,0 @@
-
-all : launch-many queuefeeder queuefeeder-server
-
-launch-many : launch-many.scm
-	csc launch-many.scm
-
-queuefeeder : queuefeeder.scm
-	csc queuefeeder.scm
-
-queuefeeder-server : queuefeeder-server.scm
-	csc queuefeeder-server.scm

DELETED loadwatch/bjob-count.sh
Index: loadwatch/bjob-count.sh
==================================================================
--- loadwatch/bjob-count.sh
+++ /dev/null
@@ -1,3 +0,0 @@
-#!/bin/bash
-
-bqueues | grep normal |awk '{print $8}'

DELETED loadwatch/launch-many.scm
Index: loadwatch/launch-many.scm
==================================================================
--- loadwatch/launch-many.scm
+++ /dev/null
@@ -1,9 +0,0 @@
-(use posix)
-
-(let loop ((count 0))
-  (if (> count 500000)
-      (print "DONE")
-      (let ((cmd (conc "./queuefeeder xena:22022 bsub ./testopenlava.sh " count " " (random 30))))
-	(print "Running: " cmd)
-	(system cmd)
-	(loop (+ count 1)))))

DELETED loadwatch/loadwatch.scm
Index: loadwatch/loadwatch.scm
==================================================================
--- loadwatch/loadwatch.scm
+++ /dev/null
@@ -1,86 +0,0 @@
-(use regex srfi-69)
-
-(define-record processdat
-  %cpu
-  virt
-  res
-  %mem
-  count
-  )
-
-(define (pp-processdat dat)
-  (print "(processdat"
-	 " %cpu="  (processdat-%cpu dat)
-	 " virt="  (processdat-virt dat)
-	 " res="   (processdat-res  dat)
-	 " %mem="  (processdat-%mem dat)
-	 " count=" (processdat-count dat)))
-
-
-(define nrex (regexp "^(\\d+[\\d\\.]*)([mkgMKG])$"))
-
-(define (get-number numstr)
-  (let ((n (string->number numstr)))
-    (if n 
-	n
-	(let ((nmatch (string-match nrex numstr)))
-	  (if nmatch
-	      (* (string->number (cadr nmatch))
-		 (case (string->symbol (caddr nmatch))
-		   ((k) 1024)
-		   ((m) 1048576)
-		   ((g) 1073741824)
-		   (else 
-		    (print "ERROR: Unrecognised unit: " (caddr nmatch) ", extracted for " numstr)
-		    1)))
-	      #f)))))
-
-
-(define (snagload)
-  (let ((dat (make-hash-table)) ;; user => hash-of-processdat
-	(hdr (regexp "^\\s+PID"))
-	(rx  (regexp "\\s+"))
-	(wht (regexp "^\\s+"))
-	)
-    (with-input-from-pipe 
-     "top -n 1 -b"
-     (lambda ()
-       (let loop ((inl   (read-line))
-		  (inbod #f))
-	 (if (eof-object? inl)
-	     dat
-	     (if (not inbod)
-		 (if (string-search hdr inl)
-		     (loop (read-line) #t)
-		     (loop (read-line) #f))
-		 (let* ((lparts (map (lambda (x)
-				       (let ((num (get-number x)))
-					 (if num num x)))
-				     (string-split-fields rx (string-substitute wht "" inl) #:infix))))
-		   (if (> (length lparts) 10)
-		       (let* ((user   (list-ref lparts 1))
-			      (virt   (list-ref lparts 4))
-			      (res    (list-ref lparts 5))
-			      (%cpu   (list-ref lparts 8))
-			      (%mem   (list-ref lparts 9))
-			      (time   (list-ref lparts 10))
-			      (pname  (list-ref lparts 11))
-			      (udat   (or (hash-table-ref/default dat user #f)
-					  (let ((u (make-hash-table)))
-					    (hash-table-set! dat user u)
-					    u)))
-			      (pdat   (or (hash-table-ref/default udat pname #f)
-					  (let ((p (make-processdat 0 0 0 0 0)))
-					    (hash-table-set! udat pname p)
-					    p))))
-			 (print "User: " user ", pname: " pname ", virt: " virt ", res: " res ", %cpu: " %cpu ", %mem: " %mem)
-			 (processdat-%cpu-set!  pdat (+ (processdat-%cpu pdat) %cpu))
-			 (processdat-%mem-set!  pdat (+ (processdat-%mem pdat) %mem))
-			 (processdat-virt-set!  pdat (+ (processdat-virt pdat) virt))
-			 (processdat-res-set!   pdat (+ (processdat-res pdat)  res))
-			 (processdat-count-set! pdat (+ (processdat-count pdat) 1))
-			 (loop (read-line) inbod))
-		       dat)))))))))
-    
-(define x (snagload))
-;; (processdat-%cpu (hash-table-ref (hash-table-ref x "matt") "evolution-calen"))

DELETED loadwatch/queuefeeder-server.scm
Index: loadwatch/queuefeeder-server.scm
==================================================================
--- loadwatch/queuefeeder-server.scm
+++ /dev/null
@@ -1,185 +0,0 @@
-;;======================================================================
-;; Copyright 2015-2015, Matthew Welland.
-;; 
-;;  This program is made available under the GNU GPL version 2.0 or
-;;  greater. See the accompanying file COPYING for details.
-;; 
-;;  This program is distributed WITHOUT ANY WARRANTY; without even the
-;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-;;  PURPOSE.
-;;======================================================================
-
-;; Queue Feeder. Use a crude droop curve to limit feeding jobs into a queue
-;;               to prevent slamming the queue
-
-;;======================================================================
-;; Methodology
-;;
-;;   Connect to the server, the server delays the appropriate time (if 
-;;   any) and then launch the task.
-;;
-
-(use nanomsg posix regex)
-
-;; (use trace)
-;; (trace nn-bind nn-socket nn-assert nn-recv nn-send thread-terminate! nn-close )
-
-(define port  22022)
-
-;; get needed stuff from commandline
-;;
-(define queuelen #f)
-(define cmd '()) ;; cmd is run to give a count of the queue length => returns number in queue
-
-(define usage "Usage: queuefeeder-server port target_queue_length command
-       where command is a script or program that gives an integer on stdout of current queue length")
-
-(let ((args (argv)))
-  (if (> (length args) 3)
-      (begin
-	(set! port     (cadr args))
-	(set! queuelen (string->number (caddr args)))
-	(set! cmd      (cadddr args))) ;; no params supported
-      (begin
-	(print usage)
-	(exit))))
-
-(if (not queuelen)
-    (begin
-      (print "queuelen must be a number")
-      (print usage)
-      (exit)))
-
-(print "Running queue feeder with port=" port ", command=" cmd)
-
-(define rep   (nn-socket 'rep))
-
-(print "connecting, got: " (nn-bind    rep  (conc "tcp://" "*" ":" port)))
-
-(define *current-delay* 0)
-(define (exp-droop-calc x targ)
-  (cond
-   ((> (- x targ) 1) 136) ;; top off at 136 seconds
-   (else 
-    (let ((res (* 50 (exp (- x targ)))))
-      (cond
-       ((and (> res 0)(< res 0.01)) 0.01)
-       ((> res 45)                  45) ;; cap at 45 seconds
-       (else res))))))
-
-;; x input value (current number in the queue)
-;; targ is the desired queue length
-;;
-(define (piecewise-droop-calc x targ)
-  (let ((top 50))
-    (cond
-     ((> (- x targ) 0)
-      top) ;; top off at top seconds
-     ((> x (- targ top))
-      (+ (* 1 (- x (- targ top)))
-	 (/ (- top targ) targ)))
-     (else (let ((res (/ x targ)))
-	     (if (< res 0.01)
-		 0.01
-		 res))))))
-
-(define (server soc)
-  (print "server starting")
-  (let loop ((msg-in (nn-recv soc))
-	     (count  0))
-    (if (eq? 0 (modulo count 1000))
-	(print "server received: " msg-in ", count=" count))
-    (cond
-     ((equal? msg-in "quit")
-      (nn-send soc "Ok, quitting"))
-     ((and (>= (string-length msg-in) 4)
-	   (equal? (substring msg-in 0 4) "ping"))
-      (nn-send soc (conc (current-process-id)))
-      (loop (nn-recv soc)(+ count 1)))
-     (else
-      (mutex-lock! *current-delay-mutex*)
-      (let ((current-delay *current-delay*))
-	(mutex-unlock! *current-delay-mutex*)
-	;; (thread-sleep! current-delay)
-	(nn-send soc (conc current-delay " hello " msg-in " you waited " current-delay " seconds"))
-	(loop (nn-recv soc)(if (> count 20000000)
-			       0
-			       (+ count 1))))))))
-
-(define (ping-self host port #!key (return-socket #t))
-  ;; send a random number along with pid and check that we get it back
-  (let* ((req     (nn-socket 'req))
-	 (key     "ping")
-	 (success #f)
-	 (keepwaiting #t)
-	 (ping    (make-thread
-		   (lambda ()
-		     (print "ping: sending string \"" key "\", expecting " (current-process-id))
-		     (nn-send req key)
-		     (let ((result  (nn-recv req)))
-		       (if (equal? (conc (current-process-id)) result)
-			   (begin
-			     (print "ping, success: received \"" result "\"")
-			     (set! success #t))
-			   (begin
-			     (print "ping, failed: received key \"" result "\"")
-			     (set! keepwaiting #f)
-			     (set! success #f)))))
-		   "ping"))
-	 (timeout (make-thread (lambda ()
-				 (let loop ((count 0))
-				   (thread-sleep! 1)
-				   (print "still waiting after " count " seconds...")
-				   (if (and keepwaiting (< count 10))
-				       (loop (+ count 1))))
-				 (if keepwaiting
-				     (begin
-				       (print "timeout waiting for ping")
-				       (thread-terminate! ping))))
-			       "timeout")))
-    (nn-connect req (conc "tcp://" host ":" port))
-    (handle-exceptions
-     exn
-     (begin
-       (print-call-chain)
-       (print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
-       (print "exn=" (condition->list exn))
-       (print "ping failed to connect to " host ":" port))
-     (thread-start! timeout)
-     (thread-start! ping)
-     (thread-join! ping)
-     (if success (thread-terminate! timeout)))
-    (if return-socket
-	(if success req #f)
-	(begin
-	  (nn-close req)
-	  success))))
-
-(define *current-delay-mutex* (make-mutex))
-
-;; update the *current-delay* value every minute or QUEUE_CHK_DELAY seconds
-(thread-start! (make-thread (lambda ()
-			      (let ((delay-time (string->number (or (get-environment-variable "QUEUE_CHK_DELAY") "30"))))
-				(let loop ()
-				  (with-input-from-pipe 
-				   cmd  ;;; my query to get queue length
-				   (lambda ()
-				     (let* ((val       (read))
-					    (droop-val (if (number? val)(piecewise-droop-calc val queuelen) #f)))
-				       ;; val is number of jobs in queue. Use a linear droop of val/40
-				       (mutex-lock! *current-delay-mutex*)
-				       (set! *current-delay* (or droop-val 30)) ;; (/ (or droop-val 100) 50))
-				       (mutex-unlock! *current-delay-mutex*)
-				       (print "droop-val=" droop-val)
-				       (thread-sleep! delay-time))))
-				  (loop))))))
-
-(let ((server-thread (make-thread (lambda ()(server rep)) "server")))
-  (thread-start! server-thread)
-  (if (ping-self (get-host-name) port)
-      (begin
-	(thread-join! server-thread)
-	(nn-close rep))
-      (print "ping failed")))
-
-(exit)

DELETED loadwatch/queuefeeder.scm
Index: loadwatch/queuefeeder.scm
==================================================================
--- loadwatch/queuefeeder.scm
+++ /dev/null
@@ -1,96 +0,0 @@
-;;======================================================================
-;; Copyright 2015-2015, Matthew Welland.
-;; 
-;;  This program is made available under the GNU GPL version 2.0 or
-;;  greater. See the accompanying file COPYING for details.
-;; 
-;;  This program is distributed WITHOUT ANY WARRANTY; without even the
-;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-;;  PURPOSE.
-;;======================================================================
-
-;; Queue Feeder. Use a crude droop curve to limit feeding jobs into a queue
-;;               to prevent slamming the queue
-
-;;======================================================================
-;; Methodology
-;;
-;;   Connect to the server, the server delays the appropriate time (if 
-;;   any) and then launch the task.
-;;
-(use nanomsg posix regex message-digest md5)
-
-(define req   (nn-socket 'req))
-
-;; get needed stuff from commandline
-;;
-(define hostport #f)
-(define cmd '())
-
-(let ((args (argv)))
-  (if (> (length args) 2)
-      (begin
-	(set! hostport (cadr args))
-	(set! cmd      (cddr args)))
-      (begin
-	(print "Usage: queuefeeder host:port command params ....")
-	(exit))))
-
-(nn-connect req  (conc "tcp://" hostport)) ;; xena:22022")
-
-(define (client-send-receive soc msg)
-  (nn-send soc msg)
-  (nn-recv soc))
-
-;; Generate a unique signature for this client location
-;;
-(define (make-signature)
-  (message-digest-string (md5-primitive) 
-                         (with-output-to-string
-                           (lambda ()
-                             (write (current-directory))))))
-
-;; (define ((talk-to-server soc))
-;;   (let loop ((cnt 200000))
-;;     (let ((name (list-ref '("Matt" "Tom" "Bob" "Jill" "James" "Jane")(random 6))))
-;;       ;; (print "Sending " name)
-;;       ;; (print
-;;       (client-send-receive req name) ;; )
-;;       (if (> cnt 0)(loop (- cnt 1)))))
-;;   (print (client-send-receive req "quit"))
-;;   (nn-close req)
-;;   (exit))
-;; 
-
-(define (get-delay signature)
-  (let* ((full-msg   (client-send-receive req (conc (current-user-name) "@" (get-host-name) ":" signature))))
-    (print "Got " full-msg)
-    (let* ((reply-msg  (string-match "^([\\d\\.]+)\\s+(.*)$" full-msg))
-	   (delay-time (if (> (length reply-msg) 2)
-			   (string->number (cadr reply-msg))
-			   1)) ;; fall back to one sec delay
-	   (msg        (if (> (length reply-msg) 2)
-			   (caddr reply-msg)
-			   full-msg)))
-      (values delay-time msg))))
-
-
-(let ((signature (make-signature)))
-  
-  (thread-start! (lambda ()
-		   (thread-sleep! 60)
-		   (print "Give up on waiting for the server")
-		   ;; (nn-close req)
-		   ;; (exit)
-		   ))
-  (thread-join! (thread-start! (lambda ()
-				 (let-values 
-				  (((delay-time msg)(get-delay signature)))
-				  (print "INFO: sleeping " delay-time " seconds per request of queuefeeder server")
-				  (thread-sleep! delay-time)
-				  (print "INFO: done waiting, now executing requested task.")))))
-  (nn-close req))
-
-(process-execute (car cmd) (cdr cmd))
-
-

DELETED loadwatch/testopenlava.sh
Index: loadwatch/testopenlava.sh
==================================================================
--- loadwatch/testopenlava.sh
+++ /dev/null
@@ -1,9 +0,0 @@
-#!/bin/bash
-
-job_order=$1
-job_length=$2
-
-echo "START: $job_order" > $job_order.log
-sleep $job_length
-echo "END: $job_order" >> $job_order.log
-

Index: megatest-version.scm
==================================================================
--- megatest-version.scm
+++ megatest-version.scm
@@ -1,7 +1,7 @@
 ;; Always use two or four digit decimal
 ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
 
 (declare (unit megatest-version))
 
-(define megatest-version 1.6506)
+(define megatest-version 1.6508)
 

Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -265,22 +265,11 @@
 (define (megatest-param->mtutil-param param)
   (let* ((mapping-alist (common:get-param-mapping flavor: 'switch-symbol)))
     (alist-ref (string->symbol param) mapping-alist eq? param)
     param))
 
-(define (val->alist val)
-  (let ((val-list (string-split-fields ";\\s*" val #:infix)))
-    (if val-list
-	(map (lambda (x)
-	       (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
-		 (case (length f)
-		   ((0) `(,#f))  ;; null string case
-		   ((1) `(,(string->symbol (car f))))
-		   ((2) `(,(string->symbol (car f)) . ,(cadr f)))
-		   (else f))))
-	     val-list)
-	'())))
+(define val->alist common:val->alist)
 
 (define (push-run-spec torun contour runkey spec)
   (configf:section-var-set! torun contour runkey
 			    (cons spec
 				  (or (configf:lookup torun contour runkey)
@@ -547,11 +536,11 @@
 ;; 
 (define (create-run-pkt mtconf action area runkey target runname mode-patt 
                         tag-expr pktsdir reason contour sched dbdest append-conf
                         runtrans)
   (let* ((good-val   (lambda (inval)(and inval (string? inval)(not (string-null? inval)))))
-	 (area-dat   (val->alist (or (configf:lookup mtconf "areas" area) "")))
+	 (area-dat   (common:val->alist (or (configf:lookup mtconf "areas" area) "")))
 	 (area-path  (alist-ref 'path      area-dat))
 	 ;; (area-xlatr (alist-ref 'targtrans area-dat))
          ;; (xlatr-key  (if area-xlatr (string->symbol area-xlatr) #f))
          (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f))
 			     (mapper   (if callname (hash-table-ref/default *runname-mappers* callname #f) #f)))
@@ -671,11 +660,11 @@
 			(len-key    (length keyparts))
 			(ruletype   (if (> len-key 1)(cadr keyparts) #f))
 			(action     (if (> len-key 2)(caddr keyparts) #f))
 			(optional   (if (> len-key 3)(cadddr keyparts) #f))
 			;; (val-list   (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params
-			(val-alist  (val->alist val))
+			(val-alist  (common:val->alist val))
 			(runname    (make-runname "" ""))
 			(runtrans   (alist-ref 'runtrans val-alist))
 
 			;; these may or may not be defined and not all are used in each handler type in the case below
 			(run-name   (alist-ref 'run-name val-alist))
@@ -916,11 +905,11 @@
 	 
 	 ;; now have to run populated
 	 (for-each
 	  (lambda (contour)
 	    (let* ((cval       (or (configf:lookup mtconf "contours" contour) ""))
-		   (cval-alist (val->alist cval))                     ;; BEWARE ... NOT the same val-alist as above!
+		   (cval-alist (common:val->alist cval))                     ;; BEWARE ... NOT the same val-alist as above!
 		   (areas      (val-alist->areas cval-alist))
 		   (selector   (alist-ref 'selector cval-alist))
 		   (mode-tag   (and selector (string-split-fields "/" selector #:infix)))
 		   (mode-patt  (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)))
 		   (tag-expr   (and mode-tag (if (null? mode-tag) #f (car mode-tag)))))
@@ -934,11 +923,11 @@
 		    (lambda (runkeydat)
 		      (for-each
 		       (lambda (area)
 			 (if (area-allowed? area areas runkey contour mode-patt) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...)
                              (let* ((aval       (or (configf:lookup mtconf "areas" area) ""))
-                                    (aval-alist (val->alist aval))
+                                    (aval-alist (common:val->alist aval))
                                     (runname    (alist-ref 'runname runkeydat))
                                     (runtrans   (alist-ref 'runtrans runkeydat))
                                     
                                     (reason     (alist-ref 'message runkeydat))
                                     (sched      (alist-ref 'sched   runkeydat))
@@ -1113,11 +1102,11 @@
       ((run remove rerun set-ss archive kill list)
        (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
 	      (mtconf    (car mtconfdat))
 	      (area      (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section
 	      (areasec   (if area (configf:lookup mtconf "areas" area) #f))
-	      (areadat   (if areasec (val->alist areasec) #f))
+	      (areadat   (if areasec (common:val->alist areasec) #f))
 	      (area-path (if areadat (alist-ref 'path areadat) #f))
 	      (pktsdirs  (configf:lookup mtconf "setup" "pktsdirs"))
 	      (pktsdir   (if pktsdirs (car (string-split pktsdirs " ")) #f))
 	      (adjargs   (hash-table-copy args:arg-hash))
 	      (new-ss    (args:get-arg "-new")))

ADDED   oldsrc/multi-dboard.scm
Index: oldsrc/multi-dboard.scm
==================================================================
--- /dev/null
+++ oldsrc/multi-dboard.scm
@@ -0,0 +1,801 @@
+;;======================================================================
+;; Copyright 2006-2013, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+;;======================================================================
+
+(use format numbers sql-de-lite srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
+(require-library iup)
+(import (prefix iup iup:))
+(use canvas-draw)
+
+(declare (uses margs))
+(declare (uses megatest-version))
+(declare (uses gutils))
+(declare (uses tree))
+(declare (uses configf))
+(declare (uses portlogger))
+(declare (uses keys))
+(declare (uses common))
+
+(include "common_records.scm")
+;; (include "db_records.scm")
+;; (include "key_records.scm")
+
+(define help (conc 
+	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
+  version " megatest-version "
+  license GPL, Copyright (C) Matt Welland 2011
+
+Usage: dashboard [options]
+  -h                : this help
+  -group groupname  : display this group of areas
+  -test testid      : control test identified by testid
+  -guimonitor       : control panel for runs
+
+Misc
+  -rows N         : set number of rows
+"))
+
+;; process args
+(define remargs (args:get-args 
+		 (argv)
+		 (list  "-group" ;; display this group of areas
+			"-debug"
+			) 
+		 (list  "-h"
+			"-v"
+			"-q"
+			)
+		 args:arg-hash
+		 0))
+
+(if (args:get-arg "-h")
+    (begin
+      (print help)
+      (exit)))
+
+;; (if (args:get-arg "-host")
+;;     (begin
+;;       (set! (common:get-remote remote) (string-split (args:get-arg "-host" ":")))
+;;       (client:launch))
+;;     (client:launch))
+
+(define *runremote* #f)
+(define *windows* (make-hash-table))
+(define *changed-main* (make-hash-table)) ;; set path/... => #t
+(define *changed-mutex* (make-mutex))     ;; use for all incoming change requests
+(define *searchpatts*   (make-hash-table))
+
+(debug:setup)
+
+(define *tim* (iup:timer))
+(define *ord* #f)
+
+(iup:attribute-set! *tim* "TIME" 300)
+(iup:attribute-set! *tim* "RUN" "YES")
+
+(define (message-window msg)
+  (iup:show
+   (iup:dialog
+    (iup:vbox 
+     (iup:label msg #:margin "40x40")))))
+
+(define (iuplistbox-fill-list lb items . default)
+  (let ((i 1)
+	(selected-item (if (null? default) #f (car default))))
+    (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
+    (for-each (lambda (item)
+		(iup:attribute-set! lb (number->string i) item)
+		(if selected-item
+		    (if (equal? selected-item item)
+			(iup:attribute-set! lb "VALUE" item))) ;; (number->string i))))
+		(set! i (+ i 1)))
+	      items)
+    i))
+
+(define (pad-list l n)(append l (make-list (- n (length l)))))
+
+
+(define (mkstr . x)
+  (string-intersperse (map conc x) ","))
+
+(define (update-search x val)
+  (hash-table-set! *searchpatts* x val))
+
+
+;;======================================================================
+;; R E C O R D S
+;;======================================================================
+
+;; NOTE: Consider switching to defstruct.
+
+;; data for an area (regression or testsuite)
+;;
+(define-record areadat
+  name               ;; area name
+  path               ;; mt run area home
+  configdat          ;; megatest config
+  denoise            ;; focal point for not putting out same messages over and over
+  client-signature   ;; key for client-server conversation
+  remote             ;; hash of all the client side connnections
+  run-keys           ;; target keys for this area
+  runs               ;; used in dashboard, hash of run-ids -> rundat
+  read-only          ;; can I write to this area?
+  monitordb          ;; db handle for monitor.db
+  maindb             ;; db handle for main.db
+  )
+
+;; rundat, basic run data
+;;
+(define-record rundat
+  id                 ;; the run-id
+  target             ;; val1/val2 ... corrosponding to run-keys in areadat
+  runname
+  state              ;; state of the run, symbol 
+  status             ;; status of the run, symbol
+  event-time         ;; when the run was initiated
+  tests              ;; hash of test-id -> testdat, QUESTION: separate by run-id?
+  db                 ;; db handle
+  )
+
+;; testdat, basic test data
+(define-record testdat
+  run-id             ;; what run is this from
+  id                 ;; test id
+  testname           ;; test name
+  itempath           ;; item path
+  state              ;; test state, symbol
+  status             ;; test status, symbol
+  event-time         ;; when the test started
+  duration           ;; how long the test took
+  )
+
+;; general data for the dboard application
+;;
+(define-record data
+  cfgdat             ;; data from ~/.megatest/<group>.dat
+  areas              ;; hash of areaname -> area-rec
+  current-window-id  ;; 
+  current-tab-id     ;; 
+  update-needed      ;; flag to indicate that the tab pointed to by current tab id needs refreshing immediately
+  tabs               ;; hash of tab-id -> areaname (??) should be of type "tab"
+  )
+
+;; all the components of an area display, all fits into a tab but
+;; parts may be swapped in/out as needed
+;;
+(define-record tab
+  tree
+  matrix    ;; the spreadsheet 
+  areadat   ;; the one-structure (one day dbstruct will be put in here)
+  view-path ;; <target/path>/<runname>/...
+  view-type ;; standard, etc.
+  controls  ;; the controls
+  data      ;; all the data kept in sync with db
+  filters   ;; user filters, alist name -> filter record, eventually store these in ~/.megatest/<group>.dat?
+  run-id    ;; the current run-id
+  test-ids  ;; the current test id hash, run-id => test-id
+  command   ;; the command from the entry field
+  headers   ;; hash of header  -> colnum
+  rows      ;; hash of rowname -> rownum
+  )
+
+(define-record filter
+  target    ;; hash of widgets for the target
+  runname   ;; the runname widget
+  testpatt  ;; the testpatt widget
+  )
+
+;;======================================================================
+;; D B
+;;======================================================================
+
+;; These are all using sql-de-lite and independent of area so cannot use stuff 
+;; from db.scm
+
+;; NB// run-id=#f => return dbdir only
+;;
+(define (areadb:dbfile-path areadat run-id)
+  (let* ((cfgdat  (areadat-configdat areadat))
+	 (dbdir   (or (configf:lookup cfgdat "setup" "dbdir")
+		      (conc (configf:lookup cfgdat "setup" "linktree") "/.db")))
+	 (fname   (if run-id
+		      (case run-id
+			((-1) "monitor.db")
+			((0) "main.db")
+			(else (conc run-id ".db")))
+		      #f)))
+    (handle-exceptions
+     exn
+     (begin
+       (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
+       (exit 1))
+     (if (not (directory? dbdir))(create-directory dbdir #t)))
+    (if fname
+	(conc dbdir "/" fname)
+	dbdir)))
+
+;; -1 => monitor.db
+;;  0 => main.db
+;; >1 => <run-id>.db
+;;
+(define (areadb:open areadat run-id)
+  (let* ((runs   (areadat-runs areadat))
+	 (rundat (if (> run-id 0) ;; it is a run
+		     (hash-table-ref/default runs run-id #f)
+		     #f))
+	 (db     (case run-id ;; if already opened, get the db and return it
+		   ((-1) (areadat-monitordb areadat))
+		   ((0)  (areadat-maindb    areadat))
+		   (else (if rundat
+			     (rundat-db rundat)
+			     #f)))))
+    (if db
+	db ;; merely return the already opened db
+	(let* ((dbfile (areadb:dbfile-path areadat run-id)) ;; not already opened, so open it
+	       (db     (if (file-exists? dbfile)
+			   (open-database dbfile)
+			   (begin
+			     (debug:print-error 0 *default-log-port* "I was asked to open " dbfile ", but file does not exist or is not readable.")
+			     #f))))
+	  (case run-id
+	    ((-1)(areadat-monitordb-set! areadat db))
+	    ((0) (areadat-maindb-set!    areadat db))
+	    (else (rundat-db-set!        rundat  db)))
+	  db))))
+
+;; populate the areadat tests info, does NOT fill the tests data itself unless asked
+;;
+(define (areadb:populate-run-info areadat)
+  (let* ((runs   (or (areadat-runs areadat) (make-hash-table)))
+	 (keys   (areadat-run-keys areadat))
+	 (maindb (areadb:open areadat 0)))
+    (if maindb
+	(query (for-each-row (lambda (row)
+			       (let ((id  (list-ref row 0))
+				     (dat (apply make-rundat (append row (list #f #f))))) ;; add placeholders for tests and db
+				 (print row)
+				 (hash-table-set! runs id dat))))
+	       (sql maindb (conc "SELECT id,"
+				 (string-intersperse keys "||'/'||")
+				 ",runname,state,status,event_time FROM runs WHERE state != 'deleted';")))
+	(debug:print-error 0 *default-log-port* "no main.db found at "  (areadb:dbfile-path areadat 0)))
+    areadat))
+
+;; given an areadat and target/runname patt fill up runs data
+;;
+;; ?????/
+
+;; given a list of run-ids refresh/retrieve runs data into areadat
+;;
+(define (areadb:fill-tests areadat #!key (run-ids #f))
+  (let* ((runs   (or (areadat-runs areadat) (make-hash-table))))
+    (for-each
+     (lambda (run-id)
+       (let* ((rundat (hash-table-ref/default runs run-id #f))
+	      (tests  (if (and rundat
+			       (rundat-tests rundat)) ;; re-use existing hash table?
+			  (rundat-tests rundat)
+			  (let ((ht (make-hash-table)))
+			    (rundat-tests-set! rundat ht)
+			    ht)))
+	      (rundb  (areadb:open areadat run-id)))
+	 (query (for-each-row (lambda (row)
+				(let* ((id         (list-ref row 0))
+				       (testname   (list-ref row 1))
+				       (itempath   (list-ref row 2))
+				       (state      (list-ref row 3))
+				       (status     (list-ref row 4))
+				       (eventtim   (list-ref row 5))
+				       (duration   (list-ref row 6)))
+				  (hash-table-set! tests id
+						   (make-testdat run-id id testname itempath state status eventtim duration)))))
+		(sql rundb "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE state != 'DELETED';"))))
+     (or run-ids (hash-table-keys runs)))
+    areadat))
+    
+
+;; initialize and refresh data
+;;		
+(define (dboard:general-updater con port)
+  (for-each
+   (lambda (window-id)
+     ;; (print "Processing for window-id " window-id)
+     (let* ((window-dat     (hash-table-ref *windows* window-id))
+	    (areas          (data-areas     window-dat))
+	    ;; (keys           (areadat-run-keys area-dat))
+	    (tabs           (data-tabs      window-dat))
+	    (tab-ids        (hash-table-keys tabs))
+	    (current-tab    (if (null? tab-ids)
+				#f
+				(hash-table-ref tabs (car tab-ids))))
+	    (current-tree   (if (null? tab-ids) #f (tab-tree   current-tab)))
+	    (current-node   (if (null? tab-ids) 0  (string->number (iup:attribute current-tree "VALUE"))))
+	    (current-path   (if (eq? current-node 0)
+				"Areas"
+				(string-intersperse (tree:node->path current-tree current-node) "/")))
+	    (current-matrix (if (null? tab-ids) #f (tab-matrix current-tab)))
+	    (seen-nodes     (make-hash-table))
+	    (path-changed   (if current-tab
+				(equal? current-path (tab-view-path current-tab))
+				#t)))
+       ;; (debug:print-info 0 *default-log-port* "Current path: " current-path)
+       ;; now for each area in the window gather the data
+       (if path-changed
+	   (begin
+	     (debug:print-info 0 *default-log-port* "clearing matrix - path changed")
+	     (dboard:clear-matrix current-tab)))
+       (for-each
+	(lambda (area-name)
+	  ;; (print "Processing for area-name " area-name)
+	  (let* ((area-dat  (hash-table-ref areas area-name))
+		 (area-path (areadat-path   area-dat))
+		 (runs      (areadat-runs   area-dat)))
+	    (if (hash-table-ref/default *changed-main* area-path 'processed)
+		(begin
+		  (print "Processing " area-dat " for area-name " area-name)
+		  (hash-table-set! *changed-main* area-path #f)
+		  (areadb:populate-run-info area-dat)
+		  (for-each 
+		   (lambda (run-id)
+		     (let* ((run     (hash-table-ref runs run-id))
+			    (target  (rundat-target run))
+			    (runname (rundat-runname run)))
+		       (if current-tree
+			   (let* ((partial-path (append (string-split target "/")(list runname)))
+				  (full-path    (cons area-name partial-path)))
+			     (if (not (hash-table-exists? seen-nodes full-path))
+				 (begin
+				   (print "INFO: Adding node " partial-path " to section " area-name)
+				   (tree:add-node current-tree "Areas" full-path)
+				   (areadb:fill-tests area-dat run-ids: (list run-id))))
+				   (hash-table-set! seen-nodes full-path #t)))))
+		   (hash-table-keys runs))))
+	    (if (or (equal? "Areas" current-path)
+		    (string-match (conc "^Areas/" area-name "(|\\/.*)$") current-path))
+		(dboard:redraw-area area-name area-dat current-tab current-matrix current-path))))
+	(hash-table-keys areas))))
+   (hash-table-keys *windows*)))
+
+;;======================================================================
+;; D A S H B O A R D   D B 
+;;======================================================================
+
+;; All moved to common.scm		
+
+;;======================================================================
+;; T R E E 
+;;======================================================================
+
+;; <area> - <target - ... > - <runname> - <test> - <itempath - ...>
+
+(define (dashboard:tree-browser data adat window-id)
+  ;; (iup:split
+  (let* ((tb      (iup:treebox
+		   #:value 0
+		   #:title "Areas"
+		   #:expand "YES"
+		   #:addexpanded "NO"
+		   #:selection-cb
+		   (lambda (obj id state)
+		     ;; (print "obj: " obj ", id: " id ", state: " state)
+		     (let* ((tree-path (tree:node->path obj id))
+			    (area      (car tree-path))
+			    (areadat-path (cdr tree-path)))
+		       #f
+		       ;; (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))))))
+		       )))))
+    ;; (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))
+
+;;======================================================================
+;; M A I N   M A T R I X
+;;======================================================================
+
+;; General displayer
+;;
+(define (dashboard:main-matrix data adat window-id)
+  (let* (;; (tab-dat         (areadat-
+	 (view-matrix     (iup:matrix
+			   ;; (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f))
+			   #:expand "YES"
+			   ;; #:fittosize "YES"
+			   #:resizematrix "YES"
+			   #:scrollbar "YES"
+			   #:numcol 100
+			   #:numlin 100
+			   #:numcol-visible 3
+			   #:numlin-visible 20
+			   #:click-cb (lambda (obj lin col status)
+					(print "obj: " obj " lin: " lin " col: " col " status: " status " value: " (iup:attribute obj "VALUE"))))))
+    
+    ;; (iup:attribute-set! view-matrix "RESIZEMATRIX" "YES")
+    (iup:attribute-set! view-matrix "WIDTH0" "100")
+    ;; (dboard:data-runs-matrix-set! *data* runs-matrix)
+    ;; (iup:hbox
+    ;;  (iup:frame 
+    ;;   #:title "Runs browser"
+    ;;   (iup:vbox
+    view-matrix))
+
+;;======================================================================
+;; A R E A S
+;;======================================================================
+
+(define (dashboard:init-area data area-name apath)
+  (let* ((mtconf      (dboard:read-mtconf apath))
+	 (area-dat    (let ((ad (make-areadat
+				 area-name ;; area name
+				 apath     ;; path to area
+				 ;; 'http     ;; transport
+				 mtconf    ;; megatest.config
+				 (make-hash-table) ;; denoise hash
+				 #f        ;; client-signature
+				 #f        ;; remote connections
+				 (keys:config-get-fields mtconf) ;; run keys
+				 (make-hash-table) ;; run-id -> (hash of test-ids => dat)
+				 (and (file-exists? apath)(file-write-access? apath)) ;; read-only
+				 #f
+				 #f
+				 )))
+			(hash-table-set! (data-areas data) area-name ad)
+			ad)))
+    area-dat))
+
+;; given the keys for an area and a path from the tree browser
+;; return the level: areas area runs run tests test
+;;
+(define (dboard:get-view-type keys current-path)
+  (let* ((path-parts (string-split current-path "/"))
+	 (path-len   (length path-parts)))
+    (cond
+     ((equal? current-path "Areas")     'areas)
+     ((eq? path-len 2)                  'area)
+     ((<= (+ (length keys) 2) path-len) 'runs)
+     (else                              'run))))
+
+(define (dboard:clear-matrix tab)
+  (if tab
+      (begin
+	(iup:attribute-set! (tab-matrix tab) "CLEARVALUE" "ALL")
+	(tab-headers-set! tab (make-hash-table))
+	(tab-rows-set!    tab (make-hash-table)))))
+
+;; full redraw of a given area
+;;
+(define (dboard:redraw-area area-name area-dat tab-dat current-matrix current-path)
+  (let* ((keys      (areadat-run-keys area-dat))
+	 (runs      (areadat-runs     area-dat))
+	 (headers   (tab-headers   tab-dat))
+	 (rows      (tab-rows      tab-dat))
+	 (used-cols (hash-table-values headers))
+	 (used-rows (hash-table-values rows))
+	 (touched   (make-hash-table)) ;; (vector row col) ==> true, touched cell
+	 (view-type (dboard:get-view-type keys current-path))
+	 (changed   #f)
+	 (state-statuses  (list "PASS" "FAIL" "WARN" "CHECK" "SKIP" "RUNNING" "LAUNCHED")))
+    ;; (debug:print 0 *default-log-port* "current-matrix=" current-matrix)
+    (case view-type
+      ((areas) ;; find row for this area, if not found, create new entry
+       (let* ((curr-rownum (hash-table-ref/default rows area-name #f))
+	      (next-rownum (+ (apply max (cons 0 used-rows)) 1))
+	      (rownum      (or curr-rownum next-rownum))
+	      (coord       (conc rownum ":0")))
+	 (if (not curr-rownum)(hash-table-set! rows area-name rownum))
+	 (if (not (equal? (iup:attribute current-matrix coord) area-name))
+	     (begin
+	       (let loop ((hed  (car state-statuses))
+			  (tal  (cdr state-statuses))
+			  (count 1))
+		 (if (not (equal? (iup:attribute current-matrix (conc "0:" count)) hed))
+		     (iup:attribute-set! current-matrix (conc "0:" count) hed))
+		 (iup:attribute-set! current-matrix (conc rownum ":" count) "0")
+		 (if (not (null? tal))
+		     (loop (car tal)(cdr tal)(+ count 1))))
+	       (debug:print-info 0 *default-log-port* "view-type=" view-type ", rownum=" rownum ", curr-rownum=" curr-rownum ", next-rownum=" next-rownum ", coord=" coord ", area-name=" area-name)
+	       (iup:attribute-set! current-matrix coord area-name)
+	       (set! changed #t))))))
+    (if changed (iup:attribute-set! current-matrix "REDRAW" "ALL"))))
+	     
+
+       
+   ;; (dboard:clear-matrix current-matrix used-cols used-rows touched) ;; clear all
+    
+	
+  
+;;======================================================================
+;; D A S H B O A R D
+;;======================================================================
+
+(define (dashboard:area-panel aname data window-id)
+  (let* ((apath      (configf:lookup (data-cfgdat data) aname "path")) ;;  (hash-table-ref (dboard:data-cfgdat data) area-name))
+	 ;;          (hash-table-ref (dboard:data-cfgdat data) aname))
+	 (area-dat   (dashboard:init-area data aname apath))
+	 (tb         (dashboard:tree-browser data area-dat window-id)) ;; (dboard:areas-tree-browser data)
+	 (ad         (dashboard:main-matrix  data area-dat window-id))
+	 (areas      (data-areas data))
+	 (dboard-dat (make-tab
+		      #f           ;; tree
+		      #f           ;; matrix
+		      area-dat     ;;
+		      #f           ;; view path
+		      'default     ;; view type
+		      #f           ;; controls
+		      (make-hash-table) ;; cached data? not sure how to use this yet :)
+		      #f           ;; filters
+		      #f           ;; the run-id
+		      (make-hash-table) ;; run-id -> test-id, for current test id
+		      ""
+		      (make-hash-table) ;; headername -> colnum
+		      (make-hash-table) ;; rowname    -> rownum
+		      )))
+    (hash-table-set! (data-areas data) aname area-dat) ;; dboard-dat)
+    (hash-table-set! (data-tabs data) window-id dboard-dat)
+    (tab-tree-set!   dboard-dat tb)
+    (tab-matrix-set! dboard-dat ad)
+    (iup:split
+     #:value 200
+     tb ad)))
+
+
+;; Main Panel
+;;
+(define (dashboard:main-panel data window-id)
+  (iup:dialog
+   #:title "Megatest Control Panel"
+;;   #:menu (dcommon:main-menu data)
+   #:shrink "YES"
+   (iup:vbox
+    (let* ((area-names  (hash-table-keys (data-cfgdat data)))
+	   (area-panels (map (lambda (aname)
+			       (dashboard:area-panel aname data window-id))
+			     area-names))
+	   (tabtop      (apply iup:tabs  
+			       #:tabchangepos-cb (lambda (obj curr prev)
+						   (data-current-tab-id-set! data curr)
+						   (data-update-needed-set!  data #t)
+						   (print "Tab is: " curr ", prev was " prev))
+			       area-panels))
+	   (tabs     (data-tabs data)))
+      (if (not (null? area-names))
+	  (let loop ((index 0)
+		     (hed   (car area-names))
+		     (tal   (cdr area-names)))
+	    ;; (hash-table-set! tabs index hed)
+	    (debug:print 0 *default-log-port* "Adding area " hed " with index " index " to dashboard")
+	    (iup:attribute-set! tabtop (conc "TABTITLE" index) hed)
+	    (if (not (null? tal))
+		(loop (+ index 1)(car tal)(cdr tal)))))
+      tabtop))))
+
+
+;;======================================================================
+;; N A N O M S G   S E R V E R
+;;======================================================================
+
+(define (dboard:server-service soc port)
+  (print "server starting")
+  (let loop ((msg-in (nn-recv soc))
+	     (count  0))
+    (if (eq? 0 (modulo count 1000))
+	(print "server received: " msg-in ", count=" count))
+    (cond
+     ;;
+     ;; quit
+     ;;
+     ((equal? msg-in "quit")
+      (nn-send soc "Ok, quitting"))
+     ;;
+     ;; ping
+     ;;
+     ((and (>= (string-length msg-in) 4)
+	   (equal? (substring msg-in 0 4) "ping"))
+      (nn-send soc (conc (current-process-id)))
+      (loop (nn-recv soc)(+ count 1)))
+     ;;
+     ;; main changed
+     ;;
+     ((and (>= (string-length msg-in) 4)
+	   (equal? (substring msg-in 0 4) "main"))
+      (let ((parts (string-split msg-in " ")))
+	(hash-table-set! *changed-main* (cadr parts) #t)
+	(nn-send soc "got it!")))
+     ;;
+     ;; ??
+     ;;
+     (else
+      (nn-send soc "hello " msg-in " you got to the else clause!")))
+    (loop (nn-recv soc)(if (> count 20000000)
+			   0
+			   (+ count 1)))))
+
+(define (dboard:one-time-ping-receive soc port)
+  (let ((msg-in (nn-recv soc)))
+    (if (and (>= (string-length msg-in) 4)
+	     (equal? (substring msg-in 0 4) "ping"))
+	(nn-send soc (conc (current-process-id))))))
+
+(define (dboard:server-start given-port #!key (num-tries 200))
+  (let* ((rep (nn-socket 'rep))
+	 (port (or given-port  (portlogger:main "find")))
+	 (con (conc "tcp://*:" port)))
+    ;; register this connect here ....
+    (nn-bind rep con)
+    (thread-start! 
+     (make-thread (lambda ()
+		    (dboard:one-time-ping-receive rep port))
+		  "one time receive thread"))
+    (if (dboard:ping-self "localhost" port)
+	(begin
+	  (print "INFO: dashboard nanomsg server started on " port)
+	  (values rep port))
+	(begin
+	  (print "WARNING: couldn't create server on port " port)
+	  (portlogger:main "set" "failed")
+	  (if (> num-tries 0)
+	      (dboard:server-start #f (- num-tries 1))
+	      (begin
+		(print "ERROR: failed to start nanomsg server")
+		(values #f #f)))))))
+
+(define (dboard:server-close con port)
+  (nn-close con)
+  (portlogger:main "set" port "released"))
+
+(define (dboard:ping-self host port #!key (return-socket #t))
+  ;; send a random number along with pid and check that we get it back
+  (let* ((req     (nn-socket 'req))
+	 (key     "ping")
+	 (success #f)
+	 (keepwaiting #t)
+	 (ping    (make-thread
+		   (lambda ()
+		     (print "ping: sending string \"" key "\", expecting " (current-process-id))
+		     (nn-send req key)
+		     (let ((result  (nn-recv req)))
+		       (if (equal? (conc (current-process-id)) result)
+			   (begin
+			     (print "ping, success: received \"" result "\"")
+			     (set! success #t))
+			   (begin
+			     (print "ping, failed: received key \"" result "\"")
+			     (set! keepwaiting #f)
+			     (set! success #f)))))
+		   "ping"))
+	 (timeout (make-thread (lambda ()
+				 (let loop ((count 0))
+				   (thread-sleep! 1)
+				   (print "still waiting after " count " seconds...")
+				   (if (and keepwaiting (< count 10))
+				       (loop (+ count 1))))
+				 (if keepwaiting
+				     (begin
+				       (print "timeout waiting for ping")
+				       (thread-terminate! ping))))
+			       "timeout")))
+    (nn-connect req (conc "tcp://" host ":" port))
+    (handle-exceptions
+     exn
+     (begin
+       (print-call-chain)
+       (print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+       (print "exn=" (condition->list exn))
+       (print "ping failed to connect to " host ":" port))
+     (thread-start! timeout)
+     (thread-start! ping)
+     (thread-join! ping)
+     (if success (thread-terminate! timeout)))
+    (if return-socket
+	(if success req #f)
+	(begin
+	  (nn-close req)
+	  success))))
+
+;;======================================================================
+;; C O N F I G U R A T I O N 
+;;======================================================================
+
+;; Get the configuration file for a group name, if the group name is "default" and it doesn't 
+;; exist, create it and add the current path if it contains megatest.config
+;;
+(define (dboard:get-config group-name)
+  (let* ((fname (conc (getenv "HOME") "/.megatest/" group-name ".dat")))
+    (if (file-exists? fname)
+	(read-config fname (make-hash-table) #t)
+	(if (dboard:create-config fname)
+	    (dboard:get-config group-name)
+	    (make-hash-table)))))
+
+(define (dboard:create-config fname)
+  ;; (handle-exceptions
+  ;;  exn
+  ;;  
+  ;;  #f ;; failed to create - just give up
+   (let* ((dirname       (pathname-directory fname))
+	  (file-name     (pathname-strip-directory fname))
+	  (curr-mtcfgdat (find-config "megatest.config"
+				      toppath: (or (get-environment-variable "MT_RUN_AREA_HOME")(current-directory))))
+	  (curr-mtcfg    (if (and curr-mtcfgdat (not (null? curr-mtcfgdat)))(cadr curr-mtcfgdat) #f))
+	  (curr-mtpath   (if curr-mtcfg (car curr-mtcfgdat) #f)))
+     (if curr-mtpath
+	 (begin
+	   (debug:print-info 0 *default-log-port* "Creating config file " fname)
+	   (if (not (file-exists? dirname))
+	       (create-directory dirname #t))
+	   (with-output-to-file fname
+	     (lambda ()
+	       (let ((aname (pathname-strip-directory curr-mtpath)))
+		 (print "[" aname "]")
+		 (print  "path " curr-mtpath))))
+	   #t)
+	 (begin
+	   (debug:print-info 0 *default-log-port* "Need to create a config but no megatest.config found: " curr-mtcfgdat)
+	   #f))))
+;; )
+
+(define (dboard:read-mtconf apath)
+  (let* ((mtconffile  (conc apath "/megatest.config")))
+    (call-with-environment-variables
+     (list (cons "MT_RUN_AREA_HOME" apath))
+     (lambda ()
+       (read-config mtconffile (make-hash-table) #f)) ;; megatest.config
+     )))
+	 
+
+;;======================================================================
+;; G U I   S T U F F 
+;;======================================================================
+
+;;; main. Theoretically could have multiple windows (each with a group of tags, thus window-id
+;;;
+(define (dboard:make-window window-id)
+  (let* (;; (window-id 0)
+	 (groupn    (or (args:get-arg "-group") "default"))
+	 (cfgdat    (dboard:get-config groupn))
+	 ;; (cfgdat    (if (file-exists? cfname)(read-config cfname (make-hash-table) #t)(make-hash-table)))
+	 (data      (make-data
+		     cfgdat ;; this is the data from ~/.megatest for the selected group
+		     (make-hash-table) ;; areaname -> area-rec
+		     0                 ;; current window id
+		     0                 ;; current tab id
+		     #f                ;; redraw needed for current tab id
+		     (make-hash-table) ;; tab-id -> areaname
+		     )))
+    (hash-table-set! *windows* window-id data)
+    (iup:show (dashboard:main-panel data window-id))
+    (iup:main-loop)))
+
+;; ease debugging by loading ~/.dashboardrc
+(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
+  (if (file-exists? debugcontrolf)
+      (load debugcontrolf)))
+
+(define (main)
+  (let-values 
+      (((con port)(dboard:server-start #f)))
+    (let ((portnum   (if (string? port)(string->number port) port)))
+      ;; got here, monitor/dashboard was started
+      (mddb:register-dashboard portnum)
+      (thread-start! (make-thread (lambda ()(dboard:server-service con portnum)) "server service"))
+      (thread-start! (make-thread (lambda ()
+				    (let loop ()
+				      (dboard:general-updater con portnum)
+				      (thread-sleep! 1)
+				      (loop))) "general updater"))
+      (dboard:make-window 0)
+      (mddb:unregister-dashboard (get-host-name) portnum)
+      (dboard:server-close con port))))
+

ADDED   oldsrc/nmsg-transport.scm
Index: oldsrc/nmsg-transport.scm
==================================================================
--- /dev/null
+++ oldsrc/nmsg-transport.scm
@@ -0,0 +1,358 @@
+
+;; Copyright 2006-2012, Matthew Welland.
+;; 
+;;  This program is made available under the GNU GPL version 2.0 or
+;;  greater. See the accompanying file COPYING for details.
+;; 
+;;  This program is distributed WITHOUT ANY WARRANTY; without even the
+;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;;  PURPOSE.
+
+(require-extension (srfi 18) extras tcp s11n)
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
+(import (prefix sqlite3 sqlite3:))
+
+;; (use nanomsg)
+
+(declare (unit nmsg-transport))
+
+(declare (uses common))
+(declare (uses db))
+(declare (uses tests))
+(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
+(declare (uses server))
+
+(include "common_records.scm")
+(include "db_records.scm")
+
+;; Transition to pub --> sub with pull <-- push
+;;
+;;   1. client sends request to server via push to the pull port
+;;   2. server puts request in queue or processes immediately as appropriate
+;;   3. server puts responses from completed requests into pub port 
+;;
+;; TODO
+;;
+;; Done Tested
+;; [x]  [ ]    1. Add columns pullport pubport to servers table
+;; [x]  [ ]    2. Add rm of monitor.db if older than 11/12/2012 
+;; [x]  [ ]    3. Add create of pullport and pubport with finding of available ports
+;; [x]  [ ]    4. Add client compose of request
+;; [x]  [ ]        - name of client: testname/itempath-test_id-hostname 
+;; [x]  [ ]        - name of request: callname, params
+;; [x]  [ ]        - request key: f(clientname, callname, params)
+;; [x]  [ ]    5. Add processing of subscription hits
+;; [x]  [ ]        - done when get key 
+;; [x]  [ ]        - return results
+;; [x]  [ ]    6. Add timeout processing
+;; [x]  [ ]        - after 60 seconds
+;; [ ]  [ ]            i. check server alive, connect to new if necessary
+;; [ ]  [ ]           ii. resend request
+;; [ ]  [ ]    7. Turn self ping back on
+
+(define (nmsg-transport:make-server-url hostport #!key (bindall #f))
+  (if (not hostport)
+      #f
+      (conc "tcp://" (if bindall "*" (car hostport)) ":" (cadr hostport))))
+
+(define *server-loop-heart-beat* (current-seconds))
+(define *heartbeat-mutex* (make-mutex))
+
+;;======================================================================
+;; S E R V E R
+;;======================================================================
+
+(define (nmsg-transport:run dbstruct hostn run-id server-id #!key (retrynum 1000))
+  (debug:print 2 *default-log-port* "Attempting to start the server ...")
+  (let* ((start-port      (portlogger:open-run-close portlogger:find-port))
+	 (server-thread   (make-thread (lambda ()
+					 (nmsg-transport:try-start-server dbstruct run-id start-port server-id))
+				       "server thread"))
+	 (tdbdat          (tasks:open-db)))
+    (thread-start! server-thread)
+    (thread-sleep! 0.1)
+    (if (nmsg-transport:ping hostn start-port timeout: 2 expected-key: (current-process-id))
+	(let ((interface (if (equal? hostn "-")(get-host-name) hostn)))
+	  (tasks:server-set-interface-port (db:delay-if-busy tdbdat) server-id interface start-port)
+	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
+	  (set! *server-info* (list hostn start-port)) ;; probably not needed anymore? currently used by keep-running
+	  (thread-sleep! 3) ;; give some margin for queries to complete before switching from file based access to server based access
+	  ;; (set! *inmemdb*  dbstruct)
+	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
+	  (thread-start! (make-thread
+			  (lambda ()(nmsg-transport:keep-running server-id run-id))
+			  "keep running"))
+	  (thread-join! server-thread))
+	(if (> retrynum 0)
+	    (begin
+	      (debug:print 0 *default-log-port* "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.")
+	      (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature")
+	      (portlogger:open-run-close portlogger:set-failed start-port)
+	      (nmsg-transport:run dbstruct hostn run-id server-id))
+	    (begin
+	      (debug:print-error 0 *default-log-port* "could not find an open port to start server on. Giving up")
+	      (exit 1))))))
+
+(define (nmsg-transport:try-start-server dbstruct run-id portnum server-id)
+  (let ((repsoc (nn-socket 'rep)))
+    (nn-bind repsoc (conc "tcp://*:" portnum))
+    (let loop ((msg-in (nn-recv repsoc)))
+      (let* ((dat    (db:string->obj msg-in transport: 'nmsg)))
+	(debug:print 0 *default-log-port* "server, received: " dat)
+	(let ((result (api:execute-requests dbstruct dat)))
+	  (debug:print 0 *default-log-port* "server, sending: " result)
+	  (nn-send repsoc (db:obj->string result  transport: 'nmsg)))
+	(loop (nn-recv repsoc))))))
+
+;; all routes though here end in exit ...
+;;
+(define (nmsg-transport:launch run-id)
+  (let* ((tdbdat   (tasks:open-db))
+	 (dbstruct (db:setup run-id))
+	 (hostn    (or (args:get-arg "-server") "-")))
+    (set! *run-id*   run-id)
+    (set! *inmemdb* dbstruct)
+    ;; with nbfake daemonize isn't really needed
+    ;;
+    ;; (if (args:get-arg "-daemonize")
+    ;;     (begin
+    ;;       (daemon:ize)
+    ;;       (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
+    ;;           (begin
+    ;;     	(current-error-port *alt-log-file*)
+    ;;     	(current-output-port *alt-log-file*)))))
+    (if (server:check-if-running run-id)
+	(begin
+	  (debug:print-info 0 *default-log-port* "Server for run-id " run-id " already running")
+	  (exit 0)))
+    (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
+	       (remtries  4))
+      (if (not server-id)
+	  (if (> remtries 0)
+	      (begin
+		(thread-sleep! 2)
+		(if (not (server:check-if-running run-id))
+		    (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)
+			  (- remtries 1))
+		    (begin
+		      (debug:print-info 0 *default-log-port* "Another server took the slot, exiting")
+		      (exit 0))))
+	      (begin
+		;; since we didn't get the server lock we are going to clean up and bail out
+		(debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
+		(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
+		))
+	  ;; locked in a server id, try to start up
+	  (nmsg-transport:run dbstruct hostn run-id server-id))
+      (set! *didsomething* #t)
+      (exit))))
+
+;;======================================================================
+;; S E R V E R   U T I L I T I E S 
+;;======================================================================
+
+(define (nmsg-transport:mk-signature)
+  (message-digest-string (md5-primitive) 
+			 (with-output-to-string
+			   (lambda ()
+			     (write (list (current-directory)
+					  (argv)))))))
+
+;;======================================================================
+;; C L I E N T S
+;;======================================================================
+
+;; ping the server at host:port
+;;   return the open socket if successful (return-socket == #t)
+;;   expect the key expected-key returned in payload
+;;   send our-key or #f as payload
+;;
+(define (nmsg-transport:ping hostn port #!key (timeout 3)(return-socket #t)(expected-key #f)(our-key #f)(socket #f))
+  ;; send a random number along with pid and check that we get it back
+  (let* ((host    (if (or (not hostn)
+			  (equal? hostn "-")) ;; use localhost
+		      (get-host-name)
+		      hostn))
+	 (req     (or socket
+		      (let ((soc (nn-socket 'req)))
+			(nn-connect soc (conc "tcp://" host ":" port))
+			soc)))
+	 (success #t)
+	 (dat     (vector "ping" our-key))
+	 (result  (condition-case 
+		   (nmsg-transport:client-api-send-receive-raw req dat timeout: timeout)
+		   ((timeout)(set! success #f) #f)))
+	 (key     (if success 
+		      (vector-ref result 1)
+		      #f)))
+    (debug:print 0 *default-log-port* "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key))
+    (if (and success
+	     (or (not expected-key) ;; just getting a reply is good enough then
+		 (equal? key expected-key)))
+	(if return-socket
+	    req
+	    (begin
+	      (if (not socket)(nn-close req)) ;; don't want a side effect of closing socket if handed it
+	      #t))
+	(begin
+	  (if (not socket)(nn-close req)) ;; failed to ping, close socket as side effect
+	  #f))))
+
+;; send data to server, wait max of timeout seconds for a response.
+;; return #( success/fail result )
+;;
+;; for effiency it is easier to do the obj->string and string->obj here.
+;;
+(define (nmsg-transport:client-api-send-receive-raw socreq indat #!key (enable-send #t)(timeout 25))
+  (let* ((success     #f)
+	 (result      #f)
+	 (keepwaiting #t)
+	 (dat         (db:obj->string indat transport: 'nmsg))
+	 (send-recv   (make-thread
+		       (lambda ()
+			 (nn-send socreq dat)
+			 (let* ((res (nn-recv socreq)))
+			   (set! success #t)
+			   (set! result (db:string->obj res transport: 'nmsg))))
+		       "send-recv"))
+	 (timeout     (make-thread
+		       (lambda ()
+			 (let loop ((count 0))
+			   (thread-sleep! 1)
+			   (debug:print-info 1 *default-log-port* "send-receive-raw, still waiting after " count " seconds...")
+			   (if (and keepwaiting (< count timeout)) ;; yes, this is very aproximate
+			       (loop (+ count 1))))
+			 (if keepwaiting
+			     (begin
+			       (print "timeout waiting for ping")
+			       (thread-terminate! send-recv))))
+		       "timeout")))
+    ;; replace with condition-case?
+    (handle-exceptions
+     exn
+     (set! result "timeout")
+     (thread-start! timeout)
+     (thread-start! send-recv)
+     (thread-join! send-recv)
+     (if success (thread-terminate! timeout)))
+    ;; raise timeout error if timed out
+    (if success
+	(if (and (vector? result)
+		 (vector-ref result 0)) ;; did it fail at the server?
+	    result                ;; nope, all good
+	    (begin
+	      (debug:print-error 0 *default-log-port* "error occured at server, info=" (vector-ref result 2))
+	      (debug:print 0 *default-log-port* " client call chain:")
+	      (print-call-chain (current-error-port))
+	      (debug:print 0 *default-log-port* " server call chain:")
+	      (pp (vector-ref result 1) (current-error-port))
+	      (signal (vector-ref result 0))))
+	(signal (make-composite-condition
+		 (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))
+
+;; run nmsg-transport:keep-running in a parallel thread to monitor that the db is being 
+;; used and to shutdown after sometime if it is not.
+;;
+(define (nmsg-transport:keep-running server-id run-id)
+  ;; if none running or if > 20 seconds since 
+  ;; server last used then start shutdown
+  ;; This thread waits for the server to come alive
+  (let* ((server-info (let loop ()
+                        (let ((sdat #f))
+                          (mutex-lock! *heartbeat-mutex*)
+                          (set! sdat *server-info*)
+                          (mutex-unlock! *heartbeat-mutex*)
+                          (if sdat 
+			      (begin
+				(debug:print-info 0 *default-log-port* "keep-running got sdat=" sdat)
+				sdat)
+                              (begin
+                                (thread-sleep! 0.5)
+                                (loop))))))
+         (iface       (car server-info))
+         (port        (cadr server-info))
+         (last-access 0)
+	 (tdbdat      (tasks:open-db))
+	 (server-timeout (let ((tmo (configf:lookup  *configdat* "server" "timeout")))
+			   (if (and (string? tmo)
+				    (string->number tmo))
+			       (* 60 60 (string->number tmo))
+			       ;; (* 3 24 60 60) ;; default to three days
+			       (* 60 1)         ;; default to one minute
+			       ;; (* 60 60 25)      ;; default to 25 hours
+			       ))))
+    (print "Keep-running got server pid " server-id ", using iface " iface " and port " port)
+    (let loop ((count 0))
+      (thread-sleep! 4) ;; no need to do this very often
+      ;; NB// sync currently does NOT return queue-length
+      (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1)))
+      ;; (print "Server running, count is " count)
+        (if (< count 1) ;; 3x3 = 9 secs aprox
+            (loop (+ count 1)))
+        
+        (mutex-lock! *heartbeat-mutex*)
+        (set! last-access *last-db-access*)
+        (mutex-unlock! *heartbeat-mutex*)
+	(db:sync-touched *inmemdb* run-id force-sync: #t)
+        (if (and *server-run*
+	       (> (+ last-access server-timeout)
+		  (current-seconds)))
+            (begin
+              (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
+              (loop 0))
+            (begin
+              (debug:print-info 0 *default-log-port* "Starting to shutdown the server.")
+              (set! *time-to-exit* #t)
+	      (db:sync-touched *inmemdb* run-id force-sync: #t)
+              (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running")
+              (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
+              (exit)
+	      ))))))
+
+;;======================================================================
+;; C L I E N T S
+;;======================================================================
+
+(define (nmsg-transport:client-connect iface portnum)
+  (let* ((reqsoc      (nmsg-transport:ping iface portnum return-socket: #t)))
+    (vector iface portnum #f #f #f (current-seconds) reqsoc)))
+
+;; returns result, there is no sucess/fail flag - handled via excpections
+;;
+(define (nmsg-transport:client-api-send-receive run-id connection-info cmd param #!key (remtries 5))
+  ;; NB// In the html version of this routine there is a call to 
+  ;;      tasks:kill-server-run-id when there is an exception
+  (mutex-lock! *http-mutex*)
+  (let* ((packet  (vector cmd param))
+	 (reqsoc  (http-transport:server-dat-get-socket connection-info))
+	 (res     (nmsg-transport:client-api-send-receive-raw reqsoc packet)))
+;;	 (status  (vector-ref rawres 0))
+;;	 (result  (vector-ref rawres 1)))
+    (mutex-unlock! *http-mutex*)
+    res)) ;; (vector status (if status (db:string->obj result transport: 'nmsg) result))))
+	
+;;======================================================================
+;; J U N K 
+;;======================================================================
+
+;; DO NOT USE
+;;
+(define (nmsg-transport:client-signal-handler signum)
+  (handle-exceptions
+   exn
+   (debug:print 0 *default-log-port* " ... exiting ...")
+   (let ((th1 (make-thread (lambda ()
+			     (if (not *received-response*)
+				 (receive-message* *runremote*))) ;; flush out last call if applicable
+			   "eat response"))
+	 (th2 (make-thread (lambda ()
+			     (debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
+			     (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
+			     (debug:print 0 *default-log-port* "       Done.")
+			     (exit 4))
+			   "exit on ^C timer")))
+     (thread-start! th2)
+     (thread-start! th1)
+     (thread-join! th2))))
+

DELETED remotediff-nmsg.scm
Index: remotediff-nmsg.scm
==================================================================
--- remotediff-nmsg.scm
+++ /dev/null
@@ -1,187 +0,0 @@
-(use posix)
-(use regex)
-(use directory-utils)
-(use srfi-18 srfi-69 nanomsg)
-
-(define (client-send-receive soc msg)
-  (nn-send soc msg)
-  (nn-recv soc))
-
-;;do as calling user
-(define (do-as-calling-user proc)
-  (let ((eid (current-effective-user-id))
-        (cid (current-user-id)))
-    (if (not (eq? eid cid)) ;; running suid
-        (set! (current-effective-user-id) cid))
-    (proc)
-    (if (not (eq? eid cid))
-        (set! (current-effective-user-id) eid))))
-
-;; use mutex to not open/close files at same time
-;;
-(define (checksum mtx file #!key (cmd "shasum"))
-  (mutex-lock! mtx)
-  (let-values (((inp oup pid)
-                (process cmd (list file))))
-    (mutex-unlock! mtx)
-    (let ((result (read-line inp)))
-      ;; now flush out remaining output
-      (let loop ((inl (read-line inp)))
-        (if (eof-object? inl)
-            (if (string? result)
-                (begin
-                  (mutex-lock! mtx)
-                  (close-input-port inp)
-                  (close-output-port oup)
-                  (mutex-unlock! mtx)
-                  (car (string-split result)))
-                #f)
-            (loop (read-line inp)))))))
-
-(define *max-running* 40)
-
-(define my-mutex-lock! conc)
-(define my-mutex-unlock! conc)
-;; (define my-mutex-lock! mutex-lock!)
-;; (define my-mutex-unlock! mutex-unlock!)
-
-(define (gather-dir-info path)
-  (let ((mtx1     (make-mutex))
-        (threads  (make-hash-table))
-        (last-num 0)
-        (req      (nn-socket 'req)))
-    (print "starting client with pid " (current-process-id))
-    (nn-connect req
-                ;; "tcp://localhost:5559")
-                "ipc:///tmp/test-ipc")
-    (find-files 
-     path 
-     ;; test: #t
-     action: (lambda (p res)
-               (let ((info (cond
-                            ((not (file-read-access? p)) '(cant-read))
-                            ((directory? p)              '(dir))
-                            ((symbolic-link? p)          (list 'symlink (read-symbolic-link p)))
-                            (else                        '(data)))))
-                 (if (eq? (car info) 'data)
-                     (let loop ((start-time (current-seconds)))
-                       (my-mutex-lock! mtx1)
-                       (let* ((num-threads (hash-table-size threads))
-                              (ok-to-run   (> *max-running* num-threads)))
-                         ;; (if (> (abs (- num-threads last-num)) 2)
-                         ;;     (begin
-                         ;;       ;; (print "num-threads:" num-threads)
-                         ;;       (set! last-num num-threads)))
-                         (my-mutex-unlock! mtx1)
-                         (if ok-to-run
-                             (let ((run-time-start (current-seconds)))
-                               ;; (print "num threads: " num-threads)
-                               (let ((th1  (make-thread
-                                            (lambda ()
-                                              (let ((cksum (checksum mtx1 p cmd: "md5sum"))
-                                                    (run-time (- (current-seconds) run-time-start)))
-                                                (my-mutex-lock! mtx1)
-                                                (client-send-receive req (conc p " " cksum))
-                                                (my-mutex-unlock! mtx1))
-                                              (let loop2 ()
-                                                (my-mutex-lock! mtx1)
-                                                (let ((registered (hash-table-exists? threads p)))
-                                                  (if registered
-                                                      (begin
-                                                        ;; (print "deleting thread reference for " p)
-                                                        (hash-table-delete! threads p))) ;; delete myself
-                                                  (my-mutex-unlock! mtx1)
-                                                  (if (not registered)
-                                                      (begin
-                                                        (thread-sleep! 0.5)
-                                                        (loop2))))))
-                                            p)))
-                                 (thread-start! th1)
-                                 ;; (thread-sleep! 0.05) ;; give things a little time to get going
-                                 ;; (thread-join! th1) ;; 
-                                 (my-mutex-lock! mtx1)
-                                 (hash-table-set! threads p th1)
-                                 (my-mutex-unlock! mtx1)
-                                 )) ;; thread is launched
-                             (let ((run-time (- (current-seconds) start-time))) ;; couldn't launch yet
-                               (cond
-                                ((< run-time 5)) ;; blast on through
-                                ((< run-time 30)(thread-sleep! 0.1))
-                                ((< run-time 60)(thread-sleep! 2))
-                                ((< run-time 120)(thread-sleep! 3))
-                                (else (thread-sleep! 3)))
-                               (loop start-time)))))))))
-    (map thread-join! (hash-table-values threads))
-    (client-send-receive req "quit")
-    (nn-close req)
-    (exit)))
-
-;; recieve and store the file data, note: this is effectively a *server*, not a client.
-;;
-(define (compare-directories path1 path2)
-  (let ((p1dat       (make-hash-table))
-        (p2dat       (make-hash-table))
-        (numdone     0) ;; increment when recieved a quit. exit when > 2
-        (rep         (nn-socket 'rep))
-        (p1len       (string-length path1))
-        (p2len       (string-length path2))
-        (both-seen   (make-hash-table)))
-    (nn-bind    rep  
-                ;; "tcp://*:5559")
-                "ipc:///tmp/test-ipc")
-    ;; start clients
-    (thread-sleep! 0.1)
-    (system (conc "./remotediff-nmsg " path1 " &"))
-    (system (conc "./remotediff-nmsg " path2 " &"))
-    (let loop ((msg-in (nn-recv rep))
-               (last-print 0))
-      (if (equal? msg-in "quit")
-          (set! numdone (+ numdone 1)))
-      (if (and (not (equal? msg-in "quit"))
-               (< numdone 2))
-          (let* ((parts (string-split msg-in))
-                 (filen (car parts))
-                 (finfo (cadr parts))
-                 (isp1  (substring-index path1 filen 0)) ;; is this a path1?
-                 (isp2  (substring-index path2 filen 0)) ;; is this a path2?
-                 (tpth  (substring filen (if isp1 p1len p2len) (string-length filen))))
-            (hash-table-set! (if isp1 p1dat p2dat)
-                             tpth
-                             finfo)
-            (if (and (hash-table-exists? p1dat tpth)
-                     (hash-table-exists? p2dat tpth))
-                (begin
-                  (if (not (equal? (hash-table-ref p1dat tpth)
-                                   (hash-table-ref p2dat tpth)))
-                      (print "DIFF: " tpth))
-                  (hash-table-set! both-seen tpth finfo)))
-            (nn-send rep "done")
-            (loop (nn-recv rep)
-                  (if (> (- (current-seconds) last-print) 15)
-                      (begin
-                        (print "Processed " (hash-table-size p1dat) ", " (hash-table-size p2dat))
-                        (current-seconds))
-                      last-print)))))
-    (print "p1: " (hash-table-size p1dat) " p2: " (hash-table-size p2dat))
-    (hash-table-for-each
-     p1dat
-     (lambda (k v)
-       (if (not (hash-table-exists? p2dat k))
-           (print "REMOVED: " k))))
-    (hash-table-for-each
-     p2dat
-     (lambda (k v)
-       (if (not (hash-table-exists? p1dat k))
-           (print "ADDED: " k))))
-    (list p1dat p2dat)))
-
-(if (< (length (argv)) 2)
-    (begin
-      (print "Usage: remotediff-nmsg file1 file2")
-      (exit)))
-
-(if (eq? (length (argv)) 2) ;; given a single path
-    (gather-dir-info (cadr (argv)))
-    (compare-directories (cadr (argv))(caddr (argv))))
-
-(print "Done")

DELETED rpctest/rpctest-continuous-client.scm
Index: rpctest/rpctest-continuous-client.scm
==================================================================
--- rpctest/rpctest-continuous-client.scm
+++ /dev/null
@@ -1,138 +0,0 @@
-;;;; rpc-demo.scm
-;;;; Simple database server / client
-
-;;; start server thusly: ./rpctest server test.db
-;;; you will need to init test.db:
-;;; sqlite3 test.db "CREATE TABLE foo (id INTEGER PRIMARY KEY, var TEXT, val TEXT);"
-
-(require-extension (srfi 18) extras tcp rpc sql-de-lite)
-
-;;; Common things
-
-(define total-queries 0)
-(define start-time (current-seconds))
-
-(define operation (string->symbol (car (command-line-arguments))))
-(define param (cadr (command-line-arguments)))
-(print "Operation: " operation ", param: " param)
-
-;; have a pool of db's to pick from
-(define *dbpool* '())
-(define *pool-mutex* (make-mutex))
-
-(define (get-db)
-  (mutex-lock! *pool-mutex*)
-  (if (null? *dbpool*)
-      (begin
-	(mutex-unlock! *pool-mutex*)
-	(let ((db (open-database param)))
-	  (set-busy-handler! db (busy-timeout 10000))
-	  (exec (sql db "PRAGMA synchronous=0;"))
-	  db))
-      (let ((res (car *dbpool*)))
-	(set! *dbpool* (cdr *dbpool*))
-	(mutex-unlock! *pool-mutex*)
-	res)))
-
-(define (return-db db)
-  (mutex-lock! *pool-mutex*)
-  (set! *dbpool* (cons db *dbpool* ))
-  (let ((res (length *dbpool*)))
-    (mutex-unlock! *pool-mutex*)
-    res))
-
-(define rpc:listener
-  (if (eq? operation 'server)
-      (tcp-listen (rpc:default-server-port))
-      (tcp-listen 0)))
-
-;; Start server thread
-(define rpc:server
-  (make-thread
-   (cute (rpc:make-server rpc:listener) "rpc:server") ;; NOTE: see equivalent code below
-   'rpc:server))
-
-;; This is what the code would look like without cute
-;; (define rpc:server
-;;   (make-thread
-;;    (lambda ()
-;;      ((rpc:make-server rpc:listener) "rpc:server"))
-;;    'rpc:server))
-
-(thread-start! rpc:server)
-
-;;; Server side
-
-(define (server)
-  (rpc:publish-procedure!
-   'change-response-port
-   (lambda (port)
-     (rpc:default-server-port port))
-   #f)
-  ;;(let ((db  (get-db))(open-database param)))
-  ;; (set-finalizer! db finalize!)
-  (rpc:publish-procedure!
-   'query
-   (lambda (sqlstmt callback)
-     (set! total-queries (+ total-queries 1))
-     (print "Executing query '" sqlstmt "' ...")
-     (let ((db (get-db)))
-       (query (for-each-row
-	       callback)
-	      (sql db sqlstmt))
-       (print "Query rate: " (/ total-queries (/ (- (current-seconds) start-time) 60)) " per minute")
-       (print "num dbs: " (return-db db))
-       )))
-  (thread-join! rpc:server))
-
-;;; Client side
-
-(define (callback1 . columns)
-  (let loop ((c columns) (i 0))
-    (unless (null? c)
-      (printf "~a=~s " i (car c))
-      (loop (cdr c) (+ i 1))))
-  (newline))
-
-(define callback2-results '())
-
-(define (callback2 . columns)
-  (set! callback2-results (cons columns callback2-results)))
-
-(define (client param)
-  ((rpc:procedure 'change-response-port "localhost")
-   (tcp-listener-port rpc:listener))
-  ((rpc:procedure 'query "localhost") param callback1)
-  (rpc:publish-procedure! 'callback2 callback2)
-  ((rpc:procedure 'query "localhost") param callback2)
-  (pp callback2-results)
-  (rpc:close-all-connections!)
-  ;; (rpc:close-connection! "localhost" (rpc:default-server-port))
-  )
-
-(define (run-query param)
-  ((rpc:procedure 'query "localhost") param callback1)
-  ((rpc:procedure 'query "localhost") param callback2)
-  callback2-results)
-
-(define (continuous-client #!key (duration 600)) ;; default - run for 10 minutes
-  ((rpc:procedure 'change-response-port "localhost")
-   (tcp-listener-port rpc:listener))
-  (rpc:publish-procedure! 'callback2 callback2)
-  (let loop ()
-    (if (< (- (current-seconds) start-time) duration)
-	(begin
-	  (run-query (conc "INSERT INTO foo (var,val) VALUES (" (random 1000) "," (random 1000) ");"))
-	  (let ((numrows (caaar (run-query "SELECT COUNT(id) FROM foo;"))))
-	    (if (and (number? numrows)
-		     (> numrows 300))
-		(print (run-query (conc "DELETE FROM foo WHERE var > " (random 1000) ";")))))
-	  (loop))))
-  (rpc:close-all-connections!))
-
-;;; Run it
-
-(if (eq? operation 'server)
-    (server)
-    (continuous-client))
-

DELETED rpctest/rpctest.scm
Index: rpctest/rpctest.scm
==================================================================
--- rpctest/rpctest.scm
+++ /dev/null
@@ -1,109 +0,0 @@
-;;;; rpc-demo.scm
-;;;; Simple database server / client
-
-;;; start server thusly: ./rpctest server test.db
-;;; you will need to init test.db:
-;;; sqlite3 test.db "CREATE TABLE foo (id INTEGER PRIMARY KEY, var TEXT, val TEXT);"
-
-(require-extension (srfi 18) extras tcp rpc sql-de-lite)
-
-;;; Common things
-
-(define total-queries 0)
-(define start-time (current-seconds))
-
-(define operation (string->symbol (car (command-line-arguments))))
-(define param (cadr (command-line-arguments)))
-(print "Operation: " operation ", param: " param)
-
-;; have a pool of db's to pick from
-(define *dbpool* '())
-(define *pool-mutex* (make-mutex))
-
-(define (get-db)
-  (mutex-lock! *pool-mutex*)
-  (if (null? *dbpool*)
-      (begin
-	(mutex-unlock! *pool-mutex*)
-	(let ((db (open-database param)))
-	  (set-busy-handler! db (busy-timeout 10000))
-	  (exec (sql db "PRAGMA synchronous=0;"))
-	  db))
-      (let ((res (car *dbpool*)))
-	(set! *dbpool* (cdr *dbpool*))
-	(mutex-unlock! *pool-mutex*)
-	res)))
-
-(define (return-db db)
-  (mutex-lock! *pool-mutex*)
-  (set! *dbpool* (cons db *dbpool* ))
-  (let ((res (length *dbpool*)))
-    (mutex-unlock! *pool-mutex*)
-    res))
-
-(define rpc:listener
-  (if (eq? operation 'server)
-      (tcp-listen (rpc:default-server-port))
-      (tcp-listen 0)))
-
-;; Start server thread
-(define rpc:server
-  (make-thread
-   (cute (rpc:make-server rpc:listener) "rpc:server")
-   'rpc:server))
-
-(thread-start! rpc:server)
-
-;;; Server side
-
-(define (server)
-  (rpc:publish-procedure!
-   'change-response-port
-   (lambda (port)
-     (rpc:default-server-port port))
-   #f)
-  ;;(let ((db  (get-db))(open-database param)))
-  ;; (set-finalizer! db finalize!)
-  (rpc:publish-procedure!
-   'query
-   (lambda (sqlstmt callback)
-     (set! total-queries (+ total-queries 1))
-     (print "Executing query '" sqlstmt "' ...")
-     (let ((db (get-db)))
-       (query (for-each-row
-	       callback)
-	      (sql db sqlstmt))
-       (print "Query rate: " (/ total-queries (/ (- (current-seconds) start-time) 60)) " per minute")
-       (print "num dbs: " (return-db db))
-       )))
-  (thread-join! rpc:server))
-
-;;; Client side
-
-(define (callback1 . columns)
-  (let loop ((c columns) (i 0))
-    (unless (null? c)
-      (printf "~a=~s " i (car c))
-      (loop (cdr c) (+ i 1))))
-  (newline))
-
-(define callback2-results '())
-
-(define (callback2 . columns)
-  (set! callback2-results (cons columns callback2-results)))
-
-(define (client)
-  ((rpc:procedure 'change-response-port "localhost")
-   (tcp-listener-port rpc:listener))
-  ((rpc:procedure 'query "localhost") param callback1)
-  (rpc:publish-procedure! 'callback2 callback2)
-  ((rpc:procedure 'query "localhost") param callback2)
-  (pp callback2-results)
-  (rpc:close-connection! "localhost" (rpc:default-server-port)))
-
-;;; Run it
-
-(if (eq? operation 'server)
-    (server)
-    (client))
-

DELETED rpctest/run-client.sh
Index: rpctest/run-client.sh
==================================================================
--- rpctest/run-client.sh
+++ /dev/null
@@ -1,12 +0,0 @@
-#!/bin/bash
-
-
-while ./rpctest client "insert into foo (var,val) values ($RANDOM,$RANDOM);";do
-    numrows=$(./rpctest client "select count(id) from foo;") # |wc -l)
-    deletefrom=$RANDOM
-    echo "numrows=$numrows, deletefrom=$deletefrom"
-    if [[ $numrows -gt 300 ]];then
-	echo "numrows=$numrows, deletefrom=$deletefrom"
-	./rpctest client "delete from foo where var > $deletefrom;"
-    fi
-done

Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -124,11 +124,11 @@
 							   " -daemonize "
 							   "")
 		      ;; " -log " logfile
 		      " -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &")))))
 	 (log-rotate  (make-thread common:rotate-logs  "server run, rotate logs thread"))
-         (load-limit  (configf:lookup-number *configdat* "jobtools" "maxhomehostload" default: 3.0)))
+         (load-limit  (configf:lookup-number *configdat* "jobtools" "max-server-start-load" default: 3.0)))
     ;; we want the remote server to start in *toppath* so push there
     (push-directory areapath)
     (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
     (thread-start! log-rotate)
     
@@ -141,10 +141,11 @@
 	(begin
 	  (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
 	  (setenv "TARGETHOST" target-host)))
       
     (setenv "TARGETHOST_LOGF" logfile)
+    (thread-sleep! (/ (random 5000) 1000)) ;; add about a random (up to 5 seconds) initial delay. It seems pretty common that many running tests request a server at the same time
     (common:wait-for-normalized-load load-limit " delaying server start due to load" target-host) ;; do not try starting servers on an already overloaded machine, just wait forever
     (system (conc "nbfake " cmdln))
     (unsetenv "TARGETHOST_LOGF")
     (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
     (thread-join! log-rotate)

DELETED spreadsheet/basic/Configurations2/accelerator/current.xml
Index: spreadsheet/basic/Configurations2/accelerator/current.xml
==================================================================
--- spreadsheet/basic/Configurations2/accelerator/current.xml
+++ /dev/null

DELETED spreadsheet/basic/META-INF/manifest.xml
Index: spreadsheet/basic/META-INF/manifest.xml
==================================================================
--- spreadsheet/basic/META-INF/manifest.xml
+++ /dev/null
@@ -1,22 +0,0 @@
-<?xml version="1.0" encoding="UTF-8"?>
-<manifest:manifest xmlns:manifest="urn:oasis:names:tc:opendocument:xmlns:manifest:1.0">
- <manifest:file-entry manifest:media-type="application/vnd.oasis.opendocument.spreadsheet" manifest:version="1.2" manifest:full-path="/"/>
- <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/statusbar/"/>
- <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/accelerator/current.xml"/>
- <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/accelerator/"/>
- <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/floater/"/>
- <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/popupmenu/"/>
- <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/progressbar/"/>
- <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/toolpanel/"/>
- <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/menubar/"/>
- <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/toolbar/"/>
- <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/images/Bitmaps/"/>
- <manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/images/"/>
- <manifest:file-entry manifest:media-type="application/vnd.sun.xml.ui.configuration" manifest:full-path="Configurations2/"/>
- <manifest:file-entry manifest:media-type="text/xml" manifest:full-path="content.xml"/>
- <manifest:file-entry manifest:media-type="text/xml" manifest:full-path="styles.xml"/>
- <manifest:file-entry manifest:media-type="text/xml" manifest:full-path="meta.xml"/>
- <manifest:file-entry manifest:media-type="image/png" manifest:full-path="Thumbnails/thumbnail.png"/>
- <manifest:file-entry manifest:media-type="" manifest:full-path="Thumbnails/"/>
- <manifest:file-entry manifest:media-type="text/xml" manifest:full-path="settings.xml"/>
-</manifest:manifest>

DELETED spreadsheet/basic/Thumbnails/thumbnail.png
Index: spreadsheet/basic/Thumbnails/thumbnail.png
==================================================================
--- spreadsheet/basic/Thumbnails/thumbnail.png
+++ /dev/null
cannot compute difference between binary files

DELETED spreadsheet/basic/content.xml
Index: spreadsheet/basic/content.xml
==================================================================
--- spreadsheet/basic/content.xml
+++ /dev/null
@@ -1,132 +0,0 @@
-<?xml version="1.0" encoding="UTF-8"?>
-<office:document-content xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:style="urn:oasis:names:tc:opendocument:xmlns:style:1.0" xmlns:text="urn:oasis:names:tc:opendocument:xmlns:text:1.0" xmlns:table="urn:oasis:names:tc:opendocument:xmlns:table:1.0" xmlns:draw="urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" xmlns:fo="urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:number="urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" xmlns:presentation="urn:oasis:names:tc:opendocument:xmlns:presentation:1.0" xmlns:svg="urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" xmlns:chart="urn:oasis:names:tc:opendocument:xmlns:chart:1.0" xmlns:dr3d="urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" xmlns:math="http://www.w3.org/1998/Math/MathML" xmlns:form="urn:oasis:names:tc:opendocument:xmlns:form:1.0" xmlns:script="urn:oasis:names:tc:opendocument:xmlns:script:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:ooow="http://openoffice.org/2004/writer" xmlns:oooc="http://openoffice.org/2004/calc" xmlns:dom="http://www.w3.org/2001/xml-events" xmlns:xforms="http://www.w3.org/2002/xforms" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:rpt="http://openoffice.org/2005/report" xmlns:of="urn:oasis:names:tc:opendocument:xmlns:of:1.2" xmlns:xhtml="http://www.w3.org/1999/xhtml" xmlns:grddl="http://www.w3.org/2003/g/data-view#" xmlns:tableooo="http://openoffice.org/2009/table" xmlns:field="urn:openoffice:names:experimental:ooo-ms-interop:xmlns:field:1.0" xmlns:formx="urn:openoffice:names:experimental:ooxml-odf-interop:xmlns:form:1.0" xmlns:css3t="http://www.w3.org/TR/css3-text/" office:version="1.2" grddl:transformation="http://docs.oasis-open.org/office/1.2/xslt/odf2rdf.xsl">
-<office:scripts/>
-<office:font-face-decls>
-<style:font-face style:name="Arial" svg:font-family="Arial" style:font-family-generic="swiss" style:font-pitch="variable"/>
-<style:font-face style:name="DejaVu Sans" svg:font-family="&apos;DejaVu Sans&apos;" style:font-family-generic="system" style:font-pitch="variable"/>
-<style:font-face style:name="Droid Sans Fallback" svg:font-family="&apos;Droid Sans Fallback&apos;" style:font-family-generic="system" style:font-pitch="variable"/>
-<style:font-face style:name="Lohit Hindi" svg:font-family="&apos;Lohit Hindi&apos;" style:font-family-generic="system" style:font-pitch="variable"/>
-</office:font-face-decls>
-<office:automatic-styles>
-<style:style style:name="co1" style:family="table-column">
-<style:table-column-properties fo:break-before="auto" style:column-width="0.8925in"/>
-</style:style>
-<style:style style:name="ro1" style:family="table-row">
-<style:table-row-properties style:row-height="0.178in" fo:break-before="auto" style:use-optimal-row-height="true"/>
-</style:style>
-<style:style style:name="ta1" style:family="table" style:master-page-name="Default">
-<style:table-properties table:display="true" style:writing-mode="lr-tb"/>
-</style:style>
-</office:automatic-styles>
-<office:body>
-<office:spreadsheet>
-<table:table table:name="Sheet1" table:style-name="ta1" table:print="false">
-<table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/>
-<table:table-row table:style-name="ro1">
-<table:table-cell office:value-type="string">
-<text:p>Row 1,A</text:p>
-</table:table-cell>
-<table:table-cell office:value-type="string">
-<text:p>Row 1,B</text:p>
-</table:table-cell>
-</table:table-row>
-<table:table-row table:style-name="ro1">
-<table:table-cell office:value-type="string">
-<text:p>Row 2,A</text:p>
-</table:table-cell>
-<table:table-cell office:value-type="string">
-<text:p>Row 2,B</text:p>
-</table:table-cell>
-</table:table-row>
-<table:table-row table:style-name="ro1">
-<table:table-cell table:number-columns-repeated="2"/>
-</table:table-row>
-<table:table-row table:style-name="ro1">
-<table:table-cell office:value-type="string">
-<text:p>this is sheet one</text:p>
-</table:table-cell>
-<table:table-cell/>
-</table:table-row>
-</table:table>
-<table:table table:name="Sheet2" table:style-name="ta1" table:print="false">
-<table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/>
-<table:table-row table:style-name="ro1">
-<table:table-cell office:value-type="string">
-<text:p>Row 1,A</text:p>
-</table:table-cell>
-<table:table-cell office:value-type="string">
-<text:p>Row 1,B</text:p>
-</table:table-cell>
-</table:table-row>
-<table:table-row table:style-name="ro1">
-<table:table-cell office:value-type="string">
-<text:p>Row 2,A</text:p>
-</table:table-cell>
-<table:table-cell office:value-type="string">
-<text:p>Row 2,B</text:p>
-</table:table-cell>
-</table:table-row>
-<table:table-row table:style-name="ro1">
-<table:table-cell table:number-columns-repeated="2"/>
-</table:table-row>
-<table:table-row table:style-name="ro1">
-<table:table-cell office:value-type="string">
-<text:p>this is sheet two</text:p>
-</table:table-cell>
-<table:table-cell/>
-</table:table-row>
-</table:table>
-<table:table table:name="Sheet3" table:style-name="ta1" table:print="false">
-<table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/>
-<table:table-row table:style-name="ro1">
-<table:table-cell office:value-type="float" office:value="1">
-<text:p>1</text:p>
-</table:table-cell>
-<table:table-cell office:value-type="float" office:value="2">
-<text:p>2</text:p>
-</table:table-cell>
-</table:table-row>
-<table:table-row table:style-name="ro1">
-<table:table-cell office:value-type="float" office:value="2">
-<text:p>2</text:p>
-</table:table-cell>
-<table:table-cell office:value-type="float" office:value="4">
-<text:p>4</text:p>
-</table:table-cell>
-</table:table-row>
-<table:table-row table:style-name="ro1">
-<table:table-cell office:value-type="float" office:value="3">
-<text:p>3</text:p>
-</table:table-cell>
-<table:table-cell office:value-type="float" office:value="6">
-<text:p>6</text:p>
-</table:table-cell>
-</table:table-row>
-<table:table-row table:style-name="ro1">
-<table:table-cell office:value-type="float" office:value="4">
-<text:p>4</text:p>
-</table:table-cell>
-<table:table-cell office:value-type="float" office:value="8">
-<text:p>8</text:p>
-</table:table-cell>
-</table:table-row>
-<table:table-row table:style-name="ro1">
-<table:table-cell office:value-type="float" office:value="5">
-<text:p>5</text:p>
-</table:table-cell>
-<table:table-cell office:value-type="float" office:value="10">
-<text:p>10</text:p>
-</table:table-cell>
-</table:table-row>
-<table:table-row table:style-name="ro1">
-<table:table-cell office:value-type="float" office:value="6">
-<text:p>6</text:p>
-</table:table-cell>
-<table:table-cell office:value-type="float" office:value="12">
-<text:p>12</text:p>
-</table:table-cell>
-</table:table-row>
-</table:table>
-</office:spreadsheet>
-</office:body>
-</office:document-content>

DELETED spreadsheet/basic/content.xml~
Index: spreadsheet/basic/content.xml~
==================================================================
--- spreadsheet/basic/content.xml~
+++ /dev/null
@@ -1,2 +0,0 @@
-<?xml version="1.0" encoding="UTF-8"?>
-<office:document-content xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:style="urn:oasis:names:tc:opendocument:xmlns:style:1.0" xmlns:text="urn:oasis:names:tc:opendocument:xmlns:text:1.0" xmlns:table="urn:oasis:names:tc:opendocument:xmlns:table:1.0" xmlns:draw="urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" xmlns:fo="urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:number="urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" xmlns:presentation="urn:oasis:names:tc:opendocument:xmlns:presentation:1.0" xmlns:svg="urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" xmlns:chart="urn:oasis:names:tc:opendocument:xmlns:chart:1.0" xmlns:dr3d="urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" xmlns:math="http://www.w3.org/1998/Math/MathML" xmlns:form="urn:oasis:names:tc:opendocument:xmlns:form:1.0" xmlns:script="urn:oasis:names:tc:opendocument:xmlns:script:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:ooow="http://openoffice.org/2004/writer" xmlns:oooc="http://openoffice.org/2004/calc" xmlns:dom="http://www.w3.org/2001/xml-events" xmlns:xforms="http://www.w3.org/2002/xforms" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:rpt="http://openoffice.org/2005/report" xmlns:of="urn:oasis:names:tc:opendocument:xmlns:of:1.2" xmlns:xhtml="http://www.w3.org/1999/xhtml" xmlns:grddl="http://www.w3.org/2003/g/data-view#" xmlns:tableooo="http://openoffice.org/2009/table" xmlns:field="urn:openoffice:names:experimental:ooo-ms-interop:xmlns:field:1.0" xmlns:formx="urn:openoffice:names:experimental:ooxml-odf-interop:xmlns:form:1.0" xmlns:css3t="http://www.w3.org/TR/css3-text/" office:version="1.2" grddl:transformation="http://docs.oasis-open.org/office/1.2/xslt/odf2rdf.xsl"><office:scripts/><office:font-face-decls><style:font-face style:name="Arial" svg:font-family="Arial" style:font-family-generic="swiss" style:font-pitch="variable"/><style:font-face style:name="DejaVu Sans" svg:font-family="&apos;DejaVu Sans&apos;" style:font-family-generic="system" style:font-pitch="variable"/><style:font-face style:name="Droid Sans Fallback" svg:font-family="&apos;Droid Sans Fallback&apos;" style:font-family-generic="system" style:font-pitch="variable"/><style:font-face style:name="Lohit Hindi" svg:font-family="&apos;Lohit Hindi&apos;" style:font-family-generic="system" style:font-pitch="variable"/></office:font-face-decls><office:automatic-styles><style:style style:name="co1" style:family="table-column"><style:table-column-properties fo:break-before="auto" style:column-width="0.8925in"/></style:style><style:style style:name="ro1" style:family="table-row"><style:table-row-properties style:row-height="0.178in" fo:break-before="auto" style:use-optimal-row-height="true"/></style:style><style:style style:name="ta1" style:family="table" style:master-page-name="Default"><style:table-properties table:display="true" style:writing-mode="lr-tb"/></style:style></office:automatic-styles><office:body><office:spreadsheet><table:table table:name="Sheet1" table:style-name="ta1" table:print="false"><table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>Row 1,A</text:p></table:table-cell><table:table-cell office:value-type="string"><text:p>Row 1,B</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>Row 2,A</text:p></table:table-cell><table:table-cell office:value-type="string"><text:p>Row 2,B</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell table:number-columns-repeated="2"/></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>this is sheet one</text:p></table:table-cell><table:table-cell/></table:table-row></table:table><table:table table:name="Sheet2" table:style-name="ta1" table:print="false"><table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>Row 1,A</text:p></table:table-cell><table:table-cell office:value-type="string"><text:p>Row 1,B</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>Row 2,A</text:p></table:table-cell><table:table-cell office:value-type="string"><text:p>Row 2,B</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell table:number-columns-repeated="2"/></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>this is sheet two</text:p></table:table-cell><table:table-cell/></table:table-row></table:table><table:table table:name="Sheet3" table:style-name="ta1" table:print="false"><table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="1"><text:p>1</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="2"><text:p>2</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="2"><text:p>2</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="4"><text:p>4</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="3"><text:p>3</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="6"><text:p>6</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="4"><text:p>4</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="8"><text:p>8</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="5"><text:p>5</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="10"><text:p>10</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="6"><text:p>6</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="12"><text:p>12</text:p></table:table-cell></table:table-row></table:table></office:spreadsheet></office:body></office:document-content>

DELETED spreadsheet/basic/meta.xml
Index: spreadsheet/basic/meta.xml
==================================================================
--- spreadsheet/basic/meta.xml
+++ /dev/null
@@ -1,2 +0,0 @@
-<?xml version="1.0" encoding="UTF-8"?>
-<office:document-meta xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:grddl="http://www.w3.org/2003/g/data-view#" office:version="1.2" grddl:transformation="http://docs.oasis-open.org/office/1.2/xslt/odf2rdf.xsl"><office:meta><meta:initial-creator>Matt Welland</meta:initial-creator><meta:creation-date>2011-09-06T20:46:23</meta:creation-date><dc:date>2011-09-06T22:05:47</dc:date><dc:creator>Matt Welland</dc:creator><meta:editing-duration>PT1H19M25S</meta:editing-duration><meta:editing-cycles>2</meta:editing-cycles><meta:generator>LibreOffice/3.3$Linux LibreOffice_project/330m19$Build-301</meta:generator><meta:document-statistic meta:table-count="3" meta:cell-count="22" meta:object-count="0"/></office:meta></office:document-meta>

DELETED spreadsheet/basic/mimetype
Index: spreadsheet/basic/mimetype
==================================================================
--- spreadsheet/basic/mimetype
+++ /dev/null
@@ -1,1 +0,0 @@
-application/vnd.oasis.opendocument.spreadsheet

DELETED spreadsheet/basic/settings.xml
Index: spreadsheet/basic/settings.xml
==================================================================
--- spreadsheet/basic/settings.xml
+++ /dev/null
@@ -1,2 +0,0 @@
-<?xml version="1.0" encoding="UTF-8"?>
-<office:document-settings xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:config="urn:oasis:names:tc:opendocument:xmlns:config:1.0" xmlns:ooo="http://openoffice.org/2004/office" office:version="1.2"><office:settings><config:config-item-set config:name="ooo:view-settings"><config:config-item config:name="VisibleAreaTop" config:type="int">0</config:config-item><config:config-item config:name="VisibleAreaLeft" config:type="int">0</config:config-item><config:config-item config:name="VisibleAreaWidth" config:type="int">4516</config:config-item><config:config-item config:name="VisibleAreaHeight" config:type="int">1799</config:config-item><config:config-item-map-indexed config:name="Views"><config:config-item-map-entry><config:config-item config:name="ViewId" config:type="string">view1</config:config-item><config:config-item-map-named config:name="Tables"><config:config-item-map-entry config:name="Sheet1"><config:config-item config:name="CursorPositionX" config:type="int">0</config:config-item><config:config-item config:name="CursorPositionY" config:type="int">0</config:config-item><config:config-item config:name="HorizontalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="VerticalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="HorizontalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="VerticalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="ActiveSplitRange" config:type="short">2</config:config-item><config:config-item config:name="PositionLeft" config:type="int">0</config:config-item><config:config-item config:name="PositionRight" config:type="int">0</config:config-item><config:config-item config:name="PositionTop" config:type="int">0</config:config-item><config:config-item config:name="PositionBottom" config:type="int">0</config:config-item><config:config-item config:name="ZoomType" config:type="short">0</config:config-item><config:config-item config:name="ZoomValue" config:type="int">100</config:config-item><config:config-item config:name="PageViewZoomValue" config:type="int">60</config:config-item><config:config-item config:name="ShowGrid" config:type="boolean">true</config:config-item></config:config-item-map-entry><config:config-item-map-entry config:name="Sheet2"><config:config-item config:name="CursorPositionX" config:type="int">0</config:config-item><config:config-item config:name="CursorPositionY" config:type="int">4</config:config-item><config:config-item config:name="HorizontalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="VerticalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="HorizontalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="VerticalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="ActiveSplitRange" config:type="short">2</config:config-item><config:config-item config:name="PositionLeft" config:type="int">0</config:config-item><config:config-item config:name="PositionRight" config:type="int">0</config:config-item><config:config-item config:name="PositionTop" config:type="int">0</config:config-item><config:config-item config:name="PositionBottom" config:type="int">0</config:config-item><config:config-item config:name="ZoomType" config:type="short">0</config:config-item><config:config-item config:name="ZoomValue" config:type="int">100</config:config-item><config:config-item config:name="PageViewZoomValue" config:type="int">60</config:config-item><config:config-item config:name="ShowGrid" config:type="boolean">true</config:config-item></config:config-item-map-entry><config:config-item-map-entry config:name="Sheet3"><config:config-item config:name="CursorPositionX" config:type="int">1</config:config-item><config:config-item config:name="CursorPositionY" config:type="int">5</config:config-item><config:config-item config:name="HorizontalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="VerticalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="HorizontalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="VerticalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="ActiveSplitRange" config:type="short">2</config:config-item><config:config-item config:name="PositionLeft" config:type="int">0</config:config-item><config:config-item config:name="PositionRight" config:type="int">0</config:config-item><config:config-item config:name="PositionTop" config:type="int">0</config:config-item><config:config-item config:name="PositionBottom" config:type="int">0</config:config-item><config:config-item config:name="ZoomType" config:type="short">0</config:config-item><config:config-item config:name="ZoomValue" config:type="int">100</config:config-item><config:config-item config:name="PageViewZoomValue" config:type="int">60</config:config-item><config:config-item config:name="ShowGrid" config:type="boolean">true</config:config-item></config:config-item-map-entry></config:config-item-map-named><config:config-item config:name="ActiveTable" config:type="string">Sheet3</config:config-item><config:config-item config:name="HorizontalScrollbarWidth" config:type="int">270</config:config-item><config:config-item config:name="ZoomType" config:type="short">0</config:config-item><config:config-item config:name="ZoomValue" config:type="int">100</config:config-item><config:config-item config:name="PageViewZoomValue" config:type="int">60</config:config-item><config:config-item config:name="ShowPageBreakPreview" config:type="boolean">false</config:config-item><config:config-item config:name="ShowZeroValues" config:type="boolean">true</config:config-item><config:config-item config:name="ShowNotes" config:type="boolean">true</config:config-item><config:config-item config:name="ShowGrid" config:type="boolean">true</config:config-item><config:config-item config:name="GridColor" config:type="long">12632256</config:config-item><config:config-item config:name="ShowPageBreaks" config:type="boolean">true</config:config-item><config:config-item config:name="HasColumnRowHeaders" config:type="boolean">true</config:config-item><config:config-item config:name="HasSheetTabs" config:type="boolean">true</config:config-item><config:config-item config:name="IsOutlineSymbolsSet" config:type="boolean">true</config:config-item><config:config-item config:name="IsSnapToRaster" config:type="boolean">false</config:config-item><config:config-item config:name="RasterIsVisible" config:type="boolean">false</config:config-item><config:config-item config:name="RasterResolutionX" config:type="int">1270</config:config-item><config:config-item config:name="RasterResolutionY" config:type="int">1270</config:config-item><config:config-item config:name="RasterSubdivisionX" config:type="int">1</config:config-item><config:config-item config:name="RasterSubdivisionY" config:type="int">1</config:config-item><config:config-item config:name="IsRasterAxisSynchronized" config:type="boolean">true</config:config-item></config:config-item-map-entry></config:config-item-map-indexed></config:config-item-set><config:config-item-set config:name="ooo:configuration-settings"><config:config-item config:name="IsKernAsianPunctuation" config:type="boolean">false</config:config-item><config:config-item config:name="IsRasterAxisSynchronized" config:type="boolean">true</config:config-item><config:config-item config:name="LinkUpdateMode" config:type="short">3</config:config-item><config:config-item config:name="SaveVersionOnClose" config:type="boolean">false</config:config-item><config:config-item config:name="AllowPrintJobCancel" config:type="boolean">true</config:config-item><config:config-item config:name="HasSheetTabs" config:type="boolean">true</config:config-item><config:config-item config:name="ShowPageBreaks" config:type="boolean">true</config:config-item><config:config-item config:name="RasterResolutionX" config:type="int">1270</config:config-item><config:config-item config:name="PrinterSetup" config:type="base64Binary"/><config:config-item config:name="RasterResolutionY" config:type="int">1270</config:config-item><config:config-item config:name="LoadReadonly" config:type="boolean">false</config:config-item><config:config-item config:name="RasterSubdivisionX" config:type="int">1</config:config-item><config:config-item config:name="ShowNotes" config:type="boolean">true</config:config-item><config:config-item config:name="ShowZeroValues" config:type="boolean">true</config:config-item><config:config-item config:name="RasterSubdivisionY" config:type="int">1</config:config-item><config:config-item config:name="ApplyUserData" config:type="boolean">true</config:config-item><config:config-item config:name="GridColor" config:type="long">12632256</config:config-item><config:config-item config:name="RasterIsVisible" config:type="boolean">false</config:config-item><config:config-item config:name="IsSnapToRaster" config:type="boolean">false</config:config-item><config:config-item config:name="PrinterName" config:type="string"/><config:config-item config:name="ShowGrid" config:type="boolean">true</config:config-item><config:config-item config:name="CharacterCompressionType" config:type="short">0</config:config-item><config:config-item config:name="HasColumnRowHeaders" config:type="boolean">true</config:config-item><config:config-item config:name="IsOutlineSymbolsSet" config:type="boolean">true</config:config-item><config:config-item config:name="AutoCalculate" config:type="boolean">true</config:config-item><config:config-item config:name="IsDocumentShared" config:type="boolean">false</config:config-item><config:config-item config:name="UpdateFromTemplate" config:type="boolean">true</config:config-item></config:config-item-set></office:settings></office:document-settings>

DELETED spreadsheet/basic/styles.xml
Index: spreadsheet/basic/styles.xml
==================================================================
--- spreadsheet/basic/styles.xml
+++ /dev/null
@@ -1,2 +0,0 @@
-<?xml version="1.0" encoding="UTF-8"?>
-<office:document-styles xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:style="urn:oasis:names:tc:opendocument:xmlns:style:1.0" xmlns:text="urn:oasis:names:tc:opendocument:xmlns:text:1.0" xmlns:table="urn:oasis:names:tc:opendocument:xmlns:table:1.0" xmlns:draw="urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" xmlns:fo="urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:number="urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" xmlns:presentation="urn:oasis:names:tc:opendocument:xmlns:presentation:1.0" xmlns:svg="urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" xmlns:chart="urn:oasis:names:tc:opendocument:xmlns:chart:1.0" xmlns:dr3d="urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" xmlns:math="http://www.w3.org/1998/Math/MathML" xmlns:form="urn:oasis:names:tc:opendocument:xmlns:form:1.0" xmlns:script="urn:oasis:names:tc:opendocument:xmlns:script:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:ooow="http://openoffice.org/2004/writer" xmlns:oooc="http://openoffice.org/2004/calc" xmlns:dom="http://www.w3.org/2001/xml-events" xmlns:rpt="http://openoffice.org/2005/report" xmlns:of="urn:oasis:names:tc:opendocument:xmlns:of:1.2" xmlns:xhtml="http://www.w3.org/1999/xhtml" xmlns:grddl="http://www.w3.org/2003/g/data-view#" xmlns:tableooo="http://openoffice.org/2009/table" xmlns:css3t="http://www.w3.org/TR/css3-text/" office:version="1.2" grddl:transformation="http://docs.oasis-open.org/office/1.2/xslt/odf2rdf.xsl"><office:font-face-decls><style:font-face style:name="Arial" svg:font-family="Arial" style:font-family-generic="swiss" style:font-pitch="variable"/><style:font-face style:name="DejaVu Sans" svg:font-family="&apos;DejaVu Sans&apos;" style:font-family-generic="system" style:font-pitch="variable"/><style:font-face style:name="Droid Sans Fallback" svg:font-family="&apos;Droid Sans Fallback&apos;" style:font-family-generic="system" style:font-pitch="variable"/><style:font-face style:name="Lohit Hindi" svg:font-family="&apos;Lohit Hindi&apos;" style:font-family-generic="system" style:font-pitch="variable"/></office:font-face-decls><office:styles><style:default-style style:family="table-cell"><style:paragraph-properties style:tab-stop-distance="0.5in"/><style:text-properties style:font-name="Arial" fo:language="en" fo:country="US" style:font-name-asian="DejaVu Sans" style:language-asian="zh" style:country-asian="CN" style:font-name-complex="DejaVu Sans" style:language-complex="hi" style:country-complex="IN"/></style:default-style><number:number-style style:name="N0"><number:number number:min-integer-digits="1"/></number:number-style><number:currency-style style:name="N104P0" style:volatile="true"><number:currency-symbol number:language="en" number:country="US">$</number:currency-symbol><number:number number:decimal-places="2" number:min-integer-digits="1" number:grouping="true"/></number:currency-style><number:currency-style style:name="N104"><style:text-properties fo:color="#ff0000"/><number:text>-</number:text><number:currency-symbol number:language="en" number:country="US">$</number:currency-symbol><number:number number:decimal-places="2" number:min-integer-digits="1" number:grouping="true"/><style:map style:condition="value()&gt;=0" style:apply-style-name="N104P0"/></number:currency-style><style:style style:name="Default" style:family="table-cell"><style:text-properties style:font-name-asian="Droid Sans Fallback" style:font-name-complex="Lohit Hindi"/></style:style><style:style style:name="Result" style:family="table-cell" style:parent-style-name="Default"><style:text-properties fo:font-style="italic" style:text-underline-style="solid" style:text-underline-width="auto" style:text-underline-color="font-color" fo:font-weight="bold"/></style:style><style:style style:name="Result2" style:family="table-cell" style:parent-style-name="Result" style:data-style-name="N104"/><style:style style:name="Heading" style:family="table-cell" style:parent-style-name="Default"><style:table-cell-properties style:text-align-source="fix" style:repeat-content="false"/><style:paragraph-properties fo:text-align="center"/><style:text-properties fo:font-size="16pt" fo:font-style="italic" fo:font-weight="bold"/></style:style><style:style style:name="Heading1" style:family="table-cell" style:parent-style-name="Heading"><style:table-cell-properties style:rotation-angle="90"/></style:style></office:styles><office:automatic-styles><style:page-layout style:name="Mpm1"><style:page-layout-properties style:writing-mode="lr-tb"/><style:header-style><style:header-footer-properties fo:min-height="0.2957in" fo:margin-left="0in" fo:margin-right="0in" fo:margin-bottom="0.0984in"/></style:header-style><style:footer-style><style:header-footer-properties fo:min-height="0.2957in" fo:margin-left="0in" fo:margin-right="0in" fo:margin-top="0.0984in"/></style:footer-style></style:page-layout><style:page-layout style:name="Mpm2"><style:page-layout-properties style:writing-mode="lr-tb"/><style:header-style><style:header-footer-properties fo:min-height="0.2957in" fo:margin-left="0in" fo:margin-right="0in" fo:margin-bottom="0.0984in" fo:border="0.0346in solid #000000" fo:padding="0.0071in" fo:background-color="#c0c0c0"><style:background-image/></style:header-footer-properties></style:header-style><style:footer-style><style:header-footer-properties fo:min-height="0.2957in" fo:margin-left="0in" fo:margin-right="0in" fo:margin-top="0.0984in" fo:border="0.0346in solid #000000" fo:padding="0.0071in" fo:background-color="#c0c0c0"><style:background-image/></style:header-footer-properties></style:footer-style></style:page-layout></office:automatic-styles><office:master-styles><style:master-page style:name="Default" style:page-layout-name="Mpm1"><style:header><text:p><text:sheet-name>???</text:sheet-name></text:p></style:header><style:header-left style:display="false"/><style:footer><text:p>Page <text:page-number>1</text:page-number></text:p></style:footer><style:footer-left style:display="false"/></style:master-page><style:master-page style:name="Report" style:page-layout-name="Mpm2"><style:header><style:region-left><text:p><text:sheet-name>???</text:sheet-name> (<text:title>???</text:title>)</text:p></style:region-left><style:region-right><text:p><text:date style:data-style-name="N2" text:date-value="2011-09-06">09/06/2011</text:date>, <text:time>22:05:47</text:time></text:p></style:region-right></style:header><style:header-left style:display="false"/><style:footer><text:p>Page <text:page-number>1</text:page-number> / <text:page-count>99</text:page-count></text:p></style:footer><style:footer-left style:display="false"/></style:master-page></office:master-styles></office:document-styles>

DELETED testhttp/example-client.scm
Index: testhttp/example-client.scm
==================================================================
--- testhttp/example-client.scm
+++ /dev/null
@@ -1,6 +0,0 @@
-(use regex http-client)
-
-(print (with-input-from-request "http://localhost:8083/?foo=1" #f 
-    (lambda ()
-      (let ((match (string-search (regexp "<body>(.*)<.body>") (caddr (string-split (read-string) "\n")))))
-	(cadr match)))))

DELETED testhttp/example-server.scm
Index: testhttp/example-server.scm
==================================================================
--- testhttp/example-server.scm
+++ /dev/null
@@ -1,26 +0,0 @@
-(use spiffy awful)
-
-(tcp-buffer-size 2048)
-(enable-sxml #t)
-
-(define (hello-world)
-  (define-page (main-page-path)
-    (lambda ()
-      (with-request-variables (foo)
-        foo))))
-
-(define (start-server #!key (portnum 8080))
-  (handle-exceptions
-   exn
-   (begin
-     (print-error-message exn)
-     (if (< portnum 9000)
-	 (begin 
-	   (print "WARNING: failed to start on portnum: " portnum ", trying next port")
-	   (sleep 1)
-	   (start-server portnum: (+ portnum 1)))
-	 (print "ERROR: Tried and tried but could not start the server")))
-   (print "INFO: Trying to start server on portnum: " portnum)
-   (awful-start hello-world port: portnum)))
-
-(start-server)

DELETED testhttp/mockupclient.scm
Index: testhttp/mockupclient.scm
==================================================================
--- testhttp/mockupclient.scm
+++ /dev/null
@@ -1,35 +0,0 @@
-(use posix)
-
-(define cname "Bob")
-(define runtime 10)
-(let ((args (argv)))
-  (if (< (length args) 3)
-      (begin
-	(print "Usage: mockupclient clientname runtime")
-	(exit))
-      (begin
-	(set! cname (cadr args))
-	(set! runtime (string->number (caddr args))))))
-      
-;; (define start-delay (/ (random 100) 9))
-;; (define runtime     (+ 1 (/ (random 200) 2)))
-
-(print "Starting client " cname " with runtime " runtime)
-
-(include "mockupclientlib.scm")
-
-(set! endtime (+ (current-seconds) runtime))
-
-(let loop ()
-  (let ((x (random 15))
-	(varname (list-ref (list "hello" "goodbye" "saluton" "kiaorana")(random 4))))
-    (case x
-      ;; ((1)(dbaccess cname 'sync "nodat"    #f))
-      ((2 3 4 5)(dbaccess cname 'set varname (random 999)))
-      ((6 7 8 9 10)(print cname ": Get \"" varname "\" " (dbaccess cname 'get varname #f)))
-      (else
-       (thread-sleep! 0.011)))
-    (if (< (current-seconds) endtime)
-	(loop))))
-
-(print "Client " cname " all done!!")

DELETED testhttp/mockupclientlib.scm
Index: testhttp/mockupclientlib.scm
==================================================================
--- testhttp/mockupclientlib.scm
+++ /dev/null
@@ -1,33 +0,0 @@
-(define sub  (make-socket 'sub))
-(define push (make-socket 'push))
-(socket-option-set! sub 'subscribe cname)
-(connect-socket sub "tcp://localhost:5563")
-(connect-socket push "tcp://localhost:5564")
-
-(define (dbaccess cname cmd var val #!key (numtries 1))
-  (let* ((msg (conc cname ":" cmd ":" (if val (conc var " " val) var)))
-	 (res #f)
-	 (do-access (lambda ()
-		      (print "Sending msg: " msg)
-		      (send-message push msg)
-		      (print "Message " msg " sent")
-		      (print "Client " cname " waiting for response to " msg)
-		      (print "Client " cname " received address " (receive-message* sub))
-		      (set! res (receive-message* sub)))))
-    (let ((th1 (make-thread do-access "do access"))
-	  (th2 (make-thread (lambda ()
-			      (thread-sleep! 5)
-			      (if (not res)
-				  (if (> numtries 0)
-				      (begin
-					(print "WARNING: access timed out for " cname ", trying again. Trys remaining=" numtries)
-					(dbaccess cname cmd var val numtries: (- numtries 1)))
-				      (begin
-					(print "ERROR: dbaccess timed out. Exiting")
-					(exit)))))
-			    "timeout thread")))
-      (thread-start! th1)
-      (thread-start! th2)
-      (thread-join! th1)
-      res)))
-

DELETED testhttp/mockupserver.scm
Index: testhttp/mockupserver.scm
==================================================================
--- testhttp/mockupserver.scm
+++ /dev/null
@@ -1,140 +0,0 @@
-;; pub/sub with envelope address
-;; Note that if you don't insert a sleep, the server will crash with SIGPIPE as soon
-;; as a client disconnects.  Also a remaining client may receive tons of
-;; messages afterward.
-
-(use srfi-18 sqlite3 spiffy)
-
-(define cname "server")
-(define total-db-accesses 0)
-(define start-time (current-seconds))
-
-;; setup the server here
-(tcp-buffer-size 2048)
-(server-port 5563)
-
-(define (open-db)
-  (let* ((dbpath    "mockup.db")
-	 (dbexists  (file-exists? dbpath))
-	 (db        (open-database dbpath)) ;; (never-give-up-open-db dbpath))
-	 (handler   (make-busy-timeout 10)))
-    (set-busy-handler! db handler)
-    (if (not dbexists)
-	(for-each
-	 (lambda (stmt)
-	   (execute db stmt))
-	 (list
-	  "PRAGMA SYNCHRONOUS=0;"
-	  "CREATE TABLE clients (id INTEGER PRIMARY KEY,name TEXT,num_accesses INTEGER DEFAULT 0);"
-	  "CREATE TABLE vars    (var TEXT,val TEXT,CONSTRAINT vars_constraint UNIQUE (var));")))
-    db))
-
-(define cid-cache (make-hash-table))
-
-(define (get-client-id db cname)
-  (let ((cid (hash-table-ref/default cid-cache cname #f)))
-    (if cid 
-	cid
-	(begin
-	  (execute db "INSERT OR REPLACE INTO clients (name) VALUES(?);" cname)
-	  (for-each-row 
-	   (lambda (id)
-	     (set! cid id))
-	   db
-	   "SELECT id FROM clients WHERE name=?;" cname)
-	  (hash-table-set! cid-cache cname cid)
-	  (set! total-db-accesses (+ total-db-accesses 2))
-	  cid))))
-
-(define (count-client db cname)
-  (let ((cid (get-client-id db cname)))
-    (execute db "UPDATE clients SET num_accesses=num_accesses+1 WHERE id=?;" cid)
-    (set! total-db-accesses (+ total-db-accesses 1))
-    ))
-
-(define db (open-db))
-;; (define queuelst '())
-;; (define mx1 (make-mutex))
-
-(define max-queue-len 0)
-
-(define (process-queue queuelst)
-  (let ((queuelen (length queuelst)))
-    (if (> queuelen max-queue-len)
-	(set! max-queue-len queuelen))
-    (for-each
-     (lambda (item)
-       (let ((cname (vector-ref item 1))
-	     (clcmd (vector-ref item 2))
-	     (cdata (vector-ref item 3)))
-	 (send-message pub cname send-more: #t)
-	 (send-message pub (case clcmd
-			     ((sync)
-			      (conc queuelen))
-			     ((set)
-			      (set! total-db-accesses (+ total-db-accesses 1))
-			      (apply execute db "INSERT OR REPLACE INTO vars (var,val) VALUES (?,?);" (string-split cdata))
-			      "ok")
-			     ((get)
-			      (set! total-db-accesses (+ total-db-accesses 1))
-			      (let ((res "noval"))
-				(for-each-row
-				 (lambda (val)
-				   (set! res val))
-				 db 
-				 "SELECT val FROM vars WHERE var=?;" cdata)
-				res))
-			     (else (conc "unk cmd: " clcmd))))))
-     queuelst)))
-
-(define th1 (make-thread 
-	     (lambda ()
-	       (let ((last-run 0)) ;; current-seconds when run last
-		 (let loop ((queuelst '()))
-		   (let* ((indat (receive-message* pull))
-			  (parts (string-split indat ":"))
-			  (cname (car parts))                   ;; client name
-			  (clcmd (string->symbol (cadr parts))) ;; client cmd
-			  (cdata (caddr parts))                 ;; client data
-			  (svect (vector (current-seconds) cname clcmd cdata))) ;; record for the queue
-		     (count-client db cname)
-		     (case clcmd
-		       ((sync) ;; just process the queue
-			(print "Got sync from " cname)
-			(process-queue (cons svect queuelst))
-			(loop '()))
-		       ((get)
-			(process-queue (cons svect queuelst))
-			(loop '()))
-		       (else
-			(loop (cons svect queuelst))))))))
-	     "server thread"))
-
-(include "mockupclientlib.scm")
-
-;; ;; send a sync to the pull port
-;; (define th2 (make-thread
-;; 	     (lambda ()
-;; 	       (let ((last-action-time (current-seconds)))
-;; 		 (let loop ()
-;; 		   (thread-sleep! 5)
-;; 		   (let ((queuelen (string->number (dbaccess "server" 'sync "nada" #f)))
-;; 			 (last-action-delta #f))
-;; 		     (if (> queuelen 1)(set! last-action-time (current-seconds)))
-;; 		     (set! last-action-delta (- (current-seconds) last-action-time))
-;; 		     (print "Server: Got queuelen=" queuelen ", last-action-delta=" last-action-delta)
-;; 		     (if (< last-action-delta 60)
-;; 			 (loop)
-;; 			 (print "Server exiting, 25 seconds since last access"))))))
-;; 	     "sync thread"))
-
-(handle-not-found 
- 
-
-(thread-start! th1)
-(thread-start! th2)
-(thread-join! th2)
-
-(let* ((run-time       (- (current-seconds) start-time))
-       (queries/second (/  total-db-accesses run-time)))
-  (print "Server exited! Total db accesses=" total-db-accesses " in " run-time " seconds for " queries/second " queries/second with max queue length of: " max-queue-len))

DELETED testhttp/testclient.scm
Index: testhttp/testclient.scm
==================================================================
--- testhttp/testclient.scm
+++ /dev/null
@@ -1,8 +0,0 @@
-(use http-client)
-
-(with-input-from-request "http://localhost:12345/hey"
-                                           ;; #f
-                                           ;; msg 
-                                           (list (cons 'dat "Testing eh"))
-                                           read-string)
-

DELETED testhttp/testserver.scm
Index: testhttp/testserver.scm
==================================================================
--- testhttp/testserver.scm
+++ /dev/null
@@ -1,16 +0,0 @@
-(use spiffy uri-common intarweb spiffy-request-vars)
-
-(root-path "/var/www")
-
-(vhost-map `(((* any) . ,(lambda (continue)
-                           (let (($ (request-vars source: 'both)))
-			     (print ($ 'dat))
-			     (if (equal? (uri-path (request-uri (current-request))) 
-					 '(/ "hey"))
-				 (send-response body: "hey there!\n"
-						headers: '((content-type text/plain)))
-				 (continue)))))))
-
-(start-server port: 12345)
-
-

DELETED testnanomsg/basic-req-rep.scm
Index: testnanomsg/basic-req-rep.scm
==================================================================
--- testnanomsg/basic-req-rep.scm
+++ /dev/null
@@ -1,3 +0,0 @@
-(use nanomsg srfi-18 sqlite3 numbers)
-
-(define resp (nn-socket 'rep))

DELETED testnanomsg/mockupclient.scm
Index: testnanomsg/mockupclient.scm
==================================================================
--- testnanomsg/mockupclient.scm
+++ /dev/null
@@ -1,42 +0,0 @@
-(use zmq posix numbers)
-
-(define cname "Bob")
-(define runtime 10)
-(let ((args (argv)))
-  (if (< (length args) 3)
-      (begin
-	(print "Usage: mockupclient clientname runtime")
-	(exit))
-      (begin
-	(set! cname (cadr args))
-	(set! runtime (string->number (caddr args))))))
-      
-;; (define start-delay (/ (random 100) 9))
-;; (define runtime     (+ 1 (/ (random 200) 2)))
-
-(print "Starting client " cname " with runtime " runtime)
-
-(include "mockupclientlib.scm")
-
-(set! endtime (+ (current-seconds) runtime))
-
-;; first ping the server to ensure we have a connection
-(if (server-ping cname 5)
-    (print "SUCCESS: Client " cname " connected to server")
-    (begin
-      (print "ERROR: Client " cname " failed ping of server, exiting")
-      (exit)))
-
-(let loop ()
-  (let ((x (random 15))
-	(varname (list-ref (list "hello" "goodbye" "saluton" "kiaorana")(random 4))))
-    (case x
-      ;; ((1)(dbaccess cname 'sync "nodat"    #f))
-      ((2 3 4 5)(dbaccess cname 'set varname (random 999)))
-      ((6 7 8 9 10)(print cname ": Get \"" varname "\" " (dbaccess cname 'get varname #f)))
-      (else
-       (thread-sleep! 0.011)))
-    (if (< (current-seconds) endtime)
-	(loop))))
-
-(print "Client " cname " all done!!")

DELETED testnanomsg/mockupclientlib.scm
Index: testnanomsg/mockupclientlib.scm
==================================================================
--- testnanomsg/mockupclientlib.scm
+++ /dev/null
@@ -1,58 +0,0 @@
-(define reqs (nn-socket 'req))
-
-(connect-socket reqs "tcp://localhost:6563")
-
-(thread-sleep! 0.2)
-
-(define (server-ping cname timeout)
-  (let ((msg     (conc cname ":ping:" timeout))
-	(maxtime (+ (current-seconds) timeout)))
-    (print "pinging server from " cname " with timeout " timeout)
-    (let loop ((res   #f))
-      (if (< maxtime (current-seconds))
-	  #f ;; failed to ping
-	  (if (equal? res "Got ping")
-	      #t
-	      (begin
-		(print "Ping received from server " res)
-		(send-message push msg)
-		(thread-sleep! 0.1)
-		(loop (receive-message sub non-blocking: #t))))))))
-  
-(define (dbaccess cname cmd var val #!key (numtries 20))
-  (let* ((msg (conc cname ":" cmd ":" (if val (conc var " " val) var)))
-	 (res #f)
-	 (mtx1 (make-mutex))
-	 (do-access (lambda ()
-		      (let ((tmpres #f))
-			(print "Sending msg: " msg)
-			(send-message push msg)
-			(print "Message " msg " sent")
-			(print "Client " cname " waiting for response to " msg)
-			(print "Client " cname " received address " (receive-message* sub))
-			(set! tmpres (receive-message* sub))
-			(mutex-lock! mtx1)
-			(set! res tmpres)
-			(mutex-unlock! mtx1))))
-	 (th1 (make-thread do-access "do access"))
-	 (th2 (make-thread (lambda ()
-			     (let ((result #f))
-			       (mutex-lock! mtx1)
-			       (set! result res)
-			       (mutex-unlock! mtx1)
-			       (thread-sleep! 5)
-			       (if (not result)
-				   (if (> numtries 0)
-				       (begin
-					 (print "WARNING: access timed out for " cname ", trying again. Trys remaining=" numtries)
-					 (dbaccess cname cmd var val numtries: (- numtries 1)))
-				       (begin
-					 (print "ERROR: dbaccess timed out. Exiting")
-					 (exit)))))
-			     "timeout thread"))))
-    (thread-start! th1)
-    (thread-start! th2)
-    (thread-join! th1)
-    (if res (print "SUCCESS: received " res " with " numtries " remaining possible attempts"))
-    res))
-

DELETED testnanomsg/mockupserver.scm
Index: testnanomsg/mockupserver.scm
==================================================================
--- testnanomsg/mockupserver.scm
+++ /dev/null
@@ -1,146 +0,0 @@
-;; pub/sub with envelope address
-;; Note that if you don't insert a sleep, the server will crash with SIGPIPE as soon
-;; as a client disconnects.  Also a remaining client may receive tons of
-;; messages afterward.
-
-(use nanomsg srfi-18 sqlite3 numbers)
-
-(define resp (nn-socket 'rep))
-(define cname "server")
-(define total-db-accesses 0)
-(define start-time (current-seconds))
-
-(nn-bind resp  "tcp://*:6563")
-
-(thread-sleep! 0.2)
-
-(define (open-db)
-  (let* ((dbpath    "mockup.db")
-	 (dbexists  (file-exists? dbpath))
-	 (db        (open-database dbpath)) ;; (never-give-up-open-db dbpath))
-	 (handler   (make-busy-timeout 10)))
-    (set-busy-handler! db handler)
-    (if (not dbexists)
-	(for-each
-	 (lambda (stmt)
-	   (execute db stmt))
-	 (list
-	  "PRAGMA SYNCHRONOUS=0;"
-	  "CREATE TABLE clients (id INTEGER PRIMARY KEY,name TEXT,num_accesses INTEGER DEFAULT 0);"
-	  "CREATE TABLE vars    (var TEXT,val TEXT,CONSTRAINT vars_constraint UNIQUE (var));")))
-    db))
-
-(define cid-cache (make-hash-table))
-
-(define (get-client-id db cname)
-  (let ((cid (hash-table-ref/default cid-cache cname #f)))
-    (if cid 
-	cid
-	(begin
-	  (execute db "INSERT OR REPLACE INTO clients (name) VALUES(?);" cname)
-	  (for-each-row 
-	   (lambda (id)
-	     (set! cid id))
-	   db
-	   "SELECT id FROM clients WHERE name=?;" cname)
-	  (hash-table-set! cid-cache cname cid)
-	  (set! total-db-accesses (+ total-db-accesses 2))
-	  cid))))
-
-(define (count-client db cname)
-  (let ((cid (get-client-id db cname)))
-    (execute db "UPDATE clients SET num_accesses=num_accesses+1 WHERE id=?;" cid)
-    (set! total-db-accesses (+ total-db-accesses 1))
-    ))
-
-(define db (open-db))
-;; (define queuelst '())
-;; (define mx1 (make-mutex))
-
-(define max-queue-len 0)
-
-(define (process-queue queuelst)
-  (let ((queuelen (length queuelst)))
-    (if (> queuelen max-queue-len)
-	(set! max-queue-len queuelen))
-    (for-each
-     (lambda (item)
-       (let ((cname (vector-ref item 1))
-	     (clcmd (vector-ref item 2))
-	     (cdata (vector-ref item 3)))
-	 (send-message pub cname send-more: #t)
-	 (send-message pub (case clcmd
-			     ((sync)
-			      (conc queuelen))
-			     ((set)
-			      (set! total-db-accesses (+ total-db-accesses 1))
-			      (apply execute db "INSERT OR REPLACE INTO vars (var,val) VALUES (?,?);" (string-split cdata))
-			      "ok")
-			     ((get)
-			      (set! total-db-accesses (+ total-db-accesses 1))
-			      (let ((res "noval"))
-				(for-each-row
-				 (lambda (val)
-				   (set! res val))
-				 db 
-				 "SELECT val FROM vars WHERE var=?;" cdata)
-				res))
-			     (else (conc "unk cmd: " clcmd))))))
-     queuelst)))
-
-;; SERVER THREAD
-(define th1 (make-thread 
-	     (lambda ()
-	       (let ((last-run 0)) ;; current-seconds when run last
-		 (let loop ((queuelst '()))
-		   (let* ((indat (receive-message* pull))
-			  (parts (string-split indat ":"))
-			  (cname (car parts))                   ;; client name
-			  (clcmd (string->symbol (cadr parts))) ;; client cmd
-			  (cdata (caddr parts))                 ;; client data
-			  (svect (vector (current-seconds) cname clcmd cdata))) ;; record for the queue
-		     ;; (print "Server received message: " indat)
-		     (count-client db cname)
-		     (case clcmd
-		       ((ping)
-			(print "Got ping from " cname)
-			(send-message pub cname send-more: #t)
-			(send-message pub "Got ping")
-			(loop queuelst))
-		       ((sync) ;; just process the queue
-			(print "Got sync from " cname)
-			(process-queue (cons svect queuelst))
-			(loop '()))
-		       ((get)
-			(process-queue (cons svect queuelst))
-			(loop '()))
-		       (else
-			(loop (cons svect queuelst))))))))
-	     "server thread"))
-
-(include "mockupclientlib.scm")
-
-;; SYNC THREAD
-;; send a sync to the pull port
-(define th2 (make-thread
-	     (lambda ()
-	       (let ((last-action-time (current-seconds)))
-		 (let loop ()
-		   (thread-sleep! 5)
-		   (let ((queuelen (string->number (dbaccess "server" 'sync "nada" #f)))
-			 (last-action-delta #f))
-		     (if (> queuelen 1)(set! last-action-time (current-seconds)))
-		     (set! last-action-delta (- (current-seconds) last-action-time))
-		     (print "Server: Got queuelen=" queuelen ", last-action-delta=" last-action-delta)
-		     (if (< last-action-delta 60)
-			 (loop)
-			 (print "Server exiting, 25 seconds since last access"))))))
-	     "sync thread"))
-
-(thread-start! th1)
-(thread-start! th2)
-(thread-join! th2)
-
-(let* ((run-time       (- (current-seconds) start-time))
-       (queries/second (/  total-db-accesses run-time)))
-  (print "Server exited! Total db accesses=" total-db-accesses " in " run-time " seconds for " queries/second " queries/second with max queue length of: " max-queue-len))

DELETED testnanomsg/pipeline.scm
Index: testnanomsg/pipeline.scm
==================================================================
--- testnanomsg/pipeline.scm
+++ /dev/null
@@ -1,25 +0,0 @@
-;; watch nanomsg's pipeline load-balancer in action.
-(use nanomsg)
-
-(define push (nn-socket 'push))
-(define pull1 (nn-socket 'pull))
-(define pull2 (nn-socket 'pull))
-
-(nn-bind    push  "inproc://test")
-(nn-connect pull1 "inproc://test")
-(nn-connect pull2 "inproc://test")
-
-(nn-send push "a")
-(nn-send push "b")
-(nn-send push "c")
-(nn-send push "d")
-
-(define ((th sock))
-  (print (current-thread) ": " (nn-recv sock))
-  (print (current-thread) ": " (nn-recv sock))
-  (print (current-thread) " is done"))
-
-(thread-start! (th pull1))
-(thread-start! (th pull2))
-
-(thread-sleep! 1)

DELETED testnanomsg/req-rep-client.scm
Index: testnanomsg/req-rep-client.scm
==================================================================
--- testnanomsg/req-rep-client.scm
+++ /dev/null
@@ -1,31 +0,0 @@
-;; watch nanomsg's pipeline load-balancer in action.
-(use nanomsg posix regex)
-
-(define req   (nn-socket 'req))
-
-(nn-connect req  "tcp://localhost:22022")
-
-;; (with-output-to-string (lambda ()(serialize obj)))
-(define (client-send-receive soc msg)
-  (nn-send soc msg)
-  (nn-recv soc))
-
-(define ((talk-to-server soc))
-  (let loop ((cnt 200000))
-    (let ((name (list-ref '("Matt" "Tom" "Bob" "Jill" "James" "Jane")(random 6))))
-      ;; (print "Sending " name)
-      ;; (print
-      (client-send-receive req name) ;; )
-      (if (> cnt 0)(loop (- cnt 1)))))
-  (print (client-send-receive req "quit"))
-  (nn-close req)
-  (exit))
-
-;; (thread-start! (lambda ()
-;; 		 (thread-sleep! 20)
-;; 		 (print "Give up on waiting for the server")
-;; 		 (nn-close req)
-;; 		 (exit)))
-
-(thread-join! (thread-start! (talk-to-server req)))
-

DELETED testnanomsg/req-rep-server.scm
Index: testnanomsg/req-rep-server.scm
==================================================================
--- testnanomsg/req-rep-server.scm
+++ /dev/null
@@ -1,94 +0,0 @@
-;; watch nanomsg's pipeline load-balancer in action.
-(use nanomsg posix regex)
-
-;; (use trace)
-;; (trace nn-bind nn-socket nn-assert nn-recv nn-send thread-terminate! nn-close )
-
-(define port  22022)
-(define host  "127.0.0.1")
-
-(define rep   (nn-socket 'rep))
-
-(print "connecting, got: " (nn-bind    rep  (conc "tcp://" "*" ":" port)))
-
-(define (server soc)
-  (print "server starting")
-  (let loop ((msg-in (nn-recv soc))
-	     (count  0))
-    (if (eq? 0 (modulo count 1000))
-	(print "server received: " msg-in ", count=" count))
-    (cond
-     ((equal? msg-in "quit")
-      (nn-send soc "Ok, quitting"))
-     ((and (>= (string-length msg-in) 4)
-	   (equal? (substring msg-in 0 4) "ping"))
-      (nn-send soc (conc (current-process-id)))
-      (loop (nn-recv soc)(+ count 1)))
-     ;;((and (>= (string-length msg-in)
-     (else
-      (let ((this-task  (/ (random 10) 200.0))
-	    (start-time (current-milliseconds)))
-	;; (thread-sleep! this-task)
-	(nn-send soc (conc "hello " msg-in " this task took " this-task " seconds to complete"))
-	;; (print "Actual send-receive time: " (- (current-milliseconds) start-time));
-	(loop (nn-recv soc)(+ count 1)))))))
-
-(define (ping-self host port #!key (return-socket #t))
-  ;; send a random number along with pid and check that we get it back
-  (let* ((req     (nn-socket 'req))
-	 (key     "ping")
-	 (success #f)
-	 (keepwaiting #t)
-	 (ping    (make-thread
-		   (lambda ()
-		     (print "ping: sending string \"" key "\", expecting " (current-process-id))
-		     (nn-send req key)
-		     (let ((result  (nn-recv req)))
-		       (if (equal? (conc (current-process-id)) result)
-			   (begin
-			     (print "ping, success: received \"" result "\"")
-			     (set! success #t))
-			   (begin
-			     (print "ping, failed: received key \"" result "\"")
-			     (set! keepwaiting #f)
-			     (set! success #f)))))
-		   "ping"))
-	 (timeout (make-thread (lambda ()
-				 (let loop ((count 0))
-				   (thread-sleep! 1)
-				   (print "still waiting after count seconds...")
-				   (if (and keepwaiting (< count 10))
-				       (loop (+ count 1))))
-				 (if keepwaiting
-				     (begin
-				       (print "timeout waiting for ping")
-				       (thread-terminate! ping))))
-			       "timeout")))
-    (nn-connect req (conc "tcp://" host ":" port))
-    (handle-exceptions
-     exn
-     (begin
-       (print-call-chain)
-       (print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
-       (print "exn=" (condition->list exn))
-       (print "ping failed to connect to " host ":" port))
-     (thread-start! timeout)
-     (thread-start! ping)
-     (thread-join! ping)
-     (if success (thread-terminate! timeout)))
-    (if return-socket
-	(if success req #f)
-	(begin
-	  (nn-close req)
-	  success))))
-
-(let ((server-thread (make-thread (lambda ()(server rep)) "server")))
-  (thread-start! server-thread)
-  ;; (thread-sleep! 1)
-  (if (ping-self host port)
-      (begin
-	(thread-join! server-thread)
-	(nn-close rep))
-      (print "ping failed")))
-
-(exit)

DELETED testnanomsg/req-rep.scm
Index: testnanomsg/req-rep.scm
==================================================================
--- testnanomsg/req-rep.scm
+++ /dev/null
@@ -1,33 +0,0 @@
-;; watch nanomsg's pipeline load-balancer in action.
-(use nanomsg)
-
-;; client
-(define req   (nn-socket 'req))
-(nn-connect req  "inproc://test") 
-
-(define (client-send-receive soc msg)
-  (nn-send soc msg)
-  (nn-recv soc))
-
-;; server
-(define rep   (nn-socket 'rep))
-(nn-bind    rep  "inproc://test")
-
-(define ((server soc))
-  (let loop ((msg-in (nn-recv soc)))
-    (if (not (equal? msg-in "quit"))
-	(begin
-	  (nn-send soc (conc "hello " msg-in))
-	  (loop (nn-recv soc))))))
-
-(thread-start! (server rep))
-
-;; client 
-(print (client-send-receive req "Matt"))
-(print (client-send-receive req "Tom"))
-
-;; (client-send-receive req "quit")
-
-(nn-close req) ;; client
-(nn-close rep) ;; server
-(exit)

DELETED testrpc/client.scm
Index: testrpc/client.scm
==================================================================
--- testrpc/client.scm
+++ /dev/null
@@ -1,8 +0,0 @@
-;;;; client.scm
-(use rpc posix)
-
-(define call (rpc:procedure 'foo "localhost"))
-
-(do ((i 10 (sub1 i)))
-    ((zero? i))
-  (print "-> " (call (random 100))))

DELETED testrpc/server.scm
Index: testrpc/server.scm
==================================================================
--- testrpc/server.scm
+++ /dev/null
@@ -1,15 +0,0 @@
-;;;; server.scm
-(use rpc)
-
-(rpc:publish-procedure!
- 'foo
- (lambda (x)
-   (print "foo: " x)
-   #f))
-
-(rpc:publish-procedure!
- 'fini
- (lambda () (print "fini") (thread-start! (lambda () (thread-sleep! 3) (print "terminate") (exit))) #f))
-
-((rpc:make-server (tcp-listen (rpc:default-server-port))) #t)
-

Index: tests/fdktestqa/fdk.config
==================================================================
--- tests/fdktestqa/fdk.config
+++ tests/fdktestqa/fdk.config
@@ -3,34 +3,26 @@
 RELEASE TEXT
 
 [setup]
 # Adjust max_concurrent_jobs to limit how much you load your machines
 # max_concurrent_jobs 150
-max_concurrent_jobs 1000
+max_concurrent_jobs 3000
 
 # This is your link path, you can move it but it is generally better to keep it stable
 linktree #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/../simplelinks}
 
 [include testqa/configs/megatest.abc.config]
 
-# timeout 0.025
-
 [jobtools]
 maxload 4
-launcher nbfake
+# launcher smartlauncher --cores 1 --memory 1
+launcher nbjob run --target pdx_soft --class 'SLES11&&1C&&1G' --qslot /icf/fdk/soft 
+# launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log 
 
 [server]
 # timeout 0.01
 # homehost xena
 # homehost 143.182.225.38
-
 # force server
-server-query-threshold 0
-
-
-[jobtools]
-# launcher nbq -P ch_vp -C SLES11_EM64T_4G -Q /ciaf/fdk
-launcher nbfake
-maxload 4
-
-# launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log 
+# server-query-threshold 0
+
 

Index: tests/fdktestqa/testqa/Makefile
==================================================================
--- tests/fdktestqa/testqa/Makefile
+++ tests/fdktestqa/testqa/Makefile
@@ -3,22 +3,23 @@
 MEGATEST  = $(BINDIR)/megatest
 DASHBOARD = $(BINDIR)/dashboard
 NEWDASHBOARD = $(BINDIR)/newdashboard
 RUNNAME   = a
 NUMTESTS  = 20
+SUBTARG = b
 
 all :
 	$(MEGATEST) -remove-runs -target a/b -runname c -testpatt %/%
 	$(MEGATEST) -run -testpatt % -target a/b -runname c
 
 bigbig :
 	for tn in a b c d;do \
-	   ($(MEGATEST) -run -testpatt % -target a/b -runname $tn & ) ; \
+	   (NUMTESTS=1000 $(MEGATEST) -run -testpatt % -target a/$(SUBTARG) -runname $$tn & ) ; \
 	done
 
 waitonpatt :
-	megatest -remove-runs -runname waitonpatt -target a/b -testpatt %
+	megatest -remove-runs -runname waitonpatt -target a/$(SUBTARG) -testpatt %
 	NUMTESTS=15 megatest -run -target a/b -runname waitonpatt -testpatt bigrun3/%8
 
 waitonall :
 	megatest -remove-runs -runname waitonall -target a/b -testpatt %
 	NUMTESTS=20 megatest -run -target a/b -runname waitonall -testpatt alltop

Index: tests/fdktestqa/testqa/megatest.config
==================================================================
--- tests/fdktestqa/testqa/megatest.config
+++ tests/fdktestqa/testqa/megatest.config
@@ -1,14 +1,18 @@
 [setup]
 testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log
 # launchwait no
-launch-delay 0.1
+# launch-delay 0.1
+launch-delay 0
+
+[jobtools]
+maxhomehostload 4
 
 [server]
 # runtime 180
 # timeout is in hours, this is how long the server will stay alive when not being used.
-timeout 0.1
+# timeout 0.1
 
 # All these are overridden in ../fdk.config
 # [jobtools]
 # launcher nbfake
 # launcher bsub -q priority -o $MT_TEST_RUN_DIR/openlava.log 

Index: tests/fdktestqa/testqa/runconfigs.config
==================================================================
--- tests/fdktestqa/testqa/runconfigs.config
+++ tests/fdktestqa/testqa/runconfigs.config
@@ -1,5 +1,7 @@
+[include local.runconfigs]
+
 [default]
 ALLTESTS see this variable
 
 # Your variables here are grouped by targets [SYSTEM/RELEASE]
 [SYSTEM_val/RELEASE_val]

DELETED testzmq/hwclient.scm
Index: testzmq/hwclient.scm
==================================================================
--- testzmq/hwclient.scm
+++ /dev/null
@@ -1,16 +0,0 @@
-(use zmq posix srfi-18)
-
-(define s (make-socket 'req))
-(connect-socket s "tcp://*:5563")
-
-(define myname (cadr (argv)))
-
-(print "Start client...")
-
-(do ((i 0 (+ i 1)))
-    ((>= i 1000))
-  (print "sending message #" i)
-  (send-message s (conc "Hello from " myname))
-  (print "sent \"Hello\", looking for a reply")
-  (printf "Received reply ~a [~a]\n"
-          i (receive-message s)))

DELETED testzmq/hwserver.scm
Index: testzmq/hwserver.scm
==================================================================
--- testzmq/hwserver.scm
+++ /dev/null
@@ -1,28 +0,0 @@
-(use zmq srfi-18 posix)
-
-(define th1 (make-thread 
-	     (lambda ()
-	       (let ((s (make-socket 'rep)))
-		 (bind-socket s "tcp://*:5563")
-		 (print "Start server...")
-		 (let loop ()
-		   (let* ((msg  (receive-message s))
-			  (name (caddr (string-split msg " ")))
-			  (resp (conc "World " name)))
-		     (print "Received request: [" msg "]")
-		     (thread-sleep! 0.0001)
-		     (print "Sending response \"" resp "\"")
-		     (send-message s resp)
-		     (loop)))))))
-(define th2 (make-thread
-	     (lambda ()
-	       (let loop ((count 0))
-		 (print "count is " count)
-		 (thread-sleep! 0.1)
-		 (if (< count 10000)
-		     (loop (+ count 1)))))))
-
-(thread-start! th1)
-(thread-start! th2)
-
-(thread-join! th1)

DELETED testzmq/hwtest.sh
Index: testzmq/hwtest.sh
==================================================================
--- testzmq/hwtest.sh
+++ /dev/null
@@ -1,14 +0,0 @@
-#!/bin/bash
-
-echo Compiling hwclient and hwserver
-csc hwclient.scm
-csc hwserver.scm
-
-./hwserver > hwserver.log &
-
-sleep 1
-for x in a b c d e f g h i j k l m n o p q r s t u v w x y z;do
-./hwclient $x &
-done
-
-# killall -v hwserver hwclient

DELETED testzmq/mockupclient.scm
Index: testzmq/mockupclient.scm
==================================================================
--- testzmq/mockupclient.scm
+++ /dev/null
@@ -1,42 +0,0 @@
-(use zmq posix numbers)
-
-(define cname "Bob")
-(define runtime 10)
-(let ((args (argv)))
-  (if (< (length args) 3)
-      (begin
-	(print "Usage: mockupclient clientname runtime")
-	(exit))
-      (begin
-	(set! cname (cadr args))
-	(set! runtime (string->number (caddr args))))))
-      
-;; (define start-delay (/ (random 100) 9))
-;; (define runtime     (+ 1 (/ (random 200) 2)))
-
-(print "Starting client " cname " with runtime " runtime)
-
-(include "mockupclientlib.scm")
-
-(set! endtime (+ (current-seconds) runtime))
-
-;; first ping the server to ensure we have a connection
-(if (server-ping cname 5)
-    (print "SUCCESS: Client " cname " connected to server")
-    (begin
-      (print "ERROR: Client " cname " failed ping of server, exiting")
-      (exit)))
-
-(let loop ()
-  (let ((x (random 15))
-	(varname (list-ref (list "hello" "goodbye" "saluton" "kiaorana")(random 4))))
-    (case x
-      ;; ((1)(dbaccess cname 'sync "nodat"    #f))
-      ((2 3 4 5)(dbaccess cname 'set varname (random 999)))
-      ((6 7 8 9 10)(print cname ": Get \"" varname "\" " (dbaccess cname 'get varname #f)))
-      (else
-       (thread-sleep! 0.011)))
-    (if (< (current-seconds) endtime)
-	(loop))))
-
-(print "Client " cname " all done!!")

DELETED testzmq/mockupclientlib.scm
Index: testzmq/mockupclientlib.scm
==================================================================
--- testzmq/mockupclientlib.scm
+++ /dev/null
@@ -1,63 +0,0 @@
-(define sub  (make-socket 'sub))
-(define push (make-socket 'push))
-(socket-option-set! sub 'subscribe cname)
-(socket-option-set! sub 'hwm 1000)
-(socket-option-set! push 'hwm 1000)
-
-(connect-socket sub "tcp://localhost:6563")
-(connect-socket push "tcp://localhost:6564")
-
-(thread-sleep! 0.2)
-
-(define (server-ping cname timeout)
-  (let ((msg     (conc cname ":ping:" timeout))
-	(maxtime (+ (current-seconds) timeout)))
-    (print "pinging server from " cname " with timeout " timeout)
-    (let loop ((res   #f))
-      (if (< maxtime (current-seconds))
-	  #f ;; failed to ping
-	  (if (equal? res "Got ping")
-	      #t
-	      (begin
-		(print "Ping received from server " res)
-		(send-message push msg)
-		(thread-sleep! 0.1)
-		(loop (receive-message sub non-blocking: #t))))))))
-  
-(define (dbaccess cname cmd var val #!key (numtries 20))
-  (let* ((msg (conc cname ":" cmd ":" (if val (conc var " " val) var)))
-	 (res #f)
-	 (mtx1 (make-mutex))
-	 (do-access (lambda ()
-		      (let ((tmpres #f))
-			(print "Sending msg: " msg)
-			(send-message push msg)
-			(print "Message " msg " sent")
-			(print "Client " cname " waiting for response to " msg)
-			(print "Client " cname " received address " (receive-message* sub))
-			(set! tmpres (receive-message* sub))
-			(mutex-lock! mtx1)
-			(set! res tmpres)
-			(mutex-unlock! mtx1))))
-	 (th1 (make-thread do-access "do access"))
-	 (th2 (make-thread (lambda ()
-			     (let ((result #f))
-			       (mutex-lock! mtx1)
-			       (set! result res)
-			       (mutex-unlock! mtx1)
-			       (thread-sleep! 5)
-			       (if (not result)
-				   (if (> numtries 0)
-				       (begin
-					 (print "WARNING: access timed out for " cname ", trying again. Trys remaining=" numtries)
-					 (dbaccess cname cmd var val numtries: (- numtries 1)))
-				       (begin
-					 (print "ERROR: dbaccess timed out. Exiting")
-					 (exit)))))
-			     "timeout thread"))))
-    (thread-start! th1)
-    (thread-start! th2)
-    (thread-join! th1)
-    (if res (print "SUCCESS: received " res " with " numtries " remaining possible attempts"))
-    res))
-

DELETED testzmq/mockupserver.scm
Index: testzmq/mockupserver.scm
==================================================================
--- testzmq/mockupserver.scm
+++ /dev/null
@@ -1,151 +0,0 @@
-;; pub/sub with envelope address
-;; Note that if you don't insert a sleep, the server will crash with SIGPIPE as soon
-;; as a client disconnects.  Also a remaining client may receive tons of
-;; messages afterward.
-
-(use zmq srfi-18 sqlite3 numbers)
-
-(define pub (make-socket 'pub))
-(define pull (make-socket 'pull))
-(define cname "server")
-(define total-db-accesses 0)
-(define start-time (current-seconds))
-
-(socket-option-set! pub 'hwm 1000)
-(socket-option-set! pull 'hwm 1000)
-
-(bind-socket pub "tcp://*:6563")
-(bind-socket pull "tcp://*:6564")
-
-(thread-sleep! 0.2)
-
-(define (open-db)
-  (let* ((dbpath    "mockup.db")
-	 (dbexists  (file-exists? dbpath))
-	 (db        (open-database dbpath)) ;; (never-give-up-open-db dbpath))
-	 (handler   (make-busy-timeout 10)))
-    (set-busy-handler! db handler)
-    (if (not dbexists)
-	(for-each
-	 (lambda (stmt)
-	   (execute db stmt))
-	 (list
-	  "PRAGMA SYNCHRONOUS=0;"
-	  "CREATE TABLE clients (id INTEGER PRIMARY KEY,name TEXT,num_accesses INTEGER DEFAULT 0);"
-	  "CREATE TABLE vars    (var TEXT,val TEXT,CONSTRAINT vars_constraint UNIQUE (var));")))
-    db))
-
-(define cid-cache (make-hash-table))
-
-(define (get-client-id db cname)
-  (let ((cid (hash-table-ref/default cid-cache cname #f)))
-    (if cid 
-	cid
-	(begin
-	  (execute db "INSERT OR REPLACE INTO clients (name) VALUES(?);" cname)
-	  (for-each-row 
-	   (lambda (id)
-	     (set! cid id))
-	   db
-	   "SELECT id FROM clients WHERE name=?;" cname)
-	  (hash-table-set! cid-cache cname cid)
-	  (set! total-db-accesses (+ total-db-accesses 2))
-	  cid))))
-
-(define (count-client db cname)
-  (let ((cid (get-client-id db cname)))
-    (execute db "UPDATE clients SET num_accesses=num_accesses+1 WHERE id=?;" cid)
-    (set! total-db-accesses (+ total-db-accesses 1))
-    ))
-
-(define db (open-db))
-;; (define queuelst '())
-;; (define mx1 (make-mutex))
-
-(define max-queue-len 0)
-
-(define (process-queue queuelst)
-  (let ((queuelen (length queuelst)))
-    (if (> queuelen max-queue-len)
-	(set! max-queue-len queuelen))
-    (for-each
-     (lambda (item)
-       (let ((cname (vector-ref item 1))
-	     (clcmd (vector-ref item 2))
-	     (cdata (vector-ref item 3)))
-	 (send-message pub cname send-more: #t)
-	 (send-message pub (case clcmd
-			     ((sync)
-			      (conc queuelen))
-			     ((set)
-			      (set! total-db-accesses (+ total-db-accesses 1))
-			      (apply execute db "INSERT OR REPLACE INTO vars (var,val) VALUES (?,?);" (string-split cdata))
-			      "ok")
-			     ((get)
-			      (set! total-db-accesses (+ total-db-accesses 1))
-			      (let ((res "noval"))
-				(for-each-row
-				 (lambda (val)
-				   (set! res val))
-				 db 
-				 "SELECT val FROM vars WHERE var=?;" cdata)
-				res))
-			     (else (conc "unk cmd: " clcmd))))))
-     queuelst)))
-
-;; SERVER THREAD
-(define th1 (make-thread 
-	     (lambda ()
-	       (let ((last-run 0)) ;; current-seconds when run last
-		 (let loop ((queuelst '()))
-		   (let* ((indat (receive-message* pull))
-			  (parts (string-split indat ":"))
-			  (cname (car parts))                   ;; client name
-			  (clcmd (string->symbol (cadr parts))) ;; client cmd
-			  (cdata (caddr parts))                 ;; client data
-			  (svect (vector (current-seconds) cname clcmd cdata))) ;; record for the queue
-		     ;; (print "Server received message: " indat)
-		     (count-client db cname)
-		     (case clcmd
-		       ((ping)
-			(print "Got ping from " cname)
-			(send-message pub cname send-more: #t)
-			(send-message pub "Got ping")
-			(loop queuelst))
-		       ((sync) ;; just process the queue
-			(print "Got sync from " cname)
-			(process-queue (cons svect queuelst))
-			(loop '()))
-		       ((get)
-			(process-queue (cons svect queuelst))
-			(loop '()))
-		       (else
-			(loop (cons svect queuelst))))))))
-	     "server thread"))
-
-(include "mockupclientlib.scm")
-
-;; SYNC THREAD
-;; send a sync to the pull port
-(define th2 (make-thread
-	     (lambda ()
-	       (let ((last-action-time (current-seconds)))
-		 (let loop ()
-		   (thread-sleep! 5)
-		   (let ((queuelen (string->number (dbaccess "server" 'sync "nada" #f)))
-			 (last-action-delta #f))
-		     (if (> queuelen 1)(set! last-action-time (current-seconds)))
-		     (set! last-action-delta (- (current-seconds) last-action-time))
-		     (print "Server: Got queuelen=" queuelen ", last-action-delta=" last-action-delta)
-		     (if (< last-action-delta 60)
-			 (loop)
-			 (print "Server exiting, 25 seconds since last access"))))))
-	     "sync thread"))
-
-(thread-start! th1)
-(thread-start! th2)
-(thread-join! th2)
-
-(let* ((run-time       (- (current-seconds) start-time))
-       (queries/second (/  total-db-accesses run-time)))
-  (print "Server exited! Total db accesses=" total-db-accesses " in " run-time " seconds for " queries/second " queries/second with max queue length of: " max-queue-len))

DELETED testzmq/random.scm
Index: testzmq/random.scm
==================================================================
--- testzmq/random.scm
+++ /dev/null
@@ -1,8 +0,0 @@
-(use posix numbers)
-(randomize (inexact->exact (current-seconds)))
-
-(define low (string->number (cadr (argv))))
-(define hi  (string->number (caddr (argv))))
-
-(print (+ low (random (- hi low))))
-

DELETED testzmq/testmockup.sh
Index: testzmq/testmockup.sh
==================================================================
--- testzmq/testmockup.sh
+++ /dev/null
@@ -1,41 +0,0 @@
-#!/bin/bash
-
-rm -f mockup.db
-
-echo Compiling mockupserver.scm and mockupclient.scm
-
-# Clean up first
-killall mockupserver mockupclient -v
-
-csc random.scm
-csc mockupserver.scm
-csc mockupclient.scm
-
-echo Starting server
-./mockupserver &
-
-sleep 1
-
-rm -f mockupclients.log
-
-echo Starting clients
-for i in a b c d e f g h i j k l m n o p q s t u v w x y z; 
-  do
-  for k in a b;
-    do
-    for j in 0 1 2 3 4 5 6 7 8 9;
-      do
-      waittime=`./random 0 60`
-      runtime=`./random 5 120`
-      echo "Starting client $i$k$j with waittime $waittime and runtime $runtime" 
-      (sleep $waittime;./mockupclient $i$k$j $runtime) &
-      # >> mockupclients.log &
-    done
-  done
-done
-
-wait
-echo testmockup.sh script done
-# echo "Waiting for 5 seconds then killing all mockupserver and mockupclient processes"
-# sleep 30
-# killall -v mockupserver mockupclient

Index: utils/cleanup-pkts.sh
==================================================================
--- utils/cleanup-pkts.sh
+++ utils/cleanup-pkts.sh
@@ -2,11 +2,11 @@
 
 pushd $1
 
 for x in *.pkt;do
     if grep 'T configf' $x > /dev/null;then
-        echo rm $x
+        rm $x
     else
         echo skip $x
     fi
 done