| ︙ | | |
16
17
18
19
20
21
22
23
24
25
26
27
28
29
|
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
|
+
+
|
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (unit common))
(include "common_records.scm")
(include "thunk-utils.scm")
;; (require-library margs)
;; (include "margs.scm")
;; (define old-exit exit)
;;
;; (define (exit . code)
|
| ︙ | | |
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
|
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
|
+
+
+
+
+
+
-
-
-
+
+
+
+
+
+
+
+
|
(mutex-lock! *context-mutex*)
(let ((cxt (hash-table-ref/default *contexts* toppath #f)))
(if (not cxt)
(set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x)))
(let ((cxt-mutex (cxt-mutex cxt)))
(mutex-unlock! *context-mutex*)
(mutex-lock! cxt-mutex)
;; here we guard proc with exception handler so
;; no matter how proc succeeds or fails,
;; the cxt-mutex will be unlocked afterward.
(let* ((EXCEPTION-SYMBOL (gensym)) ;; use a generated symbol
(guarded-proc ;; to avoid collision
(lambda args
(let ((res (proc cxt)))
(mutex-unlock! cxt-mutex)
res))))
(let* ((res (condition-case
(apply proc args)
[x () (cons EXCEPTION-SYMBOL x)])))
(mutex-unlock! cxt-mutex)
(if (and (pair? res) (eq? (car res) EXCEPTION))
(abort (cdr res))
res)))))
(guarded-proc cxt)))))
(define *db-keys* #f)
(define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f) ;; run configs data
(define *configdat* #f) ;; megatest.config data
(define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
|
| ︙ | | |
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
-
+
+
+
+
+
+
+
+
+
+
+
+
|
(define *task-db* #f) ;; (vector db path-to-db)
(define *db-access-allowed* #t) ;; flag to allow access
(define *db-access-mutex* (make-mutex))
(define *db-cache-path* #f)
;; SERVER
(define *my-client-signature* #f)
(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg
(define *transport-type* #f) ;; override with [server] transport http|rpc|nmsg
(define *DEFAULT-TRANSPORT* "http")
(define (common:set-transport-type)
(set! *transport-type*
(string->symbol
(or
(args:get-arg "-transport")
(configf:lookup *configdat* "server" "transport")
*DEFAULT-TRANSPORT*)))
*transport-type*)
(define *runremote* #f) ;; if set up for server communication this will hold <host port>
(define *max-cache-size* 0)
(define *logged-in-clients* (make-hash-table))
(define *server-id* #f)
(define *server-info* #f)
(define *time-to-exit* #f)
(define *server-run* #t)
|
| ︙ | | |
607
608
609
610
611
612
613
614
615
616
617
618
619
620
|
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
|
+
|
(thread-sleep! 1)
(delay-loop (+ count 1))))
(loop)))
(if (common:low-noise-print 30)
(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*)))))))
(define (std-exit-procedure)
(let ((no-hurry (if *time-to-exit* ;; hurry up
#f
(begin
(set! *time-to-exit* #t)
#t))))
(debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
(if (and no-hurry (debug:debug-mode 18))
|
| ︙ | | |
635
636
637
638
639
640
641
642
643
644
645
646
647
648
|
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
|
+
+
+
+
+
+
+
+
+
|
(debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
(if no-hurry
(thread-sleep! 5) ;; give the clean up few seconds to do it's stuff
(thread-sleep! 2))
(debug:print 4 *default-log-port* " ... done")
)
"clean exit")))
;; let's try to clean up open sockets
(if *runremote*
(case (remote-transport *runremote*)
((http) #t)
((rpc) (rpc:close-all-connections!))
(else
(debug:print-info 0 *default-log-port* "Transport "(remote-transport *runremote*)" not supported"))))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1))))
(define (std-signal-handler signum)
;; (signal-mask! signum)
(set! *time-to-exit* #t)
|
| ︙ | | |
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
|
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
|
-
+
-
-
+
+
|
;;
;; [launchers]
;; envsetup general
;; xor/%/n 4C16G
;; % nbgeneral
;;
;; [jobtools]
;; # if defined and not "no" flexi-launcher will bypass "launcher" unless no match.
;; # if == "yes" flexi-launcher will bypass "launcher" unless no match.
;; flexi-launcher yes
;; launcher nbfake
;;
(define (common:get-launcher configdat testname itempath)
(let ((fallback-launcher (configf:lookup configdat "jobtools" "launcher")))
(if (and (configf:lookup configdat "jobtools" "flexi-launcher") ;; overrides launcher
(not (equal? (configf:lookup configdat "jobtools" "flexi-launcher") "no")))
(if (string-search "^yes" (configf:lookup configdat "jobtools" "flexi-launcher")) ;; overrides launcher
;; (not (equal? (configf:lookup configdat "jobtools" "flexi-launcher") "no")))
(let* ((launchers (hash-table-ref/default configdat "launchers" '())))
(if (null? launchers)
fallback-launcher
(let loop ((hed (car launchers))
(tal (cdr launchers)))
(let ((patt (car hed))
(host-type (cadr hed)))
|
| ︙ | | |