(declare (unit debugprint))
(declare (uses mtargs))
(module debugprint
*
(import scheme)
(cond-expand
(chicken-4
(import
scheme
chicken
data-structures
posix
ports
extras
(prefix mtargs args:)
srfi-1
;; system-information
))
(chicken-5
(import
scheme
chicken.base
chicken.string
chicken.time
chicken.time.posix
chicken.port
chicken.process-context
chicken.process-context.posix
srfi-1
(prefix mtargs args:))
(define setenv set-environment-variable!)
))
;;======================================================================
;; 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)
(let ((debugstr (or (args:get-arg "-debug")
(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 (args:get-arg "-debug-noprop"))
(or (args:get-arg "-debug")
(not (get-environment-variable "MT_DEBUG_MODE"))))
(setenv "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))
))))
)