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"))) @@ -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 (run_id, testname, item_path);") + (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)))))))) 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,10 +1801,12 @@ '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)) 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 : retrieve data for release -m \"message\" : why retrieved? - + cp : 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)