Megatest

Diff
Login

Differences From Artifact [628e641bd0]:

To Artifact [5623f426f2]:


537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556





557
558
559
560
561
562
563
564
565
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
614
615
      (let loop ((hed (car test-names))
		 (tal (cdr test-names)))         ;; 'return-procs tells the config reader to prep running system but return a proc
	(debug:print-info 4 "hed=" hed " at top of loop")
	(let* ((config  (tests:get-testconfig hed 'return-procs))
	       (waitons (let ((instr (if config 
					 (config-lookup config "requirements" "waiton")
					 (begin ;; No config means this is a non-existant test
					   (debug:print 0 "ERROR: non-existent required test \"" hed "\"")
					   (if db (sqlite3:finalize! db))
					   (exit 1)))))
			  (debug:print-info 8 "waitons string is " instr)
			  (string-split (cond
					 ((procedure? instr)
					  (let ((res (instr)))
					    (debug:print-info 8 "waiton procedure results in string " res " for test " hed)
					    res))
					 ((string? instr)     instr)
					 (else 
					  ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed)
					  ""))))))





	  (debug:print-info 8 "waitons: " waitons)
	  ;; check for hed in waitons => this would be circular, remove it and issue an
	  ;; error
	  (if (member hed waitons)
	      (begin
		(debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!")
		(set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))))
	  
	  ;; (items   (items:get-items-from-config config)))
	  (if (not (hash-table-ref/default test-records hed #f))
	      (hash-table-set! test-records
			       hed (vector hed     ;; 0
					   config  ;; 1
					   waitons ;; 2
					   (config-lookup config "requirements" "priority")     ;; priority 3
					   (let ((items      (hash-table-ref/default config "items" #f)) ;; items 4
						 (itemstable (hash-table-ref/default config "itemstable" #f))) 
					     ;; if either items or items table is a proc return it so test running
					     ;; process can know to call items:get-items-from-config
					     ;; if either is a list and none is a proc go ahead and call get-items
					     ;; otherwise return #f - this is not an iterated test
					     (cond
					      ((procedure? items)      
					       (debug:print-info 4 "items is a procedure, will calc later")
					       items)            ;; calc later
					      ((procedure? itemstable)
					       (debug:print-info 4 "itemstable is a procedure, will calc later")
					       itemstable)       ;; calc later
					      ((filter (lambda (x)
							 (let ((val (car x)))
							   (if (procedure? val) val #f)))
						       (append (if (list? items) items '())
							       (if (list? itemstable) itemstable '())))
					       'have-procedure)
					      ((or (list? items)(list? itemstable)) ;; calc now
					       (debug:print-info 4 "items and itemstable are lists, calc now\n"
								 "    items: " items " itemstable: " itemstable)
					       (items:get-items-from-config config))
					      (else #f)))                           ;; not iterated
					   #f      ;; itemsdat 5
					   #f      ;; spare - used for item-path
					   )))
	  (for-each 
	   (lambda (waiton)
	     (if (and waiton (not (member waiton test-names)))
		 (begin
		   (set! required-tests (cons waiton required-tests))
		   (set! test-names (cons waiton test-names))))) ;; was an append, now a cons
	   waitons)
	  (let ((remtests (delete-duplicates (append waitons tal))))
	    (if (not (null? remtests))
		(loop (car remtests)(cdr remtests))))))))


;;======================================================================
;; test steps
;;======================================================================

;; teststep-set-status! used to be here








|
<
|










>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>







537
538
539
540
541
542
543
544

545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
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
614
615
616
617
618
619
620
      (let loop ((hed (car test-names))
		 (tal (cdr test-names)))         ;; 'return-procs tells the config reader to prep running system but return a proc
	(debug:print-info 4 "hed=" hed " at top of loop")
	(let* ((config  (tests:get-testconfig hed 'return-procs))
	       (waitons (let ((instr (if config 
					 (config-lookup config "requirements" "waiton")
					 (begin ;; No config means this is a non-existant test
					   (debug:print 0 "ERROR: non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.")

					     ""))))
			  (debug:print-info 8 "waitons string is " instr)
			  (string-split (cond
					 ((procedure? instr)
					  (let ((res (instr)))
					    (debug:print-info 8 "waiton procedure results in string " res " for test " hed)
					    res))
					 ((string? instr)     instr)
					 (else 
					  ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed)
					  ""))))))
	  (if (not config) ;; this is a non-existant test called in a waiton. 
	      (if (null? tal)
		  test-records
		  (loop (car tal)(cdr tal)))
	      (begin
		(debug:print-info 8 "waitons: " waitons)
		;; check for hed in waitons => this would be circular, remove it and issue an
		;; error
		(if (member hed waitons)
		    (begin
		      (debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!")
		      (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))))
		
		;; (items   (items:get-items-from-config config)))
		(if (not (hash-table-ref/default test-records hed #f))
		    (hash-table-set! test-records
				     hed (vector hed     ;; 0
						 config  ;; 1
						 waitons ;; 2
						 (config-lookup config "requirements" "priority")     ;; priority 3
						 (let ((items      (hash-table-ref/default config "items" #f)) ;; items 4
						       (itemstable (hash-table-ref/default config "itemstable" #f))) 
						   ;; if either items or items table is a proc return it so test running
						   ;; process can know to call items:get-items-from-config
						   ;; if either is a list and none is a proc go ahead and call get-items
						   ;; otherwise return #f - this is not an iterated test
						   (cond
						    ((procedure? items)      
						     (debug:print-info 4 "items is a procedure, will calc later")
						     items)            ;; calc later
						    ((procedure? itemstable)
						     (debug:print-info 4 "itemstable is a procedure, will calc later")
						     itemstable)       ;; calc later
						    ((filter (lambda (x)
							       (let ((val (car x)))
								 (if (procedure? val) val #f)))
							     (append (if (list? items) items '())
								     (if (list? itemstable) itemstable '())))
						     'have-procedure)
						    ((or (list? items)(list? itemstable)) ;; calc now
						     (debug:print-info 4 "items and itemstable are lists, calc now\n"
								       "    items: " items " itemstable: " itemstable)
						     (items:get-items-from-config config))
						    (else #f)))                           ;; not iterated
						 #f      ;; itemsdat 5
						 #f      ;; spare - used for item-path
						 )))
		(for-each 
		 (lambda (waiton)
		   (if (and waiton (not (member waiton test-names)))
		       (begin
			 (set! required-tests (cons waiton required-tests))
			 (set! test-names (cons waiton test-names))))) ;; was an append, now a cons
		 waitons)
		(let ((remtests (delete-duplicates (append waitons tal))))
		  (if (not (null? remtests))
		      (loop (car remtests)(cdr remtests))
		      test-records))))))))

;;======================================================================
;; test steps
;;======================================================================

;; teststep-set-status! used to be here