| ︙ | | | ︙ | |
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
|
| ︙ | | | ︙ | |
158
159
160
161
162
163
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 '()))
;; 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 ((fmod-time (handle-exceptions
ext
(current-seconds)
(file-modification-time fname))))
(if (file-exists? fname) ;; (common:file-exists? fname)
|
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
>
|
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
|
(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))
(fmod-time (if lock-exists
(current-seconds)
(handle-exceptions
ext
(current-seconds)
(file-modification-time fname)))))
(if lock-exists
(if (> (- (current-seconds) fmod-time) expire-time)
(begin
(debug:print-info 1 *default-log-port* "Removing stale lock "fname)
(handle-exceptions exn #f (delete-file* fname))
(common:simple-file-lock fname expire-time: expire-time))
#f)
(let ((key-string (conc (get-host-name) "-" (current-process-id))))
(with-output-to-file fname
(lambda ()
(print key-string)))
|
| ︙ | | | ︙ | |
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
|
(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))
|
|
|
|
>
>
>
|
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
|
(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))
|
| ︙ | | | ︙ | |
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
|
(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")
|
|
|
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
|
(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")
|
| ︙ | | | ︙ | |
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
|
((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))))
|
|
>
|
<
<
|
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
|
((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))))
|
| ︙ | | | ︙ | |