| ︙ | | |
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)))
(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)
|
| ︙ | | |