Random Bits of Open Code

Check-in [0d9502e738]
Login

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

Overview
Comment:Partial implementation of mtconfigf use in eval
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:0d9502e738648ea86eab5ee4b68bedd8dfb26298
User & Date: mrwellan 2018-12-17 23:35:39
Context
2018-12-18
20:10
updated method to set repository path to enable build-private egg installs check-in: 74dfe92eac user: bjbarcla tags: trunk
2018-12-17
23:35
Partial implementation of mtconfigf use in eval check-in: 0d9502e738 user: mrwellan tags: trunk
2018-11-23
16:45
Added TUBEs check-in: f84db382ca user: matt tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

a3d/testbox/a3d.scm became a symlink.

Changes to mtutils/mtconfigf/mtconfigf.scm.

66
67
68
69
70
71
72
73
74
75
76















77
78
79
80
81
82
83
...
277
278
279
280
281
282
283
















284
285
286
287
288
289
290
291
292
293
294
295
296

297



298
299
300
301
302
303
304
...
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
...
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
	 config->ini
	 set-verbosity

         squelch-debug-prints
         )

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
















;;======================================================================
;;
;; CONVERGE THIS WITH mtcommon.scm debug-print stuff
;;
;;======================================================================
(define *verbosity* 4)

................................................................................
;; 
(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 (process-line l ht allow-system #!key (linenum #f))
  (let loop ((res l))
    (if (string? res)
	(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))

		     (allsnip "(define getenv get-environment-variable)")



		     (fullcmd (case cmdsym
				((scheme scm) (conc "(lambda (ht)" allsnip "" cmd ")"))
				((system)     (conc "(lambda (ht)" allsnip "(configf:system ht \"" cmd "\"))"))
				((shell sh)   (conc "(lambda (ht)" allsnip "(string-translate (shell \""  cmd "\") \"\n\" \" \"))"))
				((realpath rp)(conc "(lambda (ht)" allsnip "(nice-path \"" cmd "\"))"))
				((getenv gv)  (conc "(lambda (ht)" allsnip "(get-environment-variable \"" cmd "\"))"))
				((mtrah)      (conc "(lambda (ht)" allsnip
................................................................................
						    "     (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))"
						    "        (if (string-null? extra) \"\" \"/\")"
						    "     extra)))"))
				((get g)   
				 (let* ((parts (string-split cmd))
					(sect  (car parts))
					(var   (cadr parts)))
				   (conc "(lambda (ht)(use mtconfigf) " allsnip " (lookup ht \"" sect "\" \"" var "\"))")))
				((runconfigs-get rget) (conc "(lambda (ht)" allsnip "(use mtconfigf)(runconfigs-get ht \"" cmd "\"))"))
				;; ((rget)           (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
		;; (print "fullcmd=" fullcmd)
		(handle-exceptions
		    exn
		    (let ((arguments ((condition-property-accessor 'exn 'arguments) exn))
			  (message    ((condition-property-accessor 'exn 'message) exn)))
................................................................................
				       ""))
		      ;; (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)) 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)))))







|



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







 







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













>
|
>
>
>







 







|
|







 







|







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
...
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
...
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
...
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
	 config->ini
	 set-verbosity

         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
                           (take
                            (string-split (chicken-version) ".")
                            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 (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))
                 (string-match "^-(s|ss|sx|script)$" (cadr argv)))
            (caddr argv))
           (else (car argv))))
         (fullpath (realpath this-script)))
    fullpath))
(define *common:this-exe-fullpath* (common:get-this-exe-fullpath))
(define *common:this-exe-dir*      (pathname-directory *common:this-exe-fullpath*))
(define *common:this-exe-name*     (pathname-strip-directory *common:this-exe-fullpath*))


(define (process-line l ht allow-system #!key (linenum #f))
  (let loop ((res l))
    (if (string? res)
	(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)"
				    "(load-library mtconfigf \"" libpath "/mtconfigf.so\")"
				    ;;                ../../eggs/lib/chicken/7/mtconfigf.so
				    "(import mtconfigf)")) ;; (import mtconfigf)")
		     (fullcmd (case cmdsym
				((scheme scm) (conc "(lambda (ht)" allsnip "" cmd ")"))
				((system)     (conc "(lambda (ht)" allsnip "(configf:system ht \"" cmd "\"))"))
				((shell sh)   (conc "(lambda (ht)" allsnip "(string-translate (shell \""  cmd "\") \"\n\" \" \"))"))
				((realpath rp)(conc "(lambda (ht)" allsnip "(nice-path \"" cmd "\"))"))
				((getenv gv)  (conc "(lambda (ht)" allsnip "(get-environment-variable \"" cmd "\"))"))
				((mtrah)      (conc "(lambda (ht)" allsnip
................................................................................
						    "     (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))"
						    "        (if (string-null? extra) \"\" \"/\")"
						    "     extra)))"))
				((get g)   
				 (let* ((parts (string-split cmd))
					(sect  (car parts))
					(var   (cadr parts)))
				   (conc "(lambda (ht)" allsnip " (lookup ht \"" sect "\" \"" var "\"))")))
				((runconfigs-get rget) (conc "(lambda (ht)" allsnip "(runconfigs-get ht \"" cmd "\"))"))
				;; ((rget)           (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
		;; (print "fullcmd=" fullcmd)
		(handle-exceptions
		    exn
		    (let ((arguments ((condition-property-accessor 'exn 'arguments) exn))
			  (message    ((condition-property-accessor 'exn 'message) exn)))
................................................................................
				       ""))
		      ;; (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)))))

Changes to mtutils/mtdb/mtdb.scm.

124
125
126
127
128
129
130


131
132

133
134
135
136
137
138
139
(use regex srfi-13 matchable
     ;; (prefix sql-de-lite s:)
     (prefix sqlite3 sql3:)
     (prefix dbi dbi:) posix typed-records
     (prefix mtcommon common:)
     (prefix mtconfigf configf:))



(define (squelch-configf-debug-prints)
  (configf:squelch-debug-prints))


;; (use trace)
(define debug-print print)
(define (set-debug-print-func func)
  (set! debug-print func))

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







>
>
|
<
>







124
125
126
127
128
129
130
131
132
133

134
135
136
137
138
139
140
141
(use regex srfi-13 matchable
     ;; (prefix sql-de-lite s:)
     (prefix sqlite3 sql3:)
     (prefix dbi dbi:) posix typed-records
     (prefix mtcommon common:)
     (prefix mtconfigf configf:))

;; call like this:  (squelch-configf-debug-prints configf:squelch-debug-prints)
;;
(define (squelch-configf-debug-prints proc)

  (proc))

;; (use trace)
(define debug-print print)
(define (set-debug-print-func func)
  (set! debug-print func))

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