66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
|
;; tests:glob-like-match
(define (tests:glob-like-match patt str)
(let ((like (substring-index "%" patt)))
(let* ((notpatt (equal? (substring-index "~" patt) 0))
(newpatt (if notpatt (substring patt 1) patt))
(finpatt (if like
(string-substitute (regexp "%") ".*" newpatt)
(string-substitute (regexp "\\*") ".*" newpatt)))
(res #f))
;; (print "tests:glob-like-match => notpatt: " notpatt ", newpatt: " newpatt ", finpatt: " finpatt)
(set! res (string-match (regexp finpatt (if like #t #f)) str))
(if notpatt (not res) res))))
;; if itempath is #f then look only at the testname part
;;
|
|
|
|
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
|
;; tests:glob-like-match
(define (tests:glob-like-match patt str)
(let ((like (substring-index "%" patt)))
(let* ((notpatt (equal? (substring-index "~" patt) 0))
(newpatt (if notpatt (substring patt 1) patt))
(finpatt (if like
(string-substitute (regexp "%") ".*" newpatt #f)
(string-substitute (regexp "\\*") ".*" newpatt #f)))
(res #f))
;; (print "tests:glob-like-match => notpatt: " notpatt ", newpatt: " newpatt ", finpatt: " finpatt)
(set! res (string-match (regexp finpatt (if like #t #f)) str))
(if notpatt (not res) res))))
;; if itempath is #f then look only at the testname part
;;
|
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
|
(rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id)
(if minutes
(rmt:general-call 'update-run-duration run-id minutes test-id))
(if (and uname hostname)
(rmt:general-call 'update-uname-host run-id uname hostname test-id)))
;; This one is for running with no db access (i.e. via rmt: internally)
(define (tests:set-full-meta-info test-id run-id minutes work-area)
(let* ((num-records 0)
(cpuload (get-cpu-load))
(diskfree (get-df (current-directory)))
(uname (get-uname "-srvpio"))
(hostname (get-host-name)))
(tdb:remote-update-testdat-meta-info run-id test-id work-area cpuload diskfree minutes)
(tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)))
(define (tests:set-partial-meta-info test-id run-id minutes work-area)
(let* ((cpuload (get-cpu-load))
(diskfree (get-df (current-directory))))
(tdb:remote-update-testdat-meta-info run-id test-id work-area cpuload diskfree minutes)))
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
>
|
|
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
|
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
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
695
|
(rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id)
(if minutes
(rmt:general-call 'update-run-duration run-id minutes test-id))
(if (and uname hostname)
(rmt:general-call 'update-uname-host run-id uname hostname test-id)))
;; This one is for running with no db access (i.e. via rmt: internally)
(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries)
;; (define (tests:set-full-meta-info test-id run-id minutes work-area)
(let ((remtries 10))
(handle-exceptions
exn
(if (> remtries 0)
(begin
(set! remtries (- remtries 1))
(thread-sleep! 10)
(tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1)))
(let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
(debug:print 0 "ERROR: tried for over a minute to update meta info and failed. Giving up")
(debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
(debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
(print "exn=" (condition->list exn))
(debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn))
(print-call-chain)))
(let* ((num-records 0) ;; (test:tdb-get-rundat-count tdb))
(cpuload (get-cpu-load))
(diskfree (get-df (current-directory)))
(uname (get-uname "-srvpio"))
(hostname (get-host-name)))
;; (tests:update-testdat-meta-info drun-id test-id work-area cpuload diskfree minutes)
(tests:update-central-meta-info trun-id test-id cpuload diskfree minutes uname hostname)))))
(define (tests:set-partial-meta-info dest-id run-id minutes work-area remtries)
;; (define (tests:set-partial-meta-info test-id run-id minutes work-area)
(let* ((cpuload (get-cpu-load))
(diskfree (get-df (current-directory)))
(remtries 10))
(handle-exceptions
exn
(if (> remtries 0)
(begin
(set! remtries (- remtries 1))
(thread-sleep! 10)
(tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1)))
(let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
(debug:print 0 "ERROR: tried for over a minute to update meta info and failed. Giving up")
(debug:print 0 "EXCEPTION: database probably overloaded or unreadable.")
(debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
(print "exn=" (condition->list exn))
(debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn))
(print-call-chain)))
;;======================================================================
;; A R C H I V I N G
;;======================================================================
(define (test:archive db test-id)
#f)
(define (test:archive-tests db keynames target)
#f)
|