Megatest

(declare (unit commonmod))

(use srfi-69)

(module commonmod
	*

(import scheme chicken data-structures extras files ports)
(import (prefix sqlite3 sqlite3:)
	posix typed-records srfi-18 srfi-69
	md5 message-digest
	regex srfi-1)

;;======================================================================
;; CONTENTS

;;
(define (get-cfg-areas cfgdat)
  (let ((adat (get-section cfgdat "areas")))
    (map (lambda (entry)
	   `(,(car entry) . 
	     ,(val->alist (cadr entry))))
	 adat)))

;;======================================================================
;; debugprint
;;======================================================================

;;======================================================================
;; debug stuff
;;======================================================================

(define verbosity (make-parameter '()))
(define *default-log-port*  (current-error-port))
(define debug:print-logger (make-parameter #f)) ;; set to a proc to call on every logging print
	 
(define (debug:setup debug debug-noprop)
  (let ((debugstr (or debug        ;; (args:get-arg "-debug")
      		      debug-noprop ;; (args:get-arg "-debug-noprop")
      		      (get-environment-variable "MT_DEBUG_MODE"))))
    (verbosity (debug:calc-verbosity debugstr 'q))
    (debug:check-verbosity (verbosity) debugstr)
    ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
    (if (not (verbosity))(verbosity 1))
    (if (and (not debug-noprop) ;; (args:get-arg "-debug-noprop")
      	     (or debug          ;; (args:get-arg "-debug")
      		 (not (get-environment-variable "MT_DEBUG_MODE"))))
      	(setenv #;set-environment-variable! "MT_DEBUG_MODE" (if (list? (verbosity))
      				    (string-intersperse (map conc (verbosity)) ",")
      				    (conc (verbosity)))))))

;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
  (if (not (or (number? verbosity)
     	       (list?   verbosity)))
      (begin
     	(print "ERROR: Invalid debug value \"" vstr "\"")
     	#f)
      #t))

;;======================================================================
;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;; 
;; (define (set-functions dbgp dbgpinfo)
;;   (set! debug:print dbgp)
;;   (set! debug:print-info dbgpinfo))

;;======================================================================
;; 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 (debug:calc-verbosity vstr arg) ;; arg is 'v (verbose) or 'q (quiet)
  (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))))
	       ((eq? arg 'v)   2) ;; verbose
	       ((eq? arg 'q)   0) ;; quiet
	       (else                   1))))
    (verbosity res)
    res))

;;======================================================================
;; check verbosity, #t is ok
#;(define (debug-check-verbosity verbosity vstr)
  (if (not (or (number? verbosity)
	       (list?   verbosity)))
      (begin
	(print "ERROR: Invalid debug value \"" vstr "\"")
	#f)
      #t))

(define (debug:debug-mode n)
  (let* ((vb (verbosity)))
    (cond
     ((and (number? vb)   ;; number number
	   (number? n))
      (<= n vb))
     ((and (list? vb)     ;; list   number
	   (number? n))
      (member n vb))
     ((and (list? vb)     ;; list   list
	   (list? n))
      (not (null? (lset-intersection! eq? vb n))))
     ((and (number? vb)
	   (list? n))
      (member vb n))
     (else #f))))

(define (debug:handle-remote-logging params)
  (if (debug:print-logger) ;; NOTE: turn params into string to keep things simple for now
      ((debug:print-logger)(conc "REMOTE ("(get-host-name)", pid="(current-process-id)") "
				 (string-intersperse (map conc params) " ") "; "
				 (string-intersperse (command-line-arguments) " ")))))

(define debug:enable-timestamp (make-parameter #t))

(define (debug:timestamp)
  (if (debug:enable-timestamp)
      (conc (time->string 
	     (seconds->local-time (current-seconds)) "%H:%M:%S") " ")
      ""))

  (define (debug:print n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  ;; (if *logging*
	      ;; (db:log-event (apply conc params))
	  (apply print (debug:timestamp) params)
	  ;; (debug:handle-remote-logging params)
	  )))
  #t ;; only here to make remote stuff happy. It'd be nice to fix that ...
  )

(define (debug:print-error n e . params)
  ;; normal print
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "ERROR: " (debug:timestamp) params)
	  ;; (debug:handle-remote-logging (cons "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: " (debug:timestamp) params)
	  ))))

(define (debug:print-info n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "INFO: (" n ") "(debug:timestamp) params) ;; res)
	  ;; (debug:handle-remote-logging (cons "INFO: " params))
	  ))))

(define (debug:print-warn n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "WARN: (" n ") " (debug:timestamp) params) ;; res)
	  ;; (debug:handle-remote-logging (cons "WARN: " params))
	  ))))

;;======================================================================
;; misc stuff
;;======================================================================

)