424
425
426
427
428
429
430
431
432
433
434
435
436
437
|
(if (>= *verbosity* 1)(pp allitems))
(if (>= *verbosity* 5)
(begin
(print "items: ")(pp (item-assoc->item-list items))
(print "itestable: ")(pp (item-table->item-list itemstable))))
(if (args:get-arg "-m")
(db:set-comment-for-run db run-id (args:get-arg "-m")))
;; braindead work-around for poorly specified allitems list BUG!!! FIXME
(if (null? allitems)(set! allitems '(())))
(let loop ((itemdat (car allitems))
(tal (cdr allitems)))
;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
;; Handle lists of items
(let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/"))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
|
(if (>= *verbosity* 1)(pp allitems))
(if (>= *verbosity* 5)
(begin
(print "items: ")(pp (item-assoc->item-list items))
(print "itestable: ")(pp (item-table->item-list itemstable))))
(if (args:get-arg "-m")
(db:set-comment-for-run db run-id (args:get-arg "-m")))
;; Here is where the test_meta table is best updated
(let ((currrecord (db:testmeta-get-record db test-name)))
(if (not currrecord)
(begin
(set! currrecord (make-vector 10 #f))
(db:testmeta-add-record db test-name)))
(for-each
(lambda (key)
(let* ((idx (cadr key))
(fld (car key))
(val (config-lookup test-conf "test_meta" fld)))
(if (and val (not (equal? (vector-ref currrecord idx) val)))
(begin
(print "Updating " test-name " " fld " to " val)
(db:testmeta-update-field db test-name fld val)))))
'(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))
;; braindead work-around for poorly specified allitems list BUG!!! FIXME
(if (null? allitems)(set! allitems '(())))
(let loop ((itemdat (car allitems))
(tal (cdr allitems)))
;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
;; Handle lists of items
(let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/"))
|
631
632
633
634
635
636
637
|
;; (if (null? (glob (conc runpath "/*")))
;; (begin
;; (debug:print 1 "Removing run dir " runpath)
;; (system (conc "rmdir -p " runpath))))
))))
))
runs)))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
|
;; (if (null? (glob (conc runpath "/*")))
;; (begin
;; (debug:print 1 "Removing run dir " runpath)
;; (system (conc "rmdir -p " runpath))))
))))
))
runs)))
;;======================================================================
;; Routines for manipulating runs
;;======================================================================
;; Since many calls to a run require pretty much the same setup
;; this wrapper is used to reduce the replication of code
(define (general-run-call switchname action-desc proc)
(if (not (args:get-arg ":runname"))
(begin
(debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname")
(exit 2))
(let ((db #f))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! db (open-db))
(if (not (car *configinfo*))
(begin
(debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found")
(exit 1))
;; Extract out stuff needed in most or many calls
;; here then call proc
(let* ((keys (db-get-keys db))
(keynames (map key:get-fieldname keys))
(keyvallst (keys->vallist keys #t)))
(proc db keys keynames keyvallst)))
(sqlite3:finalize! db)
(set! *didsomething* #t))))
(define (runs:rollup-run db keys keynames keyvallst n)
(let* ((new-run-id (register-run db keys))
(similar-runs (db:get-similar-runs db keys))
(tests-n-days (db:get-tests-n-days db similar-runs)))
(for-each
(lambda (test-id)
(db:rollup-test db run-id test-id))
tests-n-days)))
|