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)
-;; 

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))))
-

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 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))))))))

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")