Random Bits of Open Code

Check-in [b8baf172bd]
Login

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

Overview
Comment:Partial fix/implementation of rget
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:b8baf172bd4a36e05c4704f7536a24eef59be987
User & Date: matt 2018-04-30 05:22:22
Context
2018-04-30
06:03
Added get-runs-info check-in: 7e6abd32c5 user: matt tags: trunk
05:22
Partial fix/implementation of rget check-in: b8baf172bd user: matt tags: trunk
2018-04-29
23:24
Converted margs to module based egg. check-in: 7b5878b117 user: matt tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to mtutils/mtcommon/mtcommon.scm.

66
67
68
69
70
71
72

73
74
75
76
77
78
79
80

81
82
83
84
85
86
87
...
864
865
866
867
868
869
870
























871
872
873
874
875
876
877
	 ;; debug
	 debug-print
	 print-error
	 print-info
	 ;; megatest specific
	 config-get-fields
	 keys->keystr

	 ;; areas
	 get-area-name
	 get-area-path-signature
	 )

(import scheme chicken data-structures extras posix ports files)
(use (prefix sql-de-lite sql:) md5 message-digest posix typed-records format srfi-1 srfi-69 pkts regex (prefix dbi dbi:) regex-case matchable)
(use (prefix mtconfigf configf:))

(defstruct ctrldat
  (port      (current-error-port))
  (verbosity 1)
  (vcache    (make-hash-table))
  (logging   #f) ;; keep the flag and the db handle separate to enable overriding
  (logdb     #f) ;; might need to make this a stack of handles for threaded access
  (toppath   #f) ;; 
................................................................................

(define (config-get-fields cfgdat)
  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
    (if fields (map car fields) '())))

(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
  (string-intersperse keys ","))

























;;======================================================================
;; Areas
;;======================================================================

(define (get-area-name adat)
  (let ((mt-config (adat-mtconfig adat))







>







|
>







 







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







66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
...
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
	 ;; debug
	 debug-print
	 print-error
	 print-info
	 ;; megatest specific
	 config-get-fields
	 keys->keystr
	 args-get-target
	 ;; areas
	 get-area-name
	 get-area-path-signature
	 )

(import scheme chicken data-structures extras posix ports files)
(use (prefix sql-de-lite sql:) md5 message-digest posix typed-records format srfi-1 srfi-69 pkts regex (prefix dbi dbi:) regex-case matchable)
(use (prefix mtconfigf configf:) srfi-13 (prefix margs args:))

(defstruct ctrldat
  (port      (current-error-port))
  (verbosity 1)
  (vcache    (make-hash-table))
  (logging   #f) ;; keep the flag and the db handle separate to enable overriding
  (logdb     #f) ;; might need to make this a stack of handles for threaded access
  (toppath   #f) ;; 
................................................................................

(define (config-get-fields cfgdat)
  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
    (if fields (map car fields) '())))

(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
  (string-intersperse keys ","))

(define (args-get-target #!key (split #f)(exit-if-bad #f)(configdat #f))
  (let* ((keys    (if (hash-table? configdat) (config-get-fields configdat) '()))
	 (numkeys (length keys))
	 (target  (or (args:get-arg "-reqtarg")
		      (args:get-arg "-target")
		      (get-environment-variable "MT_TARGET")))
	 (tlist   (if target (string-split target "/" #t) '()))
	 (valid   (if target
		      (or (null? keys) ;; probably don't know our keys yet
			  (and (not (null? tlist))
			       (eq? numkeys (length tlist))
			       (null? (filter string-null? tlist))))
		      #f)))
    (if valid
	(if split
	    tlist
	    target)
	(if target
	    (begin
	      (print-error "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
	      (if exit-if-bad (exit 1))
	      #f)
	    #f))))

;;======================================================================
;; Areas
;;======================================================================

(define (get-area-name adat)
  (let ((mt-config (adat-mtconfig adat))

Changes to mtutils/mtconfigf/mtconfigf.scm.

65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
...
267
268
269
270
271
272
273









274
275
276
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
305
306
307
308
309

310
311



312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
	 write-alist
	 config->ini
	 set-verbosity
         )

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

;; very wierd, the reference to pathname-directory here fixes a reference to possibly unbound identifier problem
;;
;; (define (dummy-function path)
;;   (pathname-directory path)
;;   (absolute-pathname? path)
................................................................................
;; read a line and process any #{ ... } constructs

(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)"))

(define (configf:system ht cmd)
  (system cmd)
  )










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

		     (fullcmd (case cmdsym
				((scheme scm) (conc "(lambda (ht)" cmd ")"))
				((system)     (conc "(lambda (ht)(configf:system ht \"" cmd "\"))"))
				((shell sh)   (conc "(lambda (ht)(string-translate (shell \""  cmd "\") \"\n\" \" \"))"))
				((realpath rp)(conc "(lambda (ht)(nice-path \"" cmd "\"))"))
				((getenv gv)  (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))"))
				((mtrah)      (conc "(lambda (ht)"
                                                    "    (let ((extra \"" cmd "\"))"
						    "       (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)(lookup ht \"" sect "\" \"" var "\"))")))
				((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				;; ((rget)           (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
				(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
		;; (print "fullcmd=" fullcmd)
		(handle-exceptions
		 exn
		 (begin

		   (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\"")
		   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))



		   ;; (print "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)))))
		(loop (conc prestr result poststr)))







|







 







>
>
>
>
>
>
>
>
>













>

|
|
|
|
|
|
|
|
|
|




|
|




|
|
>
|
|
>
>
>
|
|
|
|
|
|
|
|







65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
...
267
268
269
270
271
272
273
274
275
276
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
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
340
	 write-alist
	 config->ini
	 set-verbosity
         )

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

;; very wierd, the reference to pathname-directory here fixes a reference to possibly unbound identifier problem
;;
;; (define (dummy-function path)
;;   (pathname-directory path)
;;   (absolute-pathname? path)
................................................................................
;; read a line and process any #{ ... } constructs

(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)"))

(define (configf:system ht cmd)
  (system cmd)
  )

;; Lookup a value in runconfigs based on -reqtarg or -target
;; 
(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
                                                    "  (let ((extra \"" cmd "\"))"
						    "     (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* "WARNING: failed to process config input \"" l "\"")
		      (debug:print 0 *default-log-port* " message: " message 
				   (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)) 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)))