;======================================================================
;; 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 <http://www.gnu.org/licenses/>.
;;
;;======================================================================
;; 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
)
(import scheme chicken data-structures extras posix ports)
(use (prefix sql-de-lite sql:) posix typed-records format srfi-1 srfi-69)
(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)
)))))
;; ;; 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 ""))
;;======================================================================
;; 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)))
)