Random Bits of Open Code

Check-in [1eb79a1815]
Login

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

Overview
Comment:updated repository-path to work for any chicken number
Timelines: family | ancestors | descendants | both | modularize-debug
Files: files | file ages | folders
SHA1:1eb79a1815d361f67068e8485b8220a8a78d33df
User & Date: bjbarcla 2019-01-08 00:21:36
Context
2019-01-17
22:57
updated repository-path to work for any chicken number Leaf check-in: 3338745f73 user: bjbarcla tags: modularize-debug
2019-01-08
00:21
updated repository-path to work for any chicken number check-in: 1eb79a1815 user: bjbarcla tags: modularize-debug
2019-01-07
18:52
added mtconfigf test for eval-string-in-environment check-in: 859807ca0b user: bjbarcla tags: modularize-debug
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to mtutils/mtconfigf/mtconfigf.scm.

330
331
332
333
334
335
336
337
338

339
340
341
342
343
344
345
346
...
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
	(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"\") ")
                                        "")
                                    *eval-string*)) 
		     (fullcmd (case cmdsym
................................................................................
                            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)))))
		(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))







|

>
|







 







|
|
|
|







330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
...
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
	(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
................................................................................
                            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))

Changes to mtutils/mtdebug/mtdebug.scm.

35
36
37
38
39
40
41

42
43
44
45
46
47
48
...
100
101
102
103
104
105
106
107








108
109
110
111
112
113
114
...
143
144
145
146
147
148
149














150
151
152
153
154
155
156
  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")

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








>







 







|
>
>
>
>
>
>
>
>







 







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







35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
...
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
...
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
  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")

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

 (define (debugging-mtdebug?)
   (get-environment-variable "MTDEBUG_DEBUG"))
 
 (define (debug:debug-mode n)
  (cond
   ((and (number? *verbosity*)   ;; number number
................................................................................
 (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))