Random Bits of Open Code

Check-in [18926076cc]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:removed dependency on m(t)args from mtconfigf and mtdebug; removed dep on mtdebug from mtconfigf
Timelines: family | ancestors | descendants | both | modularize-debug
Files: files | file ages | folders
SHA1:18926076ccb83d6009be956d83e7853cd6b894cb
User & Date: bjbarcla 2019-01-05 03:04:35
Context
2019-01-07
17:17
updated add-eval-string in mtconfigf to uniquify added strings check-in: 46f419b7b7 user: bjbarcla tags: modularize-debug
2019-01-05
03:04
removed dependency on m(t)args from mtconfigf and mtdebug; removed dep on mtdebug from mtconfigf check-in: 18926076cc user: bjbarcla tags: modularize-debug
2019-01-04
01:15
put back any? in mtargs check-in: 99148c4a59 user: bjbarcla tags: modularize-debug
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to mtutils/mtargs/mtargs.scm.

20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
    (
     arg-hash
     get-arg
     get-arg-from
     usage
     get-args
     print-args
     any?
     help
     )

(import scheme chicken data-structures extras posix ports files)
(define old-any? any?)
(use srfi-69 srfi-1)

(define arg-hash (make-hash-table))
(define help "")

(define (get-arg arg . default)
  (if (null? default)
      (hash-table-ref/default arg-hash arg #f)
      (hash-table-ref/default arg-hash arg (car default))))

(define (any? . args)
  (not (null? (filter (lambda (x) x)
		      (map get-arg args)))))

(define (get-arg-from ht arg . default)
  (if (null? default)
      (hash-table-ref/default ht arg #f)
      (hash-table-ref/default ht arg (car default))))







|




<










|







20
21
22
23
24
25
26
27
28
29
30
31

32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
    (
     arg-hash
     get-arg
     get-arg-from
     usage
     get-args
     print-args
     any-defined?
     help
     )

(import scheme chicken data-structures extras posix ports files)

(use srfi-69 srfi-1)

(define arg-hash (make-hash-table))
(define help "")

(define (get-arg arg . default)
  (if (null? default)
      (hash-table-ref/default arg-hash arg #f)
      (hash-table-ref/default arg-hash arg (car default))))

(define (any-defined? . args)
  (not (null? (filter (lambda (x) x)
		      (map get-arg args)))))

(define (get-arg-from ht arg . default)
  (if (null? default)
      (hash-table-ref/default ht arg #f)
      (hash-table-ref/default ht arg (car default))))

Changes to mtutils/mtconfigf/mtconfigf.scm.

15
16
17
18
19
20
21





22
23
24
25
26
27
28
..
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75

76
77







78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
..
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
...
351
352
353
354
355
356
357
358



359
360
361
362
363
364
365
...
367
368
369
370
371
372
373


374
375
376
377
378
379
380
381
382
383
;; 
;;     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 configf module, long term it will replace configf.scm.






(module mtconfigf
        (
	 set-debug-printers
	 lazy-convert
	 assoc-safe-add
	 section-var-set!
................................................................................
	 read-refdb
	 map-all-hier-alist
	 config->alist
	 alist->config
	 read-alist
	 write-alist
	 config->ini
	 set-verbosity
         add-eval-string
         squelch-debug-prints

         )

(import scheme chicken data-structures extras ports files)
(use posix typed-records srfi-18 pathname-expand posix-extras)
(use regex regex-case srfi-69 srfi-1 directory-utils extras srfi-13 )

(import posix)












;;(use (prefix mtargs    args:))
;; TODO: ensure mtdebug (debug printers) are defined from application and not directly "used" as below (achieves decoupling)
(use (prefix mtdebug   debug:))

;;(define args:any? args:any-defined?) ;; cannot name it any? in mtargs module


;; FROM common.scm
;;
;; this plugs a hole in posix-extras in recent chicken versions > 4.9)
(let-values (( (chicken-release-number chicken-major-version)
................................................................................
  (let ((resolve-pathname-broken?
         (or (> chicken-release-number 4)
             (and (eq? 4 chicken-release-number) (> chicken-major-version 9)))))
    (if resolve-pathname-broken?
        (define ##sys#expand-home-path pathname-expand))))


 (define (set-verbosity v)(debug:set-verbosity v))

 (define *default-log-port* (current-error-port))

 (define (debug:print-error n . args) ;;; n available to end-users but ignored for
   ;; default provided function
  (with-output-to-port (current-error-port)
    (lambda ()
................................................................................
						    "        (if (string-null? extra) \"\" \"/\")"
						    "     extra)))"))
				((get g)   
				 (let* ((parts (string-split cmd))
					(sect  (car parts))
					(var   (cadr parts)))
				   (conc "(lambda (ht)" allsnip " (configf:lookup ht \"" sect "\" \"" var "\"))")))
				((runconfigs-get rget) (conc "(lambda (ht)" allsnip "(configf:runconfigs-get ht \"" cmd "\"))"))



				(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))

		(handle-exceptions
		    exn
		    (let ((arguments ((condition-property-accessor 'exn 'arguments) exn))
			  (message    ((condition-property-accessor 'exn 'message) exn)))
		      (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\"")
................................................................................
				   (if arguments
				       (conc "; " (string-intersperse (map conc arguments) ", "))
				       ""))
		      ;; (debug:print 0 *default-log-port* "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)#;(module-environment 'mtconfigf)) ht))))
		      (set! result (conc "#{(" cmdtype ") "  cmd "}"))))
		(case cmdsym
		  ((system shell scheme scm sh)
		   (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)))))







>
>
>
>
>







 







|








>


>
>
>
>
>
>
>

<
<
<
<
<
|
<







 







|







 







|
>
>
>







 







>
>
|
|
|







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
..
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91





92

93
94
95
96
97
98
99
...
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
...
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
...
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
;; 
;;     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 configf module, long term it will replace configf.scm.
(print "before mtdebug")
;;(use (prefix mtargs    args:))
;; TODO: ensure mtdebug (debug printers) are defined from application and not directly "used" as below (achieves decoupling)
;;(use (prefix mtdebug debug:))
;;(print "after mtdebug")

(module mtconfigf
        (
	 set-debug-printers
	 lazy-convert
	 assoc-safe-add
	 section-var-set!
................................................................................
	 read-refdb
	 map-all-hier-alist
	 config->alist
	 alist->config
	 read-alist
	 write-alist
	 config->ini
	 ;;set-verbosity
         add-eval-string
         squelch-debug-prints

         )

(import scheme chicken data-structures extras ports files)
(use posix typed-records srfi-18 pathname-expand posix-extras)
(use regex regex-case srfi-69 srfi-1 directory-utils extras srfi-13 )
(use srfi-69)
(import posix)

;; stub debug printers overridden by set-debug-printers
(define (debug:print n e . args)
  (apply print args))
(define (debug:print-info n e . args)
  (apply print "INFO: " args))
(define (debug:print-error n e . args)
  (apply print "ERROR: " args))






;;(import (prefix mtdebug debug:))

;;(define args:any? args:any-defined?) ;; cannot name it any? in mtargs module


;; FROM common.scm
;;
;; this plugs a hole in posix-extras in recent chicken versions > 4.9)
(let-values (( (chicken-release-number chicken-major-version)
................................................................................
  (let ((resolve-pathname-broken?
         (or (> chicken-release-number 4)
             (and (eq? 4 chicken-release-number) (> chicken-major-version 9)))))
    (if resolve-pathname-broken?
        (define ##sys#expand-home-path pathname-expand))))


 ;;(define (set-verbosity v)(debug:set-verbosity v))

 (define *default-log-port* (current-error-port))

 (define (debug:print-error n . args) ;;; n available to end-users but ignored for
   ;; default provided function
  (with-output-to-port (current-error-port)
    (lambda ()
................................................................................
						    "        (if (string-null? extra) \"\" \"/\")"
						    "     extra)))"))
				((get g)   
				 (let* ((parts (string-split cmd))
					(sect  (car parts))
					(var   (cadr parts)))
				   (conc "(lambda (ht)" allsnip " (configf:lookup ht \"" sect "\" \"" var "\"))")))
				;;((runconfigs-get rget) (conc "(lambda (ht)" allsnip "(configf:runconfigs-get ht \"" cmd "\"))"))
                                ((runconfigs-get rget)
                                 (print "BB> hello!")
                                 (runconfigs-get ht cmd))
				(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))

		(handle-exceptions
		    exn
		    (let ((arguments ((condition-property-accessor 'exn 'arguments) exn))
			  (message    ((condition-property-accessor 'exn 'message) exn)))
		      (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\"")
................................................................................
				   (if arguments
				       (conc "; " (string-intersperse (map conc arguments) ", "))
				       ""))
		      ;; (debug:print 0 *default-log-port* "exn=" (condition->list exn))
		      (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
		  (if (or allow-system
			  (not (member cmdtype '("system" "shell" "sh"))))
                      (if (member cmdsym '(runconfigs-get rget))
                          fullcmd
		          (with-input-from-string fullcmd
			    (lambda ()
			      (set! result ((eval (read)#;(module-environment 'mtconfigf)) ht)))))
		      (set! result (conc "#{(" cmdtype ") "  cmd "}"))))
		(case cmdsym
		  ((system shell scheme scm sh)
		   (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)))))

Changes to mtutils/mtconfigf/tests/run.scm.

1

2
3










4
5
6
7
8
9
10
..
11
12
13
14
15
16
17

18
19
20
21
22
23
24
(load "../mtdebug/mtdebug.scm")

(load "mtconfigf.scm")
(import (prefix mtconfigf config:))










(use test)

(let* ((cfgdat
        (config:read-config "tests/test.config" #f #f)))

  
  (test #f "value" (config:lookup cfgdat "basic" "key"))
................................................................................
  (test #f 2 (config:lookup-number cfgdat "basic" "two"))
  
  )

(config:add-eval-string "(define (customfunc) \"hello\")")
(let* ((cfgdat
        (config:read-config "tests/test2.config" #f #f)))

  (test #f "2" (config:lookup cfgdat "schemy" "addup"))
  (test #f 2 (config:lookup-number cfgdat "schemy" "addup"))
  (test #f "hello" (config:lookup cfgdat "schemy" "custom"))
  )


(let* ((cfgdat

>


>
>
>
>
>
>
>
>
>
>







 







>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
..
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
(load "../mtdebug/mtdebug.scm")
(import mtdebug)
(load "mtconfigf.scm")
(import (prefix mtconfigf config:))

(use mtdebug)
;; configure mtconfigf
(let* ((normal-fn debug:print)
       (info-fn   debug:print-info)
       (error-fn  debug:print-error)
       (default-port (current-output-port)))
  (config:set-debug-printers normal-fn info-fn error-fn default-port))


(use test)

(let* ((cfgdat
        (config:read-config "tests/test.config" #f #f)))

  
  (test #f "value" (config:lookup cfgdat "basic" "key"))
................................................................................
  (test #f 2 (config:lookup-number cfgdat "basic" "two"))
  
  )

(config:add-eval-string "(define (customfunc) \"hello\")")
(let* ((cfgdat
        (config:read-config "tests/test2.config" #f #f)))
  (test #f "bar" (config:lookup cfgdat "schemy" "rgetref"))
  (test #f "2" (config:lookup cfgdat "schemy" "addup"))
  (test #f 2 (config:lookup-number cfgdat "schemy" "addup"))
  (test #f "hello" (config:lookup cfgdat "schemy" "custom"))
  )


(let* ((cfgdat

Changes to mtutils/mtconfigf/tests/test2.config.







1
2
3







[schemy]
addup #{scheme (+ 1 1)}
custom #{scheme (customfunc)}

>
>
>
>
>
>



>
1
2
3
4
5
6
7
8
9
10
[.dvars]
target reference

[reference]
foo bar

[schemy]
addup #{scheme (+ 1 1)}
custom #{scheme (customfunc)}
rgetref #{rget foo}

Changes to mtutils/mtdebug/mtdebug.scm.

19
20
21
22
23
24
25
26
27

28
29
30
31
32





33








34


35


36


37
38
39
40

41
42




43






44
45
46
47
48
49
50
..
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
..
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139








140
141





142
143
144
145
146
147
148
149
150


151

152
153
154
155
156
157
158


159
160
161
162
163
164
165
166
167
168
169
170
171
172


173


174




175
;;======================================================================

;; NOTE: This is the configf module, long term it will replace configf.scm.

(module
 mtdebug
 (
  print
  print-error

  print-info
  setup
  debug-mode
  add-logging-callback
  set-verbosity





  )














 


 
 (import scheme chicken data-structures extras ports files srfi-1 srfi-69
         format posix)
 (define oldprint print)

 
 (use (prefix mtargs args:))




 






 ;; cache of verbosity given string
 ;;
 (define *verbosity-cache*    (make-hash-table))
 (define *verbosity* 1)

 ;; 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
................................................................................
                   ((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))))
                   ((args:get-arg "-v")   2)
                   ((args:get-arg "-q")    0)
                   (else                   1))))
         (hash-table-set! *verbosity-cache* vstr res)
        res)))
 
 ;; check verbosity, #t is ok
 (define (check-verbosity verbosity vstr)
   (if (not (or (number? verbosity)
	        (list?   verbosity)))
       (begin
	 (oldprint "ERROR: Invalid debug value \"" vstr "\"")
	 #f)
       #t))

 
 (define (set-verbosity v)(set! *verbosity* v))

 (define (debugging-mtdebug?)
   (get-environment-variable "MTDEBUG_DEBUG"))
 
 (define (debug-mode n)
  (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 (setup)
   (let ((debugstr (or (args:get-arg "-debug")
		      (get-environment-variable "MT_DEBUG_MODE"))))
     (set! *verbosity* (calc-verbosity debugstr))
     (if (debugging-mtdebug?)
         (oldprint "BB> *verbosity* == "*verbosity*))
     (check-verbosity *verbosity* debugstr)
     ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
     (if (not *verbosity*)(set! *verbosity* 1))
     (if (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*))))))

 (define *logging-callbacks* '())
 (define (add-logging-callback cb)
   (set! *logging-callbacks* (cons cb *logging-callbacks*)))
 (define (fire-logging-callbacks log-line)
   (for-each (lambda (cb)
               (cb log-line))
             *logging-callbacks*))


 

 
 (define (print n e . params)
   (if (debug-mode n)
       (with-output-to-port (or e (current-error-port))
	 (lambda ()
           (if (not (null? *logging-callbacks*))
               (fire-logging-callbacks (apply conc params))

               (if (debugging-mtdebug?)
                   (apply oldprint "("n") "params)
                   (apply oldprint params))

               )))))
 








 (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 (not (null? *logging-callbacks*))
              (fire-logging-callbacks (apply conc params))
	      ;; (apply print "pid:" (current-process-id) " " params)
              (if (debugging-mtdebug?)
	          (apply oldprint "ERROR("n"): " params)
                  (apply oldprint "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 ()
           (if (debugging-mtdebug?)
	      (apply oldprint "ERROR("n"): " params)
              (apply oldprint "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 (not (null? *logging-callbacks*))
	       (let ((res (format#format #f "INFO("n"): (~a) ~a" n (apply conc params))))
                 (fire-logging-callbacks res))
	       ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) 
               (if (debugging-mtdebug?)
	           (apply oldprint "INFO(" n "): " params)
                   (apply oldprint "INFO: " params))
	       )))))


 







 ) ;; end module







|
|
>
|
|
|
|
|
>
>
>
>
>

>
>
>
>
>
>
>
>

>
>
|
>
>

>
>
|
<
<
<
>

<
>
>
>
>
|
>
>
>
>
>
>







 







|
|









|




|




|







 







|
|



|



|






|






<
<
<
<
|
|






|
|


|
>
>
>
>
>
>
>
>
|

>
>
>
>
>
|
|
|
|
|
|
|
<
<
>
>
|
>
|
|
|
|
|
<
<
>
>
|
|
<
<
<
<
<
<
<
<
<
<
<
<
>
>
|
>
>

>
>
>
>

19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57



58
59

60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
..
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
...
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149




150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184


185
186
187
188
189
190
191
192
193


194
195
196
197












198
199
200
201
202
203
204
205
206
207
208
;;======================================================================

;; NOTE: This is the configf module, long term it will replace configf.scm.

(module
 mtdebug
 (
  debug:print
  debug:print-error
  debug:print-warning
  debug:print-info
  debug:setup
  debug:debug-mode
  debug:add-logging-callback
  debug:set-verbosity
  debug:force-color
  debug:suppress-color
  debug:set-verbose-mode
  debug:set-quiet-mode
  debug:set-debug-mode
  )
 (import scheme chicken data-structures extras ports files srfi-1 format)
 (use posix)
 (use srfi-69)
 (use  ansi-escape-sequences)
 ;; verbosity control
 (define *verbose-mode* #f)  ;; was (args:get-arg "-v")
 (define *quiet-mode*  #f)    ;; was (args:get-arg "-q")
 (define *debug-mode*  #f)    ;; was (args:get-arg "-debug")

 (define (debug:set-verbose-mode)
   (set! *verbose-mode* #t))
 
 (define (debug:set-quiet-mode)
   (set! *quiet-mode* #t))
 
 (define (debug:set-debug-mode)
   (set! *debug-mode* #t))




 ;; color control
 

 (define *have-tty* (terminal-port? (current-output-port)))
 (define *color-mode* 'tty)
 (define (debug:force-color)
   (set! *color-mode* 'force))

 (define (debug:suppress-color)
   (set! *color-mode* 'suppress))

 
 

 ;; cache of verbosity given string
 ;;
 (define *verbosity-cache*    (make-hash-table))
 (define *verbosity* 1)

 ;; 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
................................................................................
                   ((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))))
                   (*verbose-mode*   2)
                   (*quiet-mode*     0)
                   (else                   1))))
         (hash-table-set! *verbosity-cache* 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:set-verbosity v)(set! *verbosity* v))

 (define (debugging-mtdebug?)
   (get-environment-variable "MTDEBUG_DEBUG"))
 
 (define (debug:debug-mode n)
  (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)
   (let ((debugstr (or *debug-mode*
		      (get-environment-variable "MT_DEBUG_MODE"))))
     (set! *verbosity* (calc-verbosity debugstr))
     (if (debugging-mtdebug?)
         (print "BB> *verbosity* == "*verbosity*))
     (check-verbosity *verbosity* debugstr)
     ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
     (if (not *verbosity*)(set! *verbosity* 1))
     (if (or *debug-mode*
	     (not (get-environment-variable "MT_DEBUG_MODE")))
	 (setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
				     (string-intersperse (map conc *verbosity*) ",")
				     (conc *verbosity*))))))

 (define *logging-callbacks* '())
 (define (debug:add-logging-callback cb)
   (set! *logging-callbacks* (cons cb *logging-callbacks*)))
 (define (fire-logging-callbacks log-line)
   (for-each (lambda (cb)
               (cb log-line))
             *logging-callbacks*))





 (define (debug:print n e . params)
   (if (debug:debug-mode n)
       (with-output-to-port (or e (current-error-port))
	 (lambda ()
           (if (not (null? *logging-callbacks*))
               (fire-logging-callbacks (apply conc params))

               (if (debugging-mtdebug?)
                   (apply print "("n") "params)
                   (apply print params))

               )))))

 (define (colorize-prefix prefix)
   (let* ((psym (string->symbol prefix)))
     (case psym
       ((ERROR)   (set-text '(bg-black fg-red) prefix))
       ((WARNING) (set-text '(bg-black fg-yellow) prefix))
       ((INFO)    (set-text '(bg-black fg-green) prefix))
       (else prefix))))

 (define (print-prefix prefix n e . params)
   ;; normal print
   (let* ((styled-prefix
           (if (or (eq? *color-mode* 'force)
                   (and *have-tty* (eq? *color-mode* 'tty)))
               (colorize-prefix prefix)
               prefix)))
     (if (debug:debug-mode n)
         (with-output-to-port (if (port? e) e (current-error-port))
	   (lambda ()
             (if (not (null? *logging-callbacks*))
                 (fire-logging-callbacks (apply conc params))
	         ;; (apply print "pid:" (current-process-id) " " params)
                 (if (debugging-mtdebug?)


	             (apply print styled-prefix "("n"): " params)
                     (apply print styled-prefix ": " params))
	         ))))
     
     ;; pass important messages to stderr
     (if (and (equal? prefix "ERROR") (eq? n 0)(not (eq? e (current-error-port)))) 
         (with-output-to-port (current-error-port)
	   (lambda ()
             (if (debugging-mtdebug?)


	         (apply print styled-prefix"("n"): " params)
                 (apply print styled-prefix": " params))
	     )))))
   












 (define (debug:print-error . args)
   (apply print-prefix "ERROR" args))

 (define (debug:print-warning . args)
   (apply print-prefix "WARNING" args))

 (define (debug:print-info . args)
   (apply print-prefix "INFO" args))


 ) ;; end module

Changes to mtutils/mtdebug/tests/basic-printers.scm.

1
2
3
4
5
6




7

8
9
10
11
12
13
14

(define (stringify-harness func str #!key  (n 0))
  (with-output-to-string
    (lambda ()
      (func n (current-output-port) str))))







(test #f
      "hello world\n"
      (stringify-harness debug:print "hello world"))

(test #f
      "INFO: hello world\n"
      (stringify-harness debug:print-info "hello world"))






>
>
>
>

>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19

(define (stringify-harness func str #!key  (n 0))
  (with-output-to-string
    (lambda ()
      (func n (current-output-port) str))))

(debug:print-error   0 #f "test error")
(debug:print-warning 0 #f "test warning")
(debug:print-info    0 #f "test info")
(debug:print         0 #f "test print")

(debug:suppress-color)
(test #f
      "hello world\n"
      (stringify-harness debug:print "hello world"))

(test #f
      "INFO: hello world\n"
      (stringify-harness debug:print-info "hello world"))

Changes to mtutils/mtdebug/tests/run.scm.

1
2
3
4

5
6
7
8
(load "../mtargs/mtargs.scm")
(load "mtdebug.scm")

(import (prefix mtdebug debug:))

(use test)


(include "tests/basic-printers.scm")
<


<
>





1
2

3
4
5
6
7

(load "mtdebug.scm")


(import mtdebug)
(use test)


(include "tests/basic-printers.scm")