Overview
Comment: | Print more info on pkts |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.65-use-pkts |
Files: | files | file ages | folders |
SHA1: |
28180638092e299bc395f956dfd940a1 |
User & Date: | matt on 2017-05-22 00:09:11 |
Other Links: | branch diff | manifest | tags |
Context
2017-05-25
| ||
08:56 | Dump pkts on processing configs IFF have parent (i.e. are in a server) check-in: ebd66b0fd3 user: matt tags: v1.65-use-pkts | |
2017-05-22
| ||
00:09 | Print more info on pkts check-in: 2818063809 user: matt tags: v1.65-use-pkts | |
2017-05-21
| ||
22:26 | Merged use-pkts into v1.65-use-pkts check-in: b50b384047 user: matt tags: v1.65-use-pkts | |
Changes
Modified common.scm from [5a1029146c] to [f5e4dc88a2].
︙ | ︙ | |||
2337 2338 2339 2340 2341 2342 2343 | (target . t) (status . u) (parent . P))))) (define (common:get-pkts-dirs mtconf use-lt) (let* ((pktsdirs-str (or (configf:lookup mtconf "setup" "pktsdirs") (and use-lt | > > | | 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 | (target . t) (status . u) (parent . P))))) (define (common:get-pkts-dirs mtconf use-lt) (let* ((pktsdirs-str (or (configf:lookup mtconf "setup" "pktsdirs") (and use-lt (conc (or *toppath* (current-directory)) "/lt/.pkts")))) (pktsdirs (if pktsdirs-str (string-split pktsdirs-str " ") #f))) pktsdirs)) (define (common:save-pkt pktalist-in mtconf use-lt) (let* ((parent (hash-table-ref/default *pkts-info* 'last-parent #f)) |
︙ | ︙ | |||
2379 2380 2381 2382 2383 2384 2385 | (print "ERROR: settings are missing in your megatest.config for area management.") (print " you need to have pktsdir in the [setup] section.")) (let* ((pdb (open-queue-db pdbpath "pkts.db" schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));")))) (proc pktsdirs pktsdir pdb) (dbi:close pdb))))) | | | 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 | (print "ERROR: settings are missing in your megatest.config for area management.") (print " you need to have pktsdir in the [setup] section.")) (let* ((pdb (open-queue-db pdbpath "pkts.db" schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));")))) (proc pktsdirs pktsdir pdb) (dbi:close pdb))))) (define (common:load-pkts-to-db mtconf #!key (use-lt #f)) (common:with-queue-db mtconf (lambda (pktsdirs pktsdir pdb) (for-each (lambda (pktsdir) ;; look at all (if (and (file-exists? pktsdir) (directory? pktsdir) |
︙ | ︙ | |||
2404 2405 2406 2407 2408 2409 2410 | (apkt (pkt->alist pktdat)) (ptype (alist-ref 'T apkt))) (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0) (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue")) (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...") ))) pkts)))) | | > | 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 | (apkt (pkt->alist pktdat)) (ptype (alist-ref 'T apkt))) (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0) (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue")) (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...") ))) pkts)))) pktsdirs)) use-lt: use-lt)) (define (common:get-pkt-alists pkts) (map (lambda (x) (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt pkts)) ;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending |
︙ | ︙ |
Modified mtut.scm from [0743b2c74c] to [88cf3f259e].
︙ | ︙ | |||
112 113 114 115 116 117 118 119 120 121 122 123 124 125 | remove : remove runs rerun : register action for processing set-ss : set state/status archive : compress and move test data to archive disk kill : stop tests or entire runs db : database utilities areas, contours, setup : show areas, contours or setup section from megatest.config Contour actions: process : runs import, rungen and dispatch Selectors -immediate : apply this action immediately, default is to queue up actions -area areapatt1,area2... : apply this action only to the specified areas | > | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 | remove : remove runs rerun : register action for processing set-ss : set state/status archive : compress and move test data to archive disk kill : stop tests or entire runs db : database utilities areas, contours, setup : show areas, contours or setup section from megatest.config gendot : generate a graphviz dot file from pkts. Contour actions: process : runs import, rungen and dispatch Selectors -immediate : apply this action immediately, default is to queue up actions -area areapatt1,area2... : apply this action only to the specified areas |
︙ | ︙ | |||
994 995 996 997 998 999 1000 | (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))) | > | | > | 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 | (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 ... (common:with-queue-db mtconf (lambda (pktsdirs pktsdir conn) (make-report "out.dot" conn common:pkts-spec '(action ipaddr port) )) use-lt: #t))) ((db) (if (null? remargs) (print "ERROR: missing sub command for db command") (let ((subcmd (car remargs))) (case (string->symbol subcmd) ((pgschema) (let* ((install-home (common:get-install-area)) |
︙ | ︙ | |||
1041 1042 1043 1044 1045 1046 1047 | (current-input-port (make-readline-port "mtutil> ")) (if (args:get-arg "-repl") (repl) (load (args:get-arg "-load"))))) #| (define mtconf (car (simple-setup #f))) | | | 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 | (current-input-port (make-readline-port "mtutil> ")) (if (args:get-arg "-repl") (repl) (load (args:get-arg "-load"))))) #| (define mtconf (car (simple-setup #f))) (define dat (common:with-queue-db mtconf (lambda (conn)(get-pkts conn '())))) (pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed)) |# |