Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -164,11 +164,11 @@
$(MTQA_FOSSIL) :
fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL)
clean :
- rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o
+ rm -f $(OFILES) $(GOFILES) megatest dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.*
# Deploy section (not complete yet)
#
$(DEPLOYHELPERS) : utils/mt_*
$(INSTALL) $< $@
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -129,10 +129,69 @@
;; Generic string database
(define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f)
;; Generic path database
(define *fdb* #f)
+
+;;======================================================================
+;; V E R S I O N
+;;======================================================================
+
+(define (common:get-full-version)
+ (conc megatest-version "-" megatest-fossil-hash))
+
+(define (common:version-signature)
+ (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
+
+;; from metadat lookup MEGATEST_VERSION
+;;
+(define (common:get-last-run-version)
+ (rmt:get-var "MEGATEST_VERSION"))
+
+(define (common:set-last-run-version)
+ (rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
+
+(define (common:version-changed?)
+ (not (equal? (common:get-last-run-version)
+ (common:version-signature))))
+
+(define (common:exit-on-version-changed)
+ (if (common:version-changed?)
+ (begin
+ (debug:print 0
+ "ERROR: Version mismatch!\n"
+ " expected: " (common:version-signature) "\n"
+ " got: " (common:get-last-run-version) "\n"
+ " to switch versions you can run: \"megatest -cleanup-db\"")
+ (exit 1))))
+
+;;======================================================================
+;; S P A R S E A R R A Y S
+;;======================================================================
+
+(define (make-sparse-array)
+ (let ((a (make-sparse-vector)))
+ (sparse-vector-set! a 0 (make-sparse-vector))
+ a))
+
+(define (sparse-array? a)
+ (and (sparse-vector? a)
+ (sparse-vector? (sparse-vector-ref a 0))))
+
+(define (sparse-array-ref a x y)
+ (let ((row (sparse-vector-ref a x)))
+ (if row
+ (sparse-vector-ref row y)
+ #f)))
+
+(define (sparse-array-set! a x y val)
+ (let ((row (sparse-vector-ref a x)))
+ (if row
+ (sparse-vector-set! row y val)
+ (let ((new-row (make-sparse-vector)))
+ (sparse-vector-set! a x new-row)
+ (sparse-vector-set! new-row y val)))))
;;======================================================================
;; L O C K E R S A N D B L O C K E R S
;;======================================================================
@@ -334,11 +393,11 @@
;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway
(exit))
(set-signal-handler! signal/int std-signal-handler) ;; ^C
(set-signal-handler! signal/term std-signal-handler)
-(set-signal-handler! signal/stop std-signal-handler) ;; ^Z
+;; (set-signal-handler! signal/stop std-signal-handler) ;; ^Z NO, do NOT handle ^Z!
;;======================================================================
;; M I S C U T I L S
;;======================================================================
@@ -362,13 +421,10 @@
((d) (* 24 60 60))
(else 0))))))))))
parts)
time-secs))
-(define (common:version-signature)
- (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
-
;; one-of args defined
(define (args-defined? . param)
(let ((res #f))
(for-each
(lambda (arg)
@@ -525,11 +581,11 @@
(cdr tal))
(max hed max-val))))
;;======================================================================
-;; Munge data into nice forms
+;; M U N G E D A T A I N T O N I C E F O R M S
;;======================================================================
;; Generate an index for a sparse list of key values
;; ( (rowname1 colname1 val1)(rowname2 colname2 val2) )
;;
@@ -568,11 +624,11 @@
(if (> curr-rownum rownum) curr-rownum rownum)
(if (> curr-colnum colnum) curr-colnum colnum)
))))))
;;======================================================================
-;; System stuff
+;; S Y S T E M S T U F F
;;======================================================================
;; return a nice clean pathname made absolute
(define (nice-path dir)
(normalize-pathname (if (absolute-pathname? dir)
@@ -673,11 +729,11 @@
;; with free-space-script /path/to/some/script.sh
;;
(define (get-df path)
(if (configf:lookup *configdat* "setup" "free-space-script")
(with-input-from-pipe
- (configf:lookup *configdat* "setup" "free-space-script")
+ (conc (configf:lookup *configdat* "setup" "free-space-script") " " path)
(lambda ()
(let ((res (read-line)))
(if (string? res)
(string->number res)))))
(get-unix-df path)))
@@ -838,11 +894,11 @@
(lambda (var val)
(setenv var val)))
vars))
;;======================================================================
-;; time and date nice to have stuff
+;; T I M E A N D D A T E
;;======================================================================
(define (seconds->hr-min-sec secs)
(let* ((hrs (quotient secs 3600))
(min (quotient (- secs (* hrs 3600)) 60))
@@ -881,11 +937,11 @@
((7 8 9) 3)
((10 11 12) 4)
(else #f)))
;;======================================================================
-;; Colors
+;; C O L O R S
;;======================================================================
(define (common:name->iup-color name)
(case (string->symbol (string-downcase name))
((red) "223 33 49")
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -41,11 +41,11 @@
(include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")
(define help (conc
-"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
+ "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2012-2016
Usage: dashboard [options]
-h : this help
@@ -72,11 +72,11 @@
"-guimonitor"
"-main"
"-v"
"-q"
"-use-local"
- )
+ )
args:arg-hash
0))
(if (args:get-arg "-h")
(begin
@@ -97,10 +97,11 @@
curr-tab-num
dbdir
dbfpath
dbkeys
dblocal
+ filters-changed
header
hide-empty-runs
hide-not-hide ;; toggle for hide/not hide
hide-not-hide-button
hide-not-hide-tabs
@@ -119,11 +120,11 @@
tot-runs
update-mutex
updaters
updating
useserver
- )
+ )
(define *alldat* (make-d:alldat
header: #f
allruns: '()
allruns-by-id: (make-hash-table)
@@ -144,37 +145,13 @@
hide-not-hide: #t
hide-not-hide-button: #f
hide-not-hide-tabs: #f
curr-tab-num: 0
updaters: (make-hash-table)
+ filters-changed: #f
))
-;; simple two dimentional sparse array
-;;
-(define (make-sparse-array)
- (let ((a (make-sparse-vector)))
- (sparse-vector-set! a 0 (make-sparse-vector))
- a))
-
-(define (sparse-array? a)
- (and (sparse-vector? a)
- (sparse-vector? (sparse-vector-ref a 0))))
-
-(define (sparse-array-ref a x y)
- (let ((row (sparse-vector-ref a x)))
- (if row
- (sparse-vector-ref row y)
- #f)))
-
-(define (sparse-array-set! a x y val)
- (let ((row (sparse-vector-ref a x)))
- (if row
- (sparse-vector-set! row y val)
- (let ((new-row (make-sparse-vector)))
- (sparse-vector-set! a x new-row)
- (sparse-vector-set! new-row y val)))))
-
;; data for runs, tests etc
;;
(defstruct d:rundat
;; new system
runs-index ;; target/runname => colnum
@@ -328,11 +305,11 @@
(let* ((c1 (map string->number (string-split color1)))
(c2 (map string->number (string-split color2)))
(delta (map (lambda (a b)(abs (- a b))) c1 c2)))
(null? (filter (lambda (x)(> x 3)) delta))))
-(define (compare-tests test1 test2)
+(define (dboard:compare-tests test1 test2)
(let* ((test-name1 (db:test-get-testname test1))
(item-path1 (db:test-get-item-path test1))
(eventtime1 (db:test-get-event_time test1))
(test-name2 (db:test-get-testname test2))
(item-path2 (db:test-get-item-path test2))
@@ -347,104 +324,118 @@
(string>? item-path1 item-path2)
test1-older)
(if same-time
(string>? test-name1 test-name2)
test1-older))))
-
-;; create a virtual table of all the tests
-;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
-(define (update-rundat runnamepatt numruns testnamepatt keypatts)
- (let* ((referenced-run-ids '())
- (allruns (if (d:alldat-useserver *alldat*)
- (rmt:get-runs runnamepatt numruns (d:alldat-start-run-offset *alldat*) keypatts)
- (db:get-runs (d:alldat-dblocal *alldat*) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
- (d:alldat-start-run-offset *alldat*) keypatts)))
- (header (db:get-header allruns))
- (runs (db:get-rows allruns))
- (result '())
- (maxtests 0)
- (states (hash-table-keys (d:alldat-state-ignore-hash *alldat*)))
- (statuses (hash-table-keys (d:alldat-status-ignore-hash *alldat*)))
+
+;; This is roughly the same as dboard:get-tests-dat, should merge them if possible
+;;
+(define (dboard:get-tests-for-run-duplicate data run-id run testnamepatt key-vals)
+ (let* ((states (hash-table-keys (d:alldat-state-ignore-hash data)))
+ (statuses (hash-table-keys (d:alldat-status-ignore-hash data)))
(sort-info (get-curr-sort))
(sort-by (vector-ref sort-info 1))
(sort-order (vector-ref sort-info 2))
(bubble-type (if (member sort-order '(testname))
'testname
- 'itempath)))
+ 'itempath))
+ (prev-dat (let ((rec (hash-table-ref/default (d:alldat-allruns-by-id data) run-id #f)))
+ (if rec rec (vector run '() key-vals -100)))) ;; -100 is before time began
+ (prev-tests (vector-ref prev-dat 1))
+ (last-update (vector-ref prev-dat 3))
+ (tmptests (if (d:alldat-useserver data)
+ (rmt:get-tests-for-run run-id testnamepatt states statuses
+ #f #f
+ (d:alldat-hide-not-hide data)
+ sort-by
+ sort-order
+ 'shortlist
+ (if (d:alldat-filters-changed data)
+ 0
+ last-update))
+ (db:get-tests-for-run (d:alldat-dblocal data) run-id testnamepatt states statuses
+ #f #f
+ (d:alldat-hide-not-hide data)
+ sort-by
+ sort-order
+ 'shortlist
+ (if (d:alldat-filters-changed data)
+ 0
+ last-update))))
+ (tests (let ((newdat (filter
+ (lambda (x)
+ (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging
+ (delete-duplicates (if (d:alldat-filters-changed data)
+ tmptests
+ (append tmptests prev-tests))
+ (lambda (a b)
+ (eq? (db:test-get-id a)(db:test-get-id b)))))))
+ (if (eq? *tests-sort-reverse* 3) ;; +event_time
+ (sort newdat dboard:compare-tests)
+ newdat))))
+ (debug:print 0 "(dboard:get-tests-for-run-duplicate: got " (length tests) " test records for run " run-id)
+ tests))
+
+;; create a virtual table of all the tests
+;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
+(define (update-rundat data runnamepatt numruns testnamepatt keypatts)
+ (let* ((referenced-run-ids '())
+ (allruns (if (d:alldat-useserver data)
+ (rmt:get-runs runnamepatt numruns (d:alldat-start-run-offset data) keypatts)
+ (db:get-runs (d:alldat-dblocal data) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
+ (d:alldat-start-run-offset data) keypatts)))
+ (header (db:get-header allruns))
+ (runs (db:get-rows allruns))
+ (result '())
+ (maxtests 0)
+)
;;
;; trim runs to only those that are changing often here
;;
(for-each (lambda (run)
(let* ((run-id (db:get-value-by-header run header "id"))
- (key-vals (if (d:alldat-useserver *alldat*)
+ (key-vals (if (d:alldat-useserver data)
(rmt:get-key-vals run-id)
- (db:get-key-vals (d:alldat-dblocal *alldat*) run-id)))
- (prev-dat (let ((rec (hash-table-ref/default (d:alldat-allruns-by-id *alldat*) run-id #f)))
- (if rec rec (vector run '() key-vals -100)))) ;; -100 is before time began
- (prev-tests (vector-ref prev-dat 1))
- (last-update (vector-ref prev-dat 3))
- (tmptests (if (d:alldat-useserver *alldat*)
- (rmt:get-tests-for-run run-id testnamepatt states statuses
- #f #f
- (d:alldat-hide-not-hide *alldat*)
- sort-by
- sort-order
- 'shortlist
- last-update)
- (db:get-tests-for-run (d:alldat-dblocal *alldat*) run-id testnamepatt states statuses
- #f #f
- (d:alldat-hide-not-hide *alldat*)
- sort-by
- sort-order
- 'shortlist
- last-update)))
- (tests (let ((newdat (filter
- (lambda (x)
- (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging
- (delete-duplicates (append tmptests prev-tests)
- (lambda (a b)
- (eq? (db:test-get-id a)(db:test-get-id b)))))))
- (if (eq? *tests-sort-reverse* 3) ;; +event_time
- (sort newdat compare-tests)
- newdat))))
- ;; NOTE: bubble-up also sets the global (d:alldat-item-test-names *alldat*)
+ (db:get-key-vals (d:alldat-dblocal data) run-id)))
+ (tests (dboard:get-tests-for-run-duplicate data run-id run testnamepatt key-vals)))
+ ;; NOTE: bubble-up also sets the global (d:alldat-item-test-names data)
;; (tests (bubble-up tmptests priority: bubble-type))
;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals)
;; Not sure this is needed?
(set! referenced-run-ids (cons run-id referenced-run-ids))
(if (> (length tests) maxtests)
(set! maxtests (length tests)))
- (if (or (not (d:alldat-hide-empty-runs *alldat*)) ;; this reduces the data burden when set
+ (if (or (not (d:alldat-hide-empty-runs data)) ;; this reduces the data burden when set
(not (null? tests)))
(let ((dstruct (vector run tests key-vals (- (current-seconds) 10))))
- (hash-table-set! (d:alldat-allruns-by-id *alldat*) run-id dstruct)
+ (hash-table-set! (d:alldat-allruns-by-id data) run-id dstruct)
(set! result (cons dstruct result))))))
runs)
- (d:alldat-header-set! *alldat* header)
- (d:alldat-allruns-set! *alldat* result)
- (debug:print-info 6 "(d:alldat-allruns *alldat*) has " (length (d:alldat-allruns *alldat*)) " runs")
+ (d:alldat-header-set! data header)
+ (d:alldat-allruns-set! data result)
+ (debug:print-info 6 "(d:alldat-allruns data) has " (length (d:alldat-allruns data)) " runs")
maxtests))
(define *collapsed* (make-hash-table))
-; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj)
+ ; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj)
(define (toggle-hide lnum) ; fulltestname)
(let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
(fulltestname (iup:attribute btn "TITLE"))
(parts (string-split fulltestname "("))
(basetestname (if (null? parts) "" (car parts))))
- ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f))
+ ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f))
(if (hash-table-ref/default *collapsed* basetestname #f)
(begin
- ;(iup:attribute-set! btn "FGCOLOR" "0 0 0")
+ ;(iup:attribute-set! btn "FGCOLOR" "0 0 0")
(hash-table-delete! *collapsed* basetestname))
(begin
- ;(iup:attribute-set! btn "FGCOLOR" "0 192 192")
+ ;(iup:attribute-set! btn "FGCOLOR" "0 192 192")
(hash-table-set! *collapsed* basetestname #t)))))
-
+
(define blank-line-rx (regexp "^\\s*$"))
(define (run-item-name->vectors lst)
(map (lambda (x)
(let ((splst (string-split x "("))
@@ -479,11 +470,11 @@
(map (lambda (x)
(if (equal? (vector-ref x 1) "")
(vector-ref x 0)
(conc (vector-ref x 0) "(" (vector-ref x 1) ")")))
vlst2)))
-
+
(define (update-labels uidat)
(let* ((rown 0)
(keycol (dboard:uidat-get-keycol uidat))
(lftcol (dboard:uidat-get-lftcol uidat))
(numcols (vector-length lftcol))
@@ -564,11 +555,11 @@
(res '()))
(let ((newres (append res (hash-table-ref tests hed))))
(if (null? tal)
newres
(loop (car tal)(cdr tal) newres))))))))
-
+
(define (update-buttons uidat numruns numtests)
(let* ((runs (if (> (length (d:alldat-allruns *alldat*)) numruns)
(take-right (d:alldat-allruns *alldat*) numruns)
(pad-list (d:alldat-allruns *alldat*) numruns)))
(lftcol (dboard:uidat-get-lftcol uidat))
@@ -679,14 +670,16 @@
(if (or search-changed
state-changed
status-changed)
"190 180 190"
"190 190 190"
- ))))
+ ))
+ (d:alldat-filters-changed-set! *alldat* #t)))
(define (update-search x val)
(hash-table-set! (d:alldat-searchpatts *alldat*) x val)
+ (d:alldat-filters-changed-set! *alldat* #t)
(set-bg-on-filter))
(define (mark-for-update)
(d:alldat-last-db-update-set! *alldat* 0))
@@ -827,11 +820,12 @@
(conc " :status " (string-intersperse statuses ","))))
(full-cmd "megatest"))
(case (string->symbol cmd)
((runtests)
(set! full-cmd (conc full-cmd
- " -runtests "
+ " -run"
+ " -testpatt "
test-patt
" -target "
target
" -runname "
run-name
@@ -855,22 +849,22 @@
(define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records)
(canvas-clear! cnv)
(canvas-font-set! cnv "Helvetica, -10")
(let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
((originx originy) (canvas-origin cnv)))
- ;; (print "originx: " originx " originy: " originy)
- ;; (canvas-origin-set! cnv 0 (- (/ sizey 2)))
- (if (hash-table-ref/default tests-draw-state 'first-time #t)
- (begin
- (hash-table-set! tests-draw-state 'first-time #f)
- (hash-table-set! tests-draw-state 'scalef 1)
- (hash-table-set! tests-draw-state 'tests-info (make-hash-table))
- (hash-table-set! tests-draw-state 'selected-tests (make-hash-table))
- ;; set these
- (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
- (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
- ))
+ ;; (print "originx: " originx " originy: " originy)
+ ;; (canvas-origin-set! cnv 0 (- (/ sizey 2)))
+ (if (hash-table-ref/default tests-draw-state 'first-time #t)
+ (begin
+ (hash-table-set! tests-draw-state 'first-time #f)
+ (hash-table-set! tests-draw-state 'scalef 1)
+ (hash-table-set! tests-draw-state 'tests-info (make-hash-table))
+ (hash-table-set! tests-draw-state 'selected-tests (make-hash-table))
+ ;; set these
+ (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
+ (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
+ ))
;;======================================================================
;; R U N C O N T R O L S
;;======================================================================
;;
@@ -888,13 +882,17 @@
(key-listboxes #f)
(updater-for-runs #f)
(update-keyvals (lambda ()
(let ((targ (map (lambda (x)
(iup:attribute x "VALUE"))
- (car (dashboard:update-target-selector key-listboxes)))))
+ (car (dashboard:update-target-selector key-listboxes))))
+ (curr-runname (dboard:data-get-run-name *data*)))
(dboard:data-set-target! *data* targ)
(if updater-for-runs (updater-for-runs))
+ (if (or (not (equal? curr-runname (dboard:data-get-run-name *data*)))
+ (equal? (dboard:data-get-run-name *data*) ""))
+ (dboard:data-set-run-name! *data* curr-runname))
(dashboard:update-run-command))))
(tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas
(test-patterns-textbox #f))
(hash-table-set! tests-draw-state 'first-time #t)
;; (hash-table-set! tests-draw-state 'scalef 1)
@@ -959,17 +957,19 @@
(tb (iup:textbox #:expand "HORIZONTAL"
#:action (lambda (obj val txt)
;; (print "obj: " obj " val: " val " unk: " unk)
(dboard:data-set-run-name! *data* txt) ;; (iup:attribute obj "VALUE"))
(dashboard:update-run-command))
- #:value default-run-name))
+ #:value (or default-run-name (dboard:data-get-run-name *data*))))
(lb (iup:listbox #:expand "HORIZONTAL"
#:dropdown "YES"
#:action (lambda (obj val index lbstate)
- (iup:attribute-set! tb "VALUE" val)
- (dboard:data-set-run-name! *data* val)
- (dashboard:update-run-command))))
+ (if (not (equal? val ""))
+ (begin
+ (iup:attribute-set! tb "VALUE" val)
+ (dboard:data-set-run-name! *data* val)
+ (dashboard:update-run-command))))))
(refresh-runs-list (lambda ()
(let* ((target (dboard:data-get-target-string *data*))
(runs-for-targ (if (d:alldat-useserver *alldat*)
(rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" target #f #f #f)
(db:get-runs-by-patt (d:alldat-dblocal *alldat*) (d:alldat-keys *alldat*) "%" target #f #f #f)))
@@ -977,11 +977,11 @@
(runs-dat (vector-ref runs-for-targ 1))
(run-names (cons default-run-name
(map (lambda (x)
(db:get-value-by-header x runs-header "runname"))
runs-dat))))
- (iup:attribute-set! lb "REMOVEITEM" "ALL")
+ ;; (iup:attribute-set! lb "REMOVEITEM" "ALL")
(iuplistbox-fill-list lb run-names selected-item: default-run-name)))))
(set! updater-for-runs refresh-runs-list)
(refresh-runs-list)
(dboard:data-set-run-name! *data* default-run-name)
(iup:hbox
@@ -1031,11 +1031,11 @@
(dashboard:text-list-toggle-box
(map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
(lambda (all)
(dboard:data-set-statuses! *data* all)
(dashboard:update-run-command))))))))
-
+
(iup:frame
#:title "Tests and Tasks"
(let* ((updater #f)
(last-xadj 0)
(last-yadj 0)
@@ -1067,14 +1067,14 @@
#:scrollbar "YES"
#:posx "0.5"
#:posy "0.5"
#:button-cb (lambda (obj btn pressed x y status)
;; (print "obj: " obj ", pressed " pressed ", status " status)
- ; (print "canvas-origin: " (canvas-origin the-cnv))
+ ; (print "canvas-origin: " (canvas-origin the-cnv))
;; (let-values (((xx yy)(canvas-origin the-cnv)))
- ;; (canvas-transform-set! the-cnv #f)
- ;; (print "canvas-origin: " xx " " yy " click at " x " " y))
+ ;; (canvas-transform-set! the-cnv #f)
+ ;; (print "canvas-origin: " xx " " yy " click at " x " " y))
(let* ((tests-info (hash-table-ref tests-draw-state 'tests-info))
(selected-tests (hash-table-ref tests-draw-state 'selected-tests))
(scalef (hash-table-ref tests-draw-state 'scalef))
(sizey (hash-table-ref tests-draw-state 'sizey))
(xoffset (dcommon:get-xoffset tests-draw-state #f #f))
@@ -1107,11 +1107,11 @@
(dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt))
(dashboard:update-run-command)
(if updater (updater last-xadj last-yadj)))))))
(hash-table-keys tests-info)))))))
canvas-obj)))
-
+
(iup:frame
#:title "Logs" ;; To be replaced with tabs
(let ((logs-tb (iup:textbox #:expand "YES"
#:multiline "YES")))
(dboard:data-set-logs-textbox! *data* logs-tb)
@@ -1146,12 +1146,13 @@
;;======================================================================
;; S U M M A R Y
;;======================================================================
;;
;; General info about the run(s) and megatest area
-(define (dashboard:summary db)
- (let ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f))) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
+(define (dashboard:summary data)
+ (let* ((db (d:alldat-dblocal data))
+ (rawconfig (read-config (conc *toppath* "/megatest.config") #f #f))) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
(iup:vbox
(iup:split
#:value 500
(iup:frame
#:title "General Info"
@@ -1189,84 +1190,93 @@
(if (not (null? path))
(hash-table-ref/default (d:data-path-run-ids data) path #f)
#f))
(define dashboard:update-run-summary-tab #f)
+(define dashboard:update-new-view-tab #f)
+
+(define (dboard:get-tests-dat data run-id last-update)
+ (let ((tdat (if run-id
+ (if (d:alldat-useserver data)
+ (rmt:get-tests-for-run run-id
+ (hash-table-ref/default (d:alldat-searchpatts data) "test-name" "%/%")
+ (hash-table-keys (d:alldat-state-ignore-hash data)) ;; '()
+ (hash-table-keys (d:alldat-status-ignore-hash data)) ;; '()
+ #f #f
+ (d:alldat-hide-not-hide data)
+ #f #f
+ "id,testname,item_path,state,status"
+ (if (d:alldat-filters-changed data)
+ 0
+ last-update)) ;; get 'em all
+ (db:get-tests-for-run db run-id
+ (hash-table-ref/default (d:alldat-searchpatts data) "test-name" "%/%")
+ (hash-table-keys (d:alldat-state-ignore-hash data)) ;; '()
+ (hash-table-keys (d:alldat-status-ignore-hash data)) ;; '()
+ #f #f
+ (d:alldat-hide-not-hide data)
+ #f #f
+ "id,testname,item_path,state,status"
+ (if (d:alldat-filters-changed data)
+ 0
+ last-update)))
+ '()))) ;; get 'em all
+ (debug:print 0 "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id)
+ (sort tdat (lambda (a b)
+ (let* ((aval (vector-ref a 2))
+ (bval (vector-ref b 2))
+ (anum (string->number aval))
+ (bnum (string->number bval)))
+ (if (and anum bnum)
+ (< anum bnum)
+ (string<= aval bval)))))))
;; This is the Run Summary tab
;;
-(define (dashboard:one-run db data)
+(define (dashboard:one-run db data ddata)
(let* ((tb (iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
#:addexpanded "NO"
#:selection-cb
(lambda (obj id state)
;; (print "obj: " obj ", id: " id ", state: " state)
(let* ((run-path (tree:node->path obj id))
- (run-id (tree-path->run-id data (cdr run-path))))
+ (run-id (tree-path->run-id ddata (cdr run-path))))
(if (number? run-id)
(begin
- (d:data-curr-run-id-set! data run-id)
+ (d:data-curr-run-id-set! ddata run-id)
(dashboard:update-run-summary-tab))
(debug:print 0 "ERROR: tree-path->run-id returned non-number " run-id)))
- ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
- )))
+ ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
+ )))
(cell-lookup (make-hash-table))
(run-matrix (iup:matrix
#:expand "YES"
#:click-cb
(lambda (obj lin col status)
(let* ((toolpath (car (argv)))
(key (conc lin ":" col))
(test-id (hash-table-ref/default cell-lookup key -1))
- (cmd (conc toolpath " -test " (d:data-curr-run-id data) "," test-id "&")))
+ (cmd (conc toolpath " -test " (d:data-curr-run-id ddata) "," test-id "&")))
(system cmd)))))
(updater (lambda ()
- (let* ((runs-dat (if (d:alldat-useserver *alldat*)
- (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" #f #f #f #f)
- (db:get-runs-by-patt db (d:alldat-keys *alldat*) "%" #f #f #f #f)))
+ (let* ((runs-dat (if (d:alldat-useserver data)
+ (rmt:get-runs-by-patt (d:alldat-keys data) "%" #f #f #f #f)
+ (db:get-runs-by-patt db (d:alldat-keys data) "%" #f #f #f #f)))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
- (run-id (d:data-curr-run-id data))
+ (run-id (d:data-curr-run-id ddata))
(last-update 0) ;; fix me
- (tests-dat (let ((tdat (if run-id
- (if (d:alldat-useserver *alldat*)
- (rmt:get-tests-for-run run-id
- (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
- (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '()
- (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '()
- #f #f
- (d:alldat-hide-not-hide *alldat*)
- #f #f
- "id,testname,item_path,state,status"
- last-update) ;; get 'em all
- (db:get-tests-for-run db run-id
- (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
- (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '()
- (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '()
- #f #f
- (d:alldat-hide-not-hide *alldat*)
- #f #f
- "id,testname,item_path,state,status"
- last-update))
- '()))) ;; get 'em all
- (sort tdat (lambda (a b)
- (let* ((aval (vector-ref a 2))
- (bval (vector-ref b 2))
- (anum (string->number aval))
- (bnum (string->number bval)))
- (if (and anum bnum)
- (< anum bnum)
- (string<= aval bval)))))))
+ (tests-dat (dboard:get-tests-dat data run-id last-update))
(tests-mindat (dcommon:minimize-test-data tests-dat))
(indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell))
(row-indices (cadr indices))
(col-indices (car indices))
(max-row (if (null? row-indices) 1 (common:max (map cadr row-indices))))
(max-col (if (null? col-indices) 1 (common:max (map cadr col-indices))))
- (max-visible (max (- (d:alldat-num-tests *alldat*) 15) 3)) ;; (d:alldat-num-tests *alldat*) is proportional to the size of the window
+ (max-visible (max (- (d:alldat-num-tests data) 15) 3)) ;; (d:alldat-num-tests data) is proportional to the size of the window
(numrows 1)
(numcols 1)
(changed #f)
(runs-hash (let ((ht (make-hash-table)))
(for-each (lambda (run)
@@ -1279,31 +1289,32 @@
(record-b (hash-table-ref runs-hash b))
(time-a (db:get-value-by-header record-a runs-header "event_time"))
(time-b (db:get-value-by-header record-b runs-header "event_time")))
(< time-a time-b))))))
+ (d:alldat-filters-changed-set! data #f)
;; (iup:attribute-set! tb "VALUE" "0")
;; (iup:attribute-set! tb "NAME" "Runs")
;; Update the runs tree
(for-each (lambda (run-id)
(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
(key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key))
- (d:alldat-keys *alldat*)))
+ (d:alldat-keys data)))
(run-name (db:get-value-by-header run-record runs-header "runname"))
(col-name (conc (string-intersperse key-vals "\n") "\n" run-name))
(run-path (append key-vals (list run-name)))
(existing (tree:find-node tb run-path)))
- (if (not (hash-table-ref/default (d:data-path-run-ids data) run-path #f))
+ (if (not (hash-table-ref/default (d:data-path-run-ids ddata) run-path #f))
(begin
- (hash-table-set! (d:data-run-keys data) run-id run-path)
+ (hash-table-set! (d:data-run-keys ddata) run-id run-path)
;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*)
;; (conc rownum ":" colnum) col-name)
;; (hash-table-set! runid-to-col run-id (list colnum run-record))
;; Here we update the tests treebox and tree keys
(tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name))
userdata: (conc "run-id: " run-id))
- (hash-table-set! (d:data-path-run-ids data) run-path run-id)
+ (hash-table-set! (d:data-path-run-ids ddata) run-path run-id)
;; (set! colnum (+ colnum 1))
))))
run-ids)
(iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
(iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
@@ -1359,88 +1370,60 @@
(iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))
col-indices)
(if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))
(set! dashboard:update-run-summary-tab updater)
- (d:data-runs-tree-set! data tb)
+ (d:data-runs-tree-set! ddata tb)
(iup:split
tb
run-matrix)))
;; This is the New View tab
;;
-(define (dashboard:new-view db data)
+(define (dashboard:new-view db data ddata)
(let* ((tb (iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
#:addexpanded "NO"
#:selection-cb
(lambda (obj id state)
;; (print "obj: " obj ", id: " id ", state: " state)
(let* ((run-path (tree:node->path obj id))
- (run-id (tree-path->run-id data (cdr run-path))))
+ (run-id (tree-path->run-id ddata (cdr run-path))))
(if (number? run-id)
(begin
- (d:data-curr-run-id-set! data run-id)
- (dashboard:update-run-summary-tab))
+ (d:data-curr-run-id-set! ddata run-id)
+ (dashboard:update-new-view-tab))
(debug:print 0 "ERROR: tree-path->run-id returned non-number " run-id)))
- ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
- )))
+ ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
+ )))
(cell-lookup (make-hash-table))
(run-matrix (iup:matrix
#:expand "YES"
#:click-cb
(lambda (obj lin col status)
(let* ((toolpath (car (argv)))
(key (conc lin ":" col))
(test-id (hash-table-ref/default cell-lookup key -1))
- (cmd (conc toolpath " -test " (d:data-curr-run-id data) "," test-id "&")))
+ (cmd (conc toolpath " -test " (d:data-curr-run-id ddata) "," test-id "&")))
(system cmd)))))
(updater (lambda ()
- (let* ((runs-dat (if (d:alldat-useserver *alldat*)
- (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" #f #f #f #f)
- (db:get-runs-by-patt db (d:alldat-keys *alldat*) "%" #f #f #f #f)))
+ (let* ((runs-dat (if (d:alldat-useserver data)
+ (rmt:get-runs-by-patt (d:alldat-keys data) "%" #f #f #f #f)
+ (db:get-runs-by-patt db (d:alldat-keys data) "%" #f #f #f #f)))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
- (run-id (d:data-curr-run-id data))
+ (run-id (d:data-curr-run-id ddata))
(last-update 0) ;; fix me
- (tests-dat (let ((tdat (if run-id
- (if (d:alldat-useserver *alldat*)
- (rmt:get-tests-for-run run-id
- (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
- (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '()
- (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '()
- #f #f
- (d:alldat-hide-not-hide *alldat*)
- #f #f
- "id,testname,item_path,state,status"
- last-update) ;; get 'em all
- (db:get-tests-for-run db run-id
- (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
- (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '()
- (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '()
- #f #f
- (d:alldat-hide-not-hide *alldat*)
- #f #f
- "id,testname,item_path,state,status"
- last-update))
- '()))) ;; get 'em all
- (sort tdat (lambda (a b)
- (let* ((aval (vector-ref a 2))
- (bval (vector-ref b 2))
- (anum (string->number aval))
- (bnum (string->number bval)))
- (if (and anum bnum)
- (< anum bnum)
- (string<= aval bval)))))))
+ (tests-dat (dboard:get-tests-dat data run-id last-update))
(tests-mindat (dcommon:minimize-test-data tests-dat))
(indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell))
(row-indices (cadr indices))
(col-indices (car indices))
(max-row (if (null? row-indices) 1 (common:max (map cadr row-indices))))
(max-col (if (null? col-indices) 1 (common:max (map cadr col-indices))))
- (max-visible (max (- (d:alldat-num-tests *alldat*) 15) 3)) ;; (d:alldat-num-tests *alldat*) is proportional to the size of the window
+ (max-visible (max (- (d:alldat-num-tests data) 15) 3)) ;; (d:alldat-num-tests data) is proportional to the size of the window
(numrows 1)
(numcols 1)
(changed #f)
(runs-hash (let ((ht (make-hash-table)))
(for-each (lambda (run)
@@ -1459,25 +1442,25 @@
;; (iup:attribute-set! tb "NAME" "Runs")
;; Update the runs tree
(for-each (lambda (run-id)
(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
(key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key))
- (d:alldat-keys *alldat*)))
+ (d:alldat-keys data)))
(run-name (db:get-value-by-header run-record runs-header "runname"))
(col-name (conc (string-intersperse key-vals "\n") "\n" run-name))
(run-path (append key-vals (list run-name)))
(existing (tree:find-node tb run-path)))
- (if (not (hash-table-ref/default (d:data-path-run-ids data) run-path #f))
+ (if (not (hash-table-ref/default (d:data-path-run-ids ddata) run-path #f))
(begin
- (hash-table-set! (d:data-run-keys data) run-id run-path)
+ (hash-table-set! (d:data-run-keys ddata) run-id run-path)
;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*)
;; (conc rownum ":" colnum) col-name)
;; (hash-table-set! runid-to-col run-id (list colnum run-record))
;; Here we update the tests treebox and tree keys
(tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name))
userdata: (conc "run-id: " run-id))
- (hash-table-set! (d:data-path-run-ids data) run-path run-id)
+ (hash-table-set! (d:data-path-run-ids ddata) run-path run-id)
;; (set! colnum (+ colnum 1))
))))
run-ids)
(iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
(iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
@@ -1532,34 +1515,21 @@
(iup:attribute-set! run-matrix key name)
(iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))))
col-indices)
(if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))
- (set! dashboard:update-run-summary-tab updater)
- (d:data-runs-tree-set! data tb)
+ (set! dashboard:update-new-view-tab updater)
+ (d:data-runs-tree-set! ddata tb)
(iup:split
tb
run-matrix)))
;;======================================================================
;; R U N S
;;======================================================================
-(define (make-dashboard-buttons db nruns ntests keynames runs-sum-dat new-view-dat)
- (let* ((nkeys (length keynames))
- (runsvec (make-vector nruns))
- (header (make-vector nruns))
- (lftcol (make-vector ntests))
- (keycol (make-vector ntests))
- (controls '())
- (lftlst '())
- (hdrlst '())
- (bdylst '())
- (result '())
- (i 0))
- ;; controls (along bottom)
- (set! controls
+(define (dboard:make-controls data)
(iup:hbox
(iup:vbox
(iup:frame
#:title "filter test and items"
(iup:hbox
@@ -1588,32 +1558,32 @@
;; (iup:button "Sort -t" #:action (lambda (obj)
;; (next-sort-option)
;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0))
;; (mark-for-update)))
(iup:button "HideEmpty" #:action (lambda (obj)
- (d:alldat-hide-empty-runs-set! *alldat* (not (d:alldat-hide-empty-runs *alldat*)))
- (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-empty-runs *alldat*) "+HideE" "-HideE"))
+ (d:alldat-hide-empty-runs-set! data (not (d:alldat-hide-empty-runs data)))
+ (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-empty-runs data) "+HideE" "-HideE"))
(mark-for-update)))
(let ((hideit (iup:button "HideTests" #:action (lambda (obj)
- (d:alldat-hide-not-hide-set! *alldat* (not (d:alldat-hide-not-hide *alldat*)))
- (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-not-hide *alldat*) "HideTests" "NotHide"))
+ (d:alldat-hide-not-hide-set! data (not (d:alldat-hide-not-hide data)))
+ (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-not-hide data) "HideTests" "NotHide"))
(mark-for-update)))))
- (d:alldat-hide-not-hide-button-set! *alldat* hideit) ;; never used, can eliminate ...
+ (d:alldat-hide-not-hide-button-set! data hideit) ;; never used, can eliminate ...
hideit))
(iup:hbox
(iup:button "Quit" #:action (lambda (obj)
- ;; (if (d:alldat-dblocal *alldat*) (db:close-all (d:alldat-dblocal *alldat*)))
+ ;; (if (d:alldat-dblocal data) (db:close-all (d:alldat-dblocal data)))
(exit)))
(iup:button "Refresh" #:action (lambda (obj)
(mark-for-update)))
(iup:button "Collapse" #:action (lambda (obj)
(let ((myname (iup:attribute obj "TITLE")))
(if (equal? myname "Collapse")
(begin
(for-each (lambda (tname)
(hash-table-set! *collapsed* tname #t))
- (d:alldat-item-test-names *alldat*))
+ (d:alldat-item-test-names data))
(iup:attribute-set! obj "TITLE" "Expand"))
(begin
(for-each (lambda (tname)
(hash-table-delete! *collapsed* tname))
(hash-table-keys *collapsed*))
@@ -1626,40 +1596,55 @@
iup:hbox
(map (lambda (status)
(iup:toggle status #:action (lambda (obj val)
(mark-for-update)
(if (eq? val 1)
- (hash-table-set! (d:alldat-status-ignore-hash *alldat*) status #t)
- (hash-table-delete! (d:alldat-status-ignore-hash *alldat*) status))
+ (hash-table-set! (d:alldat-status-ignore-hash data) status #t)
+ (hash-table-delete! (d:alldat-status-ignore-hash data) status))
(set-bg-on-filter))))
(map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
(apply
iup:hbox
(map (lambda (state)
(iup:toggle state #:action (lambda (obj val)
(mark-for-update)
(if (eq? val 1)
- (hash-table-set! (d:alldat-state-ignore-hash *alldat*) state #t)
- (hash-table-delete! (d:alldat-state-ignore-hash *alldat*) state))
+ (hash-table-set! (d:alldat-state-ignore-hash data) state #t)
+ (hash-table-delete! (d:alldat-state-ignore-hash data) state))
(set-bg-on-filter))))
(map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
(iup:valuator #:valuechanged_cb (lambda (obj)
(let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
(oldmax (string->number (iup:attribute obj "MAX")))
- (maxruns (d:alldat-tot-runs *alldat*)))
- (d:alldat-start-run-offset-set! *alldat* val)
+ (maxruns (d:alldat-tot-runs data)))
+ (d:alldat-start-run-offset-set! data val)
(mark-for-update)
- (debug:print 6 "(d:alldat-start-run-offset *alldat*) " (d:alldat-start-run-offset *alldat*) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
+ (debug:print 6 "(d:alldat-start-run-offset data) " (d:alldat-start-run-offset data) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
(iup:attribute-set! obj "MAX" (* maxruns 10))))
#:expand "HORIZONTAL"
- #:max (* 10 (length (d:alldat-allruns *alldat*)))
+ #:max (* 10 (length (d:alldat-allruns data)))
#:min 0
#:step 0.01)))
- ;(iup:button "inc rows" #:action (lambda (obj)(d:alldat-num-tests-set! *alldat* (+ (d:alldat-num-tests *alldat*) 1))))
- ;(iup:button "dec rows" #:action (lambda (obj)(d:alldat-num-tests-set! *alldat* (if (> (d:alldat-num-tests *alldat*) 0)(- (d:alldat-num-tests *alldat*) 1) 0))))
- )
- )
+ ;(iup:button "inc rows" #:action (lambda (obj)(d:alldat-num-tests-set! data (+ (d:alldat-num-tests data) 1))))
+ ;(iup:button "dec rows" #:action (lambda (obj)(d:alldat-num-tests-set! data (if (> (d:alldat-num-tests data) 0)(- (d:alldat-num-tests data) 1) 0))))
+ ))
+
+(define (make-dashboard-buttons data nruns ntests keynames runs-sum-dat new-view-dat)
+ (let* ((db (d:alldat-dblocal data))
+ (nkeys (length keynames))
+ (runsvec (make-vector nruns))
+ (header (make-vector nruns))
+ (lftcol (make-vector ntests))
+ (keycol (make-vector ntests))
+ (controls '())
+ (lftlst '())
+ (hdrlst '())
+ (bdylst '())
+ (result '())
+ (i 0))
+ ;; controls (along bottom)
+ (set! controls (dboard:make-controls data))
;; create the left most column for the run key names and the test names
(set! lftlst (list (iup:hbox
(iup:label) ;; (iup:valuator)
(apply iup:vbox
@@ -1681,11 +1666,11 @@
(set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL"
(iup:valuator #:valuechanged_cb (lambda (obj)
(let ((val (string->number (iup:attribute obj "VALUE")))
(oldmax (string->number (iup:attribute obj "MAX")))
(newmax (* 10 (length *alltestnamelst*))))
- (d:alldat-please-update-set! *alldat* #t)
+ (d:alldat-please-update-set! data #t)
(d:alldat-start-test-offset-set! *alldat* (inexact->exact (round (/ val 10))))
(debug:print 6 "(d:alldat-start-test-offset *alldat*) " (d:alldat-start-test-offset *alldat*) " val: " val " newmax: " newmax " oldmax: " oldmax)
(if (< val 10)
(iup:attribute-set! obj "MAX" newmax))
))
@@ -1762,20 +1747,21 @@
(list
(iup:vbox
;; the header
(apply iup:hbox (reverse hdrlst))
(apply iup:hbox (reverse bdylst))))))
- controls))
- (data (d:data-init (make-d:data)))
+ ;; controls
+ ))
+ ;; (data (d:data-init (make-d:data)))
(tabs (iup:tabs
#:tabchangepos-cb (lambda (obj curr prev)
(d:alldat-please-update-set! *alldat* #t)
(d:alldat-curr-tab-num-set! *alldat* curr))
- (dashboard:summary db)
+ (dashboard:summary *alldat*)
runs-view
- (dashboard:one-run db runs-sum-dat)
- (dashboard:new-view db new-view-dat)
+ (dashboard:one-run db data runs-sum-dat)
+ (dashboard:new-view db data new-view-dat)
(dashboard:run-controls)
)))
;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
(iup:attribute-set! tabs "TABTITLE0" "Summary")
(iup:attribute-set! tabs "TABTITLE1" "Runs")
@@ -1782,21 +1768,23 @@
(iup:attribute-set! tabs "TABTITLE2" "Run Summary")
(iup:attribute-set! tabs "TABTITLE3" "New View")
(iup:attribute-set! tabs "TABTITLE4" "Run Control")
(iup:attribute-set! tabs "BGCOLOR" "190 190 190")
(d:alldat-hide-not-hide-tabs-set! *alldat* tabs)
- tabs)))
+ (iup:vbox
+ tabs
+ controls))))
(vector keycol lftcol header runsvec)))
(if (or (args:get-arg "-rows")
(get-environment-variable "DASHBOARDROWS" ))
(begin
(d:alldat-num-tests-set! *alldat* (string->number
(or (args:get-arg "-rows")
(get-environment-variable "DASHBOARDROWS"))))
- (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '()))
- (d:alldat-num-tests-set! *alldat* (min (max (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '()) 8) 20)))
+ (update-rundat *alldat* "%" (d:alldat-numruns *alldat*) "%/%" '()))
+ (d:alldat-num-tests-set! *alldat* (min (max (update-rundat *alldat* "%" (d:alldat-numruns *alldat*) "%/%" '()) 8) 20)))
(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")
@@ -1851,11 +1839,11 @@
(begin
(case (d:alldat-curr-tab-num *alldat*)
((0)
(if dashboard:update-summary-tab (dashboard:update-summary-tab)))
((1) ;; The runs table is active
- (update-rundat (hash-table-ref/default (d:alldat-searchpatts *alldat*) "runname" "%") (d:alldat-numruns *alldat*)
+ (update-rundat *alldat* (hash-table-ref/default (d:alldat-searchpatts *alldat*) "runname" "%") (d:alldat-numruns *alldat*)
(hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%")
;; (hash-table-ref/default (d:alldat-searchpatts *alldat*) "item-name" "%")
(let ((res '()))
(for-each (lambda (key)
(if (not (equal? key "runname"))
@@ -1865,11 +1853,11 @@
res))
(update-buttons uidat (d:alldat-numruns *alldat*) (d:alldat-num-tests *alldat*)))
((2)
(dashboard:update-run-summary-tab))
((3)
- (dashboard:update-run-summary-tab))
+ (dashboard:update-new-view-tab))
(else
(let ((updater (hash-table-ref/default (d:alldat-updaters *alldat*)
(d:alldat-curr-tab-num *alldat*) #f)))
(if updater (updater)))))
(d:alldat-please-update-set! *alldat* #f)
@@ -1884,20 +1872,22 @@
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
(define (main)
- (let ((runs-sum-dat (d:data-init (make-d:data))) ;; data for run-summary tab
- (new-view-dat (d:data-init (make-d:data))))
+ (common:exit-on-version-changed)
+ (let* ((runs-sum-dat (d:data-init (make-d:data))) ;; data for run-summary tab
+ (new-view-dat (d:data-init (make-d:data)))
+ (data *alldat*))
(cond
((args:get-arg "-run")
(let ((runid (string->number (args:get-arg "-run"))))
(if runid
(begin
(lambda (x)
(on-exit std-exit-procedure)
- (examine-run (d:alldat-dblocal *alldat*) runid)))
+ (examine-run (d:alldat-dblocal data) runid)))
(begin
(print "ERROR: runid is not a number " (args:get-arg "-run"))
(exit 1)))))
((args:get-arg "-test") ;; run-id,test-id
(let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ","))))
@@ -1912,39 +1902,39 @@
(examine-test run-id test-id)
(begin
(debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
(exit 1)))))
((args:get-arg "-guimonitor")
- (gui-monitor (d:alldat-dblocal *alldat*)))
+ (gui-monitor (d:alldat-dblocal data)))
(else
- (set! uidat (make-dashboard-buttons (d:alldat-dblocal *alldat*)
- (d:alldat-numruns *alldat*)
- (d:alldat-num-tests *alldat*)
- (d:alldat-dbkeys *alldat*)
- runs-sum-dat new-view-dat))
+ (set! uidat (make-dashboard-buttons data ;; (d:alldat-dblocal data)
+ (d:alldat-numruns data)
+ (d:alldat-num-tests data)
+ (d:alldat-dbkeys data)
+ runs-sum-dat new-view-dat))
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (x)
(let ((update-is-running #f))
- (mutex-lock! (d:alldat-update-mutex *alldat*))
- (set! update-is-running (d:alldat-updating *alldat*))
+ (mutex-lock! (d:alldat-update-mutex data))
+ (set! update-is-running (d:alldat-updating data))
(if (not update-is-running)
- (d:alldat-updating-set! *alldat* #t))
- (mutex-unlock! (d:alldat-update-mutex *alldat*))
+ (d:alldat-updating-set! data #t))
+ (mutex-unlock! (d:alldat-update-mutex data))
(if (not update-is-running)
(begin
(dashboard:run-update x)
- (mutex-lock! (d:alldat-update-mutex *alldat*))
- (d:alldat-updating-set! *alldat* #f)
- (mutex-unlock! (d:alldat-update-mutex *alldat*)))))
+ (mutex-lock! (d:alldat-update-mutex data))
+ (d:alldat-updating-set! data #f)
+ (mutex-unlock! (d:alldat-update-mutex data)))))
1))))
(let ((th1 (make-thread (lambda ()
(thread-sleep! 1)
- (d:alldat-please-update-set! *alldat* #t)
+ (d:alldat-please-update-set! data #t)
(dashboard:run-update 1)) "update buttons once"))
(th2 (make-thread iup:main-loop "Main loop")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th2))))
(main)
Index: datashare-testing/.sretrieve.config
==================================================================
--- datashare-testing/.sretrieve.config
+++ datashare-testing/.sretrieve.config
@@ -1,8 +1,8 @@
[settings]
base-dir /tmp/delme_data
allowed-users matt
allowed-chars [0-9a-zA-Z\-\.]+
-
+allowed-sub-paths [0-9a-zA-Z\-\.]+
[database]
location #{scheme (create-directory "/tmp/#{getenv USER}" #t)}
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -844,30 +844,33 @@
(begin
;; NB// must sync first to ensure deleted tests get marked as such in megatest.db
(db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb)
(db:clean-up-rundb (db:get-db fromdb run-id))
;;
- ;; Feb 18, 2016: add field last_update to tests
+ ;; Feb 18, 2016: add field last_update to tests, test_steps and test_data
;;
;; remove this some time after September 2016 (added in version v1.6031
;;
- (handle-exceptions
- exn
- (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
- (debug:print 0 "Column last_update already added to tests table")
- (db:general-sqlite-error-dump exn "alter table tests ..." #f "none"))
- (sqlite3:execute
- frundb
- "ALTER TABLE tests ADD COLUMN last_update INTEGER DEFAULT 0"))
- (sqlite3:execute
- frundb
- "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests
+ (for-each
+ (lambda (table-name)
+ (handle-exceptions
+ exn
+ (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 "Column last_update already added to " table-name " table")
+ (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none"))
+ (sqlite3:execute
+ frundb
+ (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0"))
+ (sqlite3:execute
+ frundb
+ (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name "
FOR EACH ROW
BEGIN
- UPDATE tests SET last_update=(strftime('%s','now'));
- END;")
- ))))
+ UPDATE " table-name " SET last_update=(strftime('%s','now'));
+ END;"))
+ ))
+ '("tests" "test_steps" "test_data"))))))
all-run-ids)
;; removed deleted runs
(let ((dbdir (tasks:get-task-db-path)))
(for-each (lambda (run-id)
(let ((fullname (conc dbdir "/" run-id ".db")))
@@ -1036,11 +1039,11 @@
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT,
CONSTRAINT metadat_constraint UNIQUE (var));")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);")
;; Must do this *after* running patch db !! No more.
;; cannot use db:set-var since it will deadlock, hardwire the code here
- (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" megatest-version)
+ (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature))
(debug:print-info 11 "db:initialize END")))))
;;======================================================================
;; R U N S P E C I F I C D B
;;======================================================================
@@ -1087,20 +1090,19 @@
state TEXT DEFAULT 'NOT_STARTED',
status TEXT DEFAULT 'n/a',
event_time TIMESTAMP,
comment TEXT DEFAULT '',
logfile TEXT DEFAULT '',
+ last_update INTEGER DEFAULT (strftime('%s','now')),
CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));")
- ;; (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data
- ;; (id INTEGER PRIMARY KEY,
- ;; reviewed TIMESTAMP DEFAULT (strftime('%s','now')),
- ;; iterated TEXT DEFAULT '',
- ;; avg_runtime REAL DEFAULT -1,
- ;; avg_disk REAL DEFAULT -1,
- ;; tags TEXT DEFAULT '',
- ;; jobgroup TEXT DEFAULT 'default',
- ;; CONSTRAINT test_meta_constraint UNIQUE (testname));")
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);")
+ (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps
+ FOR EACH ROW
+ BEGIN
+ UPDATE test_steps SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY,
test_id INTEGER,
category TEXT DEFAULT '',
variable TEXT,
value REAL,
@@ -1108,13 +1110,19 @@
tol REAL,
units TEXT,
comment TEXT DEFAULT '',
status TEXT DEFAULT 'n/a',
type TEXT DEFAULT '',
+ last_update INTEGER DEFAULT (strftime('%s','now')),
CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));")
- ;; Why use FULL here? This data is not that critical
- ;; (sqlite3:execute db "PRAGMA synchronous = FULL;")
+ (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);")
+ (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data
+ FOR EACH ROW
+ BEGIN
+ UPDATE test_data SET last_update=(strftime('%s','now'))
+ WHERE id=old.id;
+ END;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat (
id INTEGER PRIMARY KEY,
test_id INTEGER,
update_time TIMESTAMP,
cpuload INTEGER DEFAULT -1,
@@ -1583,35 +1591,36 @@
;;======================================================================
;; returns number if string->number is successful, string otherwise
;; also updates *global-delta*
;;
-;; Operates on megatestdb
-;;
(define (db:get-var dbstruct var)
(let* ((res #f)
(dbdat (db:get-db dbstruct #f))
(db (db:dbdat-get-db dbdat)))
- ;; (db:delay-if-busy dbdat)
(sqlite3:for-each-row
(lambda (val)
(set! res val))
db
"SELECT val FROM metadat WHERE var=?;" var)
;; convert to number if can
(if (string? res)
(let ((valnum (string->number res)))
(if valnum (set! res valnum))))
- ;; scale by 10, average with current value.
+ res))
+
+;; This was part of db:get-var. It was used to estimate the load on
+;; the database files.
+;;
+;; scale by 10, average with current value.
;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
;; (if throttle throttle 0.01)))
;; 2))
;; (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit
;; (begin
;; (debug:print-info 4 "launch throttle factor=" *global-delta*)
;; (set! *last-global-delta-printed* *global-delta*)))
- res))
(define (db:set-var dbstruct var val)
(let* ((dbdat (db:get-db dbstruct #f))
(db (db:dbdat-get-db dbdat)))
(sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)))
@@ -2813,21 +2822,78 @@
;; Now rollup the counts to the central megatest.db
(db:general-call dbdat 'pass-fail-counts (list pass-count fail-count test-id))
;; if the test is not FAIL then set status based on the fail and pass counts.
(db:general-call dbdat 'test_data-pf-rollup (list test-id test-id test-id test-id))))
-;; NOT USED!?
+;; each section is a rule except "final" which is the final result
+;;
+;; [rule-5]
+;; operator in
+;; section LogFileBody
+;; desc Output voltage
+;; status OK
+;; expected 1.9
+;; measured 1.8
+;; type +/-
+;; tolerance 0.1
+;; pass 1
+;; fail 0
+;;
+;; [final]
+;; exit-code 6
+;; exit-status SKIP
+;; message If flagged we are asking for this to exit with code 6
;;
+;; recorded in steps table:
+;; category: stepname
+;; variable: rule-N
+;; value: measured
+;; expected: expected
+;; tol: tolerance
+;; units: -
+;; comment: desc or message
+;; status: status
+;; type: type
+;;
+(define (db:logpro-dat->csv dat stepname)
+ (let ((res '()))
+ (for-each
+ (lambda (entry-name)
+ (let* ((value (or (configf:lookup dat entry-name "measured") "n/a"))
+ (expected (or (configf:lookup dat entry-name "expected") "n/a"))
+ (tolerance (or (configf:lookup dat entry-name "tolerance") "n/a"))
+ (comment (or (configf:lookup dat entry-name "comment")
+ (configf:lookup dat entry-name "desc") "n/a"))
+ (status (or (configf:lookup dat entry-name "status") "n/a"))
+ (type (or (configf:lookup dat entry-name "expected") "n/a")))
+ (set! res (append
+ res
+ (list (list stepname entry-name expected tolerance comment status type))))
+ ))
+ (hash-table-keys dat))
+ res))
+
+;; $MT_MEGATEST -load-test-data << EOF
+;; foo,bar, 1.2, 1.9, >
+;; foo,rab, 1.0e9, 10e9, 1e9
+;; foo,bla, 1.2, 1.9, <
+;; foo,bal, 1.2, 1.2, < , ,Check for overload
+;; foo,alb, 1.2, 1.2, <= , Amps,This is the high power circuit test
+;; foo,abl, 1.2, 1.3, 0.1
+;; foo,bra, 1.2, pass, silly stuff
+;; faz,bar, 10, 8mA, , ,"this is a comment"
+;; EOF
+
(define (db:csv->test-data dbstruct run-id test-id csvdata)
(debug:print 4 "test-id " test-id ", csvdata: " csvdata)
(let* ((dbdat (db:get-db dbstruct run-id))
(db (db:dbdat-get-db dbdat))
(csvlist (csv->list (make-csv-reader
(open-input-string csvdata)
'((strip-leading-whitespace? #t)
(strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata)))
- (for-each
+ (for-each
(lambda (csvrow)
(let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
(category (list-ref padded-row 0))
(variable (list-ref padded-row 1))
(value (any->number-if-possible (list-ref padded-row 2)))
ADDED docs/waiton-analysis.gnumeric
Index: docs/waiton-analysis.gnumeric
==================================================================
--- /dev/null
+++ docs/waiton-analysis.gnumeric
cannot compute difference between binary files
ADDED inteldate.scm
Index: inteldate.scm
==================================================================
--- /dev/null
+++ inteldate.scm
@@ -0,0 +1,180 @@
+(use srfi-19)
+(use test)
+(use format)
+(use regex)
+(declare (unit inteldate))
+;; utility procedures to convert among
+;; different ways to express date (inteldate, seconds since epoch, isodate)
+;;
+;; samples:
+;; isodate -> "2016-01-01"
+;; inteldate -> "16ww01.5"
+;; seconds -> 1451631600
+
+;; procedures provided:
+;; ====================
+;; seconds->isodate
+;; seconds->inteldate
+;;
+;; isodate->seconds
+;; isodate->inteldate
+;;
+;; inteldate->seconds
+;; inteldate->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
+;; intel year consists of numbered weeks starting from week 1
+;; week 1 is the week containing jan 1 of the year
+;; days of week are numbered starting from 0 on sunday
+;; intel year does not match calendar year in workweek 1
+;; before jan1.
+(define (seconds->inteldate-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 (seconds->inteldate seconds)
+ (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
+ (fold conc ""
+ (map (lambda (x) (->string pad-char)) (iota padlen)))))
+ (conc padding unpadded-str)))
+ (define (zeropad num width)
+ (string-leftpad num width #:0))
+
+ (let-values (((intelyear intelweek day-of-week-num)
+ (seconds->inteldate-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->inteldate isodate)
+ (seconds->inteldate
+ (isodate->seconds isodate)))
+
+(define (inteldate->seconds inteldate)
+ (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" inteldate)))
+ (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 (inteldate->isodate inteldate)
+ (seconds->isodate (inteldate->seconds inteldate)))
+
+(define (inteldate-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 ((inteldate (car test-pair))
+ (isodate (cdr test-pair)))
+ (test
+ (conc "(isodate->inteldate "isodate ") => "inteldate)
+ inteldate
+ (isodate->inteldate isodate))
+
+ (test
+ (conc "(inteldate->isodate "inteldate ") => "isodate)
+ isodate
+ (inteldate->isodate inteldate))))
+ test-table))))
+
+;(inteldate-tests)
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -11,11 +11,11 @@
;;======================================================================
;; launch a task - this runs on the originating host, tests themselves
;;
;;======================================================================
-(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables)
+(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv)
(use defstruct)
(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))
@@ -472,11 +472,19 @@
(let loop ((ezstep (car ezstepslst))
(tal (cdr ezstepslst))
(prevstep #f))
;; check exit-info (vector-ref exit-info 1)
(if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
- (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig)))
+ (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig))
+ (stepname (car ezstep)))
+ ;; if logpro-used read in the stepname.dat file
+ (if (and logpro-used (file-exists? (conc stepname ".dat")))
+ (let* ((dat (read-config (conc stepname ".dat") #f #f))
+ (csvr (db:logpro-dat->csv dat stepname))
+ (csvt (let-values (( (fmt-cell fmt-record fmt-csv) (make-format ",")))
+ (fmt-csv (map list->csv-record csvr)))))
+ (rmt:csv->test-data run-id test-id csvt)))
(if (steprun-good? logpro-used (launch:einf-exit-code exit-info))
(if (not (null? tal))
(loop (car tal) (cdr tal) stepname))
(debug:print 4 "WARNING: step " (car ezstep) " failed. Stopping")))
(debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))))))))
@@ -768,12 +776,17 @@
given-toppath: toppath
pathenvvar: "MT_RUN_AREA_HOME"))
(first-rundat (let ((toppath (if toppath
toppath
(car first-pass))))
- (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t
- sections: sections))))
+ (read-config ;; (conc toppath "/runconfigs.config")
+ (conc (if (string? toppath)
+ toppath
+ (get-environment-variable "MT_RUN_AREA_HOME"))
+ "/runconfigs.config")
+ *runconfigdat* #t
+ sections: sections))))
(set! *runconfigdat* first-rundat)
(if first-pass ;;
(begin
(set! *configdat* (car first-pass))
(set! *configinfo* first-pass)
Index: megatest-version.scm
==================================================================
--- megatest-version.scm
+++ megatest-version.scm
@@ -1,7 +1,7 @@
;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1,1101 ... 1.99,2.00..
(declare (unit megatest-version))
-(define megatest-version 1.6031)
+(define megatest-version 1.6101)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -454,11 +454,12 @@
(let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt"))))
(debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
(hash-table-set! args:arg-hash "-testpatt" newval)
(hash-table-delete! args:arg-hash "-itempatt")))
-
+(if (args:get-arg "-runtests")
+ (debug:print 0 "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead"))
(on-exit std-exit-procedure)
;;======================================================================
;; Misc general calls
@@ -479,33 +480,10 @@
" => "))
(common:get-disks *configdat*))
"\n"))
(set! *didsomething* #t)))
-(define (make-sparse-array)
- (let ((a (make-sparse-vector)))
- (sparse-vector-set! a 0 (make-sparse-vector))
- a))
-
-(define (sparse-array? a)
- (and (sparse-vector? a)
- (sparse-vector? (sparse-vector-ref a 0))))
-
-(define (sparse-array-ref a x y)
- (let ((row (sparse-vector-ref a x)))
- (if row
- (sparse-vector-ref row y)
- #f)))
-
-(define (sparse-array-set! a x y val)
- (let ((row (sparse-vector-ref a x)))
- (if row
- (sparse-vector-set! row y val)
- (let ((new-row (make-sparse-vector)))
- (sparse-vector-set! a x new-row)
- (sparse-vector-set! new-row y val)))))
-
;; csv processing record
(define (make-refdb:csv)
(vector
(make-sparse-array)
(make-hash-table)
@@ -660,18 +638,10 @@
(if (args:get-arg "-ping")
(let* ((run-id (string->number (args:get-arg "-run-id")))
(host:port (args:get-arg "-ping")))
(server:ping run-id host:port)))
-;; (set! *did-something* #t)
-;; (begin
-;; (print ((rpc:procedure 'testing (car host-port)(cadr host-port))))
-;; (case (server:get-transport)
-;; ((http)(http:ping run-id host-port))
-;; ((rpc) (rpc:procedure 'server:login (car host-port)(cadr host-port));; *toppath*)) ;; (rpc-transport:ping run-id (car host-port)(cadr host-port)))
-;; (else (debug:print 0 "ERROR: No transport set")(exit)))))
-
;;======================================================================
;; Capture, save and manipulate environments
;;======================================================================
;; NOTE: Keep these above the section where the server or client code is setup
@@ -708,12 +678,10 @@
(env:print added removed changed)))
(env:print added removed changed))
(env:close-database db)
(set! *didsomething* #t))
(debug:print 0 "ERROR: Parameter to -envdelta should be new=star-end")))))
-
-
;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;; we start the server if not running else start the client thread
;;======================================================================
@@ -947,19 +915,22 @@
(if (not (car *configinfo*))
(begin
(debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found")
(exit 1))
;; put test parameters into convenient variables
- (runs:operate-on action
- target
- (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
- (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
- state: (common:args-get-state)
- status: (common:args-get-status)
- new-state-status: (args:get-arg "-set-state-status")))
+ (begin
+ ;; check for correct version, exit with message if not correct
+ (common:exit-on-version-changed)
+ (runs:operate-on action
+ target
+ (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
+ (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
+ state: (common:args-get-state)
+ status: (common:args-get-status)
+ new-state-status: (args:get-arg "-set-state-status"))))
(set! *didsomething* #t)))))
-
+
(if (args:get-arg "-remove-runs")
(general-run-call
"-remove-runs"
"remove runs"
(lambda (target runname keys keyvals)
@@ -1830,17 +1801,19 @@
'dejunk
;; 'adj-testids
;; 'old2new
'new2old
)
+ (if (common:version-changed?)
+ (common:set-last-run-version))
(set! *didsomething* #t)))
(if (args:get-arg "-mark-incompletes")
(begin
(if (not (launch:setup))
(begin
- (debug:print 0 "Failed to setup, exiting") b
+ (debug:print 0 "Failed to setup, exiting")
(exit 1)))
(open-run-close db:find-and-mark-incomplete #f)
(set! *didsomething* #t)))
;;======================================================================
Index: sretrieve.scm
==================================================================
--- sretrieve.scm
+++ sretrieve.scm
@@ -54,11 +54,11 @@
(define sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]]
ls : list contents of target area
get <relversion> : retrieve data for release <version>
-m \"message\" : why retrieved?
-
+ cp <relative path> : copy file to current directory
log : get listing of recent downloads
Part of the Megatest tool suite.
Learn more at http://www.kiatoa.com/fossils/megatest
@@ -108,10 +108,11 @@
;; (set-busy-handler! db (busy-timeout 10000)) ; 10 second timeout
;; ...))
;; Create the sqlite db
(define (sretrieve:db-do configdat proc)
+
(let ((path (configf:lookup configdat "database" "location")))
(if (not path)
(begin
(debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!")
(exit 1)))
@@ -125,20 +126,21 @@
exn
(begin
(debug:print 2 "ERROR: problem accessing db " dbpath
((condition-property-accessor 'exn 'message) exn))
(exit 1))
+ ;;(debug:print 0 "calling proc " proc "db path " dbpath )
(call-with-database
dbpath
(lambda (db)
- ;; (debug:print 0 "calling proc " proc " on db " db)
+ ;;(debug:print 0 "calling proc " proc " on db " db)
(set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout
(if (not dbexists)(sretrieve:initialize-db db))
(proc db)))))
(debug:print 0 "ERROR: invalid path for storing database: " path))))
-;; copy in file to dest, validation is done BEFORE calling this
+;; copy in directory to dest, validation is done BEFORE calling this
;;
(define (sretrieve:get configdat retriever version comment)
(let* ((base-dir (configf:lookup configdat "settings" "base-dir"))
(datadir (conc base-dir "/" version)))
(if (or (not base-dir)
@@ -156,16 +158,97 @@
configdat
(lambda (db)
(sretrieve:register-action db "get" retriever datadir comment)))
(sretrieve:do-as-calling-user
(lambda ()
- (change-directory datadir)
- (let ((files (filter (lambda (x)
+ (if (directory? datadir)
+ (begin
+ (change-directory datadir)
+ (let ((files (filter (lambda (x)
(not (member x '("." ".."))))
(glob "*" ".*"))))
- (print "files: " files)
- (process-execute "/bin/tar" (append (list "chfv" "-") files)))))))
+ (print "files: " files)
+ (process-execute "/bin/tar" (append (append (list "chfv" "-") files) (list "--ignore-failed-read")))))
+ (begin
+ (let* ((parent-dir (pathname-directory datadir) )
+ (filename (conc(pathname-file datadir) "." (pathname-extension datadir))))
+ (change-directory parent-dir)
+ (process-execute "/bin/tar" (list "chfv" "-" filename))
+ )))
+))
+))
+
+
+;; copy in file to dest, validation is done BEFORE calling this
+;;
+(define (sretrieve:cp configdat retriever file comment)
+ (let* ((base-dir (configf:lookup configdat "settings" "base-dir"))
+ (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))
+ (datadir (conc base-dir "/" file))
+ (filename (conc(pathname-file datadir) "." (pathname-extension datadir))))
+ (if (or (not base-dir)
+ (not (file-exists? base-dir)))
+ (begin
+ (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
+ (exit 1)))
+ (print datadir)
+ (if (not (file-exists? datadir))
+ (begin
+ (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." )
+ (exit 1)))
+ (if (directory? datadir)
+ (begin
+ (debug:print 0 "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." )
+ (exit 1)))
+ (if(not (string-match (regexp allowed-sub-paths) file))
+ (begin
+ (debug:print 0 "ERROR: Access denied to file (" file ")!! " )
+ (exit 1)))
+
+ (sretrieve:db-do
+ configdat
+ (lambda (db)
+ (sretrieve:register-action db "cp" retriever datadir comment)))
+ (sretrieve:do-as-calling-user
+ ;; (debug:print 0 "ph: "(pathname-directory datadir) "!! " )
+ (change-directory (pathname-directory datadir))
+ ;;(debug:print 0 "ph: /bin/tar" (list "chfv" "-" filename) )
+ (process-execute "/bin/tar" (list "chfv" "-" filename)))
+ ))
+
+;; ls in file to dest, validation is done BEFORE calling this
+;;
+(define (sretrieve:ls configdat retriever file comment)
+ (let* ((base-dir (configf:lookup configdat "settings" "base-dir"))
+ (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))
+ (datadir (conc base-dir "/" file))
+ (filename (conc(pathname-file datadir) "." (pathname-extension datadir))))
+ (if (or (not base-dir)
+ (not (file-exists? base-dir)))
+ (begin
+ (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found")
+ (exit 1)))
+ (print datadir)
+ (if (not (file-exists? datadir))
+ (begin
+ (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." )
+ (exit 1)))
+ (if(not (string-match (regexp allowed-sub-paths) file))
+ (begin
+ (debug:print 0 "ERROR: Access denied to file (" file ")!! " )
+ (exit 1)))
+
+ (sretrieve:do-as-calling-user
+ (lambda ()
+ ;;(change-directory datadir)
+ ;; (debug:print 0 "/usr/bin/find" (list datadir "-ls" "|" "grep" "-E" "'"allowed-file-patt"'"))
+ ;; (status (with-input-from-pipe "find " datadir " -ls | grep -E '" allowed-file-patt "'" (lambda () (read-line))))
+ ;; (debug:print 0 status)
+ (process-execute "/bin/ls" (list "-ls" "-lrt" datadir ))
+ ))))
+
+
;;(filter (lambda (x)
;; (not (member x '("." ".."))))
;; (glob "*" ".*"))))))))
@@ -376,10 +459,11 @@
res)))
(define (sretrieve:process-action configdat action . args)
(let* ((base-dir (configf:lookup configdat "settings" "base-dir"))
(user (current-user-name))
+ (allowed-sub-paths (configf:lookup configdat "settings" "allowed-sub-paths"))
(allowed-users (string-split
(or (configf:lookup configdat "settings" "allowed-users")
"")))
(default-area (configf:lookup configdat "settings" "default-area"))) ;; otherwise known as the package
@@ -409,10 +493,33 @@
(exe-dir (configf:lookup configdat "exe-info" "exe-dir")))
;; (relconfig (sretrieve:load-packages configdat exe-dir package-type)))
(debug:print 0 "retrieving " version " of " package-type " as tar data on stdout")
(sretrieve:get configdat user version msg)))
+ ((cp)
+ (if (< (length args) 1)
+ (begin
+ (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", "))
+ (exit 1)))
+ (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0))
+ (file (car args))
+ (msg (or (args:get-arg "-m") "")) )
+
+ (debug:print 0 "copinging " file " to current directory " )
+ (sretrieve:cp configdat user file msg)))
+ ((ls)
+ (if (< (length args) 1)
+ (begin
+ (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", "))
+ (exit 1)))
+ (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0))
+ (dir (car args))
+ (msg (or (args:get-arg "-m") "")) )
+
+ (debug:print 0 "Listing files in " )
+ (sretrieve:ls configdat user dir msg)))
+
(else (debug:print 0 "Unrecognised command " action)))))
;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION!
;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.sretrieverc")))
;; (if (file-exists? debugcontrolf)
@@ -442,11 +549,11 @@
(if base-dir
(begin
(print "Files in " base-dir)
(sretrieve:do-as-calling-user
(lambda ()
- (process-execute "/bin/ls" (list base-dir)))))
+ (process-execute "/bin/ls" (list "-lrt" base-dir)))))
(print "ERROR: No base dir specified!"))))
((log)
(sretrieve:db-do configdat (lambda (db)
(print "Logs : ")
(query (for-each-row
Index: tests.scm
==================================================================
--- tests.scm
+++ tests.scm
@@ -803,11 +803,11 @@
(read-config test-configf #f system-allowed
environ-patt: (if system-allowed
"pre-launch-env-vars"
#f))
#f)))
- (if cache-file (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
+ (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
(if tcfg (hash-table-set! *testconfigs* test-name tcfg))
(if (and testexists
cache-file
(file-write-access? cache-path))
(let ((tpath (conc cache-path "/.testconfig")))
ADDED utils/Makefile.git.installall
Index: utils/Makefile.git.installall
==================================================================
--- /dev/null
+++ utils/Makefile.git.installall
@@ -0,0 +1,334 @@
+
+# Copyright 2013-2015 Matthew Welland.
+#
+# This program is made available under the GNU GPL version 2.0 or
+# greater. See the accompanying file COPYING for details.
+#
+# This program is distributed WITHOUT ANY WARRANTY; without even the
+# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+# PURPOSE.
+
+help :
+ @echo You may need to do the following setup first:
+ @echo
+ @echo sudo apt-get install libreadline-dev
+ @echo sudo apt-get install libwebkitgtk-dev libfreetype6-dev libx11-dev libxpm-dev libxmu-dev \
+ libxft-dev libgtk2.0-dev libgl1-mesa-dev libglu1-mesa-dev libpangox-1.0-dev bison \
+ libwebkitgtk-3.0-dev
+ @echo -- nb// adding monodevelop gets more packages of which some might be needed...
+ @echo sudo apt-get install libmotif3
+ @echo
+ @echo Set up your PATH, setting it in the Makefile does not work as expected
+ @echo export PATH=$(PREFIX)/bin:\$$PATH
+ @echo
+ @echo For IUP set IUPBRANCH, currently $(IUPBRANCH)
+ @echo set IUPCONFIG, currently $(IUPCONFIG) - look in https://www.kiatoa.com/fossils/iuplib for .inc files
+ @echo You are using PREFIX=$(PREFIX)
+ @echo You are using PRODCHICKEN=$(PRODCHICKEN)
+ @echo You are using PROXY="$(PROXY)"
+ @echo If needed set PROXY to host.dom:port
+ @echo http_proxy=$(http_proxy)
+ @echo
+ @echo To make all do: make all
+ @echo make minimal: make nogui
+ @echo
+ @echo Note: If compiling on amd64 do CSC_OPTIONS=\'-C "-fPIC"\' make all IUPCONFIG=
+
+FPIC=-C "-fPIC"
+
+# Put the installation here
+ifeq ($(PREFIX),)
+PREFIX=$(PWD)/target
+endif
+ifeq ($(PRODCHICKEN),)
+PRODCHICKEN=$(PREFIX)/prod-chicken/
+endif
+# Set this on the command line of your make call if needed: make PROXY=host.com:1234
+PROXY=
+
+# http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz
+# http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz
+# Select version of chicken, sqlite3 etc
+CHICKEN_VERSION=4.10.1
+SQLITE3_VERSION=3090200
+# http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz
+# http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz
+# Override IUPBRANCH to use other than trunk
+IUPBRANCH=trunk
+IUPCONFIG=ubuntu-15.04.inc
+# iup-3.15
+
+# Eggs to install (straightforward ones)
+EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
+ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
+ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
+ spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \
+ srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables hahn linenoise \
+ crypt parley
+
+#
+# Derived variables
+#
+
+ifeq ($(PROXY),)
+PROX:=
+else
+http_proxy:=http://$(PROXY)
+PROX:=-proxy $(PROXY)
+endif
+
+BUILDHOME=$(PWD)
+PATH:=$(PREFIX)/bin:$(PATH)
+LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH)
+LD_LIBRARY_PATH=$(LIBPATH)
+CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install
+CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/7
+
+VPATH=$(CHICKEN_EGG_DIR):$(PWD)/eggflags
+
+vpath %.so $(CHICKEN_EGG_DIR)
+vpath %.flag eggflags
+
+EGGSOFILES=$(addprefix $(CHICKEN_EGG_DIR)/,$(addsuffix .so,$(EGGS)))
+EGGFLAGS=$(addprefix eggflags/,$(addsuffix .flag,$(EGGS)))
+
+# Stuff needed for IUP
+ISARCHX86_64=$(shell uname -a | grep x86_64)
+ifeq ($(ISARCHX86_64),)
+ARCHSIZE=
+else
+ARCHSIZE=64_
+endif
+
+CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g')
+CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\""
+# CSC_OPTIONS=-I $(PREFIX)/include -L $(CSCLIBS)
+
+nogui : base mutils
+
+#all : nogui libiup $(PREFIX)/lib/sqlite3.so
+all : nogui libiup
+
+base : chkn eggs
+
+# stuff needed for Kiatoa and Megatest from matts miscellaneous stash
+# NOTE TO SELF: eggifying these would be great...
+mutils : base logprobin $(PREFIX)/bin/hs \
+ $(PREFIX)/lib/chicken/7/mutils.so \
+ $(PREFIX)/lib/chicken/7/dbi.so \
+ $(PREFIX)/lib/chicken/7/stml.so \
+ $(PREFIX)/lib/chicken/7/margs.so
+
+chkn : $(CHICKEN_INSTALL)
+
+eggs : $(EGGSOFILES)
+
+# libiup : $(PREFIX)/lib/libavcall.a
+libiup : $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so
+
+logprobin : $(PREFIX)/bin/logpro
+
+$(PREFIX)/bin/logpro : $(CHICKEN_EGG_DIR)/regex-literals.so
+ $(CHICKEN_INSTALL) logpro
+
+# Silly rule to make installing eggs more makeish, I don't understand why I need the basename
+$(CHICKEN_EGG_DIR)/%.so : eggflags/%.flag
+ $(CHICKEN_INSTALL) $(PROX) -keep-installed $(shell basename $*)
+
+$(EGGFLAGS) : # $(CHICKEN_INSTALL)
+ mkdir -p eggflags
+ touch $(EGGFLAGS)
+
+# some setup stuff
+#
+$(PREFIX)/setup-chicken4x.sh : $(EGGFLAGS)
+ mkdir -p $(PREFIX)
+ (echo 'export PATH=$(PREFIX)/bin:$$PATH' > $(PREFIX)/setup-chicken4x.sh)
+ (echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.sh)
+
+$(PREFIX)/setup-chicken4x.csh : $(EGGFLAGS)
+ mkdir -p $(PREFIX)
+ (echo "setenv PATH $(PREFIX):'$$'PATH" > $(PREFIX)/setup-chicken4x.csh)
+ (echo "setenv LD_LIBRARY_PATH $(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.csh)
+
+chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz
+ #tar xf chicken-$(CHICKEN_VERSION).tar.gz
+ #ln -sf chicken-$(CHICKEN_VERSION) chicken-core
+ echo "Hello from chicken"
+
+chicken-4.9.0rc1.tar.gz :
+ wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz
+
+chicken-4.9.0.1.tar.gz :
+ wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz
+
+chicken-4.10.0rc1.tar.gz :
+ wget http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz
+
+chicken-4.10.0.tar.gz :
+ wget http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz
+
+chicken-4.10.1.tar.gz :
+ fossil clone https://www.kiatoa.com/fossils/chicken-core chicken-scheme.fossil
+ mkdir -p chicken-core
+ cd chicken-core; pwd
+ cd chicken-core; fossil open ../chicken-scheme.fossil
+ cd chicken-core; fossil up 337f5be
+# wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz
+
+# git clone git://code.call-cc.org/chicken-core
+# git clone http://code.call-cc.org/git/chicken-core.git
+
+$(PRODCHICKEN)/bin/chicken :
+ wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz
+ tar -xzvf chicken-4.10.1.tar.gz
+ cd chicken-4.10.1/; make PLATFORM=linux PREFIX=$(PRODCHICKEN)
+ cd chicken-4.10.1/; make PLATFORM=linux PREFIX=$(PRODCHICKEN) install
+ rm -rfv chicken-4.10.1/
+
+$(CHICKEN_INSTALL) : chicken-core/chicken.scm $(PREFIX)/setup-chicken4x.sh $(PREFIX)/setup-chicken4x.csh $(PRODCHICKEN)/bin/chicken
+ cd chicken-core; LD_LIBRARY_PATH=$(PRODCHICKEN) make PLATFORM=linux CHICKEN=$(PRODCHICKEN)/bin/chicken PREFIX=$(PREFIX)
+ cd chicken-core; LD_LIBRARY_PATH=$(PRODCHICKEN) make PLATFORM=linux CHICKEN=$(PRODCHICKEN)/bin/chicken PREFIX=$(PREFIX) install
+
+#======================================================================
+# S Q L I T E 3
+#======================================================================
+# https://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz
+sqlite-autoconf-$(SQLITE3_VERSION).tar.gz :
+ wget http://www.sqlite.org/2015/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
+
+sqlite-autoconf-$(SQLITE3_VERSION)/config.log : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
+ tar xf sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
+
+$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION)/config.log
+ cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install
+
+$(CHICKEN_EGG_DIR)/sqlite3.so : $(PREFIX)/bin/sqlite3
+ CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3
+
+#======================================================================
+# N A N O M S G
+#======================================================================
+
+# https://github.com/nanomsg/nanomsg/releases/download/0.6-beta/nanomsg-0.6-beta.tar.gz
+# https://github.com/nanomsg/nanomsg/releases/download/0.8-beta/nanomsg-0.8-beta.tar.gz
+
+nanomsg-0.6-beta.tar.gz :
+ wget http://download.nanomsg.org/nanomsg-0.6-beta.tar.gz
+
+nanomsg-0.6-beta/COPYING : nanomsg-0.6-beta.tar.gz
+ tar xf nanomsg-0.6-beta.tar.gz
+
+$(PREFIX)/bin/nanocat : nanomsg-0.6-beta/COPYING
+ cd nanomsg-0.6-beta;./configure --prefix=$(PREFIX);make;make install
+
+$(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat
+ CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg
+
+# LD_LIBRARY_PATH=/mfs/pkgs/chicken/4.10.0-amd64/lib CSC_OPTIONS="-I/mfs/pkgs/chicken/4.10.0-amd64/include -L/mfs/pkgs/chicken/4.10.0-amd64/lib -C \"-fPIC\"" /mfs/pkgs/chicken/4.10.0-amd64/bin/chicken-install -D no-library-checks nanomsg
+
+#======================================================================
+# M A T T S U T I L S
+#======================================================================
+
+# opensrc
+
+opensrc.fossil :
+ fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil
+
+opensrc/histstore/histstore.scm : opensrc.fossil
+ mkdir -p opensrc
+ cd opensrc;if [ -e .fslckout ];then fossil update; else fossil open ../opensrc.fossil; fi
+
+$(PREFIX)/lib/chicken/7/mutils.so : opensrc/histstore/histstore.scm
+ cd opensrc/mutils;chicken-install
+
+$(PREFIX)/lib/chicken/7/dbi.so : opensrc/dbi/dbi.scm
+ cd opensrc/dbi; sed -i -e 's/.*postgres.*/;;commented out/g' dbi.scm; chicken-install
+
+$(PREFIX)/lib/chicken/7/margs.so : opensrc/margs/margs.scm
+ cd opensrc/margs;chicken-install
+
+opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(CHICKEN_EGG_DIR)/sqlite3.so
+ cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs
+
+$(PREFIX)/bin/hs : opensrc/histstore/hs
+ cp -f opensrc/histstore/hs $(PREFIX)/bin/hs
+
+# stml
+stml.fossil :
+ fossil clone http://www.kiatoa.com/fossils/stml stml.fossil
+
+# open touches the .fossil :(
+stml/requirements.scm.template : stml.fossil
+ mkdir -p stml
+ cd stml;if [ -e .fslckout ];then fossil update; else fossil open ../stml.fossil;fi
+
+stml/requirements.scm : stml/requirements.scm.template
+ cp stml/install.cfg.template stml/install.cfg
+ cp stml/requirements.scm.template stml/requirements.scm
+
+$(PREFIX)/lib/chicken/7/stml.so : stml/requirements.scm
+ cd stml; sed -i -e "s#.*TARGDIR.*#TARGDIR=$(PREFIX)/bin#g" install.cfg
+ cd stml;CSC_OPTIONS='-C "-fPIC"' make
+
+#======================================================================
+# F F C A L L (Used by IUP)
+#======================================================================
+
+ffcall.fossil :
+ fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil
+
+ffcall/README : ffcall.fossil
+ mkdir -p ffcall
+ cd ffcall && if [ -e README ];then fossil update; else fossil open ../ffcall.fossil; fi
+
+# NOTE: This worked fine *without* the enable-shared
+#
+$(PREFIX)/lib/libavcall.a : ffcall/README
+ cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make CC="gcc -fPIC" && make install
+
+#======================================================================
+# I U P
+#======================================================================
+
+iuplib.fossil :
+ #fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil
+ touch iuplib.fossil
+iup/installall.sh : iuplib.fossil $(PREFIX)/lib/libiup.so
+ mkdir -p iup
+ pwd
+ wget -c --no-check-certificate http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download
+ wget -c --no-check-certificate http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download
+ wget -c --no-check-certificate http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download
+ #wget -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download
+ tar -xzvf cd-5.9_Linux26g4_64_lib.tar.gz -C iup/
+ tar -xzvf im-3.10_Linux26g4_64_lib.tar.gz -C iup/
+ tar -xzvf iup-3.17_Linux26g4_64_lib.tar.gz -C iup/
+ mkdir -p $(PREFIX)/include/ $(PREFIX)/lib/
+ cp iup/include/* $(PREFIX)/include/
+ cp iup/*.so $(PREFIX)/lib/
+ cp iup/*.a $(PREFIX)/lib/
+
+# cd iup && if [ -e makeall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi
+
+#iup/alldone : iup/makeall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so
+# cd iup && ./makeall.sh $(IUPCONFIG)
+
+$(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh
+# cd iup && ./makeall.sh $(IUPCONFIG)
+
+# $(PREFIX)/lib/libiup.so : iup/iup/alldone
+# touch -c $(PREFIX)/lib/libiup.so
+
+$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a
+ LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup
+
+# -feature disable-iup-web
+
+$(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a
+ CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw
+
+
+clean :
+ rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION)
Index: utils/Makefile.installall
==================================================================
--- utils/Makefile.installall
+++ utils/Makefile.installall
@@ -44,11 +44,12 @@
PROXY=
# http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz
# http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz
# Select version of chicken, sqlite3 etc
-CHICKEN_VERSION=4.10.0
+# CHICKEN_VERSION=4.10.0
+CHICKEN_VERSION=4.11.0rc2
SQLITE3_VERSION=3090200
# http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz
# http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz
# Override IUPBRANCH to use other than trunk
IUPBRANCH=trunk
@@ -59,11 +60,11 @@
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \
srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables hahn linenoise \
- crypt
+ crypt parley
#
# Derived variables
#
@@ -77,11 +78,11 @@
BUILDHOME=$(PWD)
PATH:=$(PREFIX)/bin:$(PATH)
LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH)
LD_LIBRARY_PATH=$(LIBPATH)
CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install
-CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/7
+CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/8
VPATH=$(CHICKEN_EGG_DIR):$(PWD)/eggflags
vpath %.so $(CHICKEN_EGG_DIR)
vpath %.flag eggflags
@@ -101,21 +102,22 @@
CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\""
# CSC_OPTIONS=-I $(PREFIX)/include -L $(CSCLIBS)
nogui : base mutils
-all : nogui libiup $(PREFIX)/lib/sqlite3.so
+#all : nogui libiup $(PREFIX)/lib/sqlite3.so
+all : nogui libiup
base : chkn eggs
# stuff needed for Kiatoa and Megatest from matts miscellaneous stash
# NOTE TO SELF: eggifying these would be great...
mutils : base logprobin $(PREFIX)/bin/hs \
- $(PREFIX)/lib/chicken/7/mutils.so \
- $(PREFIX)/lib/chicken/7/dbi.so \
- $(PREFIX)/lib/chicken/7/stml.so \
- $(PREFIX)/lib/chicken/7/margs.so
+ $(PREFIX)/lib/chicken/8/mutils.so \
+ $(PREFIX)/lib/chicken/8/dbi.so \
+ $(PREFIX)/lib/chicken/8/stml.so \
+ $(PREFIX)/lib/chicken/8/margs.so
chkn : $(CHICKEN_INSTALL)
eggs : $(EGGSOFILES)
@@ -145,14 +147,15 @@
$(PREFIX)/setup-chicken4x.csh : $(EGGFLAGS)
mkdir -p $(PREFIX)
(echo "setenv PATH $(PREFIX):'$$'PATH" > $(PREFIX)/setup-chicken4x.csh)
(echo "setenv LD_LIBRARY_PATH $(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.csh)
+# NOTE: the touch chicken-core/chicken.scm compensates for the time stamp from the tar file
chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz
tar xf chicken-$(CHICKEN_VERSION).tar.gz
ln -sf chicken-$(CHICKEN_VERSION) chicken-core
-
+ if [[ -e chicken-core/chicken.scm ]];then touch chicken-core/chicken.scm;fi
chicken-4.9.0rc1.tar.gz :
wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz
chicken-4.9.0.1.tar.gz :
@@ -162,10 +165,13 @@
wget http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz
chicken-4.10.0.tar.gz :
wget http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz
+chicken-4.11.0rc2.tar.gz :
+ wget http://code.call-cc.org/dev-snapshots/2016/04/28/chicken-4.11.0rc2.tar.gz
+
# git clone git://code.call-cc.org/chicken-core
# git clone http://code.call-cc.org/git/chicken-core.git
$(CHICKEN_INSTALL) : chicken-core/chicken.scm $(PREFIX)/setup-chicken4x.sh $(PREFIX)/setup-chicken4x.csh
cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX)
@@ -219,17 +225,17 @@
opensrc/histstore/histstore.scm : opensrc.fossil
mkdir -p opensrc
cd opensrc;if [ -e .fslckout ];then fossil update; else fossil open ../opensrc.fossil; fi
-$(PREFIX)/lib/chicken/7/mutils.so : opensrc/histstore/histstore.scm
+$(PREFIX)/lib/chicken/8/mutils.so : opensrc/histstore/histstore.scm
cd opensrc/mutils;chicken-install
-$(PREFIX)/lib/chicken/7/dbi.so : opensrc/dbi/dbi.scm
+$(PREFIX)/lib/chicken/8/dbi.so : opensrc/dbi/dbi.scm
cd opensrc/dbi;chicken-install
-$(PREFIX)/lib/chicken/7/margs.so : opensrc/margs/margs.scm
+$(PREFIX)/lib/chicken/8/margs.so : opensrc/margs/margs.scm
cd opensrc/margs;chicken-install
opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(CHICKEN_EGG_DIR)/sqlite3.so
cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs
@@ -247,11 +253,11 @@
stml/requirements.scm : stml/requirements.scm.template
cp stml/install.cfg.template stml/install.cfg
cp stml/requirements.scm.template stml/requirements.scm
-$(PREFIX)/lib/chicken/7/stml.so : stml/requirements.scm
+$(PREFIX)/lib/chicken/8/stml.so : stml/requirements.scm
cd stml;make
#======================================================================
# F F C A L L (Used by IUP)
#======================================================================
@@ -271,31 +277,44 @@
#======================================================================
# I U P
#======================================================================
iuplib.fossil :
- fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil
-
-iup/installall.sh : iuplib.fossil
+ #fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil
+ touch iuplib.fossil
+iup/installall.sh : iuplib.fossil $(PREFIX)/lib/libiup.so
mkdir -p iup
- cd iup && if [ -e makeall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi
+ pwd
+ #wget -c http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download
+ #wget -c http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download
+ #wget -c http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download
+ #wget -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download
+ tar -xzvf cd-5.9_Linux26g4_64_lib.tar.gz -C iup/
+ tar -xzvf im-3.10_Linux26g4_64_lib.tar.gz -C iup/
+ tar -xzvf iup-3.17_Linux26g4_64_lib.tar.gz -C iup/
+ mkdir -p $(PREFIX)/include/ $(PREFIX)/lib/
+ cp iup/include/* $(PREFIX)/include/
+ cp iup/*.so $(PREFIX)/lib/
+ cp iup/*.a $(PREFIX)/lib/
+
+# cd iup && if [ -e makeall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi
iup/alldone : iup/makeall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so
- cd iup && ./makeall.sh $(IUPCONFIG)
+# cd iup && ./makeall.sh $(IUPCONFIG)
$(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh iup/alldone
- cd iup && ./makeall.sh $(IUPCONFIG)
+# cd iup && ./makeall.sh $(IUPCONFIG)
# $(PREFIX)/lib/libiup.so : iup/iup/alldone
# touch -c $(PREFIX)/lib/libiup.so
$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a
- LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks iup
+ LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup
# -feature disable-iup-web
$(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a
CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw
clean :
rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION)
ADDED utils/Makefile.latest.installall
Index: utils/Makefile.latest.installall
==================================================================
--- /dev/null
+++ utils/Makefile.latest.installall
@@ -0,0 +1,320 @@
+
+# Copyright 2013-2015 Matthew Welland.
+#
+# This program is made available under the GNU GPL version 2.0 or
+# greater. See the accompanying file COPYING for details.
+#
+# This program is distributed WITHOUT ANY WARRANTY; without even the
+# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+# PURPOSE.
+
+help :
+ @echo You may need to do the following setup first:
+ @echo
+ @echo sudo apt-get install libreadline-dev
+ @echo sudo apt-get install libwebkitgtk-dev libfreetype6-dev libx11-dev libxpm-dev libxmu-dev \
+ libxft-dev libgtk2.0-dev libgl1-mesa-dev libglu1-mesa-dev libpangox-1.0-dev bison \
+ libwebkitgtk-3.0-dev
+ @echo -- nb// adding monodevelop gets more packages of which some might be needed...
+ @echo sudo apt-get install libmotif3
+ @echo
+ @echo Set up your PATH, setting it in the Makefile does not work as expected
+ @echo export PATH=$(PREFIX)/bin:\$$PATH
+ @echo
+ @echo For IUP set IUPBRANCH, currently $(IUPBRANCH)
+ @echo set IUPCONFIG, currently $(IUPCONFIG) - look in https://www.kiatoa.com/fossils/iuplib for .inc files
+ @echo You are using PREFIX=$(PREFIX)
+ @echo You are using PROXY="$(PROXY)"
+ @echo If needed set PROXY to host.dom:port
+ @echo http_proxy=$(http_proxy)
+ @echo
+ @echo To make all do: make all
+ @echo make minimal: make nogui
+ @echo
+ @echo Note: If compiling on amd64 do CSC_OPTIONS=\'-C "-fPIC"\' make all IUPCONFIG=
+
+FPIC=-C "-fPIC"
+
+# Put the installation here
+ifeq ($(PREFIX),)
+PREFIX=$(PWD)/target
+endif
+
+# Set this on the command line of your make call if needed: make PROXY=host.com:1234
+PROXY=
+
+# http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz
+# http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz
+# Select version of chicken, sqlite3 etc
+CHICKEN_VERSION=4.10.1
+SQLITE3_VERSION=3090200
+# http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz
+# http://www.sqlite.org/2015/sqlite-autoconf-3081101.tar.gz
+# Override IUPBRANCH to use other than trunk
+IUPBRANCH=trunk
+IUPCONFIG=ubuntu-15.04.inc
+# iup-3.15
+
+# Eggs to install (straightforward ones)
+EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
+ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
+ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
+ spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \
+ srfi-19 refdb ini-file sparse-vectors z3 call-with-environment-variables hahn linenoise \
+ crypt parley zlib shell udp loops foof-loop lazy-seq ansi-escape-sequences rfc3339 slice \
+ slice-utf8 scsh-process functional-lists srfi-101 uuid-lib filepath srfi-78 srfi-42 sexp-diff \
+ low-level-macros symbol-utils expand-full chicken-doc irc silex lalr lalr-driver sha1 refdb
+
+#
+# Derived variables
+#
+
+ifeq ($(PROXY),)
+PROX:=
+else
+http_proxy:=http://$(PROXY)
+PROX:=-proxy $(PROXY)
+endif
+
+BUILDHOME=$(PWD)
+PATH:=$(PREFIX)/bin:$(PATH)
+LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH)
+LD_LIBRARY_PATH=$(LIBPATH)
+CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install
+CHICKEN_EGG_DIR=$(PREFIX)/lib/chicken/7
+
+VPATH=$(CHICKEN_EGG_DIR):$(PWD)/eggflags
+
+vpath %.so $(CHICKEN_EGG_DIR)
+vpath %.flag eggflags
+
+EGGSOFILES=$(addprefix $(CHICKEN_EGG_DIR)/,$(addsuffix .so,$(EGGS)))
+EGGFLAGS=$(addprefix eggflags/,$(addsuffix .flag,$(EGGS)))
+
+# Stuff needed for IUP
+ISARCHX86_64=$(shell uname -a | grep x86_64)
+ifeq ($(ISARCHX86_64),)
+ARCHSIZE=
+else
+ARCHSIZE=64_
+endif
+
+CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g')
+CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS) -C \"-fPIC\""
+# CSC_OPTIONS=-I $(PREFIX)/include -L $(CSCLIBS)
+
+nogui : base mutils
+
+#all : nogui libiup $(PREFIX)/lib/sqlite3.so
+all : nogui libiup
+
+base : chkn eggs
+
+# stuff needed for Kiatoa and Megatest from matts miscellaneous stash
+# NOTE TO SELF: eggifying these would be great...
+mutils : base logprobin $(PREFIX)/bin/hs \
+ $(PREFIX)/lib/chicken/7/mutils.so \
+ $(PREFIX)/lib/chicken/7/dbi.so \
+ $(PREFIX)/lib/chicken/7/stml.so \
+ $(PREFIX)/lib/chicken/7/margs.so
+
+chkn : $(CHICKEN_INSTALL)
+
+eggs : $(EGGSOFILES)
+
+# libiup : $(PREFIX)/lib/libavcall.a
+libiup : $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so
+
+logprobin : $(PREFIX)/bin/logpro
+
+$(PREFIX)/bin/logpro : $(CHICKEN_EGG_DIR)/regex-literals.so
+ $(CHICKEN_INSTALL) logpro
+
+# Silly rule to make installing eggs more makeish, I don't understand why I need the basename
+$(CHICKEN_EGG_DIR)/%.so : eggflags/%.flag
+ $(CHICKEN_INSTALL) $(PROX) -keep-installed $(shell basename $*)
+
+$(EGGFLAGS) : # $(CHICKEN_INSTALL)
+ mkdir -p eggflags
+ touch $(EGGFLAGS)
+
+# some setup stuff
+#
+$(PREFIX)/setup-chicken4x.sh : $(EGGFLAGS)
+ mkdir -p $(PREFIX)
+ (echo 'export PATH=$(PREFIX)/bin:$$PATH' > $(PREFIX)/setup-chicken4x.sh)
+ (echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.sh)
+
+$(PREFIX)/setup-chicken4x.csh : $(EGGFLAGS)
+ mkdir -p $(PREFIX)
+ (echo "setenv PATH $(PREFIX):'$$'PATH" > $(PREFIX)/setup-chicken4x.csh)
+ (echo "setenv LD_LIBRARY_PATH $(LD_LIBRARY_PATH)" >> $(PREFIX)/setup-chicken4x.csh)
+
+chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz
+ tar xf chicken-$(CHICKEN_VERSION).tar.gz
+ ln -sf chicken-$(CHICKEN_VERSION) chicken-core
+
+
+chicken-4.9.0rc1.tar.gz :
+ wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz
+
+chicken-4.9.0.1.tar.gz :
+ wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz
+
+chicken-4.10.0rc1.tar.gz :
+ wget http://code.call-cc.org/dev-snapshots/2015/06/07/chicken-4.10.0rc1.tar.gz
+
+chicken-4.10.0.tar.gz :
+ wget http://code.call-cc.org/releases/4.10.0/chicken-4.10.0.tar.gz
+
+chicken-4.10.1.tar.gz :
+ wget http://code.call-cc.org/dev-snapshots/2015/08/29/chicken-4.10.1.tar.gz
+
+# git clone git://code.call-cc.org/chicken-core
+# git clone http://code.call-cc.org/git/chicken-core.git
+
+$(CHICKEN_INSTALL) : chicken-core/chicken.scm $(PREFIX)/setup-chicken4x.sh $(PREFIX)/setup-chicken4x.csh
+ cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX)
+ cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) install
+
+#======================================================================
+# S Q L I T E 3
+#======================================================================
+# https://www.sqlite.org/2015/sqlite-autoconf-3090200.tar.gz
+sqlite-autoconf-$(SQLITE3_VERSION).tar.gz :
+ wget http://www.sqlite.org/2015/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
+
+sqlite-autoconf-$(SQLITE3_VERSION)/config.log : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
+ tar xf sqlite-autoconf-$(SQLITE3_VERSION).tar.gz
+
+$(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION)/config.log
+ cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install
+
+$(CHICKEN_EGG_DIR)/sqlite3.so : $(PREFIX)/bin/sqlite3
+ CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3
+
+#======================================================================
+# N A N O M S G
+#======================================================================
+
+# https://github.com/nanomsg/nanomsg/releases/download/0.6-beta/nanomsg-0.6-beta.tar.gz
+# https://github.com/nanomsg/nanomsg/releases/download/0.8-beta/nanomsg-0.8-beta.tar.gz
+
+nanomsg-0.6-beta.tar.gz :
+ wget http://download.nanomsg.org/nanomsg-0.6-beta.tar.gz
+
+nanomsg-0.6-beta/COPYING : nanomsg-0.6-beta.tar.gz
+ tar xf nanomsg-0.6-beta.tar.gz
+
+$(PREFIX)/bin/nanocat : nanomsg-0.6-beta/COPYING
+ cd nanomsg-0.6-beta;./configure --prefix=$(PREFIX);make;make install
+
+$(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat
+ CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg
+
+# LD_LIBRARY_PATH=/mfs/pkgs/chicken/4.10.0-amd64/lib CSC_OPTIONS="-I/mfs/pkgs/chicken/4.10.0-amd64/include -L/mfs/pkgs/chicken/4.10.0-amd64/lib -C \"-fPIC\"" /mfs/pkgs/chicken/4.10.0-amd64/bin/chicken-install -D no-library-checks nanomsg
+
+#======================================================================
+# M A T T S U T I L S
+#======================================================================
+
+# opensrc
+
+opensrc.fossil :
+ fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil
+
+opensrc/histstore/histstore.scm : opensrc.fossil
+ mkdir -p opensrc
+ cd opensrc;if [ -e .fslckout ];then fossil update; else fossil open ../opensrc.fossil; fi
+
+$(PREFIX)/lib/chicken/7/mutils.so : opensrc/histstore/histstore.scm
+ cd opensrc/mutils;chicken-install
+
+$(PREFIX)/lib/chicken/7/dbi.so : opensrc/dbi/dbi.scm
+ cd opensrc/dbi;chicken-install
+
+$(PREFIX)/lib/chicken/7/margs.so : opensrc/margs/margs.scm
+ cd opensrc/margs;chicken-install
+
+opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(CHICKEN_EGG_DIR)/sqlite3.so
+ cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs
+
+$(PREFIX)/bin/hs : opensrc/histstore/hs
+ cp -f opensrc/histstore/hs $(PREFIX)/bin/hs
+
+# stml
+stml.fossil :
+ fossil clone http://www.kiatoa.com/fossils/stml stml.fossil
+
+# open touches the .fossil :(
+stml/requirements.scm.template : stml.fossil
+ mkdir -p stml
+ cd stml;if [ -e .fslckout ];then fossil update; else fossil open ../stml.fossil;fi
+
+stml/requirements.scm : stml/requirements.scm.template
+ cp stml/install.cfg.template stml/install.cfg
+ cp stml/requirements.scm.template stml/requirements.scm
+
+$(PREFIX)/lib/chicken/7/stml.so : stml/requirements.scm
+ cd stml;make
+
+#======================================================================
+# F F C A L L (Used by IUP)
+#======================================================================
+
+ffcall.fossil :
+ fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil
+
+ffcall/README : ffcall.fossil
+ mkdir -p ffcall
+ cd ffcall && if [ -e README ];then fossil update; else fossil open ../ffcall.fossil; fi
+
+# NOTE: This worked fine *without* the enable-shared
+#
+$(PREFIX)/lib/libavcall.a : ffcall/README
+ cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make CC="gcc -fPIC" && make install
+
+#======================================================================
+# I U P
+#======================================================================
+
+iuplib.fossil :
+ #fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil
+ touch iuplib.fossil
+iup/installall.sh : iuplib.fossil $(PREFIX)/lib/libiup.so
+ mkdir -p iup
+ pwd
+ #wget -c http://sourceforge.net/projects/canvasdraw/files/5.9/Linux%20Libraries/cd-5.9_Linux26g4_64_lib.tar.gz/download
+ #wget -c http://sourceforge.net/projects/iup/files/3.17/Linux%20Libraries/iup-3.17_Linux26g4_64_lib.tar.gz/download
+ #wget -c http://sourceforge.net/projects/imtoolkit/files/3.10/Linux%20Libraries/im-3.10_Linux26g4_64_lib.tar.gz/download
+ #wget -c http://sourceforge.net/projects/luabinaries/files/5.3.2/Linux%20Libraries/lua-5.3.2_Linux26g4_64_lib.tar.gz/download
+ tar -xzvf cd-5.9_Linux26g4_64_lib.tar.gz -C iup/
+ tar -xzvf im-3.10_Linux26g4_64_lib.tar.gz -C iup/
+ tar -xzvf iup-3.17_Linux26g4_64_lib.tar.gz -C iup/
+ mkdir -p $(PREFIX)/include/ $(PREFIX)/lib/
+ cp iup/include/* $(PREFIX)/include/
+ cp iup/*.so $(PREFIX)/lib/
+ cp iup/*.a $(PREFIX)/lib/
+
+# cd iup && if [ -e makeall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi
+
+#iup/alldone : iup/makeall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so
+# cd iup && ./makeall.sh $(IUPCONFIG)
+
+$(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh
+# cd iup && ./makeall.sh $(IUPCONFIG)
+
+# $(PREFIX)/lib/libiup.so : iup/iup/alldone
+# touch -c $(PREFIX)/lib/libiup.so
+
+$(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a
+ LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup
+
+# -feature disable-iup-web
+
+$(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so $(PREFIX)/lib/libavcall.a
+ CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw
+
+
+clean :
+ rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION)