︙ | | | ︙ | |
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
|
((dboard) (conc updir progname))
((mtest) (conc updir progname))
((dashboard) progname)
(else exe)))))
'("../../" "../")))))
(if (null? res)
(begin
(debug:print 0 *current-log-port* "Failed to find this executable! Using what can be found on the path")
progname)
(car res))))
(define *common:logpro-exit-code->status-sym-alist*
'( ( 0 . pass )
( 1 . fail )
( 2 . warn )
|
|
|
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
|
((dboard) (conc updir progname))
((mtest) (conc updir progname))
((dashboard) progname)
(else exe)))))
'("../../" "../")))))
(if (null? res)
(begin
(debug:print 0 *default-log-port* "Failed to find this executable! Using what can be found on the path")
progname)
(car res))))
(define *common:logpro-exit-code->status-sym-alist*
'( ( 0 . pass )
( 1 . fail )
( 2 . warn )
|
︙ | | | ︙ | |
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
|
(define (common:get-testsuite-name)
(or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
(configf:lookup *configdat* "setup" "testsuite" )
(getenv "MT_TESTSUITE_NAME")
(pathname-file (or (if (string? *toppath* )
(pathname-file *toppath*)
#f)
(common:get-topath #f)))
"please-set-setup-area-name")) ;; (pathname-file (current-directory)))))
;; safe getting of toppath
(define (common:get-toppath areapath)
(or *toppath*
(if areapath
(begin
|
|
|
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
|
(define (common:get-testsuite-name)
(or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
(configf:lookup *configdat* "setup" "testsuite" )
(getenv "MT_TESTSUITE_NAME")
(pathname-file (or (if (string? *toppath* )
(pathname-file *toppath*)
#f)
(common:get-toppath #f)))
"please-set-setup-area-name")) ;; (pathname-file (current-directory)))))
;; safe getting of toppath
(define (common:get-toppath areapath)
(or *toppath*
(if areapath
(begin
|
︙ | | | ︙ | |
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
|
(handle-exceptions exn
(begin
(if message
(debug:print-info 0 *default-log-port* message))
#f) (thunk) ))
(define (common:file-exists? path-string #!key (silent #f))
;; this avoids stack dumps in the case where
;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
(common:false-on-exception (lambda () (file-exists? path-string))
message: (if (not silent)
(conc "Unable to access path: " path-string)
#f)
))
(define (common:directory-exists? path-string)
;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
(common:false-on-exception (lambda () (directory-exists? path-string))
message: (conc "Unable to access path: " path-string)
))
;; does the directory exist and do we have write access?
;;
;; returns the directory or #f
|
<
<
|
|
|
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
|
(handle-exceptions exn
(begin
(if message
(debug:print-info 0 *default-log-port* message))
#f) (thunk) ))
(define (common:file-exists? path-string #!key (silent #f))
;;;; TODO: catch permission denied exceptions and emit appropriate warnings. Might be able to get rid of with chicken 5?
(common:false-on-exception (lambda () (file-exists? path-string))
message: (if (not silent)
(conc "Unable to access path: " path-string)
#f)
))
(define (common:directory-exists? path-string)
;;;; TODO: catch permission denied exceptions and emit appropriate warnings
(common:false-on-exception (lambda () (directory-exists? path-string))
message: (conc "Unable to access path: " path-string)
))
;; does the directory exist and do we have write access?
;;
;; returns the directory or #f
|
︙ | | | ︙ | |
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
|
;; get values from cached info from dropping file in logs dir
;; e.g. key is host and dtype is normalized-load
;;
(define (common:get-cached-info key dtype #!key (age 10))
(if *toppath*
(let* ((fullpath (conc *toppath* "/.sysdata/" key "-" dtype ".log"))
(delfile (lambda ()
(debug:print-info 1 *default-log-port* " removing bad file " fullpath ", exn=" exn)
(delete-file* fullpath)
#f)))
(if (and (file-exists? fullpath)
(file-read-access? fullpath))
(handle-exceptions
exn
|
|
|
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
|
;; get values from cached info from dropping file in logs dir
;; e.g. key is host and dtype is normalized-load
;;
(define (common:get-cached-info key dtype #!key (age 10))
(if *toppath*
(let* ((fullpath (conc *toppath* "/.sysdata/" key "-" dtype ".log"))
(delfile (lambda (exn)
(debug:print-info 1 *default-log-port* " removing bad file " fullpath ", exn=" exn)
(delete-file* fullpath)
#f)))
(if (and (file-exists? fullpath)
(file-read-access? fullpath))
(handle-exceptions
exn
|
︙ | | | ︙ | |
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
|
(debug:print 1 *default-log-port* "Failed to read mod time on file "
fullpath ", using 0, exn=" exn)
0)
(file-change-time fullpath)))))
(if (< real-age age)
(handle-exceptions
exn
(delfile)
(let* ((res (with-input-from-file fullpath read)))
(if (eof-object? res)
(begin
(delfile)
#f)
res)))
(begin
(debug:print-info 2 *default-log-port* "file " fullpath
" is too old (" real-age" seconds) to trust, skipping reading it")
#f))))
(begin
|
|
|
|
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
|
(debug:print 1 *default-log-port* "Failed to read mod time on file "
fullpath ", using 0, exn=" exn)
0)
(file-change-time fullpath)))))
(if (< real-age age)
(handle-exceptions
exn
(delfile exn)
(let* ((res (with-input-from-file fullpath read)))
(if (eof-object? res)
(begin
(delfile "n/a")
#f)
res)))
(begin
(debug:print-info 2 *default-log-port* "file " fullpath
" is too old (" real-age" seconds) to trust, skipping reading it")
#f))))
(begin
|
︙ | | | ︙ | |