Random Bits of Open Code

Check-in [5b014bb206]
Login

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

Overview
Comment:pull in modularize-debug changes
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:5b014bb206f63660c824b022de86635bea400611
User & Date: mrwellan 2019-05-20 19:44:11
Context
2019-05-20
21:27
Merged from 79c8 and tweaked a bit check-in: efd8e83582 user: mrwellan tags: trunk
19:44
pull in modularize-debug changes check-in: 5b014bb206 user: mrwellan tags: trunk
2019-05-08
05:54
Added torus check-in: 6da40221e5 user: matt tags: trunk
2019-01-17
22:57
updated repository-path to work for any chicken number Leaf check-in: 3338745f73 user: bjbarcla tags: modularize-debug
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to mtutils/Makefile.

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

SOFILES=margs/margs.so iuputils/iuputils.so mtcommon/mtcommon.so mtconfigf/mtconfigf.so mtdb/mtdb.so 

all : $(SOFILES)

test : test.log

# rm -rf /tmp/matt/mtview_cache
test.log : $(SOFILES) test/run.scm
	cd test;script -c "csi run.scm" ../test.log

iuputils/iuputils.so : iuputils/iuputils.meta iuputils/iuputils.scm iuputils/iuputils.setup
	cd iuputils;chicken-install

mtcommon/mtcommon.so : mtcommon/mtcommon.meta mtcommon/mtcommon.scm mtcommon/mtcommon.setup mtconfigf/mtconfigf.so margs/margs.so
	cd mtcommon;chicken-install

mtconfigf/mtconfigf.so : mtconfigf/mtconfigf.meta mtconfigf/mtconfigf.scm mtconfigf/mtconfigf.setup adat.scm
	cd mtconfigf;chicken-install




mtdb/mtdb.so : mtdb/mtdb.meta mtdb/mtdb.scm mtdb/mtdb.setup mtconfigf/mtconfigf.so mtcommon/mtcommon.so adat.scm
	cd mtdb;chicken-install

margs/margs.so : margs/margs.scm
	cd margs; make

# test/run.scm

clean :
	rm -f */*.so test.log

|












|


|

>
>
>




|
|





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

SOFILES=mtargs/mtargs.so iuputils/iuputils.so mtcommon/mtcommon.so mtconfigf/mtconfigf.so mtdb/mtdb.so mtdebug/mtdebug.so

all : $(SOFILES)

test : test.log

# rm -rf /tmp/matt/mtview_cache
test.log : $(SOFILES) test/run.scm
	cd test;script -c "csi run.scm" ../test.log

iuputils/iuputils.so : iuputils/iuputils.meta iuputils/iuputils.scm iuputils/iuputils.setup
	cd iuputils;chicken-install

mtcommon/mtcommon.so : mtcommon/mtcommon.meta mtcommon/mtcommon.scm mtcommon/mtcommon.setup mtconfigf/mtconfigf.so mtargs/mtargs.so
	cd mtcommon;chicken-install

mtconfigf/mtconfigf.so : mtconfigf/mtconfigf.meta mtconfigf/mtconfigf.scm mtconfigf/mtconfigf.setup adat.scm mtdebug/mtdebug.so
	cd mtconfigf;chicken-install

mtdebug/mtdebug.so : mtdebug/mtdebug.meta mtdebug/mtdebug.scm mtdebug/mtdebug.setup adat.scm mtargs/mtargs.so
	cd mtdebug;chicken-install

mtdb/mtdb.so : mtdb/mtdb.meta mtdb/mtdb.scm mtdb/mtdb.setup mtconfigf/mtconfigf.so mtcommon/mtcommon.so adat.scm
	cd mtdb;chicken-install

mtargs/mtargs.so : mtargs/mtargs.scm
	cd mtargs; make

# test/run.scm

clean :
	rm -f */*.so test.log

Name change from mtutils/margs/Makefile to mtutils/margs-EOLED-FOR-mtargs/Makefile.

Name change from mtutils/margs/margs.meta to mtutils/margs-EOLED-FOR-mtargs/margs.meta.

Name change from mtutils/margs/margs.scm to mtutils/margs-EOLED-FOR-mtargs/margs.scm.

Name change from mtutils/margs/margs.setup to mtutils/margs-EOLED-FOR-mtargs/margs.setup.

Added mtutils/mtargs/Makefile.













































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# Copyright 2007-2010, Matthew Welland.
#
#  This program is made available under the GNU GPL version 2.0 or
#  greater. See the accompanying file COPYING for details.
#
#  This program is distributed WITHOUT ANY WARRANTY; without even the
#  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
#  PURPOSE.

# TARGDIR = $(shell csi -e "(print (car \#\#sys\#include-pathnames))(exit)")

all : uptodate.log # $(TARGDIR)/mtargs.so

uptodate.log : mtargs.scm mtargs.setup
	chicken-install | tee uptodate.log

$(TARGDIR)/mtargs.so : mtargs.so
	@echo installing to $(TARGDIR)
	cp mtargs.so $(TARGDIR)

mtargs.so : mtargs.scm
	csc -s mtargs.scm

Added mtutils/mtargs/mtargs.meta.









































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
(
; Your egg's license:
(license "LGPL")

; Pick one from the list of categories (see below) for your egg and enter it
; here.
(category misc)

; A list of eggs mpeg3 depends on.  If none, you can omit this declaration
; altogether. If you are making an egg for chicken 3 and you need to use
; procedures from the `files' unit, be sure to include the `files' egg in the
; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit).
; `depends' is an alias to `needs'.
(needs srfi-69 srfi-1)

; A list of eggs required for TESTING ONLY.  See the `Tests' section.
(test-depends test)

(author "Matt Welland")
(synopsis "Primitive argument processor."))

Added mtutils/mtargs/mtargs.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
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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
;; Copyright 2007-2010, Matthew Welland.
;;
;; This file is part of mtargs.
;; 
;;     mtargs 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.
;; 
;;     mtargs 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 mtargs.  If not, see <http://www.gnu.org/licenses/>.


(module mtargs
    (
     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))))

(define (usage . args)
  (if (> (length args) 0)
      (apply print "ERROR: " args))
  (if (string? help)
      (print help)
      (print "Usage: " (car (argv)) " ... "))
  (exit 0))

(define (get-args args params switches arg-hash num-needed)
  (let* ((numtargs (length args))
	 (adj-num-needed (if num-needed (+ num-needed 2) #f)))
    (if (< numtargs (if adj-num-needed adj-num-needed 2))
	(if (>= num-needed 1)
	    (usage "No arguments provided")
	    '())
	(let loop ((arg (cadr args))
		   (tail (cddr args))
		   (remtargs '()))
	  (cond 
	   ((member arg params) ;; args with params
	    (if (< (length tail) 1)
		(usage "param given without argument " arg)
		(let ((val     (car tail))
		      (newtail (cdr tail)))
		  (hash-table-set! arg-hash arg val)
		  (if (null? newtail) remtargs
		      (loop (car newtail)(cdr newtail) remtargs)))))
	   ((member arg switches)         ;; args with no params (i.e. switches)
	    (hash-table-set! arg-hash arg #t)
	    (if (null? tail) remtargs
		(loop (car tail)(cdr tail) remtargs)))
	   (else
	    (if (null? tail)(append remtargs (list arg)) ;; return the non-used args
		(loop (car tail)(cdr tail)(append remtargs (list arg))))))))
    ))

(define (print-args remtargs arg-hash)
  (print "ARGS: " remtargs)
  (for-each (lambda (arg)
	      (print "   " arg "   " (hash-table-ref/default arg-hash arg #f)))
	    (hash-table-keys arg-hash)))


)

Added mtutils/mtargs/mtargs.setup.





































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
;; Copyright 2007-2010, Matthew Welland.
;;
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;;
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;;;; mtargs.setup

;; compile the code into a dynamically loadable shared object
;; (will generate mtargs.so)
(compile -s mtargs.scm)

;; Install as extension library
(standard-extension 'mtargs "mtargs.so")

Added mtutils/mtconfigf/Makefile.





>
>
1
2
test:
	 env CHICKEN_REPOSITORY=../../../megatest/tmpinstall/eggs/lib/chicken/7 csi -s tests/run.scm

Changes to mtutils/mtconfigf/mtconfigf.scm.

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
..
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
...
129
130
131
132
133
134
135

136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
...
307
308
309
310
311
312
313

314
315
316
317
318
319
320
...
334
335
336
337
338
339
340
341
342

343
344
345
346
347
348
349
350
351
352
353
354
355
356
...
360
361
362
363
364
365
366
367


368
369
370
371
372
373
374
...
376
377
378
379
380
381
382




383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
...
546
547
548
549
550
551
552

553
554
555
556
557
558
559
...
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783

784
785
786
787
788
789
790
....
1113
1114
1115
1116
1117
1118
1119



1120

	 read-refdb
	 map-all-hier-alist
	 config->alist
	 alist->config
	 read-alist
	 write-alist
	 config->ini
	 set-verbosity
         add-eval-string
         ;;import-module
         ;; import-proc
         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)













;; FROM common.scm
;;
;; this plugs a hole in posix-extras in recent chicken versions > 4.9)
(let-values (( (chicken-release-number chicken-major-version)
               (apply values
                      (map string->number
................................................................................
                            2)))))
  (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))))

;;======================================================================
;;
;; 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)))

................................................................................
(define (lazy-convert inval)
  (let* ((as-num (if (string? inval)(string->number inval) #f)))
    (or as-num inval)))


(define *eval-string* "")
(define (add-eval-string str)

  (set! *eval-string* (conc *eval-string* " " str)))

;;(define (import-proc name-sym the-proc) ;; does not work
;;  (let* ((wrapper (lambda x (apply the-proc x))))
;;    (eval `(define ,name-sym wrapper))))

;;(define (import-module mname) ;; does not work
;;  (eval (with-input-from-string (conc "(import "mname")") read)))


;; Moved to common
;;
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))
................................................................................
;; 
(define (runconfigs-get config var) ;; .dvars is a special bin for storing metadata such as target
  (let ((targ (lookup config ".dvars" "target"))) ;; (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
    (if targ
	(or (lookup config targ var)
	    (lookup config "default" var))
	(lookup config "default" var))))


(define (realpath x) (resolve-pathname  (pathname-expand (or x "/dev/null")) ))
(define (common:get-this-exe-fullpath #!key (argv (argv)))
  (let* ((this-script
          (cond
           ((and (> (length argv) 2)
                 (string-match "^(.*/csi|csi)$" (car argv))
................................................................................
	(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))

		     (libpath (conc *common:this-exe-dir* "/../../eggs/lib/chicken/7"))
		     (allsnip (conc "(define getenv get-environment-variable)"
                                    (if (and (not (get-environment-variable "CHICKEN_REPOSITORY"))
                                             (directory-exists? libpath))
                                        (conc "(repository-path \""libpath"\") ")
                                        "")
                                    "(use (prefix mtconfigf configf:))"
                                    *eval-string*)) 
		     (fullcmd (case cmdsym
				((scheme scm) (conc "(lambda (ht)" allsnip "" cmd ")"))
				((system)     (conc "(lambda (ht)" allsnip "(configf:configf:system ht \"" cmd "\"))"))
				((shell sh)   (conc "(lambda (ht)" allsnip "(string-translate (configf:shell \""  cmd "\") \"\n\" \" \"))"))
				((realpath rp)(conc "(lambda (ht)" allsnip "(configf:nice-path \"" cmd "\"))"))
				((getenv gv)  (conc "(lambda (ht)" allsnip "(get-environment-variable \"" cmd "\"))"))
................................................................................
						    "        (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)))))
		(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))
................................................................................
;; 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))
................................................................................
		     (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)
................................................................................
		     (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)))




)








|

<
<

>





>

>
>
>
>
>
>
>
>
>
>
>
>







 







<
<
<
<
<
<

|

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







 







>
|
<
<
<
<
<
<
<
<







 







>







 







|

>
|





<







 







|
>
>







 







>
>
>
>
|
|
|



|
|
|
|







 







>







 







|








|
|
>







 







>
>
>
|
>
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
..
99
100
101
102
103
104
105






106
107
108










109
110
111
112
113
114
115
116
117
118
119
120
121
122
...
131
132
133
134
135
136
137
138
139








140
141
142
143
144
145
146
...
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
...
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345

346
347
348
349
350
351
352
...
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
...
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
...
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
...
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
....
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
	 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)
               (apply values
                      (map string->number
................................................................................
                            2)))))
  (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 ()
      (apply print "ERROR: "args))))

(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)))

................................................................................
(define (lazy-convert inval)
  (let* ((as-num (if (string? inval)(string->number inval) #f)))
    (or as-num inval)))


(define *eval-string* "")
(define (add-eval-string str)
  (if (not (string-contains *eval-string* str))
      (set! *eval-string* (conc *eval-string* " " str))))









;; Moved to common
;;
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))
................................................................................
;; 
(define (runconfigs-get config var) ;; .dvars is a special bin for storing metadata such as target
  (let ((targ (lookup config ".dvars" "target"))) ;; (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
    (if targ
	(or (lookup config targ var)
	    (lookup config "default" var))
	(lookup config "default" var))))


(define (realpath x) (resolve-pathname  (pathname-expand (or x "/dev/null")) ))
(define (common:get-this-exe-fullpath #!key (argv (argv)))
  (let* ((this-script
          (cond
           ((and (> (length argv) 2)
                 (string-match "^(.*/csi|csi)$" (car argv))
................................................................................
	(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-milliseconds))
		     (cmdsym  (string->symbol cmdtype))
                     (libpath-number (car (reverse (string-split  (repository-path) "/"))))
		     (libpath (conc *common:this-exe-dir* "/../../eggs/lib/chicken/" libpath-number))
		     (allsnip (conc "(define getenv get-environment-variable)"
                                    (if (and (not (get-environment-variable "CHICKEN_REPOSITORY"))
                                             (directory-exists? libpath))
                                        (conc "(repository-path \""libpath"\") ")
                                        "")

                                    *eval-string*)) 
		     (fullcmd (case cmdsym
				((scheme scm) (conc "(lambda (ht)" allsnip "" cmd ")"))
				((system)     (conc "(lambda (ht)" allsnip "(configf:configf:system ht \"" cmd "\"))"))
				((shell sh)   (conc "(lambda (ht)" allsnip "(string-translate (configf:shell \""  cmd "\") \"\n\" \" \"))"))
				((realpath rp)(conc "(lambda (ht)" allsnip "(configf:nice-path \"" cmd "\"))"))
				((getenv gv)  (conc "(lambda (ht)" allsnip "(get-environment-variable \"" cmd "\"))"))
................................................................................
						    "        (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)
                                 (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))
                          (begin
                            (set! result fullcmd)
                            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-milliseconds) start-time)))
		     (if (> delta 2000)
			 (debug:print-info 0 *default-log-port* "for line \"" l "\"\n command:  " cmd " took " (/ delta 1000) " seconds to run with output:\n   " result)
			 (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command:  " cmd " took " (/ delta 1000) " 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))
................................................................................
;; 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* "BB> read-config > keep-filenames: " keep-filenames)
  (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))
................................................................................
		     (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)(keep-filenames #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
                                       keep-filenames: keep-filenames))))
      (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)
................................................................................
		     (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)))

;(use trace)
;(trace-call-sites #t)
;(trace read-config)

)

Added 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
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
(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" "rgetreftarget"))
  (test #f "baz" (config:lookup cfgdat "schemy" "rgetrefdefault"))
  (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"))
  )

(test #f
      (conc "hello " (get-environment-variable "USER"))
      (config:eval-string-in-environment "hello $USER"))

(let* ((cfgdat
        (config:read-config "tests/test3.config" #f #t)))
  (test #f "hello" (config:lookup cfgdat "systemic" "hello"))
  (test #f
        (conc "hello " (get-environment-variable "USER"))
        (config:lookup cfgdat "systemic" "hellouser"))

  )

Added mtutils/mtconfigf/tests/test.config.







>
>
>
1
2
3
[basic]
key value
two 2

Added mtutils/mtconfigf/tests/test2.config.































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
[default]
deffoo baz

[a-target]
foo bar

[.dvars]
target a-target


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

Added mtutils/mtconfigf/tests/test3.config.







>
>
>
1
2
3
[systemic]
hello [system echo hello]
hellouser [system echo hello $USER]

Added mtutils/mtdebug/Makefile.





>
>
1
2
test:
	 env CHICKEN_REPOSITORY=../../../megatest/tmpinstall/eggs/lib/chicken/7 csi -s tests/run.scm

Added mtutils/mtdebug/mtdebug.meta.









































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
(
; Your egg's license:
(license "LGPL")

; Pick one from the list of categories (see below) for your egg and enter it
; here.
(category misc)

; A list of eggs mpeg3 depends on.  If none, you can omit this declaration
; altogether. If you are making an egg for chicken 3 and you need to use
; procedures from the `files' unit, be sure to include the `files' egg in the
; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit).
; `depends' is an alias to `needs'.
(needs srfi-1 srfi-69 regex regex-case directory-utils extras srfi-13 posix typed-records)

; A list of eggs required for TESTING ONLY.  See the `Tests' section.
(test-depends test)

(author "Matt Welland")
(synopsis "Megatest config file (ini-space format) with many enhancements."))

Added mtutils/mtdebug/mtdebug.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
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
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
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
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
;;======================================================================
;; Copyright 2006-2018, 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 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 regex)
 (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 n)
   (set! *debug-mode* n))

 ;; 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
;; in for now but can probably take it out later.
;;
 (define (calc-verbosity vstr)
   (or (hash-table-ref/default *verbosity-cache* 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))))
                   (*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)
   (cond
    ((or (list? v) (number? v))
     (set! *verbosity* v))
    ((string? v)
     (set! *verbosity* (map string->number (string-split v ","))))
    (else
     (debug:print-error "Unexpected argument to debug:set-verbosity: >"v"<")))
   *verbosity*
   )
     

 (define (debugging-mtdebug?)
   (get-environment-variable "MTDEBUG_DEBUG"))
 
 (define (debug:debug-mode n)
   (let ((res 
          (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)))))
     res))
 
 (define (debug:setup)
   (let ((debugstr (or *debug-mode*
		      (get-environment-variable "MT_DEBUG_MODE"))))
     (set! *verbosity* (calc-verbosity debugstr))
     (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 (colorize-text-alist-spec text rx-spec-alist)
   (fold (lambda (i inres)
           (let* ((partial-regex (car i))
                  (full-regex    (conc "^(.*?)(" partial-regex")(.*)$"))
                  (ansi-spec     (cdr i))
                  (m             (string-match full-regex inres)))
             (if m
                 (conc (list-ref m 1)
                       (set-text ansi-spec (list-ref m 2))
                       (list-ref m 3))
                 inres)))
         text rx-spec-alist))
 
 (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

Added mtutils/mtdebug/mtdebug.setup.

































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
;; Copyright 2007-2010, Matthew Welland.
;;
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;;
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;;;; mtconfig.setup

;; compile the code into dynamically loadable shared objects
;; and install as modules

(compile -s mtdebug.scm)
(standard-extension 'mtdebug "mtdebug.so")

Added mtutils/mtdebug/tests/basic-printers.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
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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100

(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"))

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

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

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

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

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

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

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

(debug:set-verbosity 2)
(test #f
      "hello world\n"
      (stringify-harness debug:print "hello world" n: '(1 2)))

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

(test #f
      "ERROR: hello world\n"
      (stringify-harness debug:print-error "hello world" n: '(1 2)))

(debug:set-verbosity '(2 3))
(test #f
      "hello world\n"
      (stringify-harness debug:print "hello world" n: '(1 2)))

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

(test #f
      "ERROR: hello world\n"
      (stringify-harness debug:print-error "hello world" n: '(1 2)))

(debug:set-verbosity 1)
(test #f
      ""
      (stringify-harness debug:print "hello world" n: 2))

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

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

(debug:set-verbosity '(0 3))
(test #f
      ""
      (stringify-harness debug:print "hello world" n: '(1 2)))

(test #f
      ""
      (stringify-harness debug:print-info "hello world" n: '(1 2)))

(test #f
      ""
      (stringify-harness debug:print-error "hello world" n: '(1 2)))

Added mtutils/mtdebug/tests/run.scm.















>
>
>
>
>
>
>
1
2
3
4
5
6
7
(load "mtdebug.scm")

(import mtdebug)
(use test)


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