Changes In Branch v1.61 Through [bdfd79da2e] Excluding Merge-Ins
This is equivalent to a diff from 96a1f6b9af to bdfd79da2e
2016-05-10
| ||
18:12 | Cosmetic change to test_data table check-in: 4cda400543 user: mrwellan tags: v1.61 | |
17:44 | Corrected ordering of data in test_data storage of logpro rule results. check-in: bdfd79da2e user: mrwellan tags: v1.61 | |
13:36 | Extended support for exit info to non-ezsteps check-in: 50b13e991f user: mrwellan tags: v1.61 | |
2016-04-28
| ||
09:05 | Cherry pick from b5393fd63f: Missed change - need to conc on params for disk space call check-in: eefe466a08 user: mrwellan tags: v1.6013, v1.61 | |
09:05 | Cherry pick from e5dfeacf59: Updated documentation on disk checks Closed-Leaf check-in: 96a1f6b9af user: mrwellan tags: rebase-envprocessing | |
09:03 | Cherry pick from 608b7270a0: Added check for disk space to runs and improved disk space check to allow for end-user scripts (e.g. check quotas etc.). check-in: 09abbe5d7b user: mrwellan tags: rebase-envprocessing | |
Modified Makefile from [4047b294e4] to [d0842bab0c].
︙ | ︙ | |||
162 163 164 165 166 167 168 | mkdir -p ext-tests cd ext-tests;fossil open --nested $(MTQA_FOSSIL) $(MTQA_FOSSIL) : fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL) clean : | | | 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 | mkdir -p ext-tests cd ext-tests;fossil open --nested $(MTQA_FOSSIL) $(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 megatest-fossil-hash.* # Deploy section (not complete yet) # $(DEPLOYHELPERS) : utils/mt_* $(INSTALL) $< $@ chmod a+X $@ |
︙ | ︙ |
Modified api.scm from [a58bc2d4d7] to [d17ed0b31f].
︙ | ︙ | |||
45 46 47 48 49 50 51 52 53 54 55 56 57 58 | get-num-runs get-all-run-ids get-prev-run-ids get-run-ids-matching-target get-runs-by-patt get-steps-data get-steps-for-test login testmeta-get-record have-incompletes? synchash-get )) (define api:write-queries | > | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | get-num-runs get-all-run-ids get-prev-run-ids get-run-ids-matching-target get-runs-by-patt get-steps-data get-steps-for-test read-test-data login testmeta-get-record have-incompletes? synchash-get )) (define api:write-queries |
︙ | ︙ | |||
224 225 226 227 228 229 230 231 232 233 234 235 236 237 | ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) ((get-var) (apply db:get-var dbstruct params)) ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) ;; MISC ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) (run-id (cadr params)) (realparams (cddr params))) (db:with-db dbstruct run-id #t ;; these are all for modifying the db | > > > | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 | ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) ((get-var) (apply db:get-var dbstruct params)) ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) ;; TEST DATA ((read-test-data) (apply db:read-test-data dbstruct params)) ;; MISC ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) (run-id (cadr params)) (realparams (cddr params))) (db:with-db dbstruct run-id #t ;; these are all for modifying the db |
︙ | ︙ |
Modified common.scm from [f17c224b46] to [81ad0c3e87].
︙ | ︙ | |||
127 128 129 130 131 132 133 134 135 136 137 138 139 140 | (set! *env-vars-by-run-id* (make-hash-table)) (set! *test-id-cache* (make-hash-table))) ;; Generic string database (define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) ;; Generic path database (define *fdb* #f) ;;====================================================================== ;; L O C K E R S A N D B L O C K E R S ;;====================================================================== ;; block further accesses to databases. Call this before shutting db down (define (common:db-block-further-queries) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 | (set! *env-vars-by-run-id* (make-hash-table)) (set! *test-id-cache* (make-hash-table))) ;; 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 ;;====================================================================== ;; block further accesses to databases. Call this before shutting db down (define (common:db-block-further-queries) |
︙ | ︙ | |||
332 333 334 335 336 337 338 | (set! *time-to-exit* #t) (debug:print 0 "ERROR: Received signal " signum " exiting promptly") ;; (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) | | | 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 | (set! *time-to-exit* #t) (debug:print 0 "ERROR: Received signal " signum " exiting promptly") ;; (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 NO, do NOT handle ^Z! ;;====================================================================== ;; M I S C U T I L S ;;====================================================================== ;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 (define (common:hms-string->seconds tstr) |
︙ | ︙ | |||
360 361 362 363 364 365 366 | ((m) 60) ((h) (* 60 60)) ((d) (* 24 60 60)) (else 0)))))))))) parts) time-secs)) | < < < | 419 420 421 422 423 424 425 426 427 428 429 430 431 432 | ((m) 60) ((h) (* 60 60)) ((d) (* 24 60 60)) (else 0)))))))))) parts) time-secs)) ;; one-of args defined (define (args-defined? . param) (let ((res #f)) (for-each (lambda (arg) (if (args:get-arg arg)(set! res #t))) param) |
︙ | ︙ | |||
523 524 525 526 527 528 529 | (loop (max hed max-val) (car tal) (cdr tal)) (max hed max-val)))) ;;====================================================================== | | | 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 | (loop (max hed max-val) (car tal) (cdr tal)) (max hed max-val)))) ;;====================================================================== ;; 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) ) ;; ;; => ;; |
︙ | ︙ | |||
566 567 568 569 570 571 572 | new-rownames new-colnames (if (> curr-rownum rownum) curr-rownum rownum) (if (> curr-colnum colnum) curr-colnum colnum) )))))) ;;====================================================================== | | | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 | new-rownames new-colnames (if (> curr-rownum rownum) curr-rownum rownum) (if (> curr-colnum colnum) curr-colnum colnum) )))))) ;;====================================================================== ;; 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) dir (conc (current-directory) "/" dir)))) |
︙ | ︙ | |||
671 672 673 674 675 676 677 | ;; given path get free space, allows override in [setup] ;; 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 | | | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 | ;; given path get free space, allows override in [setup] ;; 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 (conc (configf:lookup *configdat* "setup" "free-space-script") " " path) (lambda () (let ((res (read-line))) (if (string? res) (string->number res))))) (get-unix-df path))) (define (get-unix-df path) |
︙ | ︙ | |||
836 837 838 839 840 841 842 | (hash-table-for-each vars (lambda (var val) (setenv var val))) vars)) ;;====================================================================== | | | 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 | (hash-table-for-each vars (lambda (var val) (setenv var val))) vars)) ;;====================================================================== ;; 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)) (sec (- secs (* hrs 3600)(* min 60)))) (conc (if (> hrs 0)(conc hrs "hr ") "") |
︙ | ︙ | |||
879 880 881 882 883 884 885 | ((1 2 3) 1) ((4 5 6) 2) ((7 8 9) 3) ((10 11 12) 4) (else #f))) ;;====================================================================== | | | 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 | ((1 2 3) 1) ((4 5 6) 2) ((7 8 9) 3) ((10 11 12) 4) (else #f))) ;;====================================================================== ;; C O L O R S ;;====================================================================== (define (common:name->iup-color name) (case (string->symbol (string-downcase name)) ((red) "223 33 49") ((grey) "192 192 192") ((orange) "255 172 13") |
︙ | ︙ |
Modified dashboard-tests.scm from [72a3228ade] to [bb11619ab4].
︙ | ︙ | |||
439 440 441 442 443 444 445 | ;; These next two are intentional bad values to ensure errors if they should not ;; get filled in properly. (logfile "/this/dir/better/not/exist") (rundir (if testdat (db:test-get-rundir testdat) logfile)) ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found | | | 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 | ;; These next two are intentional bad values to ensure errors if they should not ;; get filled in properly. (logfile "/this/dir/better/not/exist") (rundir (if testdat (db:test-get-rundir testdat) logfile)) ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found (teststeps (if testdat (tests:get-compressed-steps run-id test-id) '())) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) ;; (tests:get-testconfig testdat testname 'return-procs)) (testmeta (if testdat (let ((tm (rmt:testmeta-get-record testname))) (if tm tm (make-db:testmeta))) (make-db:testmeta))) |
︙ | ︙ | |||
515 516 517 518 519 520 521 | exn (debug:print-info 0 "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn)) (rmt:get-test-info-by-id run-id test-id ))))) ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) | | | 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 | exn (debug:print-info 0 "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn)) (rmt:get-test-info-by-id run-id test-id ))))) ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) (set! teststeps (tests:get-compressed-steps run-id test-id)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir ;; (filedb:get-path *fdb* (db:test-get-rundir testdat)) ;; ) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) ;; I don't see why this was implemented this way. Please comment it ... |
︙ | ︙ | |||
609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 | (run-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -target " keystring " -runname " runname " -run -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) )))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -v")))) (clean-run-execute (lambda (x) (let ((cmd (conc "megatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) ";megatest -target " keystring " -runname " runname " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) ))) (common:without-vars (conc (dtests:get-pre-command) cmd (dtests:get-post-command)) "MT_.*")))) (remove-test (lambda (x) | > > | 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 | (run-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -target " keystring " -runname " runname " -run -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -clean-cache" )))) (remove-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -v")))) (clean-run-execute (lambda (x) (let ((cmd (conc "megatest -remove-runs -target " keystring " -runname " runname " -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) ";megatest -target " keystring " -runname " runname " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) " -clean-cache" ))) (common:without-vars (conc (dtests:get-pre-command) cmd (dtests:get-post-command)) "MT_.*")))) (remove-test (lambda (x) |
︙ | ︙ | |||
689 690 691 692 693 694 695 | (let ((tabs (iup:tabs ;; Replace here with matrix (let ((steps-matrix (iup:matrix #:font "Courier New, -8" #:expand "YES" #:scrollbar "YES" | | | | | 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 | (let ((tabs (iup:tabs ;; Replace here with matrix (let ((steps-matrix (iup:matrix #:font "Courier New, -8" #:expand "YES" #:scrollbar "YES" #:numcol 7 #:numlin 100 #:numcol-visible 7 #:numlin-visible 5 #:click-cb (lambda (obj lin col status) ;; (if (equal? col 6) (let* ((mtrx-rc (conc lin ":" 6)) (fname (iup:attribute obj mtrx-rc))) ;; col)))) (if (eq? col 6) (view-a-log fname) |
︙ | ︙ | |||
716 717 718 719 720 721 722 723 724 725 726 727 728 729 | (iup:attribute-set! steps-matrix "0:2" "Start") (iup:attribute-set! steps-matrix "0:3" "End") (iup:attribute-set! steps-matrix "WIDTH3" "50") (iup:attribute-set! steps-matrix "0:4" "Status") (iup:attribute-set! steps-matrix "WIDTH4" "50") (iup:attribute-set! steps-matrix "0:5" "Duration") (iup:attribute-set! steps-matrix "0:6" "Log File") (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) (dcommon:populate-steps teststeps steps-matrix)))) (hash-table-set! widgets "StepsMatrix" proc) | > | 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 | (iup:attribute-set! steps-matrix "0:2" "Start") (iup:attribute-set! steps-matrix "0:3" "End") (iup:attribute-set! steps-matrix "WIDTH3" "50") (iup:attribute-set! steps-matrix "0:4" "Status") (iup:attribute-set! steps-matrix "WIDTH4" "50") (iup:attribute-set! steps-matrix "0:5" "Duration") (iup:attribute-set! steps-matrix "0:6" "Log File") (iup:attribute-set! steps-matrix "0:7" "Comment") (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) (dcommon:populate-steps teststeps steps-matrix)))) (hash-table-set! widgets "StepsMatrix" proc) |
︙ | ︙ |
Modified dashboard.scm from [078fb7a126] to [8bdc63f27d].
︙ | ︙ | |||
39 40 41 42 43 44 45 | (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "megatest-fossil-hash.scm") (define help (conc | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | (include "common_records.scm") (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 version " megatest-version " license GPL, Copyright (C) Matt Welland 2012-2016 Usage: dashboard [options] -h : this help -server host:port : connect to host:port instead of db access -test run-id,test-id : control test identified by testid |
︙ | ︙ | |||
70 71 72 73 74 75 76 | (list "-h" "-use-server" "-guimonitor" "-main" "-v" "-q" "-use-local" | | | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | (list "-h" "-use-server" "-guimonitor" "-main" "-v" "-q" "-use-local" ) args:arg-hash 0)) (if (args:get-arg "-h") (begin (print help) (exit))) |
︙ | ︙ | |||
95 96 97 98 99 100 101 102 103 104 105 106 107 108 | allruns-by-id buttondat curr-tab-num dbdir dbfpath dbkeys dblocal header hide-empty-runs hide-not-hide ;; toggle for hide/not hide hide-not-hide-button hide-not-hide-tabs item-test-names keys | > | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | allruns-by-id buttondat 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 item-test-names keys |
︙ | ︙ | |||
117 118 119 120 121 122 123 | state-ignore-hash status-ignore-hash tot-runs update-mutex updaters updating useserver | | | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 | state-ignore-hash status-ignore-hash tot-runs update-mutex updaters updating useserver ) (define *alldat* (make-d:alldat header: #f allruns: '() allruns-by-id: (make-hash-table) buttondat: (make-hash-table) searchpatts: (make-hash-table) |
︙ | ︙ | |||
142 143 144 145 146 147 148 | state-ignore-hash: (make-hash-table) hide-empty-runs: #f hide-not-hide: #t hide-not-hide-button: #f hide-not-hide-tabs: #f curr-tab-num: 0 updaters: (make-hash-table) | < | < < < < < | < < < < < < < < < < < < < < < < < < | 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 | state-ignore-hash: (make-hash-table) hide-empty-runs: #f 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 )) ;; data for runs, tests etc ;; (defstruct d:rundat ;; new system runs-index ;; target/runname => colnum tests-index ;; testname/itempath => rownum matrix-dat ;; vector of vectors rows/cols |
︙ | ︙ | |||
326 327 328 329 330 331 332 | (define (colors-similar? color1 color2) (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)))) | | | | | | < < < < < < < < < | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | < < < < < | < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 | (define (colors-similar? color1 color2) (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 (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)) (eventtime2 (db:test-get-event_time test2)) (same-name (equal? test-name1 test-name2)) (test1-top (equal? item-path1 "")) (test2-top (equal? item-path2 "")) (test1-older (> eventtime1 eventtime2)) (same-time (equal? eventtime1 eventtime2))) (if same-name (if same-time (string>? item-path1 item-path2) test1-older) (if same-time (string>? test-name1 test-name2) test1-older)))) ;; 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)) (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)))) (vector-set! prev-dat 3 (- (current-seconds) 2)) ;; go back two seconds in time to ensure all changes are captured. ;; (debug:print 0 "(dboard:get-tests-for-run-duplicate: filters-changed=" (d:alldat-filters-changed data) " last-update=" last-update " got " (length tmptests) " 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 data) (rmt:get-key-vals run-id) (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 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 data) run-id dstruct) (set! result (cons dstruct result)))))) 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 (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)) (if (hash-table-ref/default *collapsed* basetestname #f) (begin ;(iup:attribute-set! btn "FGCOLOR" "0 0 0") (hash-table-delete! *collapsed* basetestname)) (begin ;(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 "(")) (res (vector "" ""))) (vector-set! res 0 (car splst)) |
︙ | ︙ | |||
477 478 479 480 481 482 483 | (vlst (run-item-name->vectors newlst)) (vlst2 (bubble-up vlst priority: bubble-type))) (map (lambda (x) (if (equal? (vector-ref x 1) "") (vector-ref x 0) (conc (vector-ref x 0) "(" (vector-ref x 1) ")"))) vlst2))) | | | 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 | (vlst (run-item-name->vectors newlst)) (vlst2 (bubble-up vlst priority: bubble-type))) (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)) (maxn (- numcols 1)) (allvals (make-vector numcols ""))) |
︙ | ︙ | |||
562 563 564 565 566 567 568 | (let loop ((hed (car tnames)) (tal (cdr tnames)) (res '())) (let ((newres (append res (hash-table-ref tests hed)))) (if (null? tal) newres (loop (car tal)(cdr tal) newres)))))))) | | | 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 | (let loop ((hed (car tnames)) (tal (cdr tnames)) (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)) (tableheader (dboard:uidat-get-header uidat)) (table (dboard:uidat-get-runsvec uidat)) |
︙ | ︙ | |||
677 678 679 680 681 682 683 | (status-changed (not (null? (hash-table-keys (d:alldat-status-ignore-hash *alldat*)))))) (iup:attribute-set! (d:alldat-hide-not-hide-tabs *alldat*) "BGCOLOR" (if (or search-changed state-changed status-changed) "190 180 190" "190 190 190" | | > > | 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 | (status-changed (not (null? (hash-table-keys (d:alldat-status-ignore-hash *alldat*)))))) (iup:attribute-set! (d:alldat-hide-not-hide-tabs *alldat*) "BGCOLOR" (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)) ;;====================================================================== ;; R U N C O N T R O L |
︙ | ︙ | |||
816 817 818 819 820 821 822 | (statuses (dboard:data-get-statuses *data*)) (target (let ((targ-list (dboard:data-get-target *data*))) (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) (run-name (dboard:data-get-run-name *data*)) (states-str (if (or (not states) (null? states)) "" | | | | | > > | 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 | (statuses (dboard:data-get-statuses *data*)) (target (let ((targ-list (dboard:data-get-target *data*))) (if targ-list (string-intersperse targ-list "/") "no-target-selected"))) (run-name (dboard:data-get-run-name *data*)) (states-str (if (or (not states) (null? states)) "" (conc " -state " (string-intersperse states ",")))) (statuses-str (if (or (not statuses) (null? statuses)) "" (conc " -status " (string-intersperse statuses ",")))) (full-cmd "megatest")) (case (string->symbol cmd) ((run) (set! full-cmd (conc full-cmd " -run" " -testpatt " test-patt " -target " target " -runname " run-name " -clean-cache" ))) ((remove-runs) (set! full-cmd (conc full-cmd " -remove-runs -runname " run-name " -target " target |
︙ | ︙ | |||
853 854 855 856 857 858 859 | ;; Display the tests as rows of boxes on the test/task pane ;; (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))) | | | | | | | | | | | | | | | > > > > | 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 | ;; Display the tests as rows of boxes on the test/task pane ;; (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)) )) ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== ;; ;; A gui for launching tests ;; (define (dashboard:run-controls) (let* ((targets (make-hash-table)) (test-records (make-hash-table)) (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) (test-names (hash-table-keys all-tests-registry)) (sorted-testnames #f) (action "-run") (cmdln "") (runlogs (make-hash-table)) (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)))) (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) (tests:get-full-data test-names test-records '() all-tests-registry) (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) |
︙ | ︙ | |||
937 938 939 940 941 942 943 | ;; (iup:vbox ;; Command to run (iup:frame #:title "Set the action to take" (iup:hbox ;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER") | | | > > | | | | | 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 | ;; (iup:vbox ;; Command to run (iup:frame #:title "Set the action to take" (iup:hbox ;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER") (let* ((cmds-list '("run" "remove-runs" "set-state-status" "lock-runs" "unlock-runs")) (lb (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" #:action (lambda (obj val index lbstate) ;; (print obj " " val " " index " " lbstate) (dboard:data-set-command! *data* val) (dashboard:update-run-command)))) (default-cmd (car cmds-list))) (iuplistbox-fill-list lb cmds-list selected-item: default-cmd) (dboard:data-set-command! *data* default-cmd) lb))) (iup:frame #:title "Runname" (let* ((default-run-name (seconds->work-week/day (current-seconds))) (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 (or default-run-name (dboard:data-get-run-name *data*)))) (lb (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" #:action (lambda (obj val index lbstate) (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))) (runs-header (vector-ref runs-for-targ 0)) (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") (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 tb lb))) |
︙ | ︙ | |||
1029 1030 1031 1032 1033 1034 1035 | (iup:frame #:title "Statuses" (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)))))))) | | | 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 | (iup:frame #:title "Statuses" (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) (the-cnv #f) (canvas-obj |
︙ | ︙ | |||
1065 1066 1067 1068 1069 1070 1071 | ;; #:size "50x50" #:expand "YES" #:scrollbar "YES" #:posx "0.5" #:posy "0.5" #:button-cb (lambda (obj btn pressed x y status) ;; (print "obj: " obj ", pressed " pressed ", status " status) | | | | | 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 | ;; #:size "50x50" #:expand "YES" #: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)) ;; (let-values (((xx yy)(canvas-origin the-cnv))) ;; (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)) (yoffset (dcommon:get-yoffset tests-draw-state #f #f)) (new-y (- sizey y))) |
︙ | ︙ | |||
1105 1106 1107 1108 1109 1110 1111 | (hash-table-set! selected-tests test-name selected) (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) (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))) | | | 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 | (hash-table-set! selected-tests test-name selected) (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) (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) logs-tb)))))) |
︙ | ︙ | |||
1144 1145 1146 1147 1148 1149 1150 | ;; ))) ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; ;; General info about the run(s) and megatest area | | > | | 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 | ;; ))) ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; ;; General info about the run(s) and megatest area (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" (iup:vbox (iup:hbox |
︙ | ︙ | |||
1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 | (define (tree-path->run-id data path) (if (not (null? path)) (hash-table-ref/default (d:data-path-run-ids data) path #f) #f)) (define dashboard:update-run-summary-tab #f) ;; This is the Run Summary tab ;; | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | < < < < < < < < < < < < < < < < < < < | < < < < < < < < < | > | | | | | 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 | (define (tree-path->run-id data path) (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 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 ddata (cdr run-path)))) (if (number? run-id) (begin (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) ))) (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 ddata) "," test-id "&"))) (system cmd))))) (updater (lambda () (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 ddata)) (last-update 0) ;; fix me (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 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) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) (vector-ref runs-dat 1)) ht)) (run-ids (sort (filter number? (hash-table-keys runs-hash)) (lambda (a b) (let* ((record-a (hash-table-ref runs-hash a)) (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 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 ddata) run-path #f)) (begin (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 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") (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") (iup:attribute-set! run-matrix "NUMCOL" max-col ) |
︙ | ︙ | |||
1357 1358 1359 1360 1361 1362 1363 | (set! changed #t) (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) | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < | < < < < < < < < < | | 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 | (set! changed #t) (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! ddata tb) (iup:split tb run-matrix))) ;; This is the New View tab ;; (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 ddata (cdr run-path)))) (if (number? run-id) (begin (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) ))) (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 ddata) "," test-id "&"))) (system cmd))))) (updater (lambda () (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 ddata)) (last-update 0) ;; fix me (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 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) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) (vector-ref runs-dat 1)) |
︙ | ︙ | |||
1457 1458 1459 1460 1461 1462 1463 | ;; (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)) | | | | | | 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 | ;; (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 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 ddata) run-path #f)) (begin (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 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") (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") (iup:attribute-set! run-matrix "NUMCOL" max-col ) |
︙ | ︙ | |||
1530 1531 1532 1533 1534 1535 1536 | (begin (set! changed #t) (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")))))) | | | < < < < < < | < < < < < < < | 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 | (begin (set! changed #t) (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-new-view-tab updater) (d:data-runs-tree-set! ddata tb) (iup:split tb run-matrix))) ;;====================================================================== ;; R U N S ;;====================================================================== (define (dboard:make-controls data) (iup:hbox (iup:vbox (iup:frame #:title "filter test and items" (iup:hbox (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" #:action (lambda (obj unk val) |
︙ | ︙ | |||
1586 1587 1588 1589 1590 1591 1592 | ;; (set! *tests-sort-reverse* *tests-sort-reverse*0) lb) ;; (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) | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > | 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 | ;; (set! *tests-sort-reverse* *tests-sort-reverse*0) lb) ;; (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! 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! 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! data hideit) ;; never used, can eliminate ... hideit)) (iup:hbox (iup:button "Quit" #:action (lambda (obj) ;; (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 data)) (iup:attribute-set! obj "TITLE" "Expand")) (begin (for-each (lambda (tname) (hash-table-delete! *collapsed* tname)) (hash-table-keys *collapsed*)) (iup:attribute-set! obj "TITLE" "Collapse")))) (mark-for-update)))))) (iup:frame #:title "state/status filter" (iup:vbox (apply 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 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 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 data))) (d:alldat-start-run-offset-set! data val) (mark-for-update) (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 data))) #:min 0 #:step 0.01))) ;(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 (map (lambda (x) (let ((res (iup:hbox #:expand "HORIZONTAL" |
︙ | ︙ | |||
1679 1680 1681 1682 1683 1684 1685 | ((>= testnum ntests) ;; now lftlst will be an hbox with the test keys and the test name labels (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*)))) | | | 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 | ((>= testnum ntests) ;; now lftlst will be an hbox with the test keys and the test name labels (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! 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)) )) #:expand "VERTICAL" #:orientation "VERTICAL" |
︙ | ︙ | |||
1760 1761 1762 1763 1764 1765 1766 | (apply iup:hbox (cons (apply iup:vbox lftlst) (list (iup:vbox ;; the header (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)))))) | | > | | | | > | > | | | 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 | (apply iup:hbox (cons (apply iup:vbox lftlst) (list (iup:vbox ;; the header (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)))))) ;; 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 *alldat*) runs-view (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") (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) (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 *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") ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... |
︙ | ︙ | |||
1849 1850 1851 1852 1853 1854 1855 | (if dashboard:update-servers-table (dashboard:update-servers-table)))) (if recalc (begin (case (d:alldat-curr-tab-num *alldat*) ((0) (if dashboard:update-summary-tab (dashboard:update-summary-tab))) ((1) ;; The runs table is active | | | > | | > | | | | | | | | | | | | | | | | 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 | (if dashboard:update-servers-table (dashboard:update-servers-table)))) (if recalc (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 *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")) (let ((val (hash-table-ref/default (d:alldat-searchpatts *alldat*) key #f))) (if val (set! res (cons (list key val) res)))))) (d:alldat-dbkeys *alldat*)) res)) (update-buttons uidat (d:alldat-numruns *alldat*) (d:alldat-num-tests *alldat*))) ((2) (dashboard:update-run-summary-tab)) ((3) (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) (d:alldat-last-db-update-set! *alldat* modtime) (set! *last-recalc-ended-time* (current-milliseconds)))))) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) (define (main) (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 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") ",")))) (if (> (length d) 1) d (list #f #f)))) (run-id (car dat)) (test-id (cadr dat))) (if (and (number? run-id) (number? test-id) (>= test-id 0)) (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 data))) (else (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 data)) (set! update-is-running (d:alldat-updating data)) (if (not update-is-running) (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 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! 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) |
Modified datashare-testing/.sretrieve.config from [f5fc49272d] to [71cb2ce9dc].
1 2 3 4 | [settings] base-dir /tmp/delme_data allowed-users matt allowed-chars [0-9a-zA-Z\-\.]+ | | | 1 2 3 4 5 6 7 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)} |
Modified db.scm from [3b6c66a467] to [d9310f84f6].
︙ | ︙ | |||
842 843 844 845 846 847 848 | END;") ) (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)) ;; | | > > | | | | | | | | | | > > > | | > | > | | 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 | END;") ) (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, test_steps and test_data ;; ;; remove this some time after September 2016 (added in version v1.6031 ;; (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 "DROP TRIGGER IF EXISTS update_" table-name "_trigger;")) (sqlite3:execute frundb (conc "CREATE TRIGGER IF NOT EXISTS update_" table-name "_trigger AFTER UPDATE ON " table-name " FOR EACH ROW BEGIN UPDATE " table-name " SET last_update=(strftime('%s','now')) WHERE id=old.id; 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"))) (if (file-exists? fullname) (begin |
︙ | ︙ | |||
1034 1035 1036 1037 1038 1039 1040 | ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") ;; Must do this *after* running patch db !! No more. ;; cannot use db:set-var since it will deadlock, hardwire the code here | | | 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 | ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") ;; Must do this *after* running patch db !! No more. ;; cannot use db:set-var since it will deadlock, hardwire the code here (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) (debug:print-info 11 "db:initialize END"))))) ;;====================================================================== ;; R U N S P E C I F I C D B ;;====================================================================== (define (db:initialize-run-id-db db) |
︙ | ︙ | |||
1085 1086 1087 1088 1089 1090 1091 1092 | test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") | > > | < > > | < < < | | < > < | > > > > > > | 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 | test_id INTEGER, stepname TEXT, 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 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, expected REAL, 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));") (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data FOR EACH ROW BEGIN UPDATE test_data SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, test_id INTEGER, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, diskusage INTGER DEFAULT -1, |
︙ | ︙ | |||
1581 1582 1583 1584 1585 1586 1587 | ;;====================================================================== ;; M E T A G E T A N D S E T V A R S ;;====================================================================== ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* ;; | < < < > > > > > | < | 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 | ;;====================================================================== ;; M E T A G E T A N D S E T V A R S ;;====================================================================== ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* ;; (define (db:get-var dbstruct var) (let* ((res #f) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db 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)))) 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*))) (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))) (define (db:del-var dbstruct var) |
︙ | ︙ | |||
2761 2762 2763 2764 2765 2766 2767 | (db:with-db dbstruct run-id #f (lambda (db) (let* ((res '())) (sqlite3:for-each-row | | | | | 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 | (db:with-db dbstruct run-id #f (lambda (db) (let* ((res '())) (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile comment) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment) res))) db "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) (define (db:get-steps-data dbstruct run-id test-id) (db:with-db dbstruct run-id |
︙ | ︙ | |||
2811 2812 2813 2814 2815 2816 2817 | (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;" test-id test-id) ;; 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)))) | > | > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 | (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;" test-id test-id) ;; 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)))) ;; 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) (if (equal? entry-name "final") (set! res (append res (list (list stepname entry-name (configf:lookup dat entry-name "exit-code") ;; 0 ;; Value 0 ;; 1 ;; Expected 0 ;; 2 ;; Tolerance "n/a" ;; 3 ;; Units (configf:lookup dat entry-name "message") ;; 4 ;; Comment (configf:lookup dat entry-name "exit-status") ;; 5 ;; Status "logpro" ;; 6 ;; Type )))) (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 (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))) (expected (any->number-if-possible (list-ref padded-row 3))) (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number |
︙ | ︙ |
Modified db_records.scm from [de0d03e562] to [f90e27c50c].
︙ | ︙ | |||
184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 | (define-inline (tdb:step-get-id vec) (vector-ref vec 0)) (define-inline (tdb:step-get-test_id vec) (vector-ref vec 1)) (define-inline (tdb:step-get-stepname vec) (vector-ref vec 2)) (define-inline (tdb:step-get-state vec) (vector-ref vec 3)) (define-inline (tdb:step-get-status vec) (vector-ref vec 4)) (define-inline (tdb:step-get-event_time vec) (vector-ref vec 5)) (define-inline (tdb:step-get-logfile vec) (vector-ref vec 6)) (define-inline (tdb:step-set-id! vec val)(vector-set! vec 0 val)) (define-inline (tdb:step-set-test_id! vec val)(vector-set! vec 1 val)) (define-inline (tdb:step-set-stepname! vec val)(vector-set! vec 2 val)) (define-inline (tdb:step-set-state! vec val)(vector-set! vec 3 val)) (define-inline (tdb:step-set-status! vec val)(vector-set! vec 4 val)) (define-inline (tdb:step-set-event_time! vec val)(vector-set! vec 5 val)) (define-inline (tdb:step-set-logfile! vec val)(vector-set! vec 6 val)) ;; The steps table (define (make-db:steps-table)(make-vector 5)) (define-inline (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) (define-inline (tdb:steps-table-get-start vec) (vector-ref vec 1)) (define-inline (tdb:steps-table-get-end vec) (vector-ref vec 2)) | > > | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 | (define-inline (tdb:step-get-id vec) (vector-ref vec 0)) (define-inline (tdb:step-get-test_id vec) (vector-ref vec 1)) (define-inline (tdb:step-get-stepname vec) (vector-ref vec 2)) (define-inline (tdb:step-get-state vec) (vector-ref vec 3)) (define-inline (tdb:step-get-status vec) (vector-ref vec 4)) (define-inline (tdb:step-get-event_time vec) (vector-ref vec 5)) (define-inline (tdb:step-get-logfile vec) (vector-ref vec 6)) (define-inline (tdb:step-get-comment vec) (vector-ref vec 7)) (define-inline (tdb:step-set-id! vec val)(vector-set! vec 0 val)) (define-inline (tdb:step-set-test_id! vec val)(vector-set! vec 1 val)) (define-inline (tdb:step-set-stepname! vec val)(vector-set! vec 2 val)) (define-inline (tdb:step-set-state! vec val)(vector-set! vec 3 val)) (define-inline (tdb:step-set-status! vec val)(vector-set! vec 4 val)) (define-inline (tdb:step-set-event_time! vec val)(vector-set! vec 5 val)) (define-inline (tdb:step-set-logfile! vec val)(vector-set! vec 6 val)) (define-inline (tdb:step-set-comment! vec vak)(vector-set! vec 7 val)) ;; The steps table (define (make-db:steps-table)(make-vector 5)) (define-inline (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) (define-inline (tdb:steps-table-get-start vec) (vector-ref vec 1)) (define-inline (tdb:steps-table-get-end vec) (vector-ref vec 2)) |
︙ | ︙ |
Modified dcommon.scm from [4e772f3cb9] to [4ddc007d1e].
︙ | ︙ | |||
878 879 880 881 882 883 884 | (cdr tal)))))))) ;;====================================================================== ;; S T E P S ;;====================================================================== (define (dcommon:populate-steps teststeps steps-matrix) | | > | | | | | 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 | (cdr tal)))))))) ;;====================================================================== ;; S T E P S ;;====================================================================== (define (dcommon:populate-steps teststeps steps-matrix) (let ((max-row 0) (max-col 7)) (if (null? teststeps) (iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS") (let loop ((hed (car teststeps)) (tal (cdr teststeps)) (rownum 1) (colnum 1)) (if (> rownum max-row)(set! max-row rownum)) (let ((val (vector-ref hed (- colnum 1))) (mtrx-rc (conc rownum ":" colnum))) (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) (if (< colnum max-col) (loop hed tal rownum (+ colnum 1)) (if (not (null? tal)) (loop (car tal)(cdr tal)(+ rownum 1) 1)))))) (if (> max-row 0) (begin ;; we are going to speculatively clear rows until we find a row that is already cleared (let loop ((rownum (+ max-row 1)) (colnum 0) (deleted #f)) ;; (debug:print-info 0 "cleaning " rownum ":" colnum) (let* ((next-row (if (eq? colnum max-col) (+ rownum 1) rownum)) (next-col (if (eq? colnum max-col) 1 (+ colnum 1))) (mtrx-rc (conc rownum ":" colnum)) (curr-val (iup:attribute steps-matrix mtrx-rc))) ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val) (if (and (string? curr-val) (not (equal? curr-val ""))) (begin (iup:attribute-set! steps-matrix mtrx-rc "") (loop next-row next-col #t)) (if (eq? colnum max-col) ;; not done, didn't get a full blank row (if deleted (loop next-row next-col #f)) ;; exit on this not met (loop next-row next-col deleted))))) (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))) |
Added docs/waiton-analysis.gnumeric version [3f09f77a41].
cannot compute difference between binary files
Added inteldate.scm version [a6b831c59f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 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) |
Modified launch.scm from [b6e5dc6cca] to [1dfedbf893].
︙ | ︙ | |||
9 10 11 12 13 14 15 | ;; PURPOSE. ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | ;; PURPOSE. ;;====================================================================== ;; 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 csv) (use defstruct) (import (prefix base64 base64:)) (import (prefix sqlite3 sqlite3:)) (declare (unit launch)) (declare (uses common)) |
︙ | ︙ | |||
53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO")))) (if enccmd (common:read-encoded-string enccmd) '()))) ;; 0 1 2 3 (defstruct launch:einf (pid #t)(exit-status #t)(exit-code #t)(rollup-status 0)) (define (launch:runstep ezstep run-id test-id exit-info m tal testconfig) (let* ((stepname (car ezstep)) ;; do stuff to run the step (stepinfo (cadr ezstep)) (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each (stepcmd (list-ref stepparts 3)) (script "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\ (logpro-file (conc stepname ".logpro")) (html-file (conc stepname ".html")) (tconfig-logpro (configf:lookup testconfig "logpro" stepname)) (logpro-used (file-exists? logpro-file))) (if (and tconfig-logpro (not logpro-used)) ;; no logpro file found but have a defn in the testconfig (begin (with-output-to-file logpro-file | > > > > > > > > > > > > > > > > > > > > | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 | (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO")))) (if enccmd (common:read-encoded-string enccmd) '()))) ;; 0 1 2 3 (defstruct launch:einf (pid #t)(exit-status #t)(exit-code #t)(rollup-status 0)) ;; return (conc status ": " comment) from the final section so that ;; the comment can be set in the step record in launch.scm ;; (define (launch:load-logpro-dat run-id test-id stepname) (let ((cname (conc stepname ".dat"))) (if (file-exists? cname) (let* ((dat (read-config cname #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)))) (status (configf:lookup dat "final" "exit-status")) (msg (configf:lookup dat "final" "message"))) (rmt:csv->test-data run-id test-id csvt) (cond ((equal? status "PASS") "PASS") ;; skip the message part if status is pass (status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message"))) (else #f))) #f))) (define (launch:runstep ezstep run-id test-id exit-info m tal testconfig) (let* ((stepname (car ezstep)) ;; do stuff to run the step (stepinfo (cadr ezstep)) (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each (stepcmd (list-ref stepparts 3)) (script "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\ (logpro-file (conc stepname ".logpro")) (html-file (conc stepname ".html")) (dat-file (conc stepname ".dat")) (tconfig-logpro (configf:lookup testconfig "logpro" stepname)) (logpro-used (file-exists? logpro-file))) (if (and tconfig-logpro (not logpro-used)) ;; no logpro file found but have a defn in the testconfig (begin (with-output-to-file logpro-file |
︙ | ︙ | |||
129 130 131 132 133 134 135 | (if (eq? pid-val 0) (begin (thread-sleep! 2) (processloop (+ i 1))))) (debug:print-info 0 "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2))))) (let ((exinfo (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) | | | | > > > > | > | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 | (if (eq? pid-val 0) (begin (thread-sleep! 2) (processloop (+ i 1))))) (debug:print-info 0 "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2))))) (let ((exinfo (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") "")) (comment #f)) (if logpro-used (let ((datfile (conc stepname ".dat"))) ;; load the .dat file into the test_data table if it exists (if (file-exists? datfile) (set! comment (launch:load-logpro-dat run-id test-id stepname))) (rmt:test-set-log! run-id test-id (conc stepname ".html")))) (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna)) ;; set the test final status (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) (this-step-status (cond ((and (eq? process-exit-status 2) logpro-used) 'warn) ;; logpro 2 = warnings ((and (eq? process-exit-status 3) logpro-used) 'check) ;; logpro 3 = check ((and (eq? process-exit-status 4) logpro-used) 'waived) ;; logpro 4 = waived ((and (eq? process-exit-status 5) logpro-used) 'abort) ;; logpro 5 = abort |
︙ | ︙ | |||
200 201 202 203 204 205 206 | (tests:test-set-status! run-id test-id next-state "PASS" #f #f)) (else ;; 'fail (launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) ))) logpro-used)) | > > > > > > > > | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 | (tests:test-set-status! run-id test-id next-state "PASS" #f #f)) (else ;; 'fail (launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) ))) logpro-used)) (define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m) ;; (let-values ;; (((pid exit-status exit-code) ;; (run-n-wait fullrunscript))) ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) ;; Since we should have a clean slate at this time there is no need to do ;; any of the other stuff that tests:test-set-status! does. Let's just ;; force RUNNING/n/a ;; (thread-sleep! 0.3) (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") (rmt:roll-up-pass-fail-counts run-id test-name item-path #f "RUNNING") ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here ;; if there is a runscript do it first (if fullrunscript (let ((pid (process-run fullrunscript))) (rmt:test-set-top-process-pid run-id test-id pid) (let loop ((i 0)) (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) (mutex-lock! m) (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status) (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code) (launch:einf-rollup-status-set! exit-info exit-code) ;; (vector-set! exit-info 3 exit-code) ;; rollup status (mutex-unlock! m) (if (eq? pid-val 0) (begin (thread-sleep! 2) (loop (+ i 1))) ))))) ;; then, if runscript ran ok (or did not get called) ;; do all the ezsteps (if any) (if ezsteps (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic ;; ezstep names need a full re-eval here. (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs))) (ezstepslst (if (hash-table? testconfig) (hash-table-ref/default testconfig "ezsteps" '()) #f))) (if testconfig (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... (begin (launch:setup) (debug:print 0 "WARNING: no testconfig found for " test-name " in search path:\n " (string-intersperse (tests:get-tests-search-path *configdat*) "\n ")))) ;; after all that, still no testconfig? Time to abort (if (not testconfig) (begin (debug:print 0 "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now") (exit 1))) (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length") (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)) (stepname (car ezstep))) ;; if logpro-used read in the stepname.dat file (if (and logpro-used (file-exists? (conc stepname ".dat"))) (launch:load-logpro-dat run-id test-id stepname)) (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))))))) (define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags) (let* ((start-seconds (current-seconds)) (calc-minutes (lambda () (inexact->exact (round (- (current-seconds) start-seconds))))) (kill-tries 0)) ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10) (let loop ((minutes (calc-minutes)) (cpu-load (get-cpu-load)) (disk-free (get-df (current-directory)))) (let ((new-cpu-load (let* ((load (get-cpu-load)) (delta (abs (- load cpu-load)))) (if (> delta 0.6) ;; don't bother updating with small changes load #f))) (new-disk-free (let* ((df (get-df (current-directory))) (delta (abs (- df disk-free)))) (if (> delta 200) ;; ignore changes under 200 Meg df #f)))) (set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)) (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds)) (time-exceeded (> run-seconds runtlim))) (if time-exceeded (begin (debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) #t) #f))))) (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f) (if kill-job? (begin (mutex-lock! m) ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this ;; section and the runit section? Or add a loop that tries three times with a 1/4 second ;; between tries? (let* ((pid1 (launch:einf-pid exit-info)) ;; (vector-ref exit-info 0)) (pid2 (rmt:test-get-top-process-pid run-id test-id)) (pids (delete-duplicates (filter number? (list pid1 pid2))))) (if (not (null? pids)) (begin (for-each (lambda (pid) (handle-exceptions exn (begin (debug:print-info 0 "Unable to kill process with pid " pid ", possibly already killed.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) (debug:print 0 "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")") (debug:print-info 0 "Signal mask=" (signal-mask)) ;; (if (process:alive? pid) ;; (begin (map (lambda (pid-num) (process-signal pid-num signal/term)) (process:get-sub-pids pid)) (thread-sleep! 5) ;; (if (process:process-alive? pid) (map (lambda (pid-num) (handle-exceptions exn #f (process-signal pid-num signal/kill))) (process:get-sub-pids pid)))) ;; (debug:print-info 0 "not killing process " pid " as it is not alive")))) pids) (tests:test-set-status! run-id test-id "KILLED" "KILLED" (args:get-arg "-m") #f)) (begin (debug:print 0 "ERROR: Nothing to kill, pid1=" pid1 ", pid2=" pid2) (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f) ))) (mutex-unlock! m) ;; no point in sticking around. Exit now. (exit))) (if (hash-table-ref/default misc-flags 'keep-going #f) (begin (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses (if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free))))))) (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional (define (launch:execute encoded-cmd) (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) (tconfigreg (tests:get-all))) (setenv "MT_CMDINFO" encoded-cmd) (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area (top-path (assoc/default 'toppath cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area |
︙ | ︙ | |||
239 240 241 242 243 244 245 | (if (substring-index "/" runscript) runscript ;; use unadultered if contains slashes (let ((fulln (conc testpath "/" runscript))) (if (and (file-exists? fulln) (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path | | < | 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 | (if (substring-index "/" runscript) runscript ;; use unadultered if contains slashes (let ((fulln (conc testpath "/" runscript))) (if (and (file-exists? fulln) (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path ) ;; (rollup-status 0) ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) (if (or (file-exists? top-path) (> count 10)) (change-directory top-path) (begin |
︙ | ︙ | |||
272 273 274 275 276 277 278 | (debug:print 0 "Done") (exit 4))))) (thread-start! th2) (thread-start! th1) (thread-join! th2))))) (set-signal-handler! signal/int sighand) (set-signal-handler! signal/term sighand) | | < < | 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 | (debug:print 0 "Done") (exit 4))))) (thread-start! th2) (thread-start! th1) (thread-join! th2))))) (set-signal-handler! signal/int sighand) (set-signal-handler! signal/term sighand) ) ;; (set-signal-handler! signal/stop sighand) ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART, ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY* ;; (let* ((test-info (rmt:get-test-info-by-id run-id test-id)) (test-host (db:test-get-host test-info)) (test-pid (db:test-get-process_id test-info))) (cond |
︙ | ︙ | |||
388 389 390 391 392 393 394 | (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info ;; (tests:set-full-meta-info #f test-id run-id 0 work-area) ;; (tests:set-full-meta-info test-id run-id 0 work-area) (tests:set-full-meta-info #f test-id run-id 0 work-area 10) | | | | < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < | < < < < < | < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 | (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info ;; (tests:set-full-meta-info #f test-id run-id 0 work-area) ;; (tests:set-full-meta-info test-id run-id 0 work-area) (tests:set-full-meta-info #f test-id run-id 0 work-area 10) ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (file-exists? fullrunscript) (not (file-execute-access? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) ;; We are about to actually kick off the test ;; so this is a good place to remove the records for ;; any previous runs ;; (db:test-remove-steps db run-id testname itemdat) ;; (let* ((m (make-mutex)) (kill-job? #f) (exit-info (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status (job-thread #f) ;; (keep-going #t) (misc-flags (let ((ht (make-hash-table))) (hash-table-set! ht 'keep-going #t) ht)) (runit (lambda () (launch:manage-steps run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m))) (monitorjob (lambda () (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags))) (th1 (make-thread monitorjob "monitor job")) (th2 (make-thread runit "run job"))) (set! job-thread th2) (thread-start! th1) (thread-start! th2) (thread-join! th2) (debug:print-info 0 "Megatest exectute of test " test-name ", item path " item-path " complete. Notifying the db ...") (hash-table-set! misc-flags 'keep-going #f) (thread-join! th1) (thread-sleep! 1) ;; givbe thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec. (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) ;; only state and status needed - use lazy routine (testinfo (rmt:get-testinfo-state-status run-id test-id))) ;; Am I completed? |
︙ | ︙ | |||
628 629 630 631 632 633 634 | (target (common:args-get-target)) (runname (or (args:get-arg "-runname") (args:get-arg ":runname") (getenv "MT_RUNNAME"))) (fulldir (conc linktree "/" target "/" runname))) | < > | | > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 | (target (common:args-get-target)) (runname (or (args:get-arg "-runname") (args:get-arg ":runname") (getenv "MT_RUNNAME"))) (fulldir (conc linktree "/" target "/" runname))) (if (and linktree (file-exists? linktree)) ;; can't proceed without linktree (begin (debug:print-info 0 "Have -run with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%")) (if (not (file-exists? fulldir)) (create-directory fulldir #t)) ;; need to protect with exception handler (if (and target runname (file-exists? fulldir)) (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash)) (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash))) (if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached (begin (debug:print-info 0 "Caching megatest.config in " tmpfile) (configf:write-alist *configdat* tmpfile) (system (conc "ln -sf " tmpfile " " targfile)))) ))) (debug:print-info 1 "No linktree yet, no caching configs."))))) ;; gather available information, if legit read configs in this order: ;; ;; if have cache; ;; read it a return it ;; else ;; megatest.config (do not cache) |
︙ | ︙ | |||
766 767 768 769 770 771 772 | mtconfig environ-patt: "env-override" given-toppath: toppath pathenvvar: "MT_RUN_AREA_HOME")) (first-rundat (let ((toppath (if toppath toppath (car first-pass)))) | | > > > > > | | 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 | mtconfig environ-patt: "env-override" given-toppath: toppath pathenvvar: "MT_RUN_AREA_HOME")) (first-rundat (let ((toppath (if toppath toppath (car first-pass)))) (read-config ;; (conc toppath "/runconfigs.config") (conc (if (string? toppath) toppath (get-environment-variable "MT_RUN_AREA_HOME")) "/runconfigs.config") *runconfigdat* #t sections: sections)))) (set! *runconfigdat* first-rundat) (if first-pass ;; (begin (set! *configdat* (car first-pass)) (set! *configinfo* first-pass) (set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it (set! toppath *toppath*) |
︙ | ︙ |
Modified megatest-version.scm from [1b2ed8639a] to [1d4899be81].
1 | ;; Always use two or four digit decimal | | | | 1 2 3 4 5 6 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.6102) |
Modified megatest.scm from [412258d252] to [018155474b].
︙ | ︙ | |||
80 81 82 83 84 85 86 87 88 89 90 91 92 93 | and then run the specified testpatt with -preclean -lock : lock run specified by target and runname -unlock : unlock run specified by target and runname -set-run-status status : sets status for run to status, requires -target and -runname -get-run-status : gets status for run specified by target and runname -run-wait : wait on run specified by target and runname -preclean : remove the existing test directory before running the test Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) -target key1/key2/... : run for key1, key2, etc. -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfig -testpatt patt1/patt2,patt3/... : % is wildcard -runname : required, name for this particular test run -state : Applies to runs, tests or steps depending on context | > | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | and then run the specified testpatt with -preclean -lock : lock run specified by target and runname -unlock : unlock run specified by target and runname -set-run-status status : sets status for run to status, requires -target and -runname -get-run-status : gets status for run specified by target and runname -run-wait : wait on run specified by target and runname -preclean : remove the existing test directory before running the test -clean-cache : remove the cached megatest.config and runconfig.config files Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) -target key1/key2/... : run for key1, key2, etc. -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfig -testpatt patt1/patt2,patt3/... : % is wildcard -runname : required, name for this particular test run -state : Applies to runs, tests or steps depending on context |
︙ | ︙ | |||
268 269 270 271 272 273 274 275 276 277 278 279 280 281 | "-set-values" "-load-test-data" "-summarize-items" "-gui" "-daemonize" "-preclean" "-rerun-clean" ;; misc "-repl" "-lock" "-unlock" "-list-servers" "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) | > | 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 | "-set-values" "-load-test-data" "-summarize-items" "-gui" "-daemonize" "-preclean" "-rerun-clean" "-clean-cache" ;; misc "-repl" "-lock" "-unlock" "-list-servers" "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) |
︙ | ︙ | |||
383 384 385 386 387 388 389 390 391 392 393 394 395 396 | (delay-loop (+ count 1)))) (loop))) (if (common:low-noise-print 30) (debug:print-info 0 "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))) "Watchdog thread"))) (thread-start! *watchdog*) (if (args:get-arg "-log") (let ((oup (open-output-file (args:get-arg "-log")))) (debug:print-info 0 "Sending log output to " (args:get-arg "-log")) (current-error-port oup) (current-output-port oup))) | > | 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 | (delay-loop (+ count 1)))) (loop))) (if (common:low-noise-print 30) (debug:print-info 0 "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))) "Watchdog thread"))) (thread-start! *watchdog*) (if (args:get-arg "-log") (let ((oup (open-output-file (args:get-arg "-log")))) (debug:print-info 0 "Sending log output to " (args:get-arg "-log")) (current-error-port oup) (current-output-port oup))) |
︙ | ︙ | |||
406 407 408 409 410 411 412 | (change-directory (args:get-arg "-start-dir")) (begin (debug:print 0 "ERROR: non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") (exit 1)))) (if (args:get-arg "-version") (begin | | | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 | (change-directory (args:get-arg "-start-dir")) (begin (debug:print 0 "ERROR: non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") (exit 1)))) (if (args:get-arg "-version") (begin (print (common:version-signature)) ;; (print megatest-version) (exit))) (define *didsomething* #f) ;; Overall exit handling setup immediately ;; (if (or (args:get-arg "-process-reap")) |
︙ | ︙ | |||
452 453 454 455 456 457 458 | (if (args:get-arg "-itempatt") (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"))) | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < < < < < < < < < < < < < < < < < < | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 | (if (args:get-arg "-itempatt") (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 ;;====================================================================== ;; handle a clean-cache request as early as possible ;; (if (args:get-arg "-clean-cache") (begin (set! *didsomething* #t) ;; suppress the help output. (if (getenv "MT_TARGET") ;; no point in trying if no target (if (args:get-arg "-runname") (let* ((toppath (launch:setup)) (linktree (if toppath (configf:lookup *configdat* "setup" "linktree"))) (runtop (conc linktree "/" (getenv "MT_TARGET") "/" (args:get-arg "-runname"))) (files (if (file-exists? runtop) (append (glob (conc runtop "/.megatest*")) (glob (conc runtop "/.runconfig*"))) '()))) (if (null? files) (debug:print-info 0 "No cached megatest or runconfigs files found. None removed.") (begin (debug:print-info 0 "Removing cached files:\n " (string-intersperse files "\n ")) (for-each (lambda (f) (handle-exceptions exn (debug:print 0 "WARNING: Failed to remove file " f) (delete-file f))) files)))) (debug:print 0 "ERROR: -clean-cache requires -runname.")) (debug:print 0 "ERROR: -clean-cache requires -target or -reqtarg")))) (if (args:get-arg "-env2file") (begin (save-environment-as-files (args:get-arg "-env2file")) (set! *didsomething* #t))) (if (args:get-arg "-list-disks") (let ((toppath (launch:setup))) (print (string-intersperse (map (lambda (x) (string-intersperse x " => ")) (common:get-disks *configdat*)) "\n")) (set! *didsomething* #t))) ;; csv processing record (define (make-refdb:csv) (vector (make-sparse-array) (make-hash-table) (make-hash-table) 0 |
︙ | ︙ | |||
658 659 660 661 662 663 664 | )) (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))) | < < < < < < < < | 668 669 670 671 672 673 674 675 676 677 678 679 680 681 | )) (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))) ;;====================================================================== ;; Capture, save and manipulate environments ;;====================================================================== ;; NOTE: Keep these above the section where the server or client code is setup (let ((envcap (args:get-arg "-envcap"))) |
︙ | ︙ | |||
706 707 708 709 710 711 712 | (args:get-arg "-o") (lambda () (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"))))) | < < | 708 709 710 711 712 713 714 715 716 717 718 719 720 721 | (args:get-arg "-o") (lambda () (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 ;;====================================================================== (if (args:get-arg "-server") |
︙ | ︙ | |||
945 946 947 948 949 950 951 | (exit 3)) (else (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 | > > > | | | | | | | | | 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 | (exit 3)) (else (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 (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) (operate-on 'remove-runs)))) |
︙ | ︙ | |||
1624 1625 1626 1627 1628 1629 1630 | (db #f)) (change-directory testpath) (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) | > > | | 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 | (db #f)) (change-directory testpath) (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) (let ((comment (launch:load-logpro-dat run-id test-id step))) ;; (rmt:test-set-log! run-id test-id (conc stepname ".html")))) (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile)) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6)))))) (if (args:get-arg "-step") (begin (megatest:step |
︙ | ︙ | |||
1666 1667 1668 1669 1670 1671 1672 | (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f) ;; (open-db)) (state (args:get-arg ":state")) | | > | 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 | (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f) ;; (open-db)) (state (args:get-arg ":state")) (status (args:get-arg ":status")) (stepname (args:get-arg "-step"))) (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area)) (change-directory work-area) |
︙ | ︙ | |||
1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 | ;; 'new2old 'killservers 'dejunk ;; 'adj-testids ;; 'old2new 'new2old ) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin (if (not (launch:setup)) (begin | > > | | 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 | ;; 'new2old 'killservers 'dejunk ;; 'adj-testids ;; 'old2new 'new2old ) (if (common:version-changed?) (common:set-last-run-version)) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (open-run-close db:find-and-mark-incomplete #f) (set! *didsomething* #t))) ;;====================================================================== ;; Update the tests meta data from the testconfig files ;;====================================================================== |
︙ | ︙ |
Modified rmt.scm from [faa5353eed] to [b7f6f86358].
︙ | ︙ | |||
657 658 659 660 661 662 663 | (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) | > | | | | | 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 | (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) ;; (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area))) ;; (if tdb ;; (tdb:read-test-data tdb test-id categorypatt) ;; '()))) (define (rmt:testmeta-add-record testname) (rmt:send-receive 'testmeta-add-record #f (list testname))) (define (rmt:testmeta-get-record testname) (rmt:send-receive 'testmeta-get-record #f (list testname))) |
︙ | ︙ |
Modified runs.scm from [301a2c24cc] to [cd4112308f].
︙ | ︙ | |||
193 194 195 196 197 198 199 | (if (and config-reruns (> run-count config-reruns)) (set! run-count config-reruns)) (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (let ((sighand (lambda (signum) | | | 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 | (if (and config-reruns (> run-count config-reruns)) (set! run-count config-reruns)) (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (set! *time-to-exit* #t) (print "Received signal " signum ", cleaning up before exit. Please wait...") (let ((th1 (make-thread (lambda () (let ((tdbdat (tasks:open-db))) (rmt:tasks-set-state-given-param-key task-key "killed")) (print "Killed by signal " signum ". Exiting") (thread-sleep! 3) |
︙ | ︙ | |||
371 372 373 374 375 376 377 | ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 "test-records=" (hash-table->alist test-records)) (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) (if (> (length (hash-table-keys test-records)) 0) (let* ((keep-going #t) (run-queue-retries 5) (th1 (make-thread (lambda () | > | | | | | | | | | | | 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 | ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 "test-records=" (hash-table->alist test-records)) (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) (if (> (length (hash-table-keys test-records)) 0) (let* ((keep-going #t) (run-queue-retries 5) (th1 (make-thread (lambda () (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)) ;; (handle-exceptions ;; exn ;; (begin ;; (print-call-chain (current-error-port)) ;; (debug:print 0 "ERROR: failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn)) ;; (if (> run-queue-retries 0) ;; (begin ;; (set! run-queue-retries (- run-queue-retries 1)) ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))) ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))) "runs:run-tests-queue")) (th2 (make-thread (lambda () ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ... (let ((run-ids (rmt:get-all-run-ids))) (for-each (lambda (run-id) (if keep-going (handle-exceptions |
︙ | ︙ |
Modified sretrieve.scm from [76eaef987d] to [915dd04401].
︙ | ︙ | |||
52 53 54 55 56 57 58 | (define *sretrieve:current-tab-number* 0) (define *args-hash* (make-hash-table)) (define sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]] ls : list contents of target area get <relversion> : retrieve data for release <version> -m \"message\" : why retrieved? | | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | (define *sretrieve:current-tab-number* 0) (define *args-hash* (make-hash-table)) (define sretrieve:help (conc "Usage: " *exe-name* " [action [params ...]] ls : list contents of target area get <relversion> : retrieve data for release <version> -m \"message\" : why retrieved? cp <relative path> : copy file to current directory log : get listing of recent downloads Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest Version: " megatest-fossil-hash)) ;; " |
︙ | ︙ | |||
106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 | ;; (call-with-database ;; (lambda (db) ;; (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))) (if (and path (directory? path) (file-read-access? path)) (let* ((dbpath (conc path "/" *exe-name* ".db")) (writeable (file-write-access? dbpath)) (dbexists (file-exists? dbpath))) (handle-exceptions exn (begin (debug:print 2 "ERROR: problem accessing db " dbpath ((condition-property-accessor 'exn 'message) exn)) (exit 1)) (call-with-database dbpath (lambda (db) | > > | | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | ;; (call-with-database ;; (lambda (db) ;; (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))) (if (and path (directory? path) (file-read-access? path)) (let* ((dbpath (conc path "/" *exe-name* ".db")) (writeable (file-write-access? dbpath)) (dbexists (file-exists? dbpath))) (handle-exceptions 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) (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 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) (not (file-exists? base-dir))) (begin |
︙ | ︙ | |||
154 155 156 157 158 159 160 | (sretrieve:db-do configdat (lambda (db) (sretrieve:register-action db "get" retriever datadir comment))) (sretrieve:do-as-calling-user (lambda () | > > | | | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 | (sretrieve:db-do configdat (lambda (db) (sretrieve:register-action db "get" retriever datadir comment))) (sretrieve:do-as-calling-user (lambda () (if (directory? datadir) (begin (change-directory datadir) (let ((files (filter (lambda (x) (not (member x '("." "..")))) (glob "*" ".*")))) (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 "*" ".*")))))))) (define (sretrieve:validate target-dir targ-mk) (let* ((normal-path (normalize-pathname targ-mk)) |
︙ | ︙ | |||
374 375 376 377 378 379 380 381 382 383 384 385 386 387 | (make-hash-table)))) (pop-directory) res))) (define (sretrieve:process-action configdat action . args) (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) (user (current-user-name)) (allowed-users (string-split (or (configf:lookup configdat "settings" "allowed-users") ""))) (default-area (configf:lookup configdat "settings" "default-area"))) ;; otherwise known as the package (if (not base-dir) (begin | > | 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 | (make-hash-table)))) (pop-directory) 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 (if (not base-dir) (begin |
︙ | ︙ | |||
407 408 409 410 411 412 413 414 415 416 417 418 419 420 | (package-type (or (args:get-arg "-package") default-area)) (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))) (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) ;; (load debugcontrolf))) | > > > > > > > > > > > > > > > > > > > > > > > | 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 | (package-type (or (args:get-arg "-package") default-area)) (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) ;; (load debugcontrolf))) |
︙ | ︙ | |||
440 441 442 443 444 445 446 | ((ls) (let* ((base-dir (configf:lookup configdat "settings" "base-dir"))) (if base-dir (begin (print "Files in " base-dir) (sretrieve:do-as-calling-user (lambda () | | | 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 | ((ls) (let* ((base-dir (configf:lookup configdat "settings" "base-dir"))) (if base-dir (begin (print "Files in " base-dir) (sretrieve:do-as-calling-user (lambda () (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 (lambda (row) (apply print (intersperse row " | ")))) |
︙ | ︙ |
Modified tdb.scm from [9506a565ad] to [8d8250539c].
︙ | ︙ | |||
206 207 208 209 210 211 212 213 214 215 216 217 218 219 | ;; '()))) ;; NOTE: Run this local with #f for db !!! (define (tdb:load-test-data run-id test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin (debug:print 4 lin) (rmt:csv->test-data run-id test-id lin) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status too (rmt:test-data-rollup run-id test-id #f)) | > > > > > > > > > > > > | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 | ;; '()))) ;; NOTE: Run this local with #f for db !!! (define (tdb:load-test-data run-id test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin (debug:print 4 lin) (rmt:csv->test-data run-id test-id lin) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status too (rmt:test-data-rollup run-id test-id #f)) ;; NOTE: Run this local with #f for db !!! (define (tdb:load-logpro-data run-id test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin (debug:print 4 lin) (rmt:csv->test-data run-id test-id lin) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status too (rmt:test-data-rollup run-id test-id #f)) |
︙ | ︙ |
Modified tests.scm from [9b4900cf00] to [741f407659].
︙ | ︙ | |||
581 582 583 584 585 586 587 | (let ((res (make-hash-table))) (for-each (lambda (step) (debug:print 6 "step=" step) (let ((record (hash-table-ref/default res (tdb:step-get-stepname step) | | | | 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 | (let ((res (make-hash-table))) (for-each (lambda (step) (debug:print 6 "step=" step) (let ((record (hash-table-ref/default res (tdb:step-get-stepname step) ;; stepname start end status Duration Logfile Comment (vector (tdb:step-get-stepname step) "" "" "" "" "" "")))) (debug:print 6 "record(before) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)) (case (string->symbol (tdb:step-get-state step)) |
︙ | ︙ | |||
608 609 610 611 612 613 614 | (debug:print 4 "record[1]=" (vector-ref record 1) ", startt=" startt ", endt=" endt ", get-status: " (tdb:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (tdb:step-get-logfile step)) 0) | | > > > | > | < | < < | > | | 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 | (debug:print 4 "record[1]=" (vector-ref record 1) ", startt=" startt ", endt=" endt ", get-status: " (tdb:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (tdb:step-get-logfile step)) 0) (vector-set! record 5 (tdb:step-get-logfile step))) (if (> (string-length (tdb:step-get-comment step)) 0) (vector-set! record 6 (tdb:step-get-comment step)))) (else (vector-set! record 2 (tdb:step-get-state step)) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (tdb:step-get-event_time step)) (vector-set! record 6 (tdb:step-get-comment step)))) (hash-table-set! res (tdb:step-get-stepname step) record) (debug:print 6 "record(after) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)))) ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) (sort steps (lambda (a b) (cond ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) (< (tdb:step-get-id a) (tdb:step-get-id b))) (else #f))))) res)) ;; ;; (define (tests:get-compressed-steps run-id test-id) (let* ((steps-data (rmt:get-steps-for-test run-id test-id)) (comprsteps (tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) (map (lambda (x) ;; take advantage of the \n on time->string (vector (vector-ref x 0) (let ((s (vector-ref x 1))) (if (number? s)(seconds->time-string s) s)) (let ((s (vector-ref x 2))) (if (number? s)(seconds->time-string s) s)) (vector-ref x 3) ;; status (vector-ref x 4) (vector-ref x 5) ;; time delta (vector-ref x 6))) (sort (hash-table-values comprsteps) (lambda (a b) (let ((time-a (vector-ref a 1)) (time-b (vector-ref b 1))) (if (and (number? time-a)(number? time-b)) (if (< time-a time-b) #t |
︙ | ︙ | |||
673 674 675 676 677 678 679 | (test-name (db:test-get-testname test-dat)) (item-path (db:test-get-item-path test-dat)) (full-name (db:test-make-full-name test-name item-path)) (oup (open-output-file (conc (db:test-get-rundir test-dat) "/test-summary.html"))) (status (db:test-get-status test-dat)) (color (common:get-color-from-status status)) (logf (db:test-get-final_logf test-dat)) | | | 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 | (test-name (db:test-get-testname test-dat)) (item-path (db:test-get-item-path test-dat)) (full-name (db:test-make-full-name test-name item-path)) (oup (open-output-file (conc (db:test-get-rundir test-dat) "/test-summary.html"))) (status (db:test-get-status test-dat)) (color (common:get-color-from-status status)) (logf (db:test-get-final_logf test-dat)) (steps-dat (tests:get-compressed-steps run-id test-id))) ;; (dcommon:get-compressed-steps #f 1 30045) ;; (#("wasting_time" "23:36:13" "23:36:21" "0" "8.0s" "wasting_time.log")) (s:output-new oup (s:html (s:title "Summary for " full-name) |
︙ | ︙ | |||
751 752 753 754 755 756 757 | ;; (filter (lambda (testname) ;; (tests:match test-patts testname #f)) ;; (map (lambda (testp) ;; (last (string-split testp "/"))) ;; tests))))) (define (tests:get-test-path-from-environment) | | | | | | | | | | | | | > | 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 | ;; (filter (lambda (testname) ;; (tests:match test-patts testname #f)) ;; (map (lambda (testp) ;; (last (string-split testp "/"))) ;; tests))))) (define (tests:get-test-path-from-environment) (if (and (getenv "MT_LINKTREE") (getenv "MT_TARGET") (getenv "MT_RUNNAME") (getenv "MT_TEST_NAME") (getenv "MT_ITEMPATH")) (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME") "/" (getenv "MT_TEST_NAME") "/" (if (or (getenv "MT_ITEMPATH") (not (string=? "" (getenv "MT_ITEMPATH")))) (conc "/" (getenv "MT_ITEMPATH")))) #f)) ;; if .testconfig exists in test directory read and return it ;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata" ;; else read the testconfig file ;; if have path to test directory save the config as .testconfig and return it ;; (define (tests:get-testconfig test-name test-registry system-allowed #!key (force-create #f)) |
︙ | ︙ | |||
801 802 803 804 805 806 807 | (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) (tcfg (if testexists (read-config test-configf #f system-allowed environ-patt: (if system-allowed "pre-launch-env-vars" #f)) #f))) | | | 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 | (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) (tcfg (if testexists (read-config test-configf #f system-allowed environ-patt: (if system-allowed "pre-launch-env-vars" #f)) #f))) (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"))) (debug:print-info 1 "Caching testconfig for " test-name " in " tpath) (configf:write-alist tcfg tpath))) |
︙ | ︙ |
Added utils/Makefile.git.installall version [d3a2bd23c6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 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) |
Modified utils/Makefile.installall from [854a5318e0] to [7342a34bd5].
︙ | ︙ | |||
42 43 44 45 46 47 48 | # 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 | | > | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | # 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.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 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/8 VPATH=$(CHICKEN_EGG_DIR):$(PWD)/eggflags vpath %.so $(CHICKEN_EGG_DIR) vpath %.flag eggflags EGGSOFILES=$(addprefix $(CHICKEN_EGG_DIR)/,$(addsuffix .so,$(EGGS))) |
︙ | ︙ | |||
99 100 101 102 103 104 105 | 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 | | > | | | | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 | 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/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) # libiup : $(PREFIX)/lib/libavcall.a libiup : $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so |
︙ | ︙ | |||
143 144 145 146 147 148 149 150 151 152 | (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 | > | > > > | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 | (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) # 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 : 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.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) cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) install |
︙ | ︙ | |||
217 218 219 220 221 222 223 | 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 | | | | | 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 | 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/8/mutils.so : opensrc/histstore/histstore.scm cd opensrc/mutils;chicken-install $(PREFIX)/lib/chicken/8/dbi.so : opensrc/dbi/dbi.scm cd opensrc/dbi;chicken-install $(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 $(PREFIX)/bin/hs : opensrc/histstore/hs cp -f opensrc/histstore/hs $(PREFIX)/bin/hs |
︙ | ︙ | |||
245 246 247 248 249 250 251 | 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 | | | 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 | 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/8/stml.so : stml/requirements.scm cd stml;make #====================================================================== # F F C A L L (Used by IUP) #====================================================================== ffcall.fossil : |
︙ | ︙ | |||
269 270 271 272 273 274 275 | cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make CC="gcc -fPIC" && make install #====================================================================== # I U P #====================================================================== iuplib.fossil : | | | | > > > > > > > > > > > > > | | | | | 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 | 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 iup/alldone # 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) |
Added utils/Makefile.latest.installall version [149911e2cc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 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) |