Random Bits of Open Code

Check-in [46889ef81b]
Login

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

Overview
Comment:wip
Timelines: family | ancestors | descendants | both | modularize-debug
Files: files | file ages | folders
SHA1:46889ef81b44ef8b5a6605154822dd725e24d871
User & Date: bjbarcla 2018-12-27 01:29:39
Context
2018-12-27
20:49
copied margs to mtargs due to namespace conflict in eggs dir (margs.so) check-in: 5826106ded user: bjbarcla tags: modularize-debug
01:29
wip check-in: 46889ef81b user: bjbarcla tags: modularize-debug
01:29
Create new branch named "modularize-debug" check-in: aa1ce47e23 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
..
13
14
15
16
17
18
19



20
21
22
23
24
25
26
27
28
29

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

|







 







>
>
>










1
2
3
4
5
6
7
8
9
..
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

SOFILES=margs/margs.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 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

mtdebug/mtdebug.so : mtdebug/mtdebug.meta mtdebug/mtdebug.scm mtdebug/mtdebug.setup adat.scm margs/margs.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

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

# test/run.scm
clean :
	rm -f */*.so

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
;;======================================================================
;; 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
 (
  print
  print-error
  print-info
  setup
  debug-mode
  add-logging-callback
  )

 ;; 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))))
                   ((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
	 (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
	 (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")
		      (getenv "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 (getenv "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-callback*))


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