Megatest

Diff
Login

Differences From Artifact [50f8f33c26]:

To Artifact [9fba368c47]:


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
	    (list path fullpath configname)
	    (let ((remcwd (take dir (- (length dir) 1))))
	      (if (null? remcwd)
		  (list #f #f #f) ;;  #f #f) 
		  (loop remcwd))))))))

(define (config:assoc-safe-add alist key val)
  (let ((newalist (filter (lambda (x)(not (equal? key x))) alist)))
    (append alist (list (list key val)))))

;; read a config file, returns two level hierarchial hash-table,
;; adds to ht if given (must be #f otherwise)
(define (read-config path . ht)
  (if (not (file-exists? path))
      (if (null? ht)(make-hash-table) (car ht))
      (let ((inp        (open-input-file path))
	    (res        (if (null? ht)(make-hash-table)(car ht)))
	    (include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
	    (section-rx (regexp "^\\[(.*)\\]\\s*$"))
	    (blank-l-rx (regexp "^\\s*$"))
	    (key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$"))
	    (key-val-pr (regexp "^(\\S+)\\s+(.*)$"))
	    (comment-rx (regexp "^\\s*#.*")))

	(let loop ((inl               (read-line inp))
		   (curr-section-name "default"))


	  (if (eof-object? inl) 
	      (begin
		(close-input-port inp)
		res)
	      (regex-case 
	       inl 
	       (comment-rx _                  (loop (read-line inp) curr-section-name))
	       (blank-l-rx _                  (loop (read-line inp) curr-section-name))
	       (include-rx ( x include-file ) (begin
						(read-config include-file res)
						(loop (read-line inp) curr-section-name)))
	       (section-rx ( x section-name ) (loop (read-line inp) section-name))
	       (key-sys-pr ( x key cmd      ) (let ((alist (hash-table-ref/default res curr-section-name '()))
						    (val   (let* ((cmdres  (cmd-run->list cmd))
								  (status  (cadr cmdres))
								  (res     (car  cmdres)))
							     (if (not (eq? status 0))
								 (begin
								   (debug:print 0 "ERROR: problem with " inl ", return code " status)
								   (exit 1)))
							     (if (null? res)
								 ""
								 (string-intersperse res " ")))))
						(hash-table-set! res curr-section-name 
								 (config:assoc-safe-add alist key val))
								 ;; (append alist (list (list key val))))
						(loop (read-line inp) curr-section-name)))
	       (key-val-pr ( x key val      ) (let ((alist (hash-table-ref/default res curr-section-name '())))
						(hash-table-set! res curr-section-name 
								 (config:assoc-safe-add alist key val))










								 ;; (append alist (list (list key val))))



						(loop (read-line inp) curr-section-name)))

	       (else (debug:print 0 "ERROR: problem parsing " path ",\n   \"" inl "\"")

		     (loop (read-line inp) curr-section-name))))))))
  
(define (find-and-read-config fname)
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo)))







|
|













|
>

|
>
>






|
|


|
|














|



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

>







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
	    (list path fullpath configname)
	    (let ((remcwd (take dir (- (length dir) 1))))
	      (if (null? remcwd)
		  (list #f #f #f) ;;  #f #f) 
		  (loop remcwd))))))))

(define (config:assoc-safe-add alist key val)
  (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
    (append newalist (list (list key val)))))

;; read a config file, returns two level hierarchial hash-table,
;; adds to ht if given (must be #f otherwise)
(define (read-config path . ht)
  (if (not (file-exists? path))
      (if (null? ht)(make-hash-table) (car ht))
      (let ((inp        (open-input-file path))
	    (res        (if (null? ht)(make-hash-table)(car ht)))
	    (include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
	    (section-rx (regexp "^\\[(.*)\\]\\s*$"))
	    (blank-l-rx (regexp "^\\s*$"))
	    (key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$"))
	    (key-val-pr (regexp "^(\\S+)\\s+(.*)$"))
	    (comment-rx (regexp "^\\s*#.*"))
	    (cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")))
	(let loop ((inl               (read-line inp))
		   (curr-section-name "default")
		   (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
		   (lead     #f))
	  (if (eof-object? inl) 
	      (begin
		(close-input-port inp)
		res)
	      (regex-case 
	       inl 
	       (comment-rx _                  (loop (read-line inp) curr-section-name #f #f))
	       (blank-l-rx _                  (loop (read-line inp) curr-section-name #f #f))
	       (include-rx ( x include-file ) (begin
						(read-config include-file res)
						(loop (read-line inp) curr-section-name #f #f)))
	       (section-rx ( x section-name ) (loop (read-line inp) section-name #f #f))
	       (key-sys-pr ( x key cmd      ) (let ((alist (hash-table-ref/default res curr-section-name '()))
						    (val   (let* ((cmdres  (cmd-run->list cmd))
								  (status  (cadr cmdres))
								  (res     (car  cmdres)))
							     (if (not (eq? status 0))
								 (begin
								   (debug:print 0 "ERROR: problem with " inl ", return code " status)
								   (exit 1)))
							     (if (null? res)
								 ""
								 (string-intersperse res " ")))))
						(hash-table-set! res curr-section-name 
								 (config:assoc-safe-add alist key val))
								 ;; (append alist (list (list key val))))
						(loop (read-line inp) curr-section-name #f #f)))
	       (key-val-pr ( x key val      ) (let ((alist (hash-table-ref/default res curr-section-name '())))
						(hash-table-set! res curr-section-name 
								 (config:assoc-safe-add alist key val))
						(loop (read-line inp) curr-section-name key #f)))
	       ;; if a continued line
	       (cont-ln-rx ( x whsp val     ) (let ((alist (hash-table-ref/default res curr-section-name '())))
						(if var-flag             ;; if set to a string then we have a continued var
						    (let ((newval (conc 
								   (config-lookup res curr-section-name var-flag) "\n"
								   ;; trim lead from the incoming whsp to support some indenting.
								   (if lead
								       (string-substitute (regexp lead) "" whsp)
								       "")
								   val)))
						      (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
						      (hash-table-set! res curr-section-name 
								       (config:assoc-safe-add alist var-flag newval))
						      (loop (read-line inp) curr-section-name var-flag (if lead lead whsp)))
						    (loop (read-line inp) curr-section-name #f #f))))
	       (else (debug:print 0 "ERROR: problem parsing " path ",\n   \"" inl "\"")
		     (set! var-flag #f)
		     (loop (read-line inp) curr-section-name))))))))
  
(define (find-and-read-config fname)
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo)))