Megatest

Diff
Login

Differences From Artifact [175a9dda52]:

To Artifact [86a3c3c964]:


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
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







-
-
+
+



-
-
-
-
+
+
+
+















-
+







;; collect, translate, collate and assemble a pkt from the command-line
;;
;; sched => force the run start time to be recorded as sched Unix
;; epoch. This aligns times properly for triggers in some cases.
;;
;;  extra-dat format is ( 'x xval 'y yval .... )
;;
(define (command-line->pkt action args-alist sched-in #!key (extra-dat '())(area-path #f)(new-ss #f))
   (let* ((sched     (cond
(define (command-line->pkt action args-alist sched-in #!key (extra-dat '())(area-path #f)(new-ss #f)(log-port (current-error-port)))
  (let* ((sched     (cond
		     ((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time
		     ((number? sched-in) sched-in)
		     (else     (current-seconds))))
   (user  (if (and args-alist (hash-table? args-alist))
              (hash-table-ref/default args-alist "-override-user" (current-user-name))
						  (current-user-name)))
                    
	 (user  (if (and args-alist (hash-table? args-alist))
		    (hash-table-ref/default args-alist "-override-user" (current-user-name))
		    (current-user-name)))
	 
	 (args-data (if args-alist
			(if (hash-table? args-alist) ;; seriously?
			    (hash-table->alist args-alist)
			    args-alist)
			(hash-table->alist args:arg-hash))) ;; if no args-alist then we assume this is a call driven directly by commandline
	 (alldat    (apply append
			   (list 'A action
				 'U user
				 'D sched)
			   (if area-path
			       (list 'S area-path) ;; the area-path is mapped to the start-dir
			       '())
                           (if (list? extra-dat)
			       extra-dat
			       (begin
				 (debug:print 0 *default-log-port* "ERROR: command-line->pkt received bad extra-dat " extra-dat)
				 (debug-print 0 log-port "ERROR: command-line->pkt received bad extra-dat " extra-dat)
				 '()))
			   (map (lambda (x)
				  (let* ((param (car x))
					 (value (cdr x))
					 (pmeta (assoc param *arg-keys*))    ;; translate the card key to a megatest switch or parameter
					 (smeta (assoc param *switch-keys*)) ;; first lookup the key in arg-keys or switch-keys
					 (meta  (if (or pmeta smeta)
601
602
603
604
605
606
607
608

609
610
611
612
613
614
615
601
602
603
604
605
606
607

608
609
610
611
612
613
614
615







-
+







    ;(exit)
    (add-z-card
     (apply construct-sdat alldat))))

(define (simple-setup start-dir-in)
  (let* ((start-dir (or start-dir-in "."))
	 (mtconfig  (or (args:get-arg "-config") "megatest.config"))
	 (mtconfdat (find-and-read-config        ;; NB// sets MT_RUN_AREA_HOME as side effect
	 (mtconfdat (configf:find-and-read-config        ;; NB// sets MT_RUN_AREA_HOME as side effect
		     mtconfig
		     ;; environ-patt: "env-override"
		     given-toppath: start-dir
		     ;; pathenvvar: "MT_RUN_AREA_HOME"
		     ))
	 (mtconf    (if mtconfdat (car mtconfdat) #f)))
    ;; we set some dynamic data in a section called "scratchdata"
738
739
740
741
742
743
744
745



746
747


748
749

750
751
752
753
754
755
756
738
739
740
741
742
743
744

745
746
747
748

749
750
751

752
753
754
755
756
757
758
759







-
+
+
+

-
+
+

-
+







	  (print pkt))))))

;; (use trace)(trace create-run-pkt)

;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (generate-run-pkts mtconf toppath)
  (let ((std-runname (conc "sched"  (time->string (seconds->local-time (current-seconds)) "%M%H%d"))))
  (let ((std-runname   (conc "sched"  (time->string (seconds->local-time (current-seconds)) "%M%H%d")))
	(pktsdir-str   (configf:lookup mtconf "scratchdat" "toppath"))
	(setup-pdbpath (configf:lookup mtconf "setup"  "pdbpath")))
    (common:with-queue-db
     mtconf
     pktsdir-str
     setup-pdbpath
     (lambda (pktsdirs pktsdir pdb)
       (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
       (let* ((rgconfdat (configf:find-and-read-config (conc toppath "/runconfigs.config")))
	      (rgconf    (car rgconfdat))
	      (all-areas (map car (configf:get-section mtconf "areas")))
	      (contours  (configf:get-section mtconf "contours"))
	      (torun     (make-hash-table)) ;; target => ( ... info ... )
	      (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering

	 (print "rgentargs: " rgentargs)
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
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
1135
1136
1137
1138







-
+









-
+


-
+
+
+

-
+
+

-
+







	  (print pkt)))
      (print "ERROR: cannot process commands without a pkts directory")))

;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (dispatch-commands mtconf toppath)
  ;; we are expecting a directory "logs", check and create it, create the log in /tmp if not able to create logs dir
  (let ((logdir
  (let* ((logdir
	 (if (if (not (directory? "logs"))
		 (handle-exceptions
		     exn
		     #f
		   (create-directory "logs")
		   #t)
		 #t)
	     "logs"
	     "/tmp"))
	(cpuload (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)))
	(cpuload (alist-ref 'adj-proc-load (common:get-normalized-cpu-load logdir #f)))
	(maxload (string->number (or (configf:lookup mtconf "setup" "maxload")
				     (configf:lookup mtconf "jobtools" "maxload") ;; respect value used by Megatest calls
				     "1.1"))))
				     "1.1")))
	(pktsdir-str   (configf:lookup mtconf "scratchdat" "toppath"))
	(setup-pdbpath (configf:lookup mtconf "setup"  "pdbpath")))
    (common:with-queue-db
     mtconf
     pktsdir-str
     setup-pdbpath
     (lambda (pktsdirs pktsdir pdb)
       (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
       (let* ((rgconfdat (configf:find-and-read-config (conc toppath "/runconfigs.config")))
	      (rgconf    (car rgconfdat))
	      (areas     (configf:get-section mtconf "areas"))
	      (contours  (configf:get-section mtconf "contours"))
	      (pkts      (find-pkts pdb '(cmd) '()))
	      (torun     (make-hash-table)) ;; target => ( ... info ... )
	      (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
	 (for-each
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
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







-
+
+
+


-
+

-
+

-
+



















-
-
+
+
+
+

-
+
+







	 ;;  (hash-table-keys adjargs))
	 (let-values (((uuid pkt)
		       (command-line->pkt *action* adjargs #f area-path: area-path new-ss: new-ss)))
	   (write-pkt pktsdir uuid pkt))))
      ((dispatch import rungen process)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (toppath   (configf:lookup mtconf "scratchdat" "toppath")))
	      (toppath   (configf:lookup mtconf "scratchdat" "toppath"))
	      (pktsdir-str   (or (configf:lookup mtconf "scratchdat" "toppath")(configf:lookup mtconf "setup" "pktsdir")))
	      (setup-pdbpath (configf:lookup mtconf "setup"  "pdbpath")))
	 (case (string->symbol *action*)
	   ((process)  (begin
			 (common:load-pkts-to-db mtconf)
			 (common:load-pkts-to-db pktsdir-str setup-pdbpath)
			 (generate-run-pkts mtconf toppath)
			 (common:load-pkts-to-db mtconf)
			 (common:load-pkts-to-db pktsdir-str setup-pdbpath)
			 (dispatch-commands mtconf toppath)))
	   ((import)   (common:load-pkts-to-db mtconf)) ;; import pkts
	   ((import)   (common:load-pkts-to-db pktsdir-str setup-pdbpath)) ;; import pkts
	   ((rungen)   (generate-run-pkts mtconf toppath))
	   ((dispatch) (dispatch-commands mtconf toppath)))))
      ;; misc
      ((show)
       (if (> (length remargs) 0)
	   (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
		  (mtconf    (car mtconfdat))
		  (sect-dat (configf:get-section mtconf (car remargs))))
	     (if sect-dat
		 (for-each
		  (lambda (entry)
		    (if (> (length entry) 1)
			(print (car entry) "   " (cadr entry))
			(print (car entry))))
		  sect-dat)
		 (print "No section \"" (car remargs) "\" found")))
	   (print "ERROR: list requires section parameter; areas, setup or contours")))
      ((gendot)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat)))
	 (common:load-pkts-to-db mtconf use-lt: #t) ;; need to NOT do this by default ...
	      (mtconf    (car mtconfdat))
	      (pktsdir-str   (configf:lookup mtconf "scratchdat" "toppath"))
	      (setup-pdbpath (configf:lookup mtconf "setup"  "pdbpath")))
	 (common:load-pkts-to-db pktsdir-str setup-pdbpath use-lt: #t) ;; need to NOT do this by default ...
	 (common:with-queue-db
	  mtconf
	  pktsdir-str
	  setup-pdbpath
	  (lambda (pktsdirs pktsdir conn)
	    ;;                       pktspec display-fields 
	    (make-report "out.dot" conn
			 '((cmd      . ((parent . P)
					(user   . M)
					(target . t)))
			   (runstart . ((parent . P)