DELETED src/mtcommon.scm Index: src/mtcommon.scm ================================================================== --- src/mtcommon.scm +++ /dev/null @@ -1,843 +0,0 @@ -;====================================================================== -;; Copyright 2006-2016, Matthew Welland. -;; -;; This file is part of Megatest. -;; -;; Megatest is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. -;; -;; Megatest is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with Megatest. If not, see . -;; -;;====================================================================== - -;; NOTE: This is the db module, long term it will replace db.scm. -;; WARN: This module conflicts with db.scm as it uses sql-de-lite - -(declare (unit mtcommon)) - -(module mtcommon - ( - get-create-writeable-dir - print-error - print-info - log-event - debug-setup - debug-mode - check-verbosity - calc-verbosity - ;; pkts stuff - load-pkts-to-db - get-pkt-alists - with-queue-db - get-pkts-dirs - get-pkt-times - ;; unix stuff - get-cached-info - write-cached-info - get-normalized-cpu-load - bash-glob - get-youngest - ;; time - hms-string->seconds - seconds->hr-min-sec - seconds->time-string - seconds->work-week/day-time - seconds->work-week/day - seconds->year-work-week/day - seconds->year-work-week/day-time - seconds->year-week/day-time - seconds->quarter - date-time->seconds - find-start-mark-and-mark-delta - expand-cron-slash - cron-expand - cron-event - extended-cron - ;; other - get-param-mapping - ;; debug - debug-print - print-error - print-info - ) - -(import scheme chicken data-structures extras posix ports) -(use (prefix sql-de-lite sql:) posix typed-records format srfi-1 srfi-69 pkts regex (prefix dbi dbi:) regex-case matchable) - -(defstruct ctrldat - (port (current-error-port)) - (verbosity 1) - (vcache (make-hash-table)) - (logging #f) ;; keep the flag and the db handle separate to enable overriding - (logdb #f) ;; might need to make this a stack of handles for threaded access - (toppath #f) ;; - ) - -(define *log* (make-ctrldat)) - -;; this was cached based on results from profiling but it turned out the profiling -;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching -;; in for now but can probably take it out later. -;; -(define (calc-verbosity vstr args) - (or (hash-table-ref/default (ctrldat-vcache *log*) vstr #f) - (let ((res (cond - ((number? vstr) vstr) - ((not (string? vstr)) 1) - ;; ((string-match "^\\s*$" vstr) 1) - (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) - (cond - ((> (length debugvals) 1) debugvals) - ((> (length debugvals) 0)(car debugvals)) - (else 1)))) - ((hash-table-exists? args "-v") 2) - ((hash-table-exists? args "-q") 0) - (else 1)))) - (hash-table-set! (ctrldat-vcache *log*) vstr res) - res))) - -;; check verbosity, #t is ok -(define (check-verbosity verbosity vstr) - (if (not (or (number? verbosity) - (list? verbosity))) - (begin - (print "ERROR: Invalid debug value \"" vstr "\"") - #f) - #t)) - -(define (debug-mode n) - (let* ((verbosity (ctrldat-verbosity *log*))) - (cond - ((and (number? verbosity) ;; number number - (number? n)) - (<= n verbosity)) - ((and (list? verbosity) ;; list number - (number? n)) - (member n verbosity)) - ((and (list? verbosity) ;; list list - (list? n)) - (not (null? (lset-intersection! eq? verbosity n)))) - ((and (number? verbosity) - (list? n)) - (member verbosity n))))) - -(define (debug-setup args) - (let* ((debugstr (or (hash-table-ref/default args "-debug" #f) - (get-environment-variable "MT_DEBUG_MODE"))) - (verbosity (calc-verbosity debugstr args))) - ;; if we were handed a bad verbosity rule then we will override it with 1 and continue - (if (not (check-verbosity verbosity debugstr)) - (set! verbosity 1)) - (ctrldat-verbosity-set! *log* verbosity) - (if (or (hash-table-exists? args "-debug") - (not (get-environment-variable "MT_DEBUG_MODE"))) - (setenv "MT_DEBUG_MODE" (if (list? verbosity) - (string-intersperse (map conc verbosity) ",") - (conc verbosity)))))) - -(define (debug-print n e . params) - (if (debug-mode n) - (with-output-to-port (or e (current-error-port)) - (lambda () - (if (ctrldat-logging *log*) - (log-event (apply conc params)) - (apply print params) - ))))) - -;; more betterer implementation above? -;; (define (print-info n e . params) -;; (apply debug-print n e "INFO: " params)) - -;; ;; Brandon's debug printer shortcut (indulge me :) -;; (define *BB-process-starttime* (current-milliseconds)) -;; (define (BB> . in-args) -;; (let* ((stack (get-call-chain)) -;; (location "??")) -;; (for-each -;; (lambda (frame) -;; (let* ((this-loc (vector-ref frame 0)) -;; (temp (string-split (->string this-loc) " ")) -;; (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???"))) -;; (if (equal? this-func "BB>") -;; (set! location this-loc)))) -;; stack) -;; (let* ((color-on "\x1b[1m") -;; (color-off "\x1b[0m") -;; (dp-args -;; (append -;; (list 0 *default-log-port* -;; (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") ) -;; in-args))) -;; (apply debug:print dp-args)))) -;; -;; (define *BBpp_custom_expanders_list* (make-hash-table)) -;; -;; -;; -;; ;; register hash tables with BBpp. -;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE: -;; (cons hash-table? hash-table->alist)) -;; -;; ;; test name converter -;; (define (BBpp_custom_converter arg) -;; (let ((res #f)) -;; (for-each -;; (lambda (custom-type-name) -;; (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name)) -;; (custom-type-test (car custom-type-info)) -;; (custom-type-converter (cdr custom-type-info))) -;; (when (and (not res) (custom-type-test arg)) -;; (set! res (custom-type-converter arg))))) -;; (hash-table-keys *BBpp_custom_expanders_list*)) -;; (if res (BBpp_ res) arg))) -;; -;; (define (BBpp_ arg) -;; (cond -;; ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg))) -;; ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg))) -;; ((hash-table? arg) -;; (let ((al (hash-table->alist arg))) -;; (BBpp_ (cons HASH_TABLE: al)))) -;; ((null? arg) '()) -;; ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) -;; ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) -;; (else (BBpp_custom_converter arg)))) -;; -;; ;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp -;; (define (BBpp arg) -;; (pp (BBpp_ arg))) -;; -;; ;(use define-macro) -;; (define-syntax inspect -;; (syntax-rules () -;; [(_ x) -;; ;; (with-output-to-port (current-error-port) -;; (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x)))) -;; ;; ) -;; ] -;; [(_ x y ...) (begin (inspect x) (inspect y ...))])) - -(define (print-error n e . params) - ;; normal print - (if (debug-mode n) - (with-output-to-port (if (port? e) e (current-error-port)) - (lambda () - (if (ctrldat-logging *log*) - (log-event (apply conc params)) - ;; (apply print "pid:" (current-process-id) " " params) - (apply print "ERROR: " params) - )))) - ;; pass important messages to stderr - (if (and (eq? n 0)(not (eq? e (current-error-port)))) - (with-output-to-port (current-error-port) - (lambda () - (apply print "ERROR: " params) - )))) - -(define (print-info n e . params) - (if (debug-mode n) - (with-output-to-port (if (port? e) e (current-error-port)) - (lambda () - (if (ctrldat-logging *log*) - (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) - (log-event res)) - (apply print "INFO: (" n ") " params) ;; res) - ))))) - -;; if a value is printable (i.e. string or number) return the value -;; else return an empty string -(define-inline (printable val) - (if (or (number? val)(string? val)) val "")) - -;;====================================================================== -;; Unix stuff -;;====================================================================== - -;; get values from cached info from dropping file in logs dir -;; e.g. key is host and dtype is normalized-load -;; -(define (get-cached-info logdir key dtype #!key (age 5)(log-port (current-error-port))) - (let* ((fullpath (conc logdir "/" key "-" dtype ".log"))) - (if (and (file-exists? fullpath) - (file-read-access? fullpath)) - (handle-exceptions - exn - #f - (debug-print 2 log-port "reading file " fullpath) - (let ((real-age (- (current-seconds)(file-change-time fullpath)))) - (if (< real-age age) - (with-input-from-file fullpath read) - (begin - (debug-print 2 log-port "file " fullpath " is too old (" real-age" seconds)to trust, skipping reading it") - #f)))) - (begin - (debug-print 2 log-port "not reading file " fullpath) - #f)))) - -(define (write-cached-info logdir key dtype dat) - (let* ((fullpath (conc logdir "/" key "-" dtype ".log"))) - (handle-exceptions - exn - #f - (with-output-to-file fullpath (lambda ()(pp dat)))))) - - -;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads -;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc. -;; keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load -;; -(define (get-normalized-cpu-load logdir remote-host) - (let ((actual-host (or remote-host (get-host-name)))) ;; #f is localhost - (or (get-cached-info logdir actual-host "normalized-load") - (let ((data (if remote-host - (with-input-from-pipe - (conc "ssh " remote-host " cat /proc/loadavg;cat /proc/cpuinfo;echo end") - read-lines) - (append - (with-input-from-file "/proc/loadavg" - read-lines) - (with-input-from-file "/proc/cpuinfo" - read-lines) - (list "end")))) - (load-rx (regexp "^([\\d\\.]+)\\s+([\\d\\.]+)\\s+([\\d\\.]+)\\s+.*$")) - (proc-rx (regexp "^processor\\s+:\\s+(\\d+)\\s*$")) - (core-rx (regexp "^core id\\s+:\\s+(\\d+)\\s*$")) - (phys-rx (regexp "^physical id\\s+:\\s+(\\d+)\\s*$")) - (max-num (lambda (p n)(max (string->number p) n)))) - ;; (print "data=" data) - (if (null? data) ;; something went wrong - #f - (let loop ((hed (car data)) - (tal (cdr data)) - (loads #f) - (proc-num 0) ;; processor includes threads - (phys-num 0) ;; physical chip on motherboard - (core-num 0)) ;; core - ;; (print hed ", " loads ", " proc-num ", " phys-num ", " core-num) - (if (null? tal) ;; have all our data, calculate normalized load and return result - (let* ((act-proc (+ proc-num 1)) - (act-phys (+ phys-num 1)) - (act-core (+ core-num 1)) - (adj-proc-load (/ (car loads) act-proc)) - (adj-core-load (/ (car loads) act-core)) - (result - (append (list (cons 'adj-proc-load adj-proc-load) - (cons 'adj-core-load adj-core-load)) - (list (cons '1m-load (car loads)) - (cons '5m-load (cadr loads)) - (cons '15m-load (caddr loads))) - (list (cons 'proc act-proc) - (cons 'core act-core) - (cons 'phys act-phys))))) - (write-cached-info logdir actual-host "normalized-load" result) - result) - (regex-case - hed - (load-rx ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num)) - (proc-rx ( x p ) (loop (car tal)(cdr tal) loads (max-num p proc-num) phys-num core-num)) - (phys-rx ( x p ) (loop (car tal)(cdr tal) loads proc-num (max-num p phys-num) core-num)) - (core-rx ( x c ) (loop (car tal)(cdr tal) loads proc-num phys-num (max-num c core-num))) - (else - (begin - ;; (print "NO MATCH: " hed) - (loop (car tal)(cdr tal) loads proc-num phys-num core-num))))))))))) - -;; use bash to expand a glob. Does NOT handle paths with spaces! -;; -(define (bash-glob instr) - (string-split - (with-input-from-pipe - (conc "/bin/bash -c \"echo " instr "\"") - read-line))) - -;; return the youngest timestamp . filename -;; -(define (get-youngest glob-list) - (let ((all-files (apply append - (map (lambda (patt) - (handle-exceptions - exn - '() - (glob patt))) - glob-list)))) - (fold (lambda (fname res) - (let ((last-mod (car res)) - (curmod (handle-exceptions - exn - 0 - (file-modification-time fname)))) - (if (> curmod last-mod) - (list curmod fname) - res))) - '(0 "n/a") - all-files))) - -;;====================================================================== -;; L O G G I N G D B -;;====================================================================== - -(define (open-logging-db toppath) - (let* ((dbpath (conc (if toppath (conc toppath "/") "") "logging.db")) ;; fname) - (dbexists (file-exists? dbpath)) - (db (sql:open-database dbpath)) - (handler (sql:busy-timeout 136000))) ;; remove argument to override - (sql:set-busy-handler! db handler) - (if (not dbexists) - (sql:exec (sql:sql db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);"))) - (sql:exec (sql:sql db "PRAGMA synchronous = 0;")) - db)) - -(define (log-local-event toppath . loglst) - (let ((logline (apply conc loglst))) - (log-event logline))) - -(define (log-event toppath logline) - (let ((db (open-logging-db toppath))) - (sql:exec - (sql:sql db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);") - logline - (current-directory) - (string-intersperse (argv) " ") - (current-process-id)) - logline)) - -;;====================================================================== -;; paths and directories -;;====================================================================== - -;; return first path that can be created or already exists and is writable -;; -(define (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 - (begin - ;; (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.") - (print "INFO: could not create " hed ", this might cause problems down the road.") - #f) - (create-directory hed #t))))) - (if (and (string? res) - (directory? res)) - res - (if (null? tal) - #f - (loop (car tal)(cdr tal)))))))) - -(define old-file-exists? file-exists?) - -(define (file-exists? path-string) - ;; this avoids stack dumps. NOTE: The issues that triggered this approach might have been fixed TODO: test and remove if possible - ;;;; 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... - (handle-exceptions - exn - #f - (old-file-exists? path-string))) - -;;====================================================================== -;; pkts stuff -;;====================================================================== - -;; load-pkts-to-db *used* to take a list of pkts dirs and roll them into a single db. This is now broken. -;; -(define (load-pkts-to-db pktsdir setup-pdbpath toppath #!key (use-lt #f)(log-port (current-error-port))) - (let ((pktsdirs (if (list? pktsdir) pktsdir `(,pktsdir))) - (pktsdir (if (list? pktsdir) (car pktsdir) pktsdir))) - (with-queue-db - pktsdir - setup-pdbpath - toppath - (lambda (pktsdirs pktsdir pdb) - (for-each - (lambda (pktsdir) ;; look at all - (cond - ((not (file-exists? pktsdir)) - (debug-print 0 log-port "ERROR: packets directory " pktsdir " does not exist.")) - ((not (directory? pktsdir)) - (debug-print 0 log-port "ERROR: packets directory path " pktsdir " is not a directory.")) - ((not (file-read-access? pktsdir)) - (debug-print 0 log-port "ERROR: packets directory path " pktsdir " is not readable.")) - (else - (print-info 0 log-port "Loading packets found in " pktsdir) - (let ((pkts (glob (conc pktsdir "/*.pkt")))) - (for-each - (lambda (pkt) - (let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt))) - (exists (lookup-by-uuid pdb uuid #f))) - (if (not exists) - (let* ((pktdat (string-intersperse - (with-input-from-file pkt read-lines) - "\n")) - (apkt (pkt->alist pktdat)) - (ptype (alist-ref 'T apkt))) - (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0) - (debug-print 4 log-port "Added " uuid " of type " ptype " to queue")) - (debug-print 4 log-port "pkt: " uuid " exists, skipping...") - ))) - pkts))))) - pktsdirs)) - use-lt: use-lt))) - -(define (get-pkt-alists pkts) - (map (lambda (x) - (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt - pkts)) - -(define (with-queue-db pktsdir setup-pdbpath toppath proc #!key (use-lt #f)(log-port (current-error-port))) - (let* ((pktsdirs (if (list? pktsdir) pktsdir `(,pktsdir))) ;; FIXME, ignoring all possible pkts dirs for now. (get-pkts-dirs use-lt pktsdir-str)) - (pktsdir (if (list? pktsdir)(car pktsdir) pktsdir)) - ;; (toppath toppath-in) ;; (or (configf:lookup mtconf "scratchdat" "toppath") toppath-in)) - (pdbpath (or setup-pdbpath pktsdir))) ;; (configf:lookup mtconf "setup" "pdbpath") - (cond - ((not pktsdir) - (debug-print 0 log-port "ERROR: pktsdir missing from setup section in your megatest.config for area management.")) - ((not toppath) - (debug-print 0 log-port "ERROR: toppath not found, area management config problem?")) - ((not pdbpath) - (debug-print 0 log-port "ERROR: pdbpath not found. Should be derived from pktsdir?")) - ((not (directory-exists? pktsdir)) - (debug-print 0 log-port "ERROR: pkts directory not found " pktsdir)) - ((not (equal? (file-owner pktsdir)(current-effective-user-id))) - (debug-print 0 log-port "ERROR: directory " pktsdir " is not owned by " (current-effective-user-name))) - (else - (let* ((pdb (open-queue-db pdbpath "pkts.db" - schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));")))) - (proc pktsdirs pktsdir pdb) - (dbi:close pdb)))))) - -;; look at consolidating this with mtut.scm get-pkts-dir -;; -;; (configf:lookup mtconf "setup" "pktsdirs") -(define (get-pkts-dirs use-lt #!key (top-path #f)(pktsdirs #f)) - (let* ((pktsdirs-str (or pktsdirs - (and use-lt - (conc (or top-path - (current-directory)) - "/lt/.pkts")))) - (pktsdirs (if pktsdirs-str - (string-split pktsdirs-str " ") - #f))) - pktsdirs)) - -;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending -;; also delete duplicates by target i.e. (car pkt) -;; -(define (get-pkt-times pkts) - (delete-duplicates - (sort - (map (lambda (x) - `(,(alist-ref 't x) . ,(string->number (alist-ref 'D x)))) - pkts) - (lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending - (lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target - -;;====================================================================== -;; T I M E A N D D A T E -;;====================================================================== - -;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 -(define (hms-string->seconds tstr) - (let ((parts (string-split-fields "\\w+" tstr)) - (time-secs 0) - ;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks - (trx (regexp "(\\d+)([smhdMyw])"))) - (for-each (lambda (part) - (let ((match (string-match trx part))) - (if match - (let ((val (string->number (cadr match))) - (unt (caddr match))) - (if val - (set! time-secs (+ time-secs (* val - (case (string->symbol unt) - ((s) 1) - ((m) 60) ;; minutes - ((h) 3600) - ((d) 86400) - ((w) 604800) - ((M) 2628000) ;; aproximately one month - ((y) 31536000) - (else #f)))))))))) - 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)))) - (conc (if (> hrs 0)(conc hrs "hr ") "") - (if (> min 0)(conc min "m ") "") - sec "s"))) - -(define (seconds->time-string sec) - (time->string - (seconds->local-time sec) "%H:%M:%S")) - -(define (seconds->work-week/day-time sec) - (time->string - (seconds->local-time sec) "ww%V.%u %H:%M")) - -(define (seconds->work-week/day sec) - (time->string - (seconds->local-time sec) "ww%V.%u")) - -(define (seconds->year-work-week/day sec) - (time->string - (seconds->local-time sec) "%yww%V.%w")) - -(define (seconds->year-work-week/day-time sec) - (time->string - (seconds->local-time sec) "%Yww%V.%w %H:%M")) - -(define (seconds->year-week/day-time sec) - (time->string - (seconds->local-time sec) "%Yw%V.%w %H:%M")) - -(define (seconds->quarter sec) - (case (string->number - (time->string - (seconds->local-time sec) - "%m")) - ((1 2 3) 1) - ((4 5 6) 2) - ((7 8 9) 3) - ((10 11 12) 4) - (else #f))) - -;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch -;; -(define (date-time->seconds datetime) - (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S"))) - -;; given span of seconds tstart to tend -;; find start time to mark and mark delta -;; -(define (find-start-mark-and-mark-delta tstart tend) - (let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ... - (result #f) - (min 60) - (hr (* 60 60)) - (day (* 24 hr)) - (yr (* 365 day)) ;; year - (mo (/ yr 12)) - (wk (* day 7))) - (for-each - (lambda (max-blks) - (for-each - (lambda (span) ;; 5 2 1 - (if (not result) - (for-each - (lambda (timeunit timesym) ;; year month day hr min sec - (if (not result) - (let* ((time-blk (* span timeunit)) - (num-blks (quotient deltat time-blk))) - (if (and (> num-blks 4)(< num-blks max-blks)) - (let ((first (* (quotient tstart time-blk) time-blk))) - (set! result (list span timeunit time-blk first timesym)) - ))))) - (list yr mo wk day hr min 1) - '( y mo w d h m s)))) - (list 8 6 5 2 1))) - '(5 10 15 20 30 40 50 500)) - (if values - (apply values result) - (values 0 day 1 0 'd)))) - -;; given x y lim return the cron expansion -;; -(define (expand-cron-slash x y lim) - (let loop ((curr x) - (res `())) - (if (< curr lim) - (loop (+ curr y) (cons curr res)) - (reverse res)))) - -;; expand a complex cron string to a list of cron strings -;; -;; x/y => x, x+y, x+2y, x+3y while x+Ny a, b ,c -;; -;; NOTE: with flatten a lot of the crud below can be factored down. -;; -(define (cron-expand cron-str) - (if (list? cron-str) - (flatten - (fold (lambda (x res) - (if (list? x) - (let ((newres (map cron-expand x))) - (append x newres)) - (cons x res))) - '() - cron-str)) ;; (map common:cron-expand cron-str)) - (let ((cron-items (string-split cron-str)) - (slash-rx (regexp "(\\d+)/(\\d+)")) - (comma-rx (regexp ".*,.*")) - (max-vals '((min . 60) - (hour . 24) - (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations - (month . 12) - (dayofweek . 7)))) - (if (< (length cron-items) 5) ;; bad spec - cron-str ;; `(,cron-str) ;; just return the string, something downstream will fix it - (let loop ((hed (car cron-items)) - (tal (cdr cron-items)) - (type 'min) - (type-tal '(hour dayofmonth month dayofweek)) - (res '())) - (regex-case - hed - (slash-rx ( _ base incr ) (let* ((basen (string->number base)) - (incrn (string->number incr)) - (expanded-vals (expand-cron-slash basen incrn (alist-ref type max-vals))) - (new-list-crons (fold (lambda (x myres) - (cons (conc (if (null? res) - "" - (conc (string-intersperse res " ") " ")) - x " " (string-intersperse tal " ")) - myres)) - '() expanded-vals))) - ;; (print "new-list-crons: " new-list-crons) - ;; (fold (lambda (x res) - ;; (if (list? x) - ;; (let ((newres (map common:cron-expand x))) - ;; (append x newres)) - ;; (cons x res))) - ;; '() - (flatten (map cron-expand new-list-crons)))) - ;; (map common:cron-expand (map common:cron-expand new-list-crons)))) - (else (if (null? tal) - cron-str - (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed))))))))))) - - -;; given a cron string and the last time event was processed return #t to run or #f to not run -;; -;; min hour dayofmonth month dayofweek -;; 0-59 0-23 1-31 1-12 0-6 ### NOTE: dayofweek does not include 7 -;; -;; #t => yes, run the job -;; #f => no, do not run the job -;; -(define (cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW. - (let* ((cron-items (map string->number (string-split cron-str))) - (now-seconds (or now-seconds-in (current-seconds))) - (now-time (seconds->local-time now-seconds)) - (last-done-time (seconds->local-time last-done)) - (all-times (make-hash-table))) - ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items)) - (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings - #f - (match-let ((( cmin chour cdayofmonth cmonth cdayofweek) - cron-items) - ;; 0 1 2 3 4 5 6 - ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9) - (vector->list now-time)) - ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9) - (vector->list last-done-time))) - ;; create all possible time slots - ;; remove invalid slots due to (for example) day of week - ;; get the start and end entries for the ref-seconds (current) time - ;; if last-done > ref-seconds => this is an ERROR! - ;; does the last-done time fall in the legit region? - ;; yes => #f do not run again this command - ;; no => #t ok to run the command - (for-each ;; month - (lambda (month) - (for-each ;; dayofmonth - (lambda (dom) - (for-each - (lambda (hr) ;; hour - (for-each - (lambda (minute) ;; minute - (let ((copy-now (apply vector (vector->list now-time)))) - (vector-set! copy-now 0 0) ;; force seconds to zero - (vector-set! copy-now 1 minute) - (vector-set! copy-now 2 hr) - (vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced - (vector-set! copy-now 4 month) - (let* ((copy-now-secs (local-time->seconds copy-now)) - (new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector - (if (or (not cdayofweek) - (equal? (vector-ref new-copy 6) - cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified - (if (or (not cdayofmonth) - (equal? (vector-ref new-copy 3) - (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified - (hash-table-set! all-times copy-now-secs new-copy)))))) - (if cmin - `(,cmin) ;; if given cmin, have to use it - (list (- nmin 1) nmin (+ nmin 1))))) ;; minute - (if chour - `(,chour) - (list (- nhour 1) nhour (+ nhour 1))))) ;; hour - (if cdayofmonth - `(,cdayofmonth) - (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1))))) - (if cmonth - `(,cmonth) - (list (- nmonth 1) nmonth (+ nmonth 1)))) - (let ((before #f) - (is-in #f)) - (for-each - (lambda (moment) - (if (and before - (<= before now-seconds) - (>= moment now-seconds)) - (begin - ;; (print) - ;; (print "Before: " (time->string (seconds->local-time before))) - ;; (print "Now: " (time->string (seconds->local-time now-seconds))) - ;; (print "After: " (time->string (seconds->local-time moment))) - ;; (print "Last: " (time->string (seconds->local-time last-done))) - (if (< last-done before) - (set! is-in before)) - )) - (set! before moment)) - (sort (hash-table-keys all-times) <)) - is-in))))) - -(define (extended-cron cron-str now-seconds-in last-done) - (let ((expanded-cron (cron-expand cron-str))) - (if (string? expanded-cron) - (cron-event expanded-cron now-seconds-in last-done) - (let loop ((hed (car expanded-cron)) - (tal (cdr expanded-cron))) - (if (cron-event hed now-seconds-in last-done) - #t - (if (null? tal) - #f - (loop (car tal)(cdr tal)))))))) - -(define (get-param-mapping #!key (flavor #f)) - "returns alist mapping string keys in testconfig/subrun to megatest command line switches; if flavor is switch-symbol, maps tcmt symbolic switches to megatest switches" - (let ((default '(("tag-expr" . "-tagexpr") - ("mode-patt" . "-modepatt") - ("run-name" . "-runname") - ("contour" . "-contour") - ("target" . "-target") - ("test-patt" . "-testpatt") - ("msg" . "-m") - ("log" . "-log") - ("start-dir" . "-start-dir") - ("new" . "-set-state-status")))) - (if (eq? flavor 'switch-symbol) - (map (lambda (x) - (cons (string->symbol (conc "-" (car x))) (cdr x))) - default) - default))) - - - -) DELETED src/mtconfigf.scm Index: src/mtconfigf.scm ================================================================== --- src/mtconfigf.scm +++ /dev/null @@ -1,1029 +0,0 @@ -;====================================================================== -;; Copyright 2006-2016, Matthew Welland. -;; -;; This file is part of Megatest. -;; -;; Megatest is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. -;; -;; Megatest is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with Megatest. If not, see . -;; -;;====================================================================== - -;; NOTE: This is the configf module, long term it will replace configf.scm. - -(declare (unit mtconfigf)) - -(module mtconfigf - ( - set-debug-printers - lazy-convert - assoc-safe-add - section-var-set! - safe-file-exists? - read-link-f - nice-path - eval-string-in-environment - safe-setenv - with-env-vars - cmd-run->list - port->list - configf:system - process-line - shell - configf:read-line - cfgdat->env-alist - calc-allow-system - apply-wildcards - val->alist - section->val-alist - read-config - find-config - find-and-read-config - lookup - var-is? - lookup-number - section-vars - get-section - set-section-var - compress-multi-lines - expand-multi-lines - file->list - write-config - read-refdb - map-all-hier-alist - config->alist - alist->config - read-alist - write-alist - config->ini - set-verbosity - ) - -(import scheme chicken data-structures extras ports files) -(use posix typed-records srfi-18) -(use regex regex-case srfi-69 srfi-1 directory-utils extras srfi-13) -(import posix) - -;; very wierd, the reference to pathname-directory here fixes a reference to possibly unbound identifier problem -;; -;; (define (dummy-function path) -;; (pathname-directory path) -;; (absolute-pathname? path) -;; (normalize-pathname path)) - -;;====================================================================== -;; -;; CONVERGE THIS WITH mtcommon.scm debug-print stuff -;; -;;====================================================================== -(define *verbosity* 4) - -(define (set-verbosity v)(set! *verbosity* v)) - -(define (tmp-debug-print n e . params) - (if (cond - ((list? n)(< (apply min n) *verbosity*)) - ((number? n) (< n *verbosity*)) - (else #f)) - (with-output-to-port (or e (current-error-port)) - (lambda ()(apply print params))))) -(define debug:print-error tmp-debug-print) -(define debug:print tmp-debug-print) -(define debug:print-info tmp-debug-print) -(define *default-log-port* (current-error-port)) - -(define (set-debug-printers normal-fn info-fn error-fn default-port) - (if error-fn (set! debug:print-error error-fn)) - (if info-fn (set! debug:print-info info-fn)) - (if normal-fn (set! debug:print normal-fn)) - (if default-port (set! *default-log-port* default-port))) - -;; if it looks like a number -> convert it to a number, else return it -;; -(define (lazy-convert inval) - (let* ((as-num (if (string? inval)(string->number inval) #f))) - (or as-num inval))) - -;; Moved to common -;; -;; return list (path fullpath configname) -(define (find-config configname #!key (toppath #f)) - (if toppath - (let ((cfname (conc toppath "/" configname))) - (if (safe-file-exists? cfname) - (list toppath cfname configname) - (list #f #f #f))) - (let* ((cwd (string-split (current-directory) "/"))) - (let loop ((dir cwd)) - (let* ((path (conc "/" (string-intersperse dir "/"))) - (fullpath (conc path "/" configname))) - (if (safe-file-exists? fullpath) - (list path fullpath configname) - (let ((remcwd (take dir (- (length dir) 1)))) - (if (null? remcwd) - (list #f #f #f) ;; #f #f) - (loop remcwd))))))))) - -(define (assoc-safe-add alist key val #!key (metadata #f)) - (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) - (append newalist (list (if metadata - (list key val metadata) - (list key val)))))) - -(define (section-var-set! cfgdat section-name var value #!key (metadata #f)) - (hash-table-set! cfgdat section-name - (assoc-safe-add - (hash-table-ref/default cfgdat section-name '()) - var value metadata: metadata))) -;;====================================================================== -;; Environment handling stuff -;;====================================================================== - -(define (safe-file-exists? path) - (handle-exceptions exn #f (file-exists? path))) - -(define (read-link-f path) - (handle-exceptions - exn - (begin - (debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed.") - path) ;; just give up - (with-input-from-pipe - (conc "/bin/readlink -f " path) - (lambda () - (read-line))))) - -;; return a nice clean pathname made absolute -(define (nice-path dir) - (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) - (if match ;; using ~ for home? - (nice-path (conc (read-link-f (cadr match)) "/" (caddr match))) - (normalize-pathname (if (absolute-pathname? dir) - dir - (conc (current-directory) "/" dir)))))) - -(define (eval-string-in-environment str) - (handle-exceptions - exn - (begin - (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment") - #f) - (let ((cmdres (cmd-run->list (conc "echo " str)))) - (if (null? cmdres) "" - (caar cmdres))))) - -(define (safe-setenv key val) - (if (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables. - (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\"") - (if (and (string? val) - (string? key)) - (handle-exceptions - exn - (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val) - (setenv key val)) - (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)))) - -;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) -;; execute thunk in context of environment modified as per this list -;; restore env to prior state then return value of eval'd thunk. -;; ** this is not thread safe ** -(define (with-env-vars delta-env-alist-or-hash-table thunk) - (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table) - (hash-table->alist delta-env-alist-or-hash-table) - delta-env-alist-or-hash-table)) - (restore-thunks - (filter - identity - (map (lambda (env-pair) - (let* ((env-var (car env-pair)) - (new-val (let ((tmp (cdr env-pair))) - (if (list? tmp) (car tmp) tmp))) - (current-val (get-environment-variable env-var)) - (restore-thunk - (cond - ((not current-val) (lambda () (unsetenv env-var))) - ((not (string? new-val)) #f) - ((eq? current-val new-val) #f) - (else - (lambda () (setenv env-var current-val)))))) - ;;(when (not (string? new-val)) - ;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist) - ;; (pp delta-env-alist) - ;; (exit 1)) - - - (cond - ((not new-val) ;; modify env here - (unsetenv env-var)) - ((string? new-val) - (setenv env-var new-val))) - restore-thunk)) - delta-env-alist)))) - (let ((rv (thunk))) - (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state - rv))) - -(define (cmd-run->list cmd #!key (delta-env-alist-or-hash-table '())) - (with-env-vars - delta-env-alist-or-hash-table - (lambda () - (let* ((fh (open-input-pipe cmd)) - (res (port->list fh)) - (status (close-input-pipe fh))) - (list res status))))) - -(define (port->list fh) - (if (eof-object? fh) #f - (let loop ((curr (read-line fh)) - (result '())) - (if (not (eof-object? curr)) - (loop (read-line fh) - (append result (list curr))) - result)))) - -;;====================================================================== -;; Make the regexp's needed globally available -;;====================================================================== - -(define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) -(define configf:script-rx (regexp "^\\[scriptinc\\s+(\\S+)([^\\]]*)\\]\\s*$")) ;; include output from a script -(define configf:section-rx (regexp "^\\[(.*)\\]\\s*$")) -(define configf:blank-l-rx (regexp "^\\s*$")) -(define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) -(define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$")) -(define configf:key-no-val (regexp "^(\\S+)(\\s*)$")) -(define configf:comment-rx (regexp "^\\s*#.*")) -(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")) -(define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$")) - -;; read a line and process any #{ ... } constructs - -(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)")) - -(define (configf:system ht cmd) - (system cmd) - ) - -(define (process-line l ht allow-system #!key (linenum #f)) - (let loop ((res l)) - (if (string? res) - (let ((matchdat (string-search configf:var-expand-regex res))) - (if matchdat - (let* ((prestr (list-ref matchdat 1)) - (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv - (cmd (list-ref matchdat 3)) - (poststr (list-ref matchdat 4)) - (result #f) - (start-time (current-seconds)) - (cmdsym (string->symbol cmdtype)) - (fullcmd (case cmdsym - ((scheme scm) (conc "(lambda (ht)" cmd ")")) - ((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))")) - ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))")) - ((realpath rp)(conc "(lambda (ht)(nice-path \"" cmd "\"))")) - ((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))")) - ((mtrah) (conc "(lambda (ht)" - " (let ((extra \"" cmd "\"))" - " (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))" - " (if (string-null? extra) \"\" \"/\")" - " extra)))")) - ((get g) - (let* ((parts (string-split cmd)) - (sect (car parts)) - (var (cadr parts))) - (conc "(lambda (ht)(lookup ht \"" sect "\" \"" var "\"))"))) - ((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) - ;; ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) - (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) - ;; (print "fullcmd=" fullcmd) - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\"") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - ;; (print "exn=" (condition->list exn)) - (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd))) - (if (or allow-system - (not (member cmdtype '("system" "shell" "sh")))) - (with-input-from-string fullcmd - (lambda () - (set! result ((eval (read)) ht)))) - (set! result (conc "#{(" cmdtype ") " cmd "}")))) - (case cmdsym - ((system shell scheme) - (let ((delta (- (current-seconds) start-time))) - (if (> delta 2) - (debug:print-info 0 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result) - (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result))))) - (loop (conc prestr result poststr))) - res)) - res))) - -;; Run a shell command and return the output as a string -(define (shell cmd) - (let* ((output (cmd-run->list cmd)) - (res (car output)) - (status (cadr output))) - (if (equal? status 0) - (let ((outres (string-intersperse - res - "\n"))) - (debug:print-info 4 *default-log-port* "shell result:\n" outres) - outres) - (begin - (with-output-to-port (current-error-port) - (lambda () - (print "ERROR: " cmd " returned bad exit code " status))) - "")))) - -;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ... -;; -(define (configf:read-line p ht allow-processing settings) - (let loop ((inl (read-line p))) - (let ((cont-line (and (string? inl) - (not (string-null? inl)) - (equal? "\\" (string-take-right inl 1))))) - (if cont-line ;; last character is \ - (let ((nextl (read-line p))) - (if (not (eof-object? nextl)) - (loop (string-append (if cont-line - (string-take inl (- (string-length inl) 1)) - inl) - nextl)))) - (let ((res (case allow-processing ;; if (and allow-processing - ;; (not (eq? allow-processing 'return-string))) - ((#t #f) - (process-line inl ht allow-processing)) - ((return-string) - inl) - (else - (process-line inl ht allow-processing))))) - (if (and (string? res) - (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no"))) - (string-substitute "\\s+$" "" res) - res)))))) - -(define (cfgdat->env-alist section cfgdat-ht allow-system) - (filter - (lambda (pair) - (let* ((var (car pair)) - (val (cdr pair))) - (cons var - (cond - ((and allow-system (procedure? val)) ;; if we decided to use something other than #t or #f for allow-system ('return-procs or 'return-string) , this may become problematic - (val)) - ((procedure? val) #f) - ((string? val) val) - (else "#f"))))) - (append - (hash-table-ref/default cfgdat-ht "default" '()) - (if (equal? section "default") '() (hash-table-ref/default cfgdat-ht section '()))))) - -(define (calc-allow-system allow-system section sections) - (if sections - (and (or (equal? "default" section) - (member section sections)) - allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings - allow-system)) - -;; given a config hash and a section name, apply that section to all matching sections (using wildcard % or regex if /..../) -;; remove the section when done so that there is no downstream clobbering -;; -(define (apply-wildcards ht section-name) - (if (hash-table-exists? ht section-name) - (let* ((vars (hash-table-ref ht section-name)) - (rxstr (if (string-contains section-name "%") - (string-substitute (regexp "%") ".*" section-name) - (string-substitute (regexp "^/(.*)/$") "\\1" section-name))) - (rx (regexp rxstr))) - ;; (print "\nsection-name: " section-name " rxstr: " rxstr) - (for-each - (lambda (section) - (if section - (let ((same-section (string=? section-name section)) - (rx-match (string-match rx section))) - ;; (print "section: " section " vars: " vars " same-section: " same-section " rx-match: " rx-match) - (if (and (not same-section) rx-match) - (for-each - (lambda (bundle) - ;; (print "bundle: " bundle) - (let ((key (car bundle)) - (val (cadr bundle)) - (meta (if (> (length bundle) 2)(caddr bundle) #f))) - (hash-table-set! ht section (assoc-safe-add (hash-table-ref ht section) key val metadata: meta)))) - vars))))) - (hash-table-keys ht)))) - ht) - -;;====================================================================== -;; Extended config lines, allows storing more hierarchial data in the config lines -;; ABC a=1; b=hello world; c=a -;; -;; NOTE: implementation is quite limited. You currently cannot have -;; semicolons in your string values. -;;====================================================================== - -;; convert string a=1; b=2; c=a silly thing; d= -;; to '((a . 1)(b . 2)(c . "a silly thing")(d . "")) -;; -(define (val->alist val #!key (convert #f)) - (let ((val-list (string-split-fields ";\\s*" val #:infix))) - (if val-list - (map (lambda (x) - (let ((f (string-split-fields "\\s*=\\s*" x #:infix))) - (case (length f) - ((0) `(,#f)) ;; null string case - ((1) `(,(string->symbol (car f)))) - ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f))) - (if convert (lazy-convert inval) inval)))) - (else f)))) - val-list) - '()))) - -;; I don't want configf to turn into a weak yaml format but this extention is really useful -;; -(define (section->val-alist cfgdat section-name #!key (convert #f)) - (let ((section (get-section cfgdat section-name))) - (map (lambda (item) - (let ((key (car item)) - (val (cadr item))) ;; BUG IN WAIT. sections are not returned as proper alists, should fix this. - (cons key (val->alist val convert: convert)))) - section))) - -;; read a config file, returns hash table of alists - -;; read a config file, returns hash table of alists -;; adds to ht if given (must be #f otherwise) -;; allow-system: -;; #f - do not evaluate [system -;; #t - immediately evaluate [system and store result as string -;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time -;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time -;; envion-patt is a regex spec that identifies sections that will be eval'd -;; in the environment on the fly -;; sections: #f => get all, else list of sections to gather -;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path) -;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections -;; -;; NOTE: apply-wild variable is intentional (but a better name would be good) -;; -(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f) - (sections #f) (settings (make-hash-table)) (keep-filenames #f) - (post-section-procs '()) (apply-wild #t) ) - (debug:print 9 *default-log-port* "START: " path) -;; (if *configdat* -;; (common:save-pkt `((action . read-config) -;; (f . ,(cond ((string? path) path) -;; ((port? path) "port") -;; (else (conc path)))) -;; (T . configf)) -;; *configdat* #t add-only: #t)) - (if (and (not (port? path)) - (not (safe-file-exists? path))) ;; for case where we are handed a port - (begin - (debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory)) - ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read? - #f) ;; (if (not ht)(make-hash-table) ht)) - (let ((inp (if (string? path) - (open-input-file path) - path)) ;; we can be handed a port - (res (if (not ht)(make-hash-table) ht)) - (metapath (if keep-filenames - path #f)) - (process-wildcards (lambda (res curr-section-name) - (if (and apply-wild - (or (string-contains curr-section-name "%") ;; wildcard - (string-match "/.*/" curr-section-name))) ;; regex - (begin - (apply-wildcards res curr-section-name) - (hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res - (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp)) - (curr-section-name (if curr-section curr-section "default")) - (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere - (lead #f)) - (debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") - (if (eof-object? inl) - (begin - ;; process last section for wildcards - (process-wildcards res curr-section-name) - (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it. - (close-input-port inp)) - (if (list? sections) ;; delete all sections except given when sections is provided - (for-each - (lambda (section) - (if (not (member section sections)) - (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht - (hash-table-keys res))) - (debug:print 9 *default-log-port* "END: " path) - res - ) ;; retval - (regex-case - inl - (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) - curr-section-name #f #f)) - - (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) - curr-section-name #f #f)) - (configf:settings ( x setting val ) - (begin - (hash-table-set! settings setting val) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) - curr-section-name #f #f))) - - (configf:include-rx ( x include-file ) - (let* ((curr-conf-dir (pathname-directory path)) - (full-conf (if (absolute-pathname? include-file) - include-file - (nice-path - (conc (if curr-conf-dir - curr-conf-dir - ".") - "/" include-file))))) - (if (safe-file-exists? full-conf) - (begin - ;; (push-directory conf-dir) - (debug:print 9 *default-log-port* "Including: " full-conf) - (read-config full-conf res allow-system environ-patt: environ-patt - curr-section: curr-section-name sections: sections settings: settings - keep-filenames: keep-filenames) - ;; (pop-directory) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (begin - (debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")") - (debug:print 2 *default-log-port* " " full-conf) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) - curr-section-name #f #f))))) - (configf:script-rx ( x include-script params);; handle-exceptions - ;; exn - ;; (begin - ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") - ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (if (and (safe-file-exists? include-script)(file-execute-access? include-script)) - (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections)) - (env-delta (cfgdat->env-alist curr-section-name res local-allow-system)) - (new-inp-port - (with-env-vars - env-delta - (lambda () - (open-input-pipe (conc include-script " " params)))))) - (debug:print '(2 9) *default-log-port* "Including from script output: " include-script) - ;; (print "We got here, calling read-config next. Port is: " new-inp-port) - (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) - (close-input-port new-inp-port) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (begin - (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) - ) ;; ) - (configf:section-rx ( x section-name ) - (begin - ;; call post-section-procs - (for-each - (lambda (dat) - (let ((patt (car dat)) - (proc (cdr dat))) - (if (string-match patt curr-section-name) - (proc curr-section-name section-name res path)))) - post-section-procs) - ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards - ;; NOTE: we are processing the curr-section-name, NOT section-name. - (process-wildcards res curr-section-name) - (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) - ;; if we have the sections list then force all settings into "" and delete it later? - ;; (if (or (not sections) - ;; (member section-name sections)) - ;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later. - section-name - #f #f))) - (configf:key-sys-pr ( x key cmd ) - (if (calc-allow-system allow-system curr-section-name sections) - (let ((alist (hash-table-ref/default res curr-section-name '())) - (val-proc (lambda () - (let* ((start-time (current-seconds)) - (local-allow-system (calc-allow-system allow-system curr-section-name sections)) - (env-delta (cfgdat->env-alist curr-section-name res local-allow-system)) - (cmdres (cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars! - (delta (- (current-seconds) start-time)) - (status (cadr cmdres)) - (res (car cmdres))) - (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n")) - (if (not (eq? status 0)) - (begin - (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status - " output: " cmdres))) - (if (> delta 2) - (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) - (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) - (if (null? res) - "" - (string-intersperse res " ")))))) - (hash-table-set! res curr-section-name - (assoc-safe-add alist - key - (case (calc-allow-system allow-system curr-section-name sections) - ((return-procs) val-proc) - ((return-string) cmd) - (else (val-proc))) - metadata: metapath)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) - (loop (configf:read-line inp res - (calc-allow-system allow-system curr-section-name sections) - settings) - curr-section-name #f #f))) - - (configf:key-no-val ( x key val) - (let* ((alist (hash-table-ref/default res curr-section-name '())) - (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) - (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t") - (safe-setenv key fval) - (hash-table-set! res curr-section-name - (assoc-safe-add alist key fval metadata: metapath)) - (loop (configf:read-line inp res - (calc-allow-system allow-system curr-section-name sections) - settings) - curr-section-name key #f))) - - (configf:key-val-pr ( x key unk1 val unk2 ) - (let* ((alist (hash-table-ref/default res curr-section-name '())) - (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) - (realval (if envar - (eval-string-in-environment val) - val))) - (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) - (if envar (safe-setenv key realval)) - (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val) - (hash-table-set! res curr-section-name - (assoc-safe-add alist key realval metadata: metapath)) - (loop (configf:read-line inp res - (calc-allow-system allow-system curr-section-name sections) settings) - curr-section-name key #f))) - ;; if a continued line - (configf:cont-ln-rx ( x whsp val ) - (let ((alist (hash-table-ref/default res curr-section-name '()))) - (if var-flag ;; if set to a string then we have a continued var - (let ((newval (conc - (lookup res curr-section-name var-flag) "\n" - ;; trim lead from the incoming whsp to support some indenting. - (if lead - (string-substitute (regexp lead) "" whsp) - "") - val))) - ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) - (hash-table-set! res curr-section-name - (assoc-safe-add alist var-flag newval metadata: metapath)) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) - (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"") - (set! var-flag #f) - (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) - ) ;; end loop - ))) - -;; look at common:set-fields for an example of how to use the set-fields proc -;; pathenvvar will set the named var to the path of the config -;; -(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)(set-fields #f)) - (let* ((curr-dir (current-directory)) - (configinfo (find-config fname toppath: given-toppath)) - (toppath (car configinfo)) - (configfile (cadr configinfo))) - (if toppath (change-directory toppath)) - (if (and toppath pathenvvar)(setenv pathenvvar toppath)) - (let ((configdat (if configfile - (read-config configfile #f #t environ-patt: environ-patt - post-section-procs: (if set-fields (list (cons "^fields$" set-fields)) '()) - #f)))) - (if toppath (change-directory curr-dir)) - (list configdat toppath configfile fname)))) - -(define (lookup cfgdat section var) - (if (hash-table? cfgdat) - (let ((sectdat (hash-table-ref/default cfgdat section '()))) - (if (null? sectdat) - #f - (let ((match (assoc var sectdat))) - (if match ;; (and match (list? match)(> (length match) 1)) - (cadr match) - #f)) - )) - #f)) - -;; use to have definitive setting: -;; [foo] -;; var yes -;; -;; (var-is? cfgdat "foo" "var" "yes") => #t -;; -(define (var-is? cfgdat section var expected-val) - (equal? (lookup cfgdat section var) expected-val)) - -;; safely look up a value that is expected to be a number, return -;; a default (#f unless provided) -;; -(define (lookup-number cfgdat section varname #!key (default #f)) - (let* ((val (lookup cfgdat section varname)) - (res (if val - (string->number (string-substitute "\\s+" "" val #t)) - #f))) - (cond - (res res) - (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val)) - (else default)))) - -(define (section-vars cfgdat section) - (let ((sectdat (hash-table-ref/default cfgdat section '()))) - (if (null? sectdat) - '() - (map car sectdat)))) - -(define (get-section cfgdat section) - (hash-table-ref/default cfgdat section '())) - -(define (set-section-var cfgdat section var val) - (let ((sectdat (get-section cfgdat section))) - (hash-table-set! cfgdat section - (assoc-safe-add sectdat var val)))) - - ;;(append (filter (lambda (x)(not (assoc var sectdat))) sectdat) - ;; (list var val)))) - -;; moved to common -;; (define (setup) -;; (let* ((configf (find-config "megatest.config")) -;; (config (if configf (read-config configf #f #t) #f))) -;; (if config -;; (setenv "RUN_AREA_HOME" (pathname-directory configf))) -;; config)) - -;;====================================================================== -;; Non destructive writing of config file -;;====================================================================== - -(define (compress-multi-lines fdat) - ;; step 1.5 - compress any continued lines - (if (null? fdat) fdat - (let loop ((hed (car fdat)) - (tal (cdr fdat)) - (cur "") - (led #f) - (res '())) - ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!! - ;; 1. remove led whitespace - ;; 2. tack on to hed with "\n" - (let ((match (string-match configf:cont-ln-rx hed))) - (if match ;; blast! have to deal with a multiline - (let* ((lead (cadr match)) - (lval (caddr match)) - (newl (conc cur "\n" lval))) - (if (not led)(set! led lead)) - (if (null? tal) - (set! fdat (append fdat (list newl))) - (loop (car tal)(cdr tal) newl led res))) ;; NB// not tacking newl onto res - (let ((newres (if led - (append res (list cur hed)) - (append res (list hed))))) - ;; prev was a multiline - (if (null? tal) - newres - (loop (car tal)(cdr tal) "" #f newres)))))))) - -;; note: I'm cheating a little here. I merely replace "\n" with "\n " -(define (expand-multi-lines fdat) - ;; step 1.5 - compress any continued lines - (if (null? fdat) fdat - (let loop ((hed (car fdat)) - (tal (cdr fdat)) - (res '())) - (let ((newres (append res (list (string-substitute (regexp "\n") "\n " hed #t))))) - (if (null? tal) - newres - (loop (car tal)(cdr tal) newres)))))) - -(define (file->list fname) - (if (safe-file-exists? fname) - (let ((inp (open-input-file fname))) - (let loop ((inl (read-line inp)) - (res '())) - (if (eof-object? inl) - (begin - (close-input-port inp) - (reverse res)) - (loop (read-line inp)(cons inl res))))) - '())) - -;;====================================================================== -;; Write a config -;; 0. Given a refererence data structure "indat" -;; 1. Open the output file and read it into a list -;; 2. Flatten any multiline entries -;; 3. Modify values per contents of "indat" and remove absent values -;; 4. Append new values to the section (immediately after last legit entry) -;; 5. Write out the new list -;;====================================================================== - -(define (write-config indat fname #!key (required-sections '())) - (let* (;; step 1: Open the output file and read it into a list - (fdat (file->list fname)) - (refdat (make-hash-table)) - (sechash (make-hash-table)) ;; current section hash, init with hash for "default" section - (new #f) ;; put the line to be used in new, if it is to be deleted the set new to #f - (secname #f)) - - ;; step 2: Flatten multiline entries - (if (not (null? fdat))(set! fdat (compress-multi-lines fdat))) - - ;; step 3: Modify values per contents of "indat" and remove absent values - (if (not (null? fdat)) - (let loop ((hed (car fdat)) - (tal (cadr fdat)) - (res '()) - (lnum 0)) - (regex-case - hed - (configf:comment-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f)) - (configf:blank-l-rx _ (set! res (append res (list hed)))) ;; (loop (read-line inp) curr-section-name #f #f)) - (configf:section-rx ( x section-name ) (let ((section-hash (hash-table-ref/default refdat section-name #f))) - (if (not section-hash) - (let ((newhash (make-hash-table))) - (hash-table-set! refdat section-name newhash) - (set! sechash newhash)) - (set! sechash section-hash)) - (set! new hed) ;; will append this at the bottom of the loop - (set! secname section-name) - )) - ;; No need to process key cmd, let it fall though to key val - (configf:key-val-pr ( x key val ) - (let ((newval (lookup indat secname key))) ;; secname was sec. I think that was a bug - ;; can handle newval == #f here => that means key is removed - (cond - ((equal? newval val) - (set! res (append res (list hed)))) - ((not newval) ;; key has been removed - (set! new #f)) - ((not (equal? newval val)) - (hash-table-set! sechash key newval) - (set! new (conc key " " newval))) - (else - (debug:print-error 0 *default-log-port* "problem parsing line number " lnum "\"" hed "\""))))) - (else - (debug:print-error 0 *default-log-port* "Problem parsing line num " lnum " :\n " hed ))) - (if (not (null? tal)) - (loop (car tal)(cdr tal)(if new (append res (list new)) res)(+ lnum 1))) - ;; drop to here when done processing, res contains modified list of lines - (set! fdat res))) - - ;; step 4: Append new values to the section - (for-each - (lambda (section) - (let ((sdat '()) ;; append needed bits here - (svars (section-vars indat section))) - (for-each - (lambda (var) - (let ((val (lookup refdat section var))) - (if (not val) ;; this one is new - (begin - (if (null? sdat)(set! sdat (list (conc "[" section "]")))) - (set! sdat (append sdat (list (conc var " " val)))))))) - svars) - (set! fdat (append fdat sdat)))) - (delete-duplicates (append required-sections (hash-table-keys indat)))) - - ;; step 5: Write out new file - (with-output-to-file fname - (lambda () - (for-each - (lambda (line) - (print line)) - (expand-multi-lines fdat)))))) - -;;====================================================================== -;; refdb -;;====================================================================== - -;; reads a refdb into an assoc array of assoc arrays -;; returns (list dat msg) -(define (read-refdb refdb-path) - (let ((sheets-file (conc refdb-path "/sheet-names.cfg"))) - (if (not (safe-file-exists? sheets-file)) - (list #f (conc "ERROR: no refdb found at " refdb-path)) - (if (not (file-read-access? sheets-file)) - (list #f (conc "ERROR: refdb file not readable at " refdb-path)) - (let* ((sheets (with-input-from-file sheets-file - (lambda () - (let loop ((inl (read-line)) - (res '())) - (if (eof-object? inl) - (reverse res) - (loop (read-line)(cons inl res))))))) - (data '())) - (for-each - (lambda (sheet-name) - (let* ((dat-path (conc refdb-path "/" sheet-name ".dat")) - (ref-dat (read-config dat-path #f #t)) - (ref-assoc (map (lambda (key) - (list key (hash-table-ref ref-dat key))) - (hash-table-keys ref-dat)))) - ;; (hash-table->alist ref-dat))) - ;; (set! data (append data (list (list sheet-name ref-assoc)))))) - (set! data (cons (list sheet-name ref-assoc) data)))) - sheets) - (list data "NO ERRORS")))))) - -;; map over all pairs in a three level hierarchial alist and apply a function to the keys/val -;; -(define (map-all-hier-alist data proc #!key (initproc1 #f)(initproc2 #f)(initproc3 #f)) - (for-each - (lambda (sheetname) - (let* ((sheettmp (assoc sheetname data)) - (sheetdat (if sheettmp (cadr sheettmp) '()))) - (if initproc1 (initproc1 sheetname)) - (for-each - (lambda (sectionname) - (let* ((sectiontmp (assoc sectionname sheetdat)) - (sectiondat (if sectiontmp (cadr sectiontmp) '()))) - (if initproc2 (initproc2 sheetname sectionname)) - (for-each - (lambda (varname) - (let* ((valtmp (assoc varname sectiondat)) - (val (if valtmp (cadr valtmp) ""))) - (proc sheetname sectionname varname val))) - (map car sectiondat)))) - (map car sheetdat)))) - (map car data)) - data) - -;;====================================================================== -;; C O N F I G T O / F R O M A L I S T -;;====================================================================== - -(define (config->alist cfgdat) - (hash-table->alist cfgdat)) - -(define (alist->config adat) - (let ((ht (make-hash-table))) - (for-each - (lambda (section) - (hash-table-set! ht (car section)(cdr section))) - adat) - ht)) - -;; if -(define (read-alist fname) - (handle-exceptions - exn - #f - (alist->config - (with-input-from-file fname read)))) - -(define (write-alist cdat fname #!key (locker #f)(unlocker #f)) - (if (and locker (not (locker fname))) - (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname)) - (let* ((dat (config->alist cdat)) - (res - (begin - (with-output-to-file fname ;; first write out the file - (lambda () - (pp dat))) - - (if (file-exists? fname) ;; now verify it is readable - (if (read-alist fname) - #t ;; data is good. - (begin - (handle-exceptions - exn - #f - (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.") - (delete-file fname)) - #f)) - #f)))) - (if unlocker (unlocker fname)) - res)) - -;; convert hierarchial list to ini format -;; -(define (config->ini data) - (map - (lambda (section) - (let ((section-name (car section)) - (section-dat (cdr section))) - (print "\n[" section-name "]") - (map (lambda (dat-pair) - (let* ((var (car dat-pair)) - (val (cadr dat-pair)) - (fname (if (> (length dat-pair) 2)(caddr dat-pair) #f))) - (if fname (print "# " var "=>" fname)) - (print var " " val))) - section-dat))) ;; (print "section-dat: " section-dat)) - (hash-table->alist data))) - -) DELETED src/mtdb.scm Index: src/mtdb.scm ================================================================== --- src/mtdb.scm +++ /dev/null @@ -1,105 +0,0 @@ -;====================================================================== -;; Copyright 2006-2016, Matthew Welland. -;; -;; This file is part of Megatest. -;; -;; Megatest is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. -;; -;; Megatest is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with Megatest. If not, see . -;; -;;====================================================================== - -;; NOTE: This is the db module, long term it will replace db.scm. -;; WARN: This module conflicts with db.scm as it uses sql-de-lite - -(declare (unit mtdb)) -(declare (uses mtcommon)) - -(module mtdb - ( - get-db-tmp-area - ) - -(import scheme chicken data-structures extras (prefix mtcommon common:)) -(use (prefix sql-de-lite sql) posix typed-records) - -(define *default-log-port* (current-error-port)) - -;;====================================================================== -;; Database access -;;====================================================================== - - -;;====================================================================== -;; R E C O R D S -;;====================================================================== - -;; areas -;; run.db -;; runs => 1.db, 2.db ... - -;; each db entry is a pair ( db . dbfilepath ) -;; I propose this record evolves into the area record -;; -(defstruct dbr:dbstruct - (tmpdb #f) - (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack - (mtdb #f) - (refndb #f) - (homehost #f) ;; not used yet - (on-homehost #f) ;; not used yet - (read-only #f) - ) ;; goal is to converge on one struct for an area but for now it is too confusing - - -;; record for keeping state,status and count for doing roll-ups in -;; iterated tests -;; -(defstruct dbr:counts - (state #f) - (status #f) - (count 0)) - -;;====================================================================== -;; SQLITE3 HELPERS -;;====================================================================== - - -(define (general-sql-de-lite-error-dump exn stmt . params) - (let ((err-status ((condition-property-accessor 'sql-de-lite 'status #f) exn))) ;; RADT ... how does this work? - ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) - (print "err-status: " err-status) - (common:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) - (print-call-chain (current-error-port)))) - -;;====================================================================== -;; Manage the /tmp/ db mirror area -;;====================================================================== - -(define (get-db-tmp-area area-path area-name) - (let ((dbdir (conc "/tmp/" (current-user-name) - "/megatest_localdb/" - area-name "/" - (string-translate area-path "/" ".")))) - (if area-path ;; common:get-create-writeable-dir - (handle-exceptions - exn - (begin - (common:print-error 0 *default-log-port* "Couldn't create path to " dbdir) - (exit 1)) - (let ((dbpath (common:get-create-writeable-dir - (list dbdir)))) ;; #t)))) - dbpath)) - #f))) - - -)