140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
+
|
(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 *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
(define *on-exit-procs* '()) ;; add procs to this list to be executed on exit
(define *default-area-tag* "local")
;; DATABASE
;; (define *dbstruct-dbs* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
;; db stats
(define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex* (make-mutex))
|
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
|
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
|
-
+
+
|
(string-split pktsdirs-str " ")
#f)))
pktsdirs))
;;======================================================================
;; use-lt is use linktree "lt" link to find pkts dir
(define (common:save-pkt pktalist-in mtconf use-lt #!key (add-only #f)) ;; add-only saves the pkt only if there is a parent already
(if (or add-only
(if (or (not add-only)
(hash-table-exists? *pkts-info* 'last-parent))
(let* ((parent (hash-table-ref/default *pkts-info* 'last-parent #f))
(pktalist (if parent
(cons `(parent . ,parent)
pktalist-in)
pktalist-in)))
(let-values (((uuid pkt)
(alist->pkt pktalist common:pkts-spec)))
(hash-table-set! *pkts-info* 'last-parent uuid)
(let ((pktsdir (or (hash-table-ref/default *pkts-info* 'pkts-dir #f)
(let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt))
(pktsdir (car pktsdirs))) ;; assume it is there
(hash-table-set! *pkts-info* 'pkts-dir pktsdir)
pktsdir))))
(debug:print 0 *default-log-port* "pktsdir: "pktsdir)
(handle-exceptions
exn
(debug:print-info 0 "failed to write out packet to " pktsdir ", exn=" exn) ;; don't care if this failed for now but MUST FIX - BUG!!
(if (not (file-exists? pktsdir))
(create-directory pktsdir #t))
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
|