1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
|
;;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo typed-records)
(require-extension regex posix)
(require-extension (srfi 18) extras tcp rpc)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
|
|
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
|
;;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records)
(require-extension regex posix)
(require-extension (srfi 18) extras tcp rpc)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
|
| ︙ | | | ︙ | |
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus* 0) ;; attempt to work around possible thread issues
(define *passnum* 0) ;; when running track calls to run-tests or similar
(define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0))
(define *alt-log-file* #f) ;; used by -log
(define *common:denoise* (make-hash-table)) ;; for low noise printing
(define *default-log-port* (current-error-port))
;; DATABASE
(define *dbstruct-db* #f)
(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex* (make-mutex))
(define *db-sync-mutex* (make-mutex))
(define *db-multi-sync-mutex* (make-mutex))
(define *db-local-sync* (make-hash-table)) ;; used to record last touch of db
(define *megatest-db* #f)
(define *last-db-access* (current-seconds)) ;; update when db is accessed via server
(define *db-write-access* #t)
(define *inmemdb* #f)
(define *task-db* #f) ;; (vector db path-to-db)
(define *db-access-allowed* #t) ;; flag to allow access
(define *db-access-mutex* (make-mutex))
;; SERVER
(define *my-client-signature* #f)
(define *transport-type* 'http)
(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg
(define *runremote* (make-hash-table)) ;; if set up for server communication this will hold <host port>
(define *max-cache-size* 0)
(define *logged-in-clients* (make-hash-table))
(define *client-non-blocking-mode* #f)
(define *server-id* #f)
(define *server-info* #f)
(define *time-to-exit* #f)
(define *received-response* #f)
(define *default-numtries* 10)
(define *server-run* #t)
(define *run-id* #f)
(define *server-kind-run* (make-hash-table))
(define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
(define *keys* (make-hash-table)) ;; cache the keys here
(define *keyvals* (make-hash-table))
(define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here
(define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here
(define *test-ids* (make-hash-table)) ;; cache run-id, testname, and item-path => test-id
|
>
>
>
|
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus* 0) ;; attempt to work around possible thread issues
(define *passnum* 0) ;; when running track calls to run-tests or similar
(define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0))
(define *alt-log-file* #f) ;; used by -log
(define *common:denoise* (make-hash-table)) ;; for low noise printing
(define *default-log-port* (current-error-port))
(define *time-zero* (current-seconds)) ;; for the watchdog
;; DATABASE
(define *dbstruct-db* #f)
(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex* (make-mutex))
(define *db-sync-mutex* (make-mutex))
(define *db-multi-sync-mutex* (make-mutex))
(define *db-local-sync* (make-hash-table)) ;; used to record last touch of db
(define *megatest-db* #f)
(define *last-db-access* (current-seconds)) ;; update when db is accessed via server
(define *db-write-access* #t)
(define *inmemdb* #f)
(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)
(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg
(define *runremote* (make-hash-table)) ;; if set up for server communication this will hold <host port>
(define *max-cache-size* 0)
(define *logged-in-clients* (make-hash-table))
(define *client-non-blocking-mode* #f)
(define *server-id* #f)
(define *server-info* #f)
(define *time-to-exit* #f)
(define *received-response* #f)
(define *default-numtries* 10)
(define *server-run* #t)
(define *run-id* #f)
(define *server-kind-run* (make-hash-table))
(define *home-host* #f)
(define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
(define *keys* (make-hash-table)) ;; cache the keys here
(define *keyvals* (make-hash-table))
(define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here
(define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here
(define *test-ids* (make-hash-table)) ;; cache run-id, testname, and item-path => test-id
|
| ︙ | | | ︙ | |
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
(db:multi-db-sync
#f ;; do all run-ids
;; 'new2old
'killservers
'dejunk
;; 'adj-testids
;; 'old2new
'new2old)
(if (common:version-changed?)
(common:set-last-run-version)))
;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
;;
(define (common:exit-on-version-changed)
(if (common:version-changed?)
|
|
>
|
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
|
(db:multi-db-sync
#f ;; do all run-ids
;; 'new2old
'killservers
'dejunk
;; 'adj-testids
;; 'old2new
'new2old
'schema)
(if (common:version-changed?)
(common:set-last-run-version)))
;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
;;
(define (common:exit-on-version-changed)
(if (common:version-changed?)
|
| ︙ | | | ︙ | |
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
|
(delete-file* fname))
;;======================================================================
;; S T A T E S A N D S T A T U S E S
;;======================================================================
(define *common:std-states*
'((0 "COMPLETED")
(1 "NOT_STARTED")
(2 "RUNNING")
(3 "REMOTEHOSTSTART")
(4 "LAUNCHED")
(5 "KILLED")
(6 "KILLREQ")
(7 "STUCK")
(8 "ARCHIVED")))
(define *common:std-statuses*
'((0 "PASS")
(1 "WARN")
(2 "FAIL")
(3 "CHECK")
(4 "n/a")
(5 "WAIVED")
(6 "SKIP")
(7 "DELETED")
(8 "STUCK/DEAD")
(9 "ABORT")))
;; These are stopping conditions that prevent a test from being run
(define *common:cant-run-states-sym*
'(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE ABORT ARCHIVED))
;;======================================================================
;; D E B U G G I N G S T U F F
;;======================================================================
(define *verbosity* 1)
(define *logging* #f)
|
|
>
>
>
|
|
<
|
<
<
|
|
>
|
|
|
|
|
|
<
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
|
(delete-file* fname))
;;======================================================================
;; S T A T E S A N D S T A T U S E S
;;======================================================================
(define *common:std-states*
'((0 "ARCHIVED")
(1 "STUCK")
(2 "KILLREQ")
(3 "KILLED")
(4 "NOT_STARTED")
(5 "COMPLETED")
(6 "LAUNCHED")
(7 "REMOTEHOSTSTART")
(8 "RUNNING")
))
(define *common:std-statuses*
'(;; (0 "DELETED")
(1 "n/a")
(2 "PASS")
(3 "CHECK")
(4 "SKIP")
(5 "WARN")
(6 "WAIVED")
(7 "STUCK/DEAD")
(8 "FAIL")
(9 "ABORT")))
(define *common:ended-states* ;; states which indicate the test is stopped and will not proceed
'("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE"))
(define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked
'("KILLED" "KILLREQ" "STUCK" "INCOMPLETE"))
(define (common:special-sort items order comp)
(let ((items-order (map reverse order))
(acomp (or comp >)))
(sort items
(lambda (a b)
(let ((a-num (cadr (or (assoc a items-order) '(0 0))))
(b-num (cadr (or (assoc b items-order) '(0 0)))))
(acomp a-num b-num))))))
;; These are stopping conditions that prevent a test from being run
(define *common:cant-run-states-sym*
'(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE ABORT ARCHIVED))
;; given a toplevel with currstate, currstatus apply state and status
;; => (newstate . newstatus)
(define (common:apply-state-status currstate currstatus state status)
(let* ((cstate (string->symbol (string-downcase currstate)))
(cstatus (string->symbol (string-downcase currstatus)))
(sstate (string->symbol (string-downcase state)))
(sstatus (string->symbol (string-downcase status)))
(nstate #f)
(nstatus #f))
(set! nstate
(case cstate
((completed not_started killed killreq stuck archived)
(case sstate ;; completed -> sstate
((completed killed killreq stuck archived) completed)
((running remotehoststart launched) running)
(else unknown-error-1)))
((running remotehoststart launched)
(case sstate
((completed killed killreq stuck archived) #f) ;; need to look at all items
((running remotehoststart launched) running)
(else unknown-error-2)))
(else unknown-error-3)))
(set! nstatus
(case sstatus
((pass)
(case nstate
((pass n/a deleted) pass)
((warn) warn)
((fail) fail)
((check) check)
((waived) waived)
((skip) skip)
((stuck/dead) stuck)
((abort) abort)
(else unknown-error-4)))
((warn)
(case nstate
((pass warn n/a skip deleted) warn)
((fail) fail)
((check) check)
((waived) waived)
((stuck/dead) stuck)
(else unknown-error-5)))
((fail)
(case nstate
((pass warn fail check n/a waived skip deleted stuck/dead stuck) fail)
((abort) abort)
(else unknown-error-6)))
(else unknown-error-7)))
(cons
(if nstate (symbol->string nstate) nstate)
(if nstatus (symbol->string nstatus) nstatus))))
;;======================================================================
;; D E B U G G I N G S T U F F
;;======================================================================
(define *verbosity* 1)
(define *logging* #f)
|
| ︙ | | | ︙ | |
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
|
(define (common:get-testsuite-name)
(or (configf:lookup *configdat* "setup" "testsuite" )
(if *toppath*
(pathname-file *toppath*)
(pathname-file (current-directory)))))
;;======================================================================
;; E X I T H A N D L I N G
;;======================================================================
(define (common:legacy-sync-recommended)
(or (args:get-arg "-runtests")
(args:get-arg "-run")
(args:get-arg "-server")
;; (args:get-arg "-set-run-status")
(args:get-arg "-remove-runs")
;; (args:get-arg "-get-run-status")
))
(define (common:legacy-sync-required)
(configf:lookup *configdat* "setup" "megatest-db"))
(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))
(rmt:print-db-stats))
(let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
(let ((run-ids (hash-table-keys *db-local-sync*)))
(if (and (not (null? run-ids))
(or (common:legacy-sync-recommended)
(configf:lookup *configdat* "setup" "megatest-db")))
(if no-hurry (db:multi-db-sync run-ids 'new2old))))
(if *dbstruct-db* (db:close-all *dbstruct-db*))
(if *inmemdb* (db:close-all *inmemdb*))
(if (and *megatest-db*
(sqlite3:database? *megatest-db*))
(begin
(sqlite3:interrupt! *megatest-db*)
(sqlite3:finalize! *megatest-db* #t)
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
>
|
>
|
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
|
(define (common:get-testsuite-name)
(or (configf:lookup *configdat* "setup" "testsuite" )
(if *toppath*
(pathname-file *toppath*)
(pathname-file (current-directory)))))
(define (common:get-db-tmp-area)
(if *db-cache-path*
*db-cache-path*
(let ((dbpath (create-directory (conc "/tmp/" (current-user-name)
"/megatest_localdb/"
(common:get-testsuite-name) "/"
(string-translate *toppath* "/" ".")) #t)))
(set! *db-cache-path* dbpath)
dbpath)))
(define (common:get-area-path-signature)
(message-digest-string (md5-primitive) *toppath*))
;;======================================================================
;; E X I T H A N D L I N G
;;======================================================================
(define (common:legacy-sync-recommended)
(or (and (common:get-homehost)
(cdr (common:get-homehost)))
(args:get-arg "-runtests")
(args:get-arg "-run")
(args:get-arg "-server")
;; (args:get-arg "-set-run-status")
(args:get-arg "-remove-runs")
;; (args:get-arg "-get-run-status")
(args:get-arg "-use-db-cache") ;; feels like a bad idea ...
))
(define (common:legacy-sync-required)
(configf:lookup *configdat* "setup" "megatest-db"))
;; run-ids
;; if #f use *db-local-sync* : or 'local-sync-flags
;; if #t use timestamps : or 'timestamps
(define (common:sync-to-megatest.db run-ids)
(let ((start-time (current-seconds))
(run-ids-to-process (if (list? run-ids)
run-ids
(if (or (eq? run-ids 'timestamps)(eq? run-ids #t))
(db:get-changed-run-ids (let* ((mtdb-fpath (conc *toppath* "/megatest.db"))
(mtdb-exists (file-exists? mtdb-fpath)))
(if mtdb-exists
(file-modification-time mtdb-fpath)
0)))
(hash-table-keys *db-local-sync*)))))
(debug:print-info 4 *default-log-port* "Processing run-ids: " run-ids-to-process)
(for-each
(lambda (run-id)
(mutex-lock! *db-multi-sync-mutex*)
(if (or run-ids ;; if we were provided with run-ids, proceed
(hash-table-ref/default *db-local-sync* run-id #f))
;; (if (> (- start-time last-write) 5) ;; every five seconds
(begin ;; let ((sync-time (- (current-seconds) start-time)))
(db:multi-db-sync (list run-id) 'new2old)
(let ((sync-time (- (current-seconds) start-time)))
(debug:print-info 3 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")
(if (common:low-noise-print 30 "sync new to old")
(debug:print-info 0 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
(hash-table-delete! *db-local-sync* run-id)))
(mutex-unlock! *db-multi-sync-mutex*))
run-ids-to-process)))
(define (common:watchdog)
(thread-sleep! 0.05) ;; delay for startup
(let ((legacy-sync (common:legacy-sync-required))
(debug-mode (debug:debug-mode 1))
(last-time (current-seconds)))
(if (or (common:legacy-sync-recommended)
legacy-sync)
(let loop ()
;; sync for filesystem local db writes
;;
(let ((start-time (current-seconds)))
(common:sync-to-megatest.db 'local-sync-flags)
(if (and debug-mode
(> (- start-time last-time) 60))
(begin
(set! last-time start-time)
(debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
;; keep going unless time to exit
;;
(if (not *time-to-exit*)
(let delay-loop ((count 0))
(if (and (not *time-to-exit*)
(< count 4)) ;; was 11, changing to 4.
(begin
(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))
(rmt:print-db-stats))
(let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
;; (let ((run-ids (hash-table-keys *db-local-sync*)))
;; (if (and (not (null? run-ids))
;; (or (common:legacy-sync-recommended)
;; (configf:lookup *configdat* "setup" "megatest-db")))
;; (if no-hurry
;; (db:multi-db-sync run-ids 'new2old))
;; ))
(if *dbstruct-db* (db:close-all *dbstruct-db*))
(if *inmemdb* (db:close-all *inmemdb*))
(if (and *megatest-db*
(sqlite3:database? *megatest-db*))
(begin
(sqlite3:interrupt! *megatest-db*)
(sqlite3:finalize! *megatest-db* #t)
|
| ︙ | | | ︙ | |
547
548
549
550
551
552
553
554
555
556
557
558
559
560
|
exn
#f
(pathname-directory
(pathname-directory
(pathname-directory exe-path))))
#f)))
;;======================================================================
;; T A R G E T S , S T A T E , S T A T U S ,
;; R U N N A M E A N D T E S T P A T T
;;======================================================================
;; Lookup a value in runconfigs based on -reqtarg or -target
(define (runconfigs-get config var)
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
|
exn
#f
(pathname-directory
(pathname-directory
(pathname-directory exe-path))))
#f)))
;; return first path that can be created or already exists and is writable
;;
(define (common:get-create-writeable-dir dirs)
(if (null? dirs)
#f
(let loop ((hed (car dirs))
(tal (cdr dirs)))
(let ((res (or (and (directory? hed)
(file-write-access? hed)
hed)
(handle-exceptions
exn
#f
(create-directory hed #t)))))
(if (and (string? res)
(directory? res))
res
(if (null? tal)
#f
(loop (car tal)(cdr tal))))))))
;;======================================================================
;; T A R G E T S , S T A T E , S T A T U S ,
;; R U N N A M E A N D T E S T P A T T
;;======================================================================
;; Lookup a value in runconfigs based on -reqtarg or -target
(define (runconfigs-get config var)
|
| ︙ | | | ︙ | |
611
612
613
614
615
616
617
618
619
620
621
622
623
624
|
tlist
target)
(if target
(begin
(debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
#f)
#f))))
;;======================================================================
;; M I S C L I S T S
;;======================================================================
;; items in lista are matched value and position in listb
;; return the remaining items in listb or #f
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
|
tlist
target)
(if target
(begin
(debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
#f)
#f))))
;; logic for getting homehost. Returns (host . at-home)
;;
(define (common:get-homehost)
(cond
(*home-host* *home-host*)
((not *toppath*) #f) ;; don't know toppath yet? return #f
(else
(let* ((currhost (get-host-name))
(bestadrs (server:get-best-guess-address currhost))
;; first look in config, then look in file .homehost, create it if not found
(homehost (or (configf:lookup *configdat* "server" "homehost" )
(let ((hhf (conc *toppath* "/.homehost")))
(if (file-exists? hhf)
(with-input-from-file hhf read-line)
(if (file-write-access? *toppath*)
(begin
(with-output-to-file hhf
(lambda ()
(print bestadrs)))
(common:get-homehost))
#f)))))
(at-home (or (equal? homehost currhost)
(equal? homehost bestadrs))))
(set! *home-host* (cons homehost at-home))
*home-host*))))
;;======================================================================
;; M I S C L I S T S
;;======================================================================
;; items in lista are matched value and position in listb
;; return the remaining items in listb or #f
|
| ︙ | | | ︙ | |
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
|
(if match
(let ((newval (string->number (cadr match))))
(if (number? newval)
(set! freespc newval))))))
(car df-results))
freespc))
;; check space in dbdir
;; returns: ok/not dbspace required-space
;;
(define (common:check-db-dir-space)
(let* ((dbdir (db:get-dbdir))
(dbspace (if (directory? dbdir)
(get-df dbdir)
0))
(required (string->number
(or (configf:lookup *configdat* "setup" "dbdir-space-required")
"100000"))))
dbdir)))
;; check available space in dbdir, exit if insufficient
;;
(define (common:check-db-dir-and-exit-if-insufficient)
(let* ((spacedat (common:check-db-dir-space))
(is-ok (car spacedat))
(dbspace (cadr spacedat))
(required (caddr spacedat))
(dbdir (cadddr spacedat)))
(if (not is-ok)
(begin
(debug:print-error 0 *default-log-port* "Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.")
|
<
<
<
|
<
|
|
|
<
<
<
|
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
|
(if match
(let ((newval (string->number (cadr match))))
(if (number? newval)
(set! freespc newval))))))
(car df-results))
freespc))
(define (common:check-space-in-dir dirpath required)
(let* ((dbspace (if (directory? dirpath)
(get-df dirpath)
0)))
(list (> dbspace required)
dbspace
required
dirpath)))
;; check space in dbdir and in megatest dir
;; returns: ok/not dbspace required-space
;;
(define (common:check-db-dir-space)
(let* ((required (string->number
(or (configf:lookup *configdat* "setup" "dbdir-space-required")
"100000")))
(dbdir (common:get-db-tmp-area)) ;; (db:get-dbdir))
(tdbspace (common:check-space-in-dir dbdir required))
(mdbspace (common:check-space-in-dir *toppath* required)))
(sort (list tdbspace mdbspace) (lambda (a b)
(< (cadr a)(cadr b))))))
;; check available space in dbdir, exit if insufficient
;;
(define (common:check-db-dir-and-exit-if-insufficient)
(let* ((spacedat (car (common:check-db-dir-space))) ;; look only at worst for now
(is-ok (car spacedat))
(dbspace (cadr spacedat))
(required (caddr spacedat))
(dbdir (cadddr spacedat)))
(if (not is-ok)
(begin
(debug:print-error 0 *default-log-port* "Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.")
|
| ︙ | | | ︙ | |