| ︙ | | | ︙ | |
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
88
89
90
91
92
93
94
|
;; posix-extras
chicken.base
chicken.condition
chicken.file
chicken.file.posix
chicken.io
chicken.pathname
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
chicken.time.posix
matchable
md5
message-digest
pathname-expand
regex
regex-case
srfi-1
srfi-18
srfi-69
typed-records
system-information
)))
;;======================================================================
;; CONTENTS
;;
;; config file utils
;; misc conversion, data manipulation functions
|
>
>
>
|
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
88
89
90
91
92
93
94
95
96
97
|
;; posix-extras
chicken.base
chicken.condition
chicken.file
chicken.file.posix
chicken.io
chicken.pathname
chicken.port
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
chicken.time.posix
matchable
md5
message-digest
pathname-expand
regex
regex-case
srfi-1
srfi-18
srfi-69
typed-records
system-information
debugprint
)))
;;======================================================================
;; CONTENTS
;;
;; config file utils
;; misc conversion, data manipulation functions
|
| ︙ | | | ︙ | |
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
(define *my-client-signature* #f)
(define (client:get-signature)
(if *my-client-signature* *my-client-signature*
(let ((sig (conc (get-host-name) " " (current-process-id))))
(set! *my-client-signature* sig)
*my-client-signature*)))
;;======================================================================
;; config file utils
;;======================================================================
(define (lookup cfgdat section var)
(if (hash-table? cfgdat)
|
>
>
>
|
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
(define *my-client-signature* #f)
(define (client:get-signature)
(if *my-client-signature* *my-client-signature*
(let ((sig (conc (get-host-name) " " (current-process-id))))
(set! *my-client-signature* sig)
*my-client-signature*)))
(define *server-info* #f)
(define *toppath* #f)
;;======================================================================
;; config file utils
;;======================================================================
(define (lookup cfgdat section var)
(if (hash-table? cfgdat)
|
| ︙ | | | ︙ | |
158
159
160
161
162
163
164
165
166
167
168
169
170
171
|
(if valstr
(val->alist valstr)
'()))) ;; should it return empty list or #f to indicate not set?
(define (get-section cfgdat section)
(hash-table-ref/default cfgdat section '()))
;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; to get the lock
;;
(define (common:simple-file-lock fname #!key (expire-time 300))
(let* ((lock-exists (file-exists? fname))
|
>
>
>
>
>
>
>
|
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
|
(if valstr
(val->alist valstr)
'()))) ;; should it return empty list or #f to indicate not set?
(define (get-section cfgdat section)
(hash-table-ref/default cfgdat section '()))
(define (common:make-tmpdir-name areapath tmpadj)
(let* ((area (pathname-file areapath))
(dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb")))
(unless (directory-exists? dname)
(create-directory dname #t))
dname))
;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; to get the lock
;;
(define (common:simple-file-lock fname #!key (expire-time 300))
(let* ((lock-exists (file-exists? fname))
|
| ︙ | | | ︙ | |
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
|
(if convert (lazy-convert inval) inval))))
(else f))))
(filter (lambda (x)
(not (string-match "^\\s*" x)))
val-list))
'())))
(define (get-cpu-load)
(let* ((load-info (with-input-from-file "/proc/loadavg" read-lines)))
(map string->number (string-split load-info))))
(define *current-host-cores* #f)
(define (get-current-host-cores)
(or *current-host-cores*
(let ((cpu-info (with-input-from-file "/proc/cpuinfo" read-lines)))
(let loop ((lines cpu-info))
|
|
|
|
>
>
>
|
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
|
(if convert (lazy-convert inval) inval))))
(else f))))
(filter (lambda (x)
(not (string-match "^\\s*" x)))
val-list))
'())))
(define (commonmod:get-cpu-load)
(let* ((load-info (with-input-from-file "/proc/loadavg" read-lines))
(res (map string->number (string-split (car load-info)))))
(if (null? res)
#f ;; something is wrong
(car res))))
(define *current-host-cores* #f)
(define (get-current-host-cores)
(or *current-host-cores*
(let ((cpu-info (with-input-from-file "/proc/cpuinfo" read-lines)))
(let loop ((lines cpu-info))
|
| ︙ | | | ︙ | |
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
|
(conc "ps -def | egrep \""processname"\" |wc -l")
(lambda ()
(string->number (read-line)))))
;; get the normalized (i.e. load / numcpus) for *this* host
;;
(define (get-normalized-cpu-load)
(/ (get-cpu-load)(get-current-host-cores)))
;;======================================================================
;; testsuite and area utilites
;;======================================================================
(define (get-testsuite-name toppath configdat)
(or (lookup configdat "setup" "area-name")
|
|
|
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
|
(conc "ps -def | egrep \""processname"\" |wc -l")
(lambda ()
(string->number (read-line)))))
;; get the normalized (i.e. load / numcpus) for *this* host
;;
(define (get-normalized-cpu-load)
(/ (commonmod:get-cpu-load)(get-current-host-cores)))
;;======================================================================
;; testsuite and area utilites
;;======================================================================
(define (get-testsuite-name toppath configdat)
(or (lookup configdat "setup" "area-name")
|
| ︙ | | | ︙ | |
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
|
((m) 60) ;; minutes
((h) 3600)
((d) 86400)
((w) 604800)
((M) 2628000) ;; aproximately one month
((y) 31536000)
(else
0)))))))
;; (print "ERROR: can't parse timestring "tstr", component "part)
;; can't (yet) use debugprint. rely on -show-config for user to find errors
)))
parts)
time-secs))
(define (seconds->hr-min-sec secs)
(let* ((hrs (quotient secs 3600))
(min (quotient (- secs (* hrs 3600)) 60))
(sec (- secs (* hrs 3600)(* min 60))))
|
|
>
|
<
<
|
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
|
((m) 60) ;; minutes
((h) 3600)
((d) 86400)
((w) 604800)
((M) 2628000) ;; aproximately one month
((y) 31536000)
(else
0)))))
(debug:print 0 *default-log-port* "ERROR: can't parse timestring "tstr", component "part", string: "(cadr match))))
(debug:print 0 *default-log-port* "ERROR: can't parse timestring "tstr", component "part))))
parts)
time-secs))
(define (seconds->hr-min-sec secs)
(let* ((hrs (quotient secs 3600))
(min (quotient (- secs (* hrs 3600)) 60))
(sec (- secs (* hrs 3600)(* min 60))))
|
| ︙ | | | ︙ | |