Megatest

Check-in [5e97f11795]
Login
Overview
Comment:Attempt to merge all across.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | v1.70-defunct
Files: files | file ages | folders
SHA1: 5e97f1179511c6d802106381bf6e26e63516ac67
User & Date: mrwellan on 2020-10-04 02:21:13
Other Links: branch diff | manifest | tags
Context
2020-10-04
02:21
Attempt to merge all across. Closed-Leaf check-in: 5e97f11795 user: mrwellan tags: v1.70-defunct
2020-10-03
22:25
Fixed merge related issues. check-in: acb5b0b2be user: mrwellan tags: v1.70-defunct
Changes

Modified db.scm from [900db7dda7] to [2415d6246d].

1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
(define  (db:drop-trigger db tbl-name)
  (let* ((trigger-name (if (equal? tbl-name "test_steps")
			   "update_teststeps_trigger" 
                           (conc "update_" tbl-name "_trigger"))))
    (for-each
     (lambda (key) 
       (if (equal? (car key) trigger-name)
           (sqlite3:execute db (conc "drop trigger if exists " trigger-name))))
     db:trigger-list)))

(define  (db:create-trigger db tbl-name)
      (let* ((trigger-name (if (equal? tbl-name "test_steps")
                              "update_teststeps_trigger" 
                              (conc "update_" tbl-name "_trigger"))))
       (for-each (lambda (key) 







|







1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
(define  (db:drop-trigger db tbl-name)
  (let* ((trigger-name (if (equal? tbl-name "test_steps")
			   "update_teststeps_trigger" 
                           (conc "update_" tbl-name "_trigger"))))
    (for-each
     (lambda (key) 
       (if (equal? (car key) trigger-name)
             (sqlite3:execute db (conc "drop trigger if exists " trigger-name))))
     db:trigger-list)))

(define  (db:create-trigger db tbl-name)
      (let* ((trigger-name (if (equal? tbl-name "test_steps")
                              "update_teststeps_trigger" 
                              (conc "update_" tbl-name "_trigger"))))
       (for-each (lambda (key) 

Modified runs.scm from [c2e599115c] to [c93f22731f].

845
846
847
848
849
850
851

852
853
854
855
856
857
858
					                                    ;;; it has been at least 10 seconds
      (runs:testdat-prereqs-not-met testdat)  ;; return the cached result
      (let* ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: mode itemmaps: itemmaps)))
	(runs:testdat-prereqs-not-met-set! testdat res)
	(runs:testdat-last-update-set! testdat (current-seconds))
	res)))


;;======================================================================
;; runs:expand-items is called by runs:run-tests-queue
;;======================================================================
;;
;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature:
;;    (let loop ((hed         (car sorted-test-names))
;;	         (tal         (cdr sorted-test-names))







>







845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
					                                    ;;; it has been at least 10 seconds
      (runs:testdat-prereqs-not-met testdat)  ;; return the cached result
      (let* ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: mode itemmaps: itemmaps)))
	(runs:testdat-prereqs-not-met-set! testdat res)
	(runs:testdat-last-update-set! testdat (current-seconds))
	res)))

	   
;;======================================================================
;; runs:expand-items is called by runs:run-tests-queue
;;======================================================================
;;
;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature:
;;    (let loop ((hed         (car sorted-test-names))
;;	         (tal         (cdr sorted-test-names))
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
	 (runnables       (runs:calc-runnable prereqs-not-met))
         (unexpanded-prereqs
          (filter (lambda (testname)
                    (let* ((test-rec (hash-table-ref test-records testname))
                           (items       (tests:testqueue-get-items  test-rec)))
                      ;;(BB> "HEY " testname "=>"items)
                      (or (procedure? items)(eq? items 'have-procedure))))
                  waitons))


         )
    (debug:print-info 4 *default-log-port* "START OF INNER COND #2 "
		      "\n can-run-more:    " can-run-more
		      "\n testname:        " hed
		      "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met)
		      "\n non-completed:   " (runs:pretty-string non-completed) 
		      "\n prereq-fails:    " (runs:pretty-string prereq-fails)
		      "\n fails:           " (runs:pretty-string fails)







|
<
<
<







873
874
875
876
877
878
879
880



881
882
883
884
885
886
887
	 (runnables       (runs:calc-runnable prereqs-not-met))
         (unexpanded-prereqs
          (filter (lambda (testname)
                    (let* ((test-rec (hash-table-ref test-records testname))
                           (items       (tests:testqueue-get-items  test-rec)))
                      ;;(BB> "HEY " testname "=>"items)
                      (or (procedure? items)(eq? items 'have-procedure))))
                  waitons)))



    (debug:print-info 4 *default-log-port* "START OF INNER COND #2 "
		      "\n can-run-more:    " can-run-more
		      "\n testname:        " hed
		      "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met)
		      "\n non-completed:   " (runs:pretty-string non-completed) 
		      "\n prereq-fails:    " (runs:pretty-string prereq-fails)
		      "\n fails:           " (runs:pretty-string fails)
1461
1462
1463
1464
1465
1466
1467
1468

1469
1470
1471
1472
1473
1474
1475
   (if (> (length lst) 8)(append (take lst 3)(list "...")) lst))

;;======================================================================
;; runs:run-tests-queue is called by runs:run-tests
;;======================================================================
;;
;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... >
(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry)

  ;; At this point the list of parent tests is expanded 
  ;; NB// Should expand items here and then insert into the run queue.
  (debug:print 5 *default-log-port* "test-records: " test-records ", flags: " (hash-table->alist flags))

  ;; Do mark-and-find clean up of db before starting runing of quue
  ;;
  ;; (rmt:find-and-mark-incomplete)







|
>







1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
   (if (> (length lst) 8)(append (take lst 3)(list "...")) lst))

;;======================================================================
;; runs:run-tests-queue is called by runs:run-tests
;;======================================================================
;;
;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... >
(define (runs:run-tests-queue run-id runname test-records keyvals flags
			      test-patts required-tests reglen-in all-tests-registry)
  ;; At this point the list of parent tests is expanded 
  ;; NB// Should expand items here and then insert into the run queue.
  (debug:print 5 *default-log-port* "test-records: " test-records ", flags: " (hash-table->alist flags))

  ;; Do mark-and-find clean up of db before starting runing of quue
  ;;
  ;; (rmt:find-and-mark-incomplete)
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687


1688
1689
1690
1691
1692
1693
1694
1695
1696
	 ;; 
	 ((not items)
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-2")
	  (debug:print-info 4 *default-log-port* "OUTER COND: (not items)")
	  (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests))
		   (not (null? tal)))
	      (loop (car tal)(cdr tal) reg reruns))

	  ;; gonna try a strategy change here.
	  ;;
	  ;; check if can run more tests. if yes, continue, if no, rest until can run more


	  ;; look at the test jobgroup and tot jobs running
	  ;;
	  ;; NOTE: This does NOT actually gate here, only captures the proc to be called later
	  ;; 
	  (if (not (runs:dat-wait-for-jobs-function runsdat))
	      (runs:dat-wait-for-jobs-function-set!
	       runsdat 
	       (lambda (testdat-in)
		 (let* ((jobgroup              (runs:testdat-jobgroup testdat-in))







|
|
<
|
>
>
|
<







1676
1677
1678
1679
1680
1681
1682
1683
1684

1685
1686
1687
1688

1689
1690
1691
1692
1693
1694
1695
	 ;; 
	 ((not items)
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-2")
	  (debug:print-info 4 *default-log-port* "OUTER COND: (not items)")
	  (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests))
		   (not (null? tal)))
	      (loop (car tal)(cdr tal) reg reruns))
      ;; side effect is to save the prereqs in the struct
	  (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path

					 mode: testmode
					 itemmaps: itemmaps)
      ;; not sure why this used to be here
      ;; (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running

	  ;; NOTE: This does NOT actually gate here, only captures the proc to be called later
	  ;; 
	  (if (not (runs:dat-wait-for-jobs-function runsdat))
	      (runs:dat-wait-for-jobs-function-set!
	       runsdat 
	       (lambda (testdat-in)
		 (let* ((jobgroup              (runs:testdat-jobgroup testdat-in))
1798
1799
1800
1801
1802
1803
1804
1805

1806
1807
1808
1809
1810
1811
1812
         
	 ;; if items is a proc then need to run items:get-items-from-config, get the list and loop 
	 ;;    - but only do that if resources exist to kick off the job
	 ;; EXPAND ITEMS
	 ((or (procedure? items)(eq? items 'have-procedure))
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-4")
	  (let ((can-run-more    #f)) ;; (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)))
	    (if (not can-run-more) #;(and (list? can-run-more) ;; IDEA, this mechanism may have had some value, make it configurable to test pros/cons TODO

		(car can-run-more))
		(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs
						    run-id waitons item-path testmode test-record
						    can-run-more items runname tconfig reglen test-registry
						    test-records itemmaps testdat)))
		  (if loop-list
		      (apply loop loop-list)







|
>







1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
         
	 ;; if items is a proc then need to run items:get-items-from-config, get the list and loop 
	 ;;    - but only do that if resources exist to kick off the job
	 ;; EXPAND ITEMS
	 ((or (procedure? items)(eq? items 'have-procedure))
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-4")
	  (let ((can-run-more    #f)) ;; (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)))
	    (if (not can-run-more) #;(and (list? can-run-more) ;; IDEA, this mechanism may have had some value,
		                                               ;;; make it configurable to test pros/cons TODO
		(car can-run-more))
		(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs
						    run-id waitons item-path testmode test-record
						    can-run-more items runname tconfig reglen test-registry
						    test-records itemmaps testdat)))
		  (if loop-list
		      (apply loop loop-list)