Megatest

Diff
Login

Differences From Artifact [e77bf1baa0]:

To Artifact [c9b27c71eb]:


518
519
520
521
522
523
524
525



526
527
528
529
530
531
532
518
519
520
521
522
523
524

525
526
527
528
529
530
531
532
533
534







-
+
+
+








    ;; Ensure all tests are registered in the test_meta table
    (runs:update-all-test_meta #f)

    ;; run the run prehook if there are no tests yet run for this run:
    ;;
    (runs:run-pre-hook run-id)
    
    ;; mark all test launced flag as false in the meta table 
    (rmt:set-var (conc "lunch-complete-" run-id) "no")
    (rmt:set-run-state-status run-id "new" "n/a")
    ;; now add non-directly referenced dependencies (i.e. waiton)
    ;;======================================================================
    ;; refactoring this block into tests:get-full-data
    ;;
    ;; What happended, this code is now duplicated in tests!?
    ;;
    ;;======================================================================
672
673
674
675
676
677
678
679
680
681
682
683
684






685
686
687
688
689
690
691
674
675
676
677
678
679
680






681
682
683
684
685
686
687
688
689
690
691
692
693







-
-
-
-
-
-
+
+
+
+
+
+







		  (if (not (hash-table-ref/default flags "-rerun" #f))
		      (hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS"))
		  ;; recursive call to self
      (runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))))
	  (debug:print-info 0 *default-log-port* "No tests to run")))
    (debug:print-info 4 *default-log-port* "All done by here")
    ;; TODO: try putting post hook call here
    (if (eq? run-count 0)
     (begin  
      (debug:print-info 0 *default-log-port* "Calling Post Hook")  
      (debug:print-info 2 *default-log-port* " run-count " run-count)
      (runs:run-post-hook run-id))
      (debug:print-info 2 *default-log-port* "Not calling post hook runcount = " run-count ))   
    ;(if (eq? run-count 0)
    ; (begin  
    ;  (debug:print-info 0 *default-log-port* "Calling Post Hook")  
    ;  (debug:print-info 2 *default-log-port* " run-count " run-count)
    ;  (runs:run-post-hook run-id))
    ;  (debug:print-info 2 *default-log-port* "Not calling post hook runcount = " run-count ))   
    (rmt:tasks-set-state-given-param-key task-key "done")
    ;; (sqlite3:finalize! tasks-db)
    ))


;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable.
;;
1645
1646
1647
1648
1649
1650
1651


1652

1653
1654
1655
1656
1657
1658
1659
1647
1648
1649
1650
1651
1652
1653
1654
1655

1656
1657
1658
1659
1660
1661
1662
1663







+
+
-
+







          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-8")
	  (debug:print-info 0 *default-log-port* "Have leftovers!")
	  (loop (car reg)(cdr reg) '() reruns))
	 (else
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-9")
	  (debug:print-info 4 *default-log-port* "Exiting loop with...\n  hed=" hed "\n  tal=" tal "\n  reruns=" reruns))
	 ))) ;; end loop on sorted test names
    ;; this is the point where everything is launced and now you can mark the run in metadata table as all launced 
    (rmt:set-var (conc "lunch-complete-" run-id) "yes")
    
  
    ;; now *if* -run-wait we wait for all tests to be done
    ;; Now wait for any RUNNING tests to complete (if in run-wait mode)
    (thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle
    (let wait-loop ((num-running      (rmt:get-count-tests-running-for-run-id run-id))
		    (prev-num-running 0))
      ;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running)
      (if (and (or (args:get-arg "-run-wait")
2005
2006
2007
2008
2009
2010
2011
2012




2013
2014
2015
2016
2017
2018
2019
2009
2010
2011
2012
2013
2014
2015

2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026







-
+
+
+
+







		   (lambda (action)
		     (case action
		       ((print)
			(print " " (simple-run-runname run)
			       " " (time->string (seconds->local-time (simple-run-event_time run)) "WW%V.%u %H:%M:%S")
			       " " (if remove "REMOVE" "")))
		       ((remove-runs)
			(if remove (system (conc precmd " megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %"))))
			(if remove (system (conc precmd " megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %"
						 (if (member 'kill-runs actions) ;; if kill-runs is specified then set -kill-wait to 0
						     " -kill-wait 0"
						     "")))))
		       ((archive)
			(if remove (system (conc precmd " megatest -archive save-remove -target " target " -runname " (simple-run-runname run) " -testpatt %"))))
		       ((kill-runs)
			(if remove (system (conc precmd " megatest -kill-runs -target " target " -runname " (simple-run-runname run) " -testpatt %"))))
			))
		   actions))))
          sorted)))
2142
2143
2144
2145
2146
2147
2148
2149

2150
2151
2152
2153
2154
2155
2156
2149
2150
2151
2152
2153
2154
2155

2156
2157
2158
2159
2160
2161
2162
2163







-
+







									 (> (string-length dira)(string-length dirb))
									 #f))))))
		       (toplevel-retries (make-hash-table)) ;; try three times to loop through and remove top level tests
		       (test-retry-time  (make-hash-table))
                       (backgrounded-remove-status     (make-hash-table))
                       (backgrounded-remove-last-visit (make-hash-table))
                       (backgrounded-remove-result     (make-hash-table))
		       (allow-run-time   10)) ;; seconds to allow for killing tests before just brutally killing 'em
		       (allow-run-time   (string->number (or (args:get-arg "-kill-wait") "10")))) ;; seconds to allow for killing tests before just brutally killing 'em
		   (let loop ((test (car sorted-tests))
			      (tal  (cdr sorted-tests)))
		     (let* ((test-id       (db:test-get-id test))
			    (new-test-dat  (rmt:get-test-info-by-id run-id test-id)))
		       (if (not new-test-dat)
			   (begin
			     (debug:print-error 0 *default-log-port* "We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!")
2489
2490
2491
2492
2493
2494
2495
2496




2497
2498

2499

2500
2501


2502

2503
2504
2505
2506
2507
2508
2509
2496
2497
2498
2499
2500
2501
2502

2503
2504
2505
2506
2507
2508
2509

2510
2511

2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522







-
+
+
+
+


+
-
+

-
+
+

+








(define (runs:handle-locking target keys runname lock unlock user)
  (let* ((db       #f)
	 (rundat   (mt:get-runs-by-patt keys runname target))
	 (header   (vector-ref rundat 0))
	 (runs     (vector-ref rundat 1)))
    (for-each (lambda (run)
		(let ((run-id (db:get-value-by-header run header "id")))
		(let ((run-id (db:get-value-by-header run header "id"))
           (str (if lock 
									"lock"
                  "unlock")))
		  (if (or lock
			  (and unlock
			       (or (args:get-arg "-force")
			       (begin
                (begin
				 (print "Do you really wish to unlock run " run-id "?\n   y/n: ")
				 (equal? "y" (read-line)))))
				 (equal? "y" (read-line))))))
          (begin 
		      (rmt:lock/unlock-run run-id lock unlock user)
					(debug:print-info 0 *default-log-port* "Done " str " on run id " run-id))
		      (debug:print-info 0 *default-log-port* "Skipping lock/unlock on " run-id))))
	      runs)))
;;======================================================================
;; Rollup runs
;;======================================================================

;; Update the test_meta table for this test