Megatest

Diff
Login

Differences From Artifact [6958f2dc04]:

To Artifact [cfc96f0d59]:


21
22
23
24
25
26
27
28

29
30
31
32
33
34
35

36
37
38
39
40
41
42
21
22
23
24
25
26
27

28
29
30
31
32
33
34

35
36
37
38
39
40
41
42







-
+






-
+








(include "common_records.scm")

;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))
	(if (file-exists? cfname)
	(if (common:file-exists? cfname)
	    (list toppath cfname configname)
	    (list #f      #f     #f)))
      (let* ((cwd (string-split (current-directory) "/")))
	(let loop ((dir cwd))
	  (let* ((path     (conc "/" (string-intersperse dir "/")))
		 (fullpath (conc path "/" configname)))
	    (if (file-exists? fullpath)
	    (if (common:file-exists? fullpath)
		(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 #!key (metadata #f))
226
227
228
229
230
231
232
233

234
235
236
237
238
239
240
226
227
228
229
230
231
232

233
234
235
236
237
238
239
240







-
+







;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections
;;
(define (read-config path ht allow-system #!key (environ-patt #f)            (curr-section #f)
		     (sections #f)              (settings (make-hash-table)) (keep-filenames #f)
		     (post-section-procs '())   (apply-wildcards #t))
  (debug:print 9 *default-log-port* "START: " path)
  (if (and (not (port? path))
	   (not (file-exists? path))) ;; for case where we are handed a port
	   (not (common:file-exists? path))) ;; for case where we are handed a port
      (begin 
	(debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory))
	;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
	#f) ;; (if (not ht)(make-hash-table) ht))
      (let ((inp        (if (string? path)
			    (open-input-file path)
			      path)) ;; we can be handed a port
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
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







-
+















-
+







							     (full-conf     (if (absolute-pathname? include-file)
										include-file
										(common:nice-path 
										 (conc (if curr-conf-dir
											   curr-conf-dir
											   ".")
										       "/" include-file)))))
							(if (file-exists? full-conf)
							(if (common:file-exists? full-conf)
							    (begin
							      ;; (push-directory conf-dir)
							      (debug:print 9 *default-log-port* "Including: " full-conf)
							      (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
							      ;; (pop-directory)
							      (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
							    (begin
							      (debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")")
							      (debug:print 2 *default-log-port* "        " full-conf)
							      (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))))
	       (configf:script-rx ( x include-script params);; handle-exceptions
                                  ;;    exn
                                  ;;    (begin
                                  ;;      (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.")
                                  ;;      (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
							 (if (and (file-exists? include-script)(file-execute-access? include-script))
							 (if (and (common:file-exists? include-script)(file-execute-access? include-script))
							     (let* ((new-inp-port (open-input-pipe (conc include-script " " params))))
							       (debug:print '(2 9) *default-log-port* "Including from script output: " include-script)
							      ;;  (print "We got here, calling read-config next. Port is: " new-inp-port)
							       (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
							       (close-input-port new-inp-port)
							       (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
							     (begin
508
509
510
511
512
513
514
515

516
517
518
519
520
521
522
508
509
510
511
512
513
514

515
516
517
518
519
520
521
522







-
+







		 (res '()))
	(let ((newres (append res (list (string-substitute (regexp "\n") "\n         " hed #t)))))
	  (if (null? tal)
	      newres
	      (loop (car tal)(cdr tal) newres))))))

(define (configf:file->list fname)
  (if (file-exists? fname)
  (if (common:file-exists? fname)
      (let ((inp (open-input-file fname)))
	(let loop ((inl (read-line inp))
		   (res '()))
	  (if (eof-object? inl)
	      (begin
		(close-input-port inp)
		(reverse res))
612
613
614
615
616
617
618
619

620
621
622
623
624
625
626
612
613
614
615
616
617
618

619
620
621
622
623
624
625
626







-
+







;; refdb
;;======================================================================

;; reads a refdb into an assoc array of assoc arrays
;;   returns (list dat msg)
(define (configf:read-refdb refdb-path)
  (let ((sheets-file  (conc refdb-path "/sheet-names.cfg")))
    (if (not (file-exists? sheets-file))
    (if (not (common:file-exists? sheets-file))
	(list #f (conc "ERROR: no refdb found at " refdb-path))
	(if (not (file-read-access? sheets-file))
	    (list #f (conc "ERROR: refdb file not readable at " refdb-path))
	    (let* ((sheets (with-input-from-file sheets-file
			     (lambda ()
			       (let loop ((inl (read-line))
					  (res '()))
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709




















710
711
712


713
714
715
716

717
718
719
720
721
722
723
684
685
686
687
688
689
690



















691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710



711
712




713
714
715
716
717
718
719
720







-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
-
-
-
-
+







  (handle-exceptions
      exn
      #f
    (configf:alist->config
     (with-input-from-file fname read))))

(define (configf:write-alist cdat fname)
    (if (common:faux-lock fname)
        (let* ((dat  (configf:config->alist cdat))
               (res
                (begin
                  (with-output-to-file fname ;; first write out the file
                    (lambda ()
                      (pp dat)))
                  
                  (if (common:file-exists? fname)   ;; now verify it is readable
                      (if (configf:read-alist fname)
                          #t ;; data is good.
                          (begin
                            (handle-exceptions
                             exn
                             #f
                             (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.")
                             (delete-file fname))
                            #f))
                      #f))))
  (if (not (common:faux-lock fname))
      (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname))
  (let* ((dat  (configf:config->alist cdat))
         (res
          (begin
            (with-output-to-file fname ;; first write out the file
              (lambda ()
                (pp dat)))
            
            (if (common:file-exists? fname)   ;; now verify it is readable
                (if (configf:read-alist fname)
                    #t ;; data is good.
                    (begin
                      (handle-exceptions
                       exn
                       #f
                       (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.")
                       (delete-file fname))
                      #f))
                #f))))
          
          (common:faux-unlock fname)
          res)
    (common:faux-unlock fname)
    res))
        (begin
          (debug:print 0 *default-log-port* "WARNING: could not get faux-lock on " fname)
          #f)))

  
;; convert hierarchial list to ini format
;;
(define (configf:config->ini data)
  (map 
   (lambda (section)
     (let ((section-name (car section))
	   (section-dat  (cdr section)))