Megatest

Check-in [66d220dfd7]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:More action on removing globals
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | multi-testsuite-support
Files: files | file ages | folders
SHA1: 66d220dfd707e95cc675b6fab5a0c3bd7e30f9ba
User & Date: matt on 2014-12-28 22:33:12
Other Links: branch diff | manifest | tags
Context
2014-12-28
22:33
More action on removing globals Closed-Leaf check-in: 66d220dfd7 user: matt tags: multi-testsuite-support
18:39
Removing reliance on globals in prep for multi-testsuite support in dashboard check-in: f8db475db1 user: matt tags: multi-testsuite-support
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified common.scm from [cb095d1eb1] to [2beae978dd]. 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19

;;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

(use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml z3)
(require-extension sqlite3 regex posix)

(require-extension (srfi 18) extras tcp rpc)

(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))













|








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19

;;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

(use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml z3 call-with-environment-variables)
(require-extension sqlite3 regex posix)

(require-extension (srfi 18) extras tcp rpc)

(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
︙︙
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

       (setenv key val))
      (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)))

(define home (getenv "HOME"))
(define user (getenv "USER"))

;; GLOBAL GLETCHES
(define *db-keys* #f)
(define *configinfo* #f)
(define *configdat*  #f)
(define *toppath*    #f)
(define *already-seen-runconfig-info* #f)
(define *waiting-queue*     (make-hash-table))
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
(define *passnum*           0) ;; when running track calls to run-tests or similar
(define *write-frequency*   (make-hash-table)) ;; run-id => (vector (current-seconds) 0))
(define *alt-log-file* #f)  ;; used by -log
(define *common:denoise*    (make-hash-table)) ;; for low noise printing




;; MULTI-TESTSUITE support
(define *testsuite-mutex* (make-mutex))

;; DATABASE
(define *dbstruct-db*  #f)
(define *db-stats*            (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex*      (make-mutex))
(define *db-sync-mutex*       (make-mutex))








|
|
|
|
|
|
|
|
|
|
|
|

>
>
>
|








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

       (setenv key val))
      (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)))

(define home (getenv "HOME"))
(define user (getenv "USER"))

;; GLOBAL GLETCHES
;; (define *db-keys* #f)
;; (define *configinfo* #f)
;; (define *configdat*  #f)
;; (define *toppath*    #f)
;; (define *already-seen-runconfig-info* #f)
;; (define *waiting-queue*     (make-hash-table))
;; (define *test-meta-updated* (make-hash-table))
;; (define *globalexitstatus*  0) ;; attempt to work around possible thread issues
;; (define *passnum*           0) ;; when running track calls to run-tests or similar
;; (define *write-frequency*   (make-hash-table)) ;; run-id => (vector (current-seconds) 0))
;; (define *alt-log-file* #f)  ;; used by -log
;; (define *common:denoise*    (make-hash-table)) ;; for low noise printing

;; All the above *theoretically* replaced by ...
(define *testsuite-data* (make-hash-table)) ;; area-path => testsuite-vector < toppath linktree configdat envvars dbstruct >

;; MULTI-TESTSUITE support, use when the env-vars are in use (set up and take down using call-with-environment-variables.)
(define *testsuite-mutex* (make-mutex))

;; DATABASE
(define *dbstruct-db*  #f)
(define *db-stats*            (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex*      (make-mutex))
(define *db-sync-mutex*       (make-mutex))
︙︙
146
147
148
149
150
151
152
153

154
155
156
157
158
159
160
161

162
163
164
165
166
167
168
169
170
171
172
173

174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
















191
192
193
194
195
196
197

			 (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")
			  pathenvvar: "MT_RUN_AREA_HOME")))
	 (configdat  (if (car configinfo)(car configinfo) #f))
	 (toppath    (if (car configinfo)(cadr configinfo) #f))
	 (linktree   (configf:lookup configdat "setup" "linktree"))) ;; link tree is critical

    (if linktree
	(if (not (file-exists? linktree))
	    (begin
	      (handle-exceptions
	       exn
	       (begin
		 (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree)
		 (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)))

	       (create-directory linktree #t))))
	(begin
	  (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
	  (exit 1)))
    (if linktree
	(let ((dbdir (or (configf:lookup configdat "setup" "dbdir") ;; not really supported yet, placeholder only
			 (conc linktree "/.db"))))
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files")
	     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)))

	   (if (not (directory-exists? dbdir))(create-directory dbdir))))
	;; (setenv "MT_LINKTREE" linktree))
	(begin
	  (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section")
	  ;; (exit 1)
	  )
	)
    (if (not (and toppath
		  (directory-exists? toppath)))
	;; (setenv "MT_RUN_AREA_HOME" *toppath*)
	(begin
	  (debug:print 0 "ERROR: failed to find the top path to your Megatest area.")))
	;; (exit 1)))
    (mutex-unlock! *testsuite-mutex*)
    (vector toppath linktree configinfo
	    (list (cons "MT_LINKTREE" linktree)
		  (cons "MT_RUN_AREA_HOME" toppath)))))

















;;======================================================================
;; L O C K E R S   A N D   B L O C K E R S 
;;======================================================================

;; block further accesses to databases. Call this before shutting db down
(define (common:db-block-further-queries)








|
>







|
>



|







|
>




<
|
<


<

|
|

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








149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183

184

185
186

187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216

			 (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")
			  pathenvvar: "MT_RUN_AREA_HOME")))
	 (configdat  (if (car configinfo)(car configinfo) #f))
	 (toppath    (if (car configinfo)(cadr configinfo) #f))
	 (linktree   (configf:lookup configdat "setup" "linktree")) ;; link tree is critical
	 (failed     #f))
    (if linktree
	(if (not (file-exists? linktree))
	    (begin
	      (handle-exceptions
	       exn
	       (begin
		 (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree)
		 (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
		 (set! failed #t))
	       (create-directory linktree #t))))
	(begin
	  (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
	  (set! failed #t)))
    (if linktree
	(let ((dbdir (or (configf:lookup configdat "setup" "dbdir") ;; not really supported yet, placeholder only
			 (conc linktree "/.db"))))
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files")
	     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	     (set! failed #t))
	   (if (not (directory-exists? dbdir))(create-directory dbdir))))
	;; (setenv "MT_LINKTREE" linktree))
	(begin
	  (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section")

	  (set! failed #t)))

    (if (not (and toppath
		  (directory-exists? toppath)))

	(begin
	  (debug:print 0 "ERROR: failed to find the top path to your Megatest area.")
	  (set! failed #t)))
    (mutex-unlock! *testsuite-mutex*)
    (let ((testsuite-data (vector toppath linktree configinfo
				  (list (cons "MT_LINKTREE" linktree)
					(cons "MT_RUN_AREA_HOME" toppath))
				  #f)))
      (if failed
	  #f
	  (begin
	    (hash-table-set! *testsuite-data* toppath testsuite-data)
	    testsuite-data)))))

;; get the vars from the testsuite-data envvars store and run proc
;;
(define (common:with-vars testsuite-data proc . additional-vars)
  (mutex-lock! *testsuite-mutex*)
  (let* ((envvars (append (common_records:testsuite-get-envvars testsuite-data)
			  additional-vars))
	 (res (call-with-environment-variables envvars proc)))
    (mutex-unlock! *testsuite-mutex*)
    res))

;;======================================================================
;; L O C K E R S   A N D   B L O C K E R S 
;;======================================================================

;; block further accesses to databases. Call this before shutting db down
(define (common:db-block-further-queries)
︙︙

Modified common_records.scm from [fe3b733b14] to [07a3931f12].

︙︙
100
101
102
103
104
105
106
107
108
109
110
111

112
113
114
115

116
117
118
119
120
121

  (if (or (number? val)(string? val)) val ""))

;;======================================================================
;; T E S T S U I T E   R E C O R D S
;;======================================================================

;; make-vector-record common_records testsuite toppath linktree configdat envvars
(define (make-common_records:testsuite)(make-vector 4))
(define-inline (common_records:testsuite-get-toppath     vec)    (vector-ref  vec 0))
(define-inline (common_records:testsuite-get-linktree    vec)    (vector-ref  vec 1))
(define-inline (common_records:testsuite-get-configdat   vec)    (vector-ref  vec 2))
(define-inline (common_records:testsuite-get-envvars     vec)    (vector-ref  vec 3))

(define-inline (common_records:testsuite-set-toppath!    vec val)(vector-set! vec 0 val))
(define-inline (common_records:testsuite-set-linktree!   vec val)(vector-set! vec 1 val))
(define-inline (common_records:testsuite-set-configdat!  vec val)(vector-set! vec 2 val))
(define-inline (common_records:testsuite-set-envvars!    vec val)(vector-set! vec 3 val))


(define (common_records:testsuite-add-envvar! vec var val)
  (let ((envvars (cons (cons var val) 
		       (or (common_records:testsuite-get-envvars vec) '()))))
    (common_records:testsuite-set-envvars! vec envvars)
    envvars))








|




>




>







100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123

  (if (or (number? val)(string? val)) val ""))

;;======================================================================
;; T E S T S U I T E   R E C O R D S
;;======================================================================

;; make-vector-record common_records testsuite toppath linktree configdat envvars
(define (make-common_records:testsuite)(make-vector 5))
(define-inline (common_records:testsuite-get-toppath     vec)    (vector-ref  vec 0))
(define-inline (common_records:testsuite-get-linktree    vec)    (vector-ref  vec 1))
(define-inline (common_records:testsuite-get-configdat   vec)    (vector-ref  vec 2))
(define-inline (common_records:testsuite-get-envvars     vec)    (vector-ref  vec 3))
(define-inline (common_records:testsuite-get-dbstruct    vec)    (vector-ref  vec 4))
(define-inline (common_records:testsuite-set-toppath!    vec val)(vector-set! vec 0 val))
(define-inline (common_records:testsuite-set-linktree!   vec val)(vector-set! vec 1 val))
(define-inline (common_records:testsuite-set-configdat!  vec val)(vector-set! vec 2 val))
(define-inline (common_records:testsuite-set-envvars!    vec val)(vector-set! vec 3 val))
(define-inline (common_records:testsuite-set-dbstruct!   vec val)(vector-set! vec 4 val))

(define (common_records:testsuite-add-envvar! vec var val)
  (let ((envvars (cons (cons var val) 
		       (or (common_records:testsuite-get-envvars vec) '()))))
    (common_records:testsuite-set-envvars! vec envvars)
    envvars))

Modified launch.scm from [5cf0e6cf87] to [d4c7988f06].

︙︙
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602

	;; (setenv "MT_RUN_AREA_HOME" *toppath*)
	(begin
	  (debug:print 0 "ERROR: failed to find the top path to your Megatest area.")))
	;; (exit 1)))
    (mutex-unlock! *testsuite-mutex*)
    configinfo))

(define (launch:cache-config)
  ;; if we have a linktree and -runtests and -target and the directory exists dump the config
  ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
  (if (and *configdat* 
	   (args:get-arg "-runtests"))
      (let* ((linktree (get-environment-variable "MT_LINKTREE"))
	     (target   (common:args-get-target))
	     (runname  (or (args:get-arg "-runname")
			   (args:get-arg ":runname")))
	     (fulldir  (conc linktree "/"
			     target "/"
			     runname)))
	(debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir)
	(if (file-exists? linktree) ;; can't proceed without linktree
	    (begin
	      (if (not (file-exists? fulldir))
		  (create-directory fulldir #t)) ;; need to protect with exception handler 
	      (if (and target
		       runname
		       (file-exists? fulldir))
		  (let ((tmpfile  (conc fulldir "/.megatest.cfg." (current-seconds)))
			(targfile (conc fulldir "/.megatest.cfg")))
		    (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg")
		    (configf:write-alist *configdat* tmpfile)
		    (system (conc "ln -sf " tmpfile " " targfile))
		    )))))))

(define (get-best-disk confdat)
  (let* ((disks    (hash-table-ref/default confdat "disks" #f))
	 (minspace (let ((m (configf:lookup confdat "setup" "minspace")))
		     (string->number (or m "10000")))))








|


|



















|








565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602

	;; (setenv "MT_RUN_AREA_HOME" *toppath*)
	(begin
	  (debug:print 0 "ERROR: failed to find the top path to your Megatest area.")))
	;; (exit 1)))
    (mutex-unlock! *testsuite-mutex*)
    configinfo))

(define (launch:cache-config testsuite-data)
  ;; if we have a linktree and -runtests and -target and the directory exists dump the config
  ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
  (if (and testsuite-data ;; *configdat* 
	   (args:get-arg "-runtests"))
      (let* ((linktree (get-environment-variable "MT_LINKTREE"))
	     (target   (common:args-get-target))
	     (runname  (or (args:get-arg "-runname")
			   (args:get-arg ":runname")))
	     (fulldir  (conc linktree "/"
			     target "/"
			     runname)))
	(debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir)
	(if (file-exists? linktree) ;; can't proceed without linktree
	    (begin
	      (if (not (file-exists? fulldir))
		  (create-directory fulldir #t)) ;; need to protect with exception handler 
	      (if (and target
		       runname
		       (file-exists? fulldir))
		  (let ((tmpfile  (conc fulldir "/.megatest.cfg." (current-seconds)))
			(targfile (conc fulldir "/.megatest.cfg")))
		    (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg")
		    (configf:write-alist testsuite-data tmpfile)
		    (system (conc "ln -sf " tmpfile " " targfile))
		    )))))))

(define (get-best-disk confdat)
  (let* ((disks    (hash-table-ref/default confdat "disks" #f))
	 (minspace (let ((m (configf:lookup confdat "setup" "minspace")))
		     (string->number (or m "10000")))))
︙︙

Modified megatest.scm from [2c3c187b26] to [ed2c91c8ce].

︙︙
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

;; The watchdog is to keep an eye on things like db sync etc.
;;
(define *time-zero* (current-seconds))
(define *watchdog*
  (make-thread 
   (lambda ()
     (thread-sleep! 0.05) ;; delay for startup
     (let ((legacy-sync (configf:lookup *configdat* "setup" "megatest-db"))
	   (debug-mode  (debug:debug-mode 1))
	   (last-time   (current-seconds)))
       (let loop ()
	 ;; sync for filesystem local db writes
	 ;;
	 (let ((start-time      (current-seconds))
	       (servers-started (make-hash-table)))
	   (for-each 
	    (lambda (run-id)
	      (mutex-lock! *db-multi-sync-mutex*)
	      (if (and legacy-sync 
		       (hash-table-ref/default *db-local-sync* run-id #f))
		  ;; (if (> (- start-time last-write) 5) ;; every five seconds
		  (begin ;; let ((sync-time (- (current-seconds) start-time)))
		    (db:multi-db-sync (list run-id) 'new2old)
		    (if (common:low-noise-print 30 "sync new to old")
			(let ((sync-time (- (current-seconds) start-time)))
			  (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
		    ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run
		    ;;     (begin
		    ;;       (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id)
		    ;;       (server:kind-run run-id)))))
		    (hash-table-delete! *db-local-sync* run-id)))
	      (mutex-unlock! *db-multi-sync-mutex*))
	    (hash-table-keys *db-local-sync*))
	   (if (and debug-mode
		    (> (- start-time last-time) 60))
	       (begin
		 (set! last-time start-time)
		 (debug:print-info 1 "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
	 
	 ;; keep going unless time to exit








|







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|








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

;; The watchdog is to keep an eye on things like db sync etc.
;;
(define *time-zero* (current-seconds))
(define *watchdog*
  (make-thread 
   (lambda ()
     (thread-sleep! 0.05) ;; delay for startup
     (let (;; (legacy-sync (configf:lookup *configdat* "setup" "megatest-db"))
	   (debug-mode  (debug:debug-mode 1))
	   (last-time   (current-seconds)))
       (let loop ()
	 ;; sync for filesystem local db writes
	 ;;
	 (let ((start-time      (current-seconds))
	       (servers-started (make-hash-table)))
	 ;;   (for-each 
	 ;;    (lambda (run-id)
	 ;;      (mutex-lock! *db-multi-sync-mutex*)
	 ;;      (if (and legacy-sync 
	 ;;               (hash-table-ref/default *db-local-sync* run-id #f))
	 ;;          ;; (if (> (- start-time last-write) 5) ;; every five seconds
	 ;;          (begin ;; let ((sync-time (- (current-seconds) start-time)))
	 ;;            (db:multi-db-sync (list run-id) 'new2old)
	 ;;            (if (common:low-noise-print 30 "sync new to old")
	 ;;        	(let ((sync-time (- (current-seconds) start-time)))
	 ;;        	  (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
	 ;;            ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run
	 ;;            ;;     (begin
	 ;;            ;;       (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id)
	 ;;            ;;       (server:kind-run run-id)))))
	 ;;            (hash-table-delete! *db-local-sync* run-id)))
	 ;;      (mutex-unlock! *db-multi-sync-mutex*))
	 ;;    (hash-table-keys *db-local-sync*))
	   (if (and debug-mode
		    (> (- start-time last-time) 60))
	       (begin
		 (set! last-time start-time)
		 (debug:print-info 1 "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
	 
	 ;; keep going unless time to exit
︙︙
653
654
655
656
657
658
659

660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680

		     equal?
		     (hash-table-keys args:arg-hash)
		     '("-list-servers"
		       "-stop-server"
		       "-show-cmdinfo"
		       "-list-runs"
		       "-ping")))

	(if (launch:setup-for-run)
	    (let ((run-id    (and (args:get-arg "-run-id")
				  (string->number (args:get-arg "-run-id")))))
	      ;; (set! *fdb*   (filedb:open-db (conc *toppath* "/db/paths.db")))
	      ;; if not list or kill then start a client (if appropriate)
	      (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
		      (eq? (length (hash-table-keys args:arg-hash)) 0))
		  (debug:print-info 1 "Server connection not needed")
		  (begin
		    ;; (if run-id 
		    ;;     (client:launch run-id) 
		    ;;     (client:launch 0)      ;; without run-id we'll start a server for "0"
		    #t
		    ))))))

;; MAY STILL NEED THIS
;;		       (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t))))))))))

(if (or (args:get-arg "-list-servers")
	(args:get-arg "-stop-server"))
    (let ((tl (launch:setup-for-run)))








>
|












|








653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681

		     equal?
		     (hash-table-keys args:arg-hash)
		     '("-list-servers"
		       "-stop-server"
		       "-show-cmdinfo"
		       "-list-runs"
		       "-ping")))
	(let ((testsuite-data (common:multi-setup-for-run)))
	(if testsuite-data ;; (launch:setup-for-run)
	    (let ((run-id    (and (args:get-arg "-run-id")
				  (string->number (args:get-arg "-run-id")))))
	      ;; (set! *fdb*   (filedb:open-db (conc *toppath* "/db/paths.db")))
	      ;; if not list or kill then start a client (if appropriate)
	      (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
		      (eq? (length (hash-table-keys args:arg-hash)) 0))
		  (debug:print-info 1 "Server connection not needed")
		  (begin
		    ;; (if run-id 
		    ;;     (client:launch run-id) 
		    ;;     (client:launch 0)      ;; without run-id we'll start a server for "0"
		    #t
		    )))))))

;; MAY STILL NEED THIS
;;		       (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t))))))))))

(if (or (args:get-arg "-list-servers")
	(args:get-arg "-stop-server"))
    (let ((tl (launch:setup-for-run)))
︙︙

Modified runs.scm from [da9f606770] to [b678c3717d].

︙︙
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668






1669
1670
1671
1672
1673
1674
1675
1676
1677
1678



1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705

     ((not target)
      (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target")
      (exit 3))
     ((not runname)
      (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname")
      (exit 3))
     (else
      (let (;; (db   #f)
	    (keys #f))
	(if (launch:setup-for-run)






	    (launch:cache-config)
	    (begin 
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	;; (if (args:get-arg "-server")
	;;     (cdb:remote-run server:start db (args:get-arg "-server")))
	(set! keys (keys:config-get-fields *configdat*))
	;; have enough to process -target or -reqtarg here
	(if (args:get-arg "-reqtarg")
	    (let* ((runconfigf (conc  *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL 



		   (runconfig  (read-config runconfigf #f #t environ-patt: #f)))
	      (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
		  (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
		    
		  (begin
		    (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
		    ;; (if db (sqlite3:finalize! db))
		    (exit 1)
		    )))
	    (if (args:get-arg "-target")
		(keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash)))
	(if (not (car *configinfo*))
	    (begin
	      (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found")
	      (exit 1))
	    ;; Extract out stuff needed in most or many calls
	    ;; here then call proc
	    (let* ((keyvals    (keys:target->keyval keys target)))
	      (proc target runname keys keyvals)))
	;; (if db (sqlite3:finalize! db))
	(set! *didsomething* #t))))))

;;======================================================================
;; Lock/unlock runs
;;======================================================================

(define (runs:handle-locking target keys runname lock unlock user)








<
|
|
>
>
>
>
>
>
|





|


|
>
>
>
|










|







<








1659
1660
1661
1662
1663
1664
1665

1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705

1706
1707
1708
1709
1710
1711
1712

     ((not target)
      (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target")
      (exit 3))
     ((not runname)
      (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname")
      (exit 3))
     (else

      (let* ((keys #f)
	     (testsuite-data (common:multi-setup-for-run))
	     (configdat      (common_records:testsuite-get-configdat testsuite-data))
	     (toppath        (common_records:testsuite-get-toppath   testsuite-data)))
	(if testsuite-data
	    (common:with-vars 
	     testsuite-data
	     (lambda ()
	       (launch:cache-config testsuite-data)))
	    (begin 
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	;; (if (args:get-arg "-server")
	;;     (cdb:remote-run server:start db (args:get-arg "-server")))
	(set! keys (keys:config-get-fields configdat))
	;; have enough to process -target or -reqtarg here
	(if (args:get-arg "-reqtarg")
	    (let* ((runconfigf (conc  toppath "/runconfigs.config")) ;; DO NOT EVALUATE ALL 
		   (runconfig  (common:with-vars
				testsuite-data
				(lambda ()
				  (read-config runconfigf #f #t environ-patt: #f)))))
	      (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
		  (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
		    
		  (begin
		    (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
		    ;; (if db (sqlite3:finalize! db))
		    (exit 1)
		    )))
	    (if (args:get-arg "-target")
		(keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash)))
	(if testsuite-data ;; (not (car *configinfo*))
	    (begin
	      (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found")
	      (exit 1))
	    ;; Extract out stuff needed in most or many calls
	    ;; here then call proc
	    (let* ((keyvals    (keys:target->keyval keys target)))
	      (proc target runname keys keyvals)))

	(set! *didsomething* #t))))))

;;======================================================================
;; Lock/unlock runs
;;======================================================================

(define (runs:handle-locking target keys runname lock unlock user)
︙︙

This page was generated in about 0.111s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00