Megatest

Check-in [0438d75d6c]
Login
Overview
Comment:Fixed bug with finding wrong megatest.config and megatest.db due to usage of symlinks
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.44
Files: files | file ages | folders
SHA1: 0438d75d6cfeae7c3f7b52f8ea905f1116ce5411
User & Date: mrwellan on 2012-06-26 14:06:20
Other Links: branch diff | manifest | tags
Context
2012-06-27
13:51
Fixed typo check-in: d3fc157db1 user: mrwellan tags: v1.44
2012-06-26
14:06
Fixed bug with finding wrong megatest.config and megatest.db due to usage of symlinks check-in: 0438d75d6c user: mrwellan tags: v1.44
2012-06-22
13:47
Bumped version number check-in: 034e389e7c user: fdk71adm tags: v1.44
Changes

Modified configf.scm from [35e1d07762] to [430ee65b96].

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
















35
36
37
38
39
40
41
17
18
19
20
21
22
23











24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46







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







(declare (unit configf))
(declare (uses common))
(declare (uses process))

(include "common_records.scm")

;; return list (path fullpath configname)
(define (find-config configname)
  (let* ((cwd (string-split (current-directory) "/")))
    (let loop ((dir cwd))
      (let* ((path     (conc "/" (string-intersperse dir "/")))
	     (fullpath (conc path "/" configname)))
	(if (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 (find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))
	(if (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)
		(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)))))

(define (config:eval-string-in-environment str)
  (let ((cmdres (cmd-run->list (conc "echo " str))))
206
207
208
209
210
211
212
213

214
215

216
217
218
219
220
221
222
211
212
213
214
215
216
217

218
219

220
221
222
223
224
225
226
227







-
+

-
+







								       (config:assoc-safe-add alist var-flag newval))
						      (loop (configf:read-line inp res) curr-section-name var-flag (if lead lead whsp)))
						    (loop (configf:read-line inp res) curr-section-name #f #f))))
	       (else (debug:print 0 "ERROR: problem parsing " path ",\n   \"" inl "\"")
		     (set! var-flag #f)
		     (loop (configf:read-line inp res) curr-section-name #f #f))))))))
  
(define (find-and-read-config fname #!key (environ-patt #f))
(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f))
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname))
         (configinfo (find-config fname toppath: given-toppath))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo)))
    (if toppath (change-directory toppath)) 
    (let ((configdat  (if configfile (read-config configfile #f #t environ-patt: environ-patt) #f))) ;; (make-hash-table))))
      (if toppath (change-directory curr-dir))
      (list configdat toppath configfile fname))))

Modified db.scm from [b8582e66d4] to [9c55b17e1a].

39
40
41
42
43
44
45

46
47
48
49
50
51
52
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53







+







(define (open-db) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (let* ((dbpath    (conc *toppath* "/megatest.db")) ;; fname)
	 (dbexists  (file-exists? dbpath))
	 (db        (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath))
	 (handler   (make-busy-timeout (if (args:get-arg "-override-timeout")
					   (string->number (args:get-arg "-override-timeout"))
					   36000)))) ;; 136000)))
    (debug:print 4 "INFO: dbpath=" dbpath)
    (sqlite3:set-busy-handler! db handler)
    (if (not dbexists)
	(db:initialize db))
    db))

(define (db:initialize db)
  (let* ((configdat (car *configinfo*))  ;; tut tut, global warning...

Modified launch.scm from [5c9948d4db] to [9233896a79].

346
347
348
349
350
351
352
353
354






355
356
357
358
359
360
361
346
347
348
349
350
351
352


353
354
355
356
357
358
359
360
361
362
363
364
365







-
-
+
+
+
+
+
+







	    (if (not (vector-ref exit-info 1))
		(exit 4)))))))

;; set up the very basics needed for doing anything here.
(define (setup-for-run)
  ;; would set values for KEYS in the environment here for better support of env-override but 
  ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to 
  ;; pass on that idea for now.
  (set! *configinfo* (find-and-read-config (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config") environ-patt: "env-override"))
  ;; pass on that idea for now
  ;; special case
  (set! *configinfo* (find-and-read-config 
		      (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config")
		      environ-patt: "env-override"
		      given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")))
  (set! *configdat*  (if (car *configinfo*)(car *configinfo*) #f))
  (set! *toppath*    (if (car *configinfo*)(cadr *configinfo*) #f))
  (if *toppath*
      (setenv "MT_RUN_AREA_HOME" *toppath*) ;; to be deprecated
      (debug:print 0 "ERROR: failed to find the top path to your run setup."))
  *toppath*)

636
637
638
639
640
641
642
643


644
640
641
642
643
644
645
646

647
648
649







-
+
+

	    ;; but this hack will work! Thanks go to Alan Post of the Chicken email list
	    ;; NB// Is this still needed? Should be safe to go back to "exit" now?
	    (process-signal (current-process-id) signal/kill)
	    ))
      (alist->env-vars miscprevvals)
      (alist->env-vars testprevvals)
      (alist->env-vars commonprevvals)
      launch-results)))
      launch-results))
  (change-directory *toppath*))

Modified megatest-version.scm from [08980e8127] to [eae4e8d6e7].

1
2
3
4
5
6

7
1
2
3
4
5

6
7





-
+

;; Always use two digit decimal
;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.4401)
(define megatest-version 1.4402)