Overview
Comment: | Pulled in changes only related to fixes from newview branch |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | v1.65-oops-n |
Files: | files | file ages | folders |
SHA1: |
4d6ba57051a102f9251c78a8a709de29 |
User & Date: | matt on 2020-05-31 16:48:11 |
Other Links: | branch diff | manifest | tags |
Context
2020-05-31
| ||
16:48 | Pulled in changes only related to fixes from newview branch Closed-Leaf check-in: 4d6ba57051 user: matt tags: v1.65-oops-n | |
2020-03-10
| ||
15:14 | merged branch check-in: 367ffc5bdf user: mmgraham tags: v1.65, v1.6545 | |
Changes
Modified api.scm from [a15c0cd809] to [8a3eb8aa72].
︙ | ︙ | |||
56 57 58 59 60 61 62 63 64 65 66 67 68 69 | get-run-times get-targets get-target ;; register-run get-tests-tags get-test-times get-tests-for-run get-test-id get-tests-for-runs-mindata get-tests-for-run-mindata get-run-name-from-id get-runs simple-get-runs get-num-runs | > | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | get-run-times get-targets get-target ;; register-run get-tests-tags get-test-times get-tests-for-run get-tests-for-run-state-status get-test-id get-tests-for-runs-mindata get-tests-for-run-mindata get-run-name-from-id get-runs simple-get-runs get-num-runs |
︙ | ︙ | |||
290 291 292 293 294 295 296 297 298 299 300 301 302 303 | ;; RUNS ((get-run-info) (apply db:get-run-info dbstruct params)) ((get-run-status) (apply db:get-run-status dbstruct params)) ((get-run-state) (apply db:get-run-state dbstruct params)) ((set-run-status) (apply db:set-run-status dbstruct params)) ((set-run-state-status) (apply db:set-run-state-status dbstruct params)) ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) ((get-test-id) (apply db:get-test-id dbstruct params)) ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) ;; ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) ((get-runs) (apply db:get-runs dbstruct params)) ((simple-get-runs) (apply db:simple-get-runs dbstruct params)) ((get-num-runs) (apply db:get-num-runs dbstruct params)) ((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt dbstruct params)) | > | 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 | ;; RUNS ((get-run-info) (apply db:get-run-info dbstruct params)) ((get-run-status) (apply db:get-run-status dbstruct params)) ((get-run-state) (apply db:get-run-state dbstruct params)) ((set-run-status) (apply db:set-run-status dbstruct params)) ((set-run-state-status) (apply db:set-run-state-status dbstruct params)) ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) ((get-tests-for-run-state-status) (apply db:get-tests-for-run-state-status dbstruct params)) ((get-test-id) (apply db:get-test-id dbstruct params)) ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) ;; ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) ((get-runs) (apply db:get-runs dbstruct params)) ((simple-get-runs) (apply db:simple-get-runs dbstruct params)) ((get-num-runs) (apply db:get-num-runs dbstruct params)) ((get-runs-cnt-by-patt) (apply db:get-runs-cnt-by-patt dbstruct params)) |
︙ | ︙ |
Modified dashboard.scm from [2679042d5f] to [4ce2a6eac9].
︙ | ︙ | |||
429 430 431 432 433 434 435 436 437 438 439 440 441 442 | ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat key-vals ((last-update 0) : number) ;; last query to db got records from before last-update ((last-db-time 0) : number) ;; last timestamp on megatest.db ((data-changed #f) : boolean) ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items (db-path #f)) ;; register dboard:rundat with BBpp ;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle (hash-table-set! *BBpp_custom_expanders_list* RUNDAT: (cons dboard:rundat? (lambda (tabdat-item) (filter | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 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 | ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat key-vals ((last-update 0) : number) ;; last query to db got records from before last-update ((last-db-time 0) : number) ;; last timestamp on megatest.db ((data-changed #f) : boolean) ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items (db-path #f)) ;; for the new runs view lets build up a few new record types and then consolidate later ;; ;; this is a two level deep pipeline for the incoming data: ;; sql query data ==> filters ==> data for display ;; (defstruct dboard:rdat ;; view related items (runnum 0) ;; which column we are processing, index into runsbynum, we sweep across all these runs then start over (leftcol 0) ;; number of the leftmost visible column (toprow 0) ;; topmost visible row (numcols 24) ;; number of columns visible (numrows 20) ;; number of rows visible ;; data from sql db (keys (rmt:get-keys)) ;; to be removed when targets handling is refactored (runs (make-sparse-vector)) ;; id => runrec (runsbynum (make-vector 100 #f)) ;; vector num => runrec (targ-runid (make-hash-table)) ;; area/target/runname => run-id ;; not sure this will be needed (tests (make-hash-table)) ;; test[/itempath] => list of test rec ;; run sql filters (targ-sql-filt "%") (runname-sql-filt "%") (run-state-sql-filt "%") (run-status-sql-filt "%") ;; test sql filter (testname-sql-filt "%") (itempath-sql-filt "%") (test-state-sql-filt "%") (test-status-sql-filt "%") ;; other sql related fields (last-updates (make-sparse-vector 0)) ;; run-id -> timestamp of the last update from sql db, set to zero on any field changes ;; filtered data (cols (make-sparse-vector)) ;; columnnum => run-id (tests (make-hash-table)) ;; test[/itempath] => (vector columnnum => test rec) ;; various (prev-run-ids '()) ;; push previously looked at runs on this (view-changed #f) ;; widgets (runs-tree #f) ;; ) (define (dboard:rdat-push-run-id rdat run-id) (dboard:rdat-prev-run-ids-set! rdat (cons run-id (dboard:rdat-prev-run-ids rdat)))) (defstruct dboard:runrec id target ;; a/b/c... tdef ;; for future use ) (defstruct dboard:testrec id runid testname ;; test[/itempath] state status start-time duration ) ;; register dboard:rundat with BBpp ;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle (hash-table-set! *BBpp_custom_expanders_list* RUNDAT: (cons dboard:rundat? (lambda (tabdat-item) (filter |
︙ | ︙ | |||
1410 1411 1412 1413 1414 1415 1416 | (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)) | | | 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 | (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)) ;; refer to (dboard:tabcodat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys (let* ((result (iup:vbox (dcommon:command-execution-control tabdat) (iup:split #:orientation "VERTICAL" ;; "HORIZONTAL" #:value 200 ;; |
︙ | ︙ | |||
1454 1455 1456 1457 1458 1459 1460 | ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) ;; logs-tb)) ;; browse runs as a tree. Used in both "Runs" tab and ;; in the runs control panel. ;; (define (dboard:runs-tree-browser commondat tabdat) | | | | | | > | > | > | | | | | | | > > | > > > | > | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 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 1655 1656 1657 1658 1659 1660 1661 1662 1663 | ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) ;; logs-tb)) ;; browse runs as a tree. Used in both "Runs" tab and ;; in the runs control panel. ;; (define (dboard:runs-tree-browser commondat tabdat) (let* ((txtbox (iup:textbox #:action (lambda (val a b) (debug:catch-and-dump (lambda () ;; for the Runs view we put the list ;; of keyvals into tabdat target for ;; the Run Controls we put then update ;; the run-command (if b (dboard:tabdat-target-set! tabdat (string-split b "/"))) (dashboard:update-run-command tabdat)) "command-testname-selector tb action")) #:value (dboard:test-patt->lines (dboard:tabdat-test-patts-use tabdat)) #:expand "HORIZONTAL" ;; #:size "10x30" )) (tb (iup:treebox #:value 0 #:title "Runs" ;; was #:name -- iup 3.19 changed ;; this... "Changed: [DEPRECATED ;; REMOVED] removed the old attribute ;; NAMEid from IupTree to avoid ;; conflict with the common attribute ;; NAME. Use the TITLEid attribute." #:expand "YES" #:addexpanded "YES" #:size "10x" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () (let* ((run-path (tree:node->path obj id)) (run-id (tree-path->run-id tabdat (cdr run-path)))) ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? ;; done below when run-id is a number (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print ;; "run-path: ;; " ;; run-path) (iup:attribute-set! txtbox "VALUE" (string-intersperse (cdr run-path) "/")) (dashboard:update-run-command tabdat) (dboard:tabdat-layout-update-ok-set! tabdat #f) (if (number? run-id) (begin ;; capture last two in tabdat. (dboard:tabdat-prev-run-id-set! tabdat (dboard:tabdat-curr-run-id tabdat)) (dboard:tabdat-curr-run-id-set! tabdat run-id) (dboard:tabdat-view-changed-set! tabdat #t)) (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) "treebox")) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) (dboard:tabdat-runs-tree-set! tabdat tb) (iup:detachbox (iup:vbox txtbox tb )))) ;; browse runs as a tree. Used in both "Runs" tab and ;; in the runs control panel. ;; ;; THIS IS THE NEW ONE ;; (define (dboard:runs-tree-new-browser commondat rdat) (let* ((txtbox (iup:textbox #:action (lambda (val a b) (debug:catch-and-dump (lambda () ;; for the Runs view we put the list ;; of keyvals into tabdat target for ;; the Run Controls we put then update ;; the run-command (if b (dboard:rdat-targ-sql-filt-set! rdat (string-split b "/"))) #;(dashboard:update-run-command tabdat)) "command-testname-selector tb action")) ;; #:value (dboard:test-patt->lines ;; This seems like it was wrong, BUG in code where it was copied from? ;; (dboard:tabdat-test-patts-use tabdat)) #:expand "HORIZONTAL" ;; #:size "10x30" )) (tb (iup:treebox #:value 0 #:title "Runs" ;; was #:name -- iup 3.19 changed ;; this... "Changed: [DEPRECATED ;; REMOVED] removed the old attribute ;; NAMEid from IupTree to avoid ;; conflict with the common attribute ;; NAME. Use the TITLEid attribute." #:expand "YES" #:addexpanded "YES" #:size "10x" #:selection-cb (lambda (obj id state) (debug:catch-and-dump (lambda () (let* ((run-path (tree:node->path obj id)) (run-id (new-tree-path->run-id rdat (cdr run-path)))) ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? ;; done below when run-id is a number (dboard:rdat-targ-sql-filt-set! rdat (cdr run-path)) ;; (print ;; "run-path: ;; " ;; run-path) (iup:attribute-set! txtbox "VALUE" (string-intersperse (cdr run-path) "/")) #;(dashboard:update-run-command tabdat) #;(dboard:tabdat-layout-update-ok-set! tabdat #f) (if (number? run-id) (begin ;; capture last two in tabdat. (dboard:rdat-push-run-id rdat run-id) (dboard:rdat-view-changed-set! rdat #t)) (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) "treebox")) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) (dboard:rdat-runs-tree-set! rdat tb) (iup:detachbox (iup:vbox txtbox tb )))) ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== ;; ;; A gui for launching tests ;; |
︙ | ︙ | |||
1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 | ;; ;; display and manage a single run at a time (define (tree-path->run-id tabdat path) (if (not (null? path)) (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) #f)) ;; (define (dboard:get-tests-dat tabdat run-id last-update) ;; (let* ((access-mode (dboard:tabdat-access-mode tabdat)) ;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run ;; run-id ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") ;; (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() | > > > > > | 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 | ;; ;; display and manage a single run at a time (define (tree-path->run-id tabdat path) (if (not (null? path)) (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) #f)) (define (new-tree-path->run-id rdat path) (if (not (null? path)) (hash-table-ref/default (dboard:rdat-path-run-ids tabdat) path #f) #f)) ;; (define (dboard:get-tests-dat tabdat run-id last-update) ;; (let* ((access-mode (dboard:tabdat-access-mode tabdat)) ;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run ;; run-id ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") ;; (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() |
︙ | ︙ | |||
2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 | (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) (iup:attribute-set! obj "MAX" (* maxruns 10)))) #:expand "HORIZONTAL" #:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10)) #:min 0 #:step 0.01)) (define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) (let* ((stats-dat (dboard:tabdat-make-data)) (runs-dat (dboard:tabdat-make-data)) (onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure (runcontrols-dat (dboard:tabdat-make-data)) (runtimes-dat (dboard:tabdat-make-data)) (nruns (dboard:tabdat-numruns runs-dat)) (ntests (dboard:tabdat-num-tests runs-dat)) (keynames (dboard:tabdat-dbkeys runs-dat)) (nkeys (length keynames)) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 | (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) (iup:attribute-set! obj "MAX" (* maxruns 10)))) #:expand "HORIZONTAL" #:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10)) #:min 0 #:step 0.01)) ;; make-simple-run procedure (target3772 id3773 runname3774 state3775 status3776 owner3777 event_time3778) ;; rmt:simple-get-runs procedure (runpatt1001 count1002 offset1003 target1004) ;; simple-run-event_time procedure (x3834) ;; simple-run-event_time-set! procedure (x3830 val3831) ;; simple-run-id procedure (x3794) ;; simple-run-id-set! procedure (x3790 val3791) ;; simple-run-owner procedure (x3826) ;; simple-run-owner-set! procedure (x3822 val3823) ;; simple-run-runname procedure (x3802) ;; simple-run-runname-set! procedure (x3798 val3799) ;; simple-run-state procedure (x3810) ;; simple-run-state-set! procedure (x3806 val3807) ;; simple-run-status procedure (x3818) ;; simple-run-status-set! procedure (x3814 val3815) ;; simple-run-target procedure (x3786) ;; simple-run-target-set! procedure (x3782 val3783) ;; simple-run? procedure (x3780) ;;====================================================================== ;; Extracting the data to display for runs ;; ;; This needs to be re-entrant such that it does one column per call ;; on the zeroeth call update runs data ;; on each subsequent call update one run (configurable - could do two, three ... or update until tdelta exceeded ;; on last run reset to zeroeth ;; ;; 1. select with run filters; area, target, runname, runstate, runstatus, starttime, duration ;; - put this information into two data structures: ;; a. hash of area/target/runname => runstruct #< ordernun, id, area, target, runname, state, ;; status, starttime, duration, non-deleted testcount> ;; ordernum reflects order as received from sql query ;; b. sparsevec of id => runstruct ;; 2. for each run in runshash ordered by ordernum do: ;; retrieve data since last update for that run ;; if there is a deleted test - retrieve full data ;; if there are non-deleted tests register this run in the columns sparsevec ;; if this is the zeroeth column regenerate the rows sparsevec ;; if this column is in the visible zone update visible cells ;; ;; Other factors: ;; 1. left index handling: ;; - add test/itempaths to left index as discovered, re-order and ;; update row -> test/itempath mapping on each read run ;;====================================================================== ;; runs is <vec header runs> ;; get ALL runs info ;; update rdat-targ-run-id ;; update rdat-runs ;; (define (dashboard:update-runs-data rdat) (let* ((tb (dboard:rdat-runs-tree rdat)) (targ-sql-filt (dboard:rdat-targ-sql-filt rdat)) (runname-sql-filt (dboard:rdat-runname-sql-filt rdat)) (state-sql-filt (dboard:rdat-run-state-sql-filt rdat)) (status-sql-filt (dboard:rdat-run-status-sql-filt rdat)) ;; Use (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) (data (rmt:simple-get-runs runname-sql-filt #f #f targ-sql-filt #f)) (numruns (length data))) ;; store in the runsbynum vector (dboard:rdat-runsbynum-set! rdat (list->vector data)) ;; update runs id => runrec ;; update targ-runid target/runname => run-id (for-each (lambda (runrec) (let* ((run-id (simple-run-id runrec)) (full-targ-runname (conc (simple-run-target runrec) "/" (simple-run-runname runrec)))) (debug:print 0 *default-log-port* "Update run " run-id) (sparse-vector-set! (dboard:rdat-runs rdat) run-id runrec) (hash-table-set! (dboard:rdat-targ-runid rdat) full-targ-runname run-id) )) data) numruns)) ;; NOTE: runnum is NOT the run-id, it is a pointer into the runsbynum vector ;; (define (dashboard:update-run-data runnum rdat) (let* ((curr-time (current-seconds)) (runrec (vector-ref (dboard:rdat-runsbynum rdat) runnum)) (run-id (simple-run-id runrec)) (last-update (sparse-vector-ref (dboard:rdat-last-updates rdat) run-id)) ;; filters (testname-sql-filt (dboard:rdat-testname-sql-filt rdat)) ;; (itempath-sql-filt (dboard:rdat-itempath-sql-filt rdat)) (test-state-sql-filt (dboard:rdat-test-state-sql-filt rdat)) ;; not used yet (test-status-sql-filt (dboard:rdat-test-status-sql-filt rdat)) ;; not used yet (tests (rmt:get-tests-for-run-state-status run-id testname-sql-filt last-update ;; last-update ))) (sparse-vector-set! (dboard:rdat-last-updates rdat) run-id (- curr-time 1)) (debug:print 0 *default-log-port* "Got " (length tests) " tests for run-id " run-id " testname-sql-filt " testname-sql-filt " and last-update " last-update) (length tests))) (define (new-runs-updater commondat rdat) (let* ((runnum (dboard:rdat-runnum rdat)) (start-time (current-milliseconds)) (tot-runs #f)) (if (eq? runnum 0)(dashboard:update-runs-data rdat)) (set! tot-runs (vector-length (dboard:rdat-runsbynum rdat))) (let loop ((rn runnum)) (if (and (< (- (current-milliseconds) start-time) 500) (< rn tot-runs)) (let* ((newrn (if (>= runnum (vector-length (dboard:rdat-runsbynum rdat))) 0 ;; start over (+ rn 1)))) ;; (+ runnum 1))) (dashboard:update-run-data rn rdat) (dboard:rdat-runnum-set! rdat newrn) (if (> newrn 0) (loop newrn))))) (if (>= (dboard:rdat-runnum rdat) tot-runs) (dboard:rdat-runnum-set! rdat 0)) ;; (dboard:rdat-runnum-set! rdat rn))) ;; not needed as it is set above ;; (dboard:rdat-last-update-set! rdat (- (current-seconds) 10)) ;; (tree:add-node tb "Runs" (string-split full-targ-runname "/")) '())) (define (dboard:runs-new-matrix commondat rdat) (iup:matrix #:alignment1 "ALEFT" ;; #:expand "YES" ;; "HORIZONTAL" #:scrollbar "YES" #:numcol 10 #:numlin 20 #:numcol-visible 5 ;; (min 8) #:numlin-visible 1 #:click-cb (lambda (obj row col status) (let* ((cell (conc row ":" col))) #f)) )) (define (make-runs-view commondat rdat tab-num) ;; register an updater (dboard:commondat-add-updater commondat (lambda () (new-runs-updater commondat rdat)) tab-num: tab-num) (iup:vbox (iup:split #:orientation "VERTICAL" ;; "HORIZONTAL" #:value 100 (dboard:runs-tree-new-browser commondat rdat) (dboard:runs-new-matrix commondat rdat) ))) (define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat) (let* ((stats-dat (dboard:tabdat-make-data)) (runs-dat (dboard:tabdat-make-data)) (runs2-dat (make-dboard:rdat)) ;; (dboard:tabdat-make-data)) (onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure (runcontrols-dat (dboard:tabdat-make-data)) (runtimes-dat (dboard:tabdat-make-data)) (nruns (dboard:tabdat-numruns runs-dat)) (ntests (dboard:tabdat-num-tests runs-dat)) (keynames (dboard:tabdat-dbkeys runs-dat)) (nkeys (length keynames)) |
︙ | ︙ | |||
2475 2476 2477 2478 2479 2480 2481 | res)) keynames))))) (let loop ((testnum 0) (res '())) (cond ((>= testnum ntests) ;; now lftlst will be an hbox with the test keys and the test name labels | > > > | > | | | | | | | > > | | | | | | | | | 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 | res)) keynames))))) (let loop ((testnum 0) (res '())) (cond ((>= 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 (dboard:tabdat-all-test-names runs-dat))))) (dboard:commondat-please-update-set! commondat #t) (dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10)))) (debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) " (dboard:tabdat-start-test-offset runs-dat) " val: " val " newmax: " newmax " oldmax: " oldmax) (if (< val 10) (iup:attribute-set! obj "MAX" newmax)) )) #:expand "VERTICAL" #:orientation "VERTICAL" #:min 0 #:step 0.01) (apply iup:vbox (reverse res))))))) (else (let ((labl (iup:button "" ;; the testname labels #:flat "YES" #:alignment "ALEFT" ; #:image img1 ; #:impress img2 #:size (conc cell-width btn-height) |
︙ | ︙ | |||
2604 2605 2606 2607 2608 2609 2610 | (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)) (dashboard:runs-horizontal-slider runs-dat)))) controls )) (views-cfgdat (common:load-views-config)) (additional-tabnames '()) | | | 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 | (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)) (dashboard:runs-horizontal-slider runs-dat)))) controls )) (views-cfgdat (common:load-views-config)) (additional-tabnames '()) (tab-start-num 6) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW ;; (data (dboard:tabdat-init (make-d:data))) (additional-views ;; process views-dat (let ((tab-num tab-start-num) (result '())) (for-each (lambda (view-name) (debug:print 0 *default-log-port* "Adding view " view-name) |
︙ | ︙ | |||
2646 2647 2648 2649 2650 2651 2652 | (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) (dboard:commondat-please-update-set! commondat #t) (dboard:tabdat-layout-update-ok-set! tabdat #t))) "tabchangepos")) (dashboard:summary commondat stats-dat tab-num: 0) runs-view | > | | | | | | > | 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 | (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) (dboard:commondat-please-update-set! commondat #t) (dboard:tabdat-layout-update-ok-set! tabdat #t))) "tabchangepos")) (dashboard:summary commondat stats-dat tab-num: 0) runs-view (make-runs-view commondat runs2-dat 2) (dashboard:runs-summary commondat onerun-dat tab-num: 3) ;; (dashboard:new-view db data new-view-dat tab-num: 3) (dashboard:run-controls commondat runcontrols-dat tab-num: 4) (dashboard:run-times commondat runtimes-dat tab-num: 5) ;; (dashboard:runs-summary commondat onerun-dat tab-num: 4) additional-views))) ;; (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" "Runs2") (iup:attribute-set! tabs "TABTITLE3" "Run Summary") (iup:attribute-set! tabs "TABTITLE4" "Run Control") (iup:attribute-set! tabs "TABTITLE5" "Run Times") ;; (iup:attribute-set! tabs "TABTITLE3" "New View") ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") ;; set the tab names for user added tabs (for-each (lambda (tab-info) (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info))) |
︙ | ︙ | |||
3416 3417 3418 3419 3420 3421 3422 | fres)))) (define (dashboard:runs-tab-updater commondat tab-num) (debug:catch-and-dump (lambda () (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)) (dbkeys (dboard:tabdat-dbkeys tabdat))) | < < < < < < < < | 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 | fres)))) (define (dashboard:runs-tab-updater commondat tab-num) (debug:catch-and-dump (lambda () (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)) (dbkeys (dboard:tabdat-dbkeys tabdat))) (dashboard:do-update-rundat tabdat) (let ((uidat (dboard:commondat-uidat commondat))) (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) )) "dashboard:runs-tab-updater")) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== |
︙ | ︙ | |||
3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 | (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) (dboard:commondat-curr-tab-num-set! commondat 0) (dboard:commondat-add-updater commondat (lambda () (dashboard:runs-tab-updater commondat 1)) tab-num: 1) (iup:callback-set! *tim* "ACTION_CB" (lambda (time-obj) (let ((update-is-running #f)) (mutex-lock! (dboard:commondat-update-mutex commondat)) (set! update-is-running (dboard:commondat-updating commondat)) (if (not update-is-running) | > > > > > | 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 | (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) (dboard:commondat-curr-tab-num-set! commondat 0) (dboard:commondat-add-updater commondat (lambda () (dashboard:runs-tab-updater commondat 1)) tab-num: 1) (dboard:commondat-add-updater commondat (lambda () (dashboard:runs-tab-updater commondat 1)) tab-num: 2) (iup:callback-set! *tim* "ACTION_CB" (lambda (time-obj) (let ((update-is-running #f)) (mutex-lock! (dboard:commondat-update-mutex commondat)) (set! update-is-running (dboard:commondat-updating commondat)) (if (not update-is-running) |
︙ | ︙ |
Modified db.scm from [4dafe820e6] to [4b75655ccf].
︙ | ︙ | |||
2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 | (lambda (key) (set! res (cons key res))) db "SELECT fieldname FROM keys ORDER BY id DESC;"))) (set! *db-keys* res) res))) ;; look up values in a header/data structure (define (db:get-value-by-header row header field) (if (or (null? header) (not row)) #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) | > > > > | 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 | (lambda (key) (set! res (cons key res))) db "SELECT fieldname FROM keys ORDER BY id DESC;"))) (set! *db-keys* res) res))) ;; extract index number given a header/data structure (define (db:get-index-by-header header field) (list-index (lambda (x)(equal? x field)) header)) ;; look up values in a header/data structure (define (db:get-value-by-header row header field) (if (or (null? header) (not row)) #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) |
︙ | ︙ | |||
2256 2257 2258 2259 2260 2261 2262 | (define-record simple-run target id runname state status owner event_time) (define-record-printer (simple-run x out) (fprintf out "#,(simple-run ~S ~S ~S ~S)" (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) )))) ;; simple get-runs ;; | | | > > > > | > | 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 | (define-record simple-run target id runname state status owner event_time) (define-record-printer (simple-run x out) (fprintf out "#,(simple-run ~S ~S ~S ~S)" (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) )))) ;; simple get-runs ;; (define (db:simple-get-runs dbstruct runpatt count offset target last-update) (let* ((res '()) (keys (db:get-keys dbstruct)) (runpattstr (db:patt->like "runname" runpatt)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (targstr (string-intersperse keys "||'/'||")) (keystr (conc targstr " AS target," (string-intersperse remfields ","))) (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? " ;; Generate: " AND x LIKE 'keypatt' ..." " AND target LIKE '" target "'" " AND state != 'deleted' " (if (number? last-update) (conc " AND last_update >= " last-update) "") " ORDER BY event_time DESC " (if (number? count) (conc " LIMIT " count) "") (if (number? offset) (conc " OFFSET " offset) ""))) ) (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (target id runname state status owner event_time) (set! res (cons (make-simple-run target id runname state status owner event_time) res))) db |
︙ | ︙ | |||
2870 2871 2872 2873 2874 2875 2876 | (vector-ref inrec 2) ;; testname (vector-ref inrec 4) ;; state (vector-ref inrec 5) ;; status -1 "" -1 -1 "" "-" (vector-ref inrec 3) ;; item-path -1 "-" "-")) | | > > > > > > > > > > > > > > > > > > > > | 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 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 | (vector-ref inrec 2) ;; testname (vector-ref inrec 4) ;; state (vector-ref inrec 5) ;; status -1 "" -1 -1 "" "-" (vector-ref inrec 3) ;; item-path -1 "-" "-")) #;(define (db:get-tests-for-run-state-status dbstruct run-id testpatt) (let* ((res '()) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))) (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (id testname item-path state status) ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) db qry run-id))) res)) (define (db:get-tests-for-run-state-status dbstruct run-id testpatt #!optional (last-update 0)) (let* ((res '()) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE run_id=? " " AND last_update > ? " (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") ))) (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:fold-row (lambda (res id testname item-path state status event-time run-duration) ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (cons (vector id run-id testname state status event-time "" -1 -1 "" "-" item-path run-duration "-" "-") res)) '() db qry run-id (or last-update 0)))))) (define (db:get-testinfo-state-status dbstruct run-id test-id) (let ((res #f)) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (run-id testname item-path state status) |
︙ | ︙ |
Modified rmt.scm from [63fb23d391] to [8ff320805f].
︙ | ︙ | |||
556 557 558 559 560 561 562 563 564 565 566 567 568 569 | ;; (if (number? run-id) (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode))) ;; (begin ;; (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id) ;; (print-call-chain (current-error-port)) ;; '()))) ;; get stuff via synchash (define (rmt:synchash-get run-id proc synckey keynum params) (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params))) (define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in) (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in))) | > > > | 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 | ;; (if (number? run-id) (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode))) ;; (begin ;; (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id) ;; (print-call-chain (current-error-port)) ;; '()))) (define (rmt:get-tests-for-run-state-status run-id testpatt last-update) (rmt:send-receive 'get-tests-for-run-state-status run-id (list run-id testpatt last-update))) ;; get stuff via synchash (define (rmt:synchash-get run-id proc synckey keynum params) (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params))) (define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in) (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in))) |
︙ | ︙ | |||
733 734 735 736 737 738 739 | (define (rmt:delete-old-deleted-test-records) (rmt:send-receive 'delete-old-deleted-test-records #f '())) (define (rmt:get-runs runpatt count offset keypatts) (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) | | | | 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 | (define (rmt:delete-old-deleted-test-records) (rmt:send-receive 'delete-old-deleted-test-records #f '())) (define (rmt:get-runs runpatt count offset keypatts) (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) (define (rmt:simple-get-runs runpatt count offset target last-update) (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target last-update))) (define (rmt:get-all-run-ids) (rmt:send-receive 'get-all-run-ids #f '())) (define (rmt:get-prev-run-ids run-id) (rmt:send-receive 'get-prev-run-ids #f (list run-id))) |
︙ | ︙ |
Modified runs.scm from [6cea658ad9] to [e3f5a06ce2].
︙ | ︙ | |||
2010 2011 2012 2013 2014 2015 2016 | ;; (define (runs:get-hash-by-target target-patts runpatt) (let* ((targets (string-split target-patts ",")) (keys (rmt:get-keys)) (res-ht (make-hash-table))) ;; target -> ( runrecord1 runrecord2 ... ) (for-each (lambda (target-patt) | | | 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 | ;; (define (runs:get-hash-by-target target-patts runpatt) (let* ((targets (string-split target-patts ",")) (keys (rmt:get-keys)) (res-ht (make-hash-table))) ;; target -> ( runrecord1 runrecord2 ... ) (for-each (lambda (target-patt) (let ((runs (rmt:simple-get-runs runpatt #f #f target-patt #f))) (for-each (lambda (run) (let ((target (simple-run-target run))) (hash-table-set! res-ht target (cons run (hash-table-ref/default res-ht target '()))))) runs))) targets) res-ht)) |
︙ | ︙ |