Random Bits of Open Code

Check-in [32e28ca603]
Login

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

Overview
Comment:added tests for mtdebug and mtconfigf
Timelines: family | ancestors | descendants | both | modularize-debug
Files: files | file ages | folders
SHA1:32e28ca6035d2d32930b7a7374b614aab8bb91e6
User & Date: bjbarcla 2019-01-04 00:57:16
Context
2019-01-04
00:58
marked margs for deprecation check-in: 99121dd728 user: bjbarcla tags: modularize-debug
00:57
added tests for mtdebug and mtconfigf check-in: 32e28ca603 user: bjbarcla tags: modularize-debug
2018-12-27
21:30
updated makefile to use mtargs egg, not margs egg check-in: 0070c96e2b user: bjbarcla tags: modularize-debug
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to mtutils/mtargs/mtargs.scm.

19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
..
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
    (
     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)
................................................................................
  (if (> (length args) 0)
      (apply print "ERROR: " args))
  (if (string? help)
      (print help)
      (print "Usage: " (car (argv)) " ... "))
  (exit 0))

 ;; one-of args defined
#;(define (any-defined? . param)
  (let ((res #f))
    (for-each 
     (lambda (arg)
       (if (get-arg arg)(set! res #t)))
     param)
    res))

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







|




|







 







<
<
<
<
<
<
<
<
<
<







19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
..
52
53
54
55
56
57
58










59
60
61
62
63
64
65
    (
     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)
................................................................................
  (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")
	    '())

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.

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
...
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
...
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
	 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)))

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







<
<

>






>
>
>
>
>
>
>
>
>
>
>







 







<
<
<
<
<
<

|

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







 







<
<
<
<
<
<
<
<







 







<







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
..
97
98
99
100
101
102
103






104
105
106










107
108
109
110
111
112
113
114
115
116
117
118
119
120
...
130
131
132
133
134
135
136








137
138
139
140
141
142
143
...
334
335
336
337
338
339
340

341
342
343
344
345
346
347
	 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)
               (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)))

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









;; Moved to common
;;
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))
................................................................................
		     (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"\") ")
                                        "")

                                    *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 "\"))"))

Added mtutils/mtdebug/Makefile.





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

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
..
62
63
64
65
66
67
68
69
70
71





72
73
74
75
76
77
78
..
85
86
87
88
89
90
91


92
93
94
95
96
97
98
...
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
;;======================================================================

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

(module
 mtdebug
 (
  dprint
  print-error
  print-info
  setup
  debug-mode
  add-logging-callback

  )




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


 (use (prefix mtargs args:))
 
 ;; cache of verbosity given string
 ;;
 (define *verbosity-cache*    (make-hash-table))
 (define *verbosity* 1)

................................................................................
        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)
  (cond
   ((and (number? *verbosity*)   ;; number number
	 (number? n))
    (<= n *verbosity*))
   ((and (list? *verbosity*)     ;; list   number
................................................................................
	 (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))


     (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*) ",")
................................................................................
 (define (fire-logging-callbacks log-line)
   (for-each (lambda (cb)
               (cb log-line))
             *logging-callbacks*))


 
 

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



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


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


	       )))))
 

 ) ;; 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
..
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
..
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
...
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
;;======================================================================

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

................................................................................
        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
................................................................................
	 (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*) ",")
................................................................................
 (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

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

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

(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
8
(load "../mtargs/mtargs.scm")
(load "mtdebug.scm")

(import (prefix mtdebug debug:))
(use test)


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