Megatest

Check-in [de5a88efa7]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Made fs the default transport as it seems to work much better now
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.55
Files: files | file ages | folders
SHA1: de5a88efa724d1c604ee58a1b758c885f615e68b
User & Date: matt on 2013-08-04 18:34:14
Other Links: branch diff | manifest | tags
Context
2013-08-04
21:21
Cleaned up auto server start a little check-in: 166fac4584 user: matt tags: v1.55
18:34
Made fs the default transport as it seems to work much better now check-in: de5a88efa7 user: matt tags: v1.55
01:01
Added some checks to ensure directories are there before changing to them, generalized some of the tasks in installall. Removed writing of environment in mt_ezstep updated the manual with brief mention on how to get the environment from one step to another check-in: 908b883b86 user: matt tags: v1.55
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified client.scm from [402eaa1014] to [5629ce5408].

︙
52
53
54
55
56
57
58
59

60
61
62
63
64
65
66

52
53
54
55
56
57
58

59
60
61
62
63
64
65
66








-
+








;;
;; There are two scenarios. 
;;   1. We are a test manager and we received *transport-type* and *runremote* via cmdline
;;   2. We are a run tests, list runs or other interactive process and we mush figure out
;;      *transport-type* and *runremote* from the monitor.db
;;
;; client:setup
(define (client:setup #!key (numtries 50))
(define (client:setup #!key (numtries 3))
  (if (not *toppath*)
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: failed to find megatest.config, exiting")
	    (exit))))
  (push-directory *toppath*) ;; This is probably NOT needed 
  (debug:print-info 11 "*transport-type* is " *transport-type* ", *runremote* is " *runremote*)
︙
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90












91
92
93
94
95
96
97

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








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








    			       (string->symbol (tasks:hostinfo-get-transport hostinfo))
			       'fs))
    ;; ;; DEBUG STUFF
    ;; (if (eq? *transport-type* 'fs)(begin (print "ERROR!!!!!!! refusing to run with transport " *transport-type*)(exit 99)))
    
    (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) ""))
    (case *transport-type* 
      ((fs) ;; (if (not *megatest-db*)(set! *megatest-db* (open-db))))
       ;; we are not doing fs any longer. let's cheat and start up a server
       ;; if we are falling back on fs (not 100% supported) do an about face and start a server
       (if (not (equal? (args:get-arg "-transport") "fs"))
	   (begin
	     (set! *transport-type* #f)
	     (system (conc "megatest -list-servers | grep " megatest-version " | grep alive || megatest -server - -daemonize && sleep 3"))
	     (thread-sleep! 1)
	     (if (> numtries 0)
		 (client:setup numtries: (- numtries 1))))))
      ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db))))
      ;; NB// Going back to enabling fs and possibly even make it the default.
       ;; ;; we are not doing fs any longer. let's cheat and start up a server
       ;; ;; if we are falling back on fs (not 100% supported) do an about face and start a server
       ;; (if (not (equal? (args:get-arg "-transport") "fs"))
       ;;     (begin
       ;;       (set! *transport-type* #f)
       ;;       (system ;; (conc "megatest -list-servers | grep " (common:version-signature) " | grep alive || megatest -server - -daemonize && sleep 3"))
       ;;        "megatest -server - -daemonize")
       ;;       (thread-sleep! 1)
       ;;       (if (> numtries 0)
       ;;  	 (client:setup numtries: (- numtries 1))))))
      ((http)
       (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
				      (tasks:hostinfo-get-port hostinfo)))
      ((zmq)
       (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
				     (tasks:hostinfo-get-port      hostinfo)
				     (tasks:hostinfo-get-pubport   hostinfo)))
︙

Modified common.scm from [026189a548] to [0004ed06a1].

︙
38
39
40
41
42
43
44
45

46
47
48
49
50
51
52

38
39
40
41
42
43
44

45
46
47
48
49
50
51
52








-
+








(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

;; SERVER
(define *my-client-signature* #f)
(define *transport-type*    #f)
(define *transport-type*    'fs)
(define *megatest-db*       #f)
(define *rpc:listener*      #f) ;; if set up for server communication this will hold the tcp port
(define *runremote*         #f) ;; if set up for server communication this will hold <host port>
(define *last-db-access*    (current-seconds))  ;; update when db is accessed via server
(define *max-cache-size*    0)
(define *logged-in-clients* (make-hash-table))
(define *client-non-blocking-mode* #f)
︙

Modified launch.scm from [32f5996c52] to [b23191ac40].

︙
371
372
373
374
375
376
377


378
379
380
381
382
383
384
385
386
387










388
389
390
391
392
393
394

371
372
373
374
375
376
377
378
379










380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396








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









;; 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
  ;; special case
  (if (not (hash-table? *configdat*))  ;; no need to re-open on every call
      (begin
  (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")
		      pathenvvar: "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."))
	(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")
			    pathenvvar: "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*)

(define (get-best-disk confdat)
  (let* ((disks    (hash-table-ref/default confdat "disks" #f))
	 (best     #f)
	 (bestsize 0))
    (if disks
︙

Modified megatest.scm from [5cecb64bdf] to [073256ec29].

︙
251
252
253
254
255
256
257

258
259
260
261




262
263
264
265
266
267
268

251
252
253
254
255
256
257
258




259
260
261
262
263
264
265
266
267
268
269








+
-
-
-
-
+
+
+
+








(if (args:get-arg "-version")
    (begin
      (print megatest-version)
      (exit)))

(define *didsomething* #f)

;; Force default transport to fs
(if (and (or (args:get-arg "-list-targets")
	     (args:get-arg "-list-db-targets"))
	 (not (args:get-arg "-transport")))
    (hash-table-set! args:arg-hash "-transport" "fs"))
(if ;; (and (or (args:get-arg "-list-targets")
    ;;          (args:get-arg "-list-db-targets"))
 (not (args:get-arg "-transport"))
 (hash-table-set! args:arg-hash "-transport" "fs"))

;;======================================================================
;; Misc setup stuff
;;======================================================================

(debug:setup)
︙
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
341







342
343
344





345
346
347
348
349
350
351

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
341
342
343
344
345
346








+
+
+





-
+
+

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








;;   we start the server if not running else start the client thread
;;======================================================================

(if (args:get-arg "-server")
    (let ((transport (args:get-arg "-transport" "http")))
      (debug:print 2 "Launching server using transport " transport)
      (server:launch (string->symbol transport)))

    ;; Not a server? This section will decide how to communicate
    ;;
    (if (not (null? (lset-intersection 
		     equal?
		     (hash-table-keys args:arg-hash)
		     '("-runtests"    "-list-runs"   "-rollup"
		       "-remove-runs" "-lock"        "-unlock"
		       "-update-meta" "-extract-ods"))))
		       "-update-meta" "-extract-ods" "-list-servers"
		       "-stop-server" "-show-cmdinfo"))))
	(if (setup-for-run)
	    (let loop ((servers  (open-run-close tasks:get-best-server tasks:open-db))
		       (trycount 0))
	      (if (or (not servers)
		      (null? servers))
		  (begin
	    (begin
		    (if (even? trycount) ;; just do the server start every other time through this loop (every 8 seconds)
			(begin
			  (debug:print 0 "INFO: Starting server as none running ...")
			  ;; (server:launch (string->symbol (args:get-arg "-transport" "http"))))
			  ;; no need to use fork, no need to do the list-servers trick. Just start the damn server, it will exit on it's own
			  ;; if there is an existing server
			  (system "megatest -server - -daemonize")
			  (thread-sleep! 3)
			  ;; (process-run (car (argv)) (list "-server" "-" "-daemonize" "-transport" (args:get-arg "-transport" "http")))
			  ;; (system (conc "megatest -list-servers | egrep '" megatest-version ".*alive' || megatest -server - -daemonize && sleep 3"))
			  ;; (process-fork (lambda ()
			  ;;       	  (daemon:ize)
			  ;;       	  (server:launch (string->symbol (args:get-arg "-transport" "http")))))
			  )

			(begin
			  (debug:print-info 0 "Waiting for server to start")
	      ;; 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")
			  (thread-sleep! 4)))
		    (if (< trycount 10)
			(loop (open-run-close tasks:get-best-server tasks:open-db) 
			      (+ trycount 1))
		  ;; ok, so lets connect to the server
		  (let ((transport-from-config (configf:lookup *configdat* "setup" "transport"))
			(transport-from-cmdln  (args:get-arg "-transport")))
		    (cond
		     ((and transport-from-config (not (equal? transport-from-config "fs")))
		      (server:ensure-running)
		      (client:launch))
			(debug:print 0 "WARNING: Couldn't start or find a server.")))
		  (debug:print 0 "INFO: Server(s) running " servers)
		  )))))
		     ((and transport-from-cmdln (not (equal? transport-from-cmdln "fs")))
		      (server:ensure-running)
		      (client:launch))
		     (else
		      (set! *transport-type* 'fs)))))))))

(if (or (args:get-arg "-list-servers")
	(args:get-arg "-stop-server"))
    (let ((tl (setup-for-run)))
      (if tl 
	  (let* ((servers (open-run-close tasks:get-all-servers tasks:open-db))
		 (fmtstr  "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n")
︙
386
387
388
389
390
391
392
393

394
395
396
397
398
399
400
401
402
403
404
405
406

381
382
383
384
385
386
387

388






389
390
391
392
393
394
395








-
+
-
-
-
-
-
-








		     (begin
		       (debug:print-info 0 "Attempting to stop server with pid " pid)
		       (tasks:kill-server status hostname pullport pid transport)))))
	     servers)
	    (debug:print-info 1 "Done with listservers")
	    (set! *didsomething* #t)
	    (exit)) ;; must do, would have to add checks to many/all calls below
	  (exit)))
	  (exit))))
    ;; 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")
	;; ok, so lets connect to the server
	(client:launch)))

;;======================================================================
;; Weird special calls that need to run *after* the server has started?
;;======================================================================

(if (args:get-arg "-list-targets")
    (let ((targets (common:get-runconfig-targets)))
︙
451
452
453
454
455
456
457

458
459
460
461
462






463
464
465
466
467
468
469

440
441
442
443
444
445
446
447





448
449
450
451
452
453
454
455
456
457
458
459
460








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








       ((string=? (args:get-arg "-dumpmode") "json")
	(json-write data))
       (else
	(debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
      (set! *didsomething* #t)))

(if (args:get-arg "-show-cmdinfo")
    (if (getenv "MT_CMDINFO")
    (let ((data (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))))
      (if (equal? (args:get-arg "-dumpmode") "json")
	  (json-write data)
	  (pp data))
      (set! *didsomething* #t)))
	(let ((data (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))))
	  (if (equal? (args:get-arg "-dumpmode") "json")
	      (json-write data)
	      (pp data))
	  (set! *didsomething* #t))
	(debug:print-info 0 "environment variable MT_CMDINFO is not set")))

;;======================================================================
;; Remove old run(s)
;;======================================================================

;; since several actions can be specified on the command line the removal
;; is done first
︙

Modified server.scm from [1157749304] to [8151d68998].

︙
49
50
51
52
53
54
55
56

57
58
59
60
61
62
63

49
50
51
52
53
54
55

56
57
58
59
60
61
62
63








-
+








      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: cannot find megatest.config, exiting")
	    (exit))))
  (debug:print-info 2 "Starting server using " transport " transport")
  (set! *transport-type* transport)
  (case transport
    ((fs)   (exit)) ;; there is no "fs" transport
    ((fs)   (exit)) ;; there is no "fs" server transport
    ((http) (http-transport:launch))
    ((zmq)  (zmq-transport:launch))
    (else
     (debug:print "WARNING: unrecognised transport " transport)
     (exit))))

;;======================================================================
︙
115
116
117
118
119
120
121






























115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

     (let ((pub-socket (vector-ref *runremote* 1)))
       (send-message pub-socket return-addr send-more: #t)
       (send-message pub-socket (db:obj->string (vector success/fail query-sig result)))))
    (else 
     (debug:print 0 "ERROR: unrecognised transport type: " *transport-type*)
     result)))

(define (server:ensure-running)
  (let loop ((servers  (open-run-close tasks:get-best-server tasks:open-db))
	     (trycount 0))
    (if (or (not servers)
	    (null? servers))
	(begin
	  (if (even? trycount) ;; just do the server start every other time through this loop (every 8 seconds)
	      (begin
		(debug:print 0 "INFO: Starting server as none running ...")
		;; (server:launch (string->symbol (args:get-arg "-transport" "http"))))
		;; no need to use fork, no need to do the list-servers trick. Just start the damn server, it will exit on it's own
		;; if there is an existing server
		(system "megatest -server - -daemonize")
		(thread-sleep! 3)
		;; (process-run (car (argv)) (list "-server" "-" "-daemonize" "-transport" (args:get-arg "-transport" "http")))
		;; (system (conc "megatest -list-servers | egrep '" megatest-version ".*alive' || megatest -server - -daemonize && sleep 3"))
		;; (process-fork (lambda ()
		;;       	  (daemon:ize)
		;;       	  (server:launch (string->symbol (args:get-arg "-transport" "http")))))
		)
	      (begin
		(debug:print-info 0 "Waiting for server to start")
		(thread-sleep! 4)))
	  (if (< trycount 10)
	      (loop (open-run-close tasks:get-best-server tasks:open-db) 
		    (+ trycount 1))
	      (debug:print 0 "WARNING: Couldn't start or find a server.")))
	(debug:print 0 "INFO: Server(s) running " servers)
	)))

Added tests/fullrun/tests/ez_fail_quick/testconfig version [76759892d8]. 
















1
2
3
4
5
6
7
8
9
10
11
12
13
14

+
+
+
+
+
+
+
+
+
+
+
+
+
+

[requirements]
priority 10

[ezsteps]
# should fail on next step
lookitnada  ls /nada

[test_meta]
author matt
owner  bob
description This test runs a single ezstep which fails immediately.

tags first,single
reviewed 09/10/2011, by Matt








Modified tests/installall/megatest.config
from [9e822318aa]
to [a67193d07e].



1
2
3
4
5
6
7
8
9

10
11
12
13
14
15
16

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










+








[fields]
CHICKEN_VERSION TEXT
MEGATEST_VERSION TEXT
IUPMODE TEXT
BUILD_TAG TEXT

[setup]
max_concurrent_jobs 6
linktree #{getenv MT_RUN_AREA_HOME}/links
testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log

[jobtools]
useshell yes
launcher nbfind

[env-override]
EXAMPLE_VAR example value




︙







Modified tests/installall/runconfigs.config
from [afb2b7611e]
to [7b227fbb06].




︙


20
21
22
23
24
25
26

27
28
29
30
31
32
33

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








+








[include configs/hicken-#{getenv CHICKEN_VERSION}.config]

# Currently must have at least one variable in a section
[4.8.0/trunk/bin/std]
IUP_VERSION na

[4.8.0.4/trunk/src/std]
CHICKEN_URL http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.4.tar.gz
IUP_VERSION na

[4.8.1/trunk/src/std]
IUP_VERSION na

[4.8.0/v1.5508/opt]
IUP_VERSION na




︙







Modified tests/installall/tests/chicken/download.sh
from [852d0f9c90]
to [ba9f4a1774].



1
2
3
4
5
6
7

8
9

10
11
12


13
14
15
16
17
18
19

1
2
3
4
5
6

7
8

9


10
11
12
13
14
15
16
17
18
19







-
+

-
+
-
-

+
+








#!/usr/bin/env bash

# Run your step here

source $PREFIX/buildsetup.sh

if ! [[ -e ${DOWNLOADS}/chicken-${CHICKEN_VERSION}.tar.gz ]]; then 
if [ ! -e ${DOWNLOADS}/chicken-${CHICKEN_VERSION}.tar.gz ]; then 
  if [ "${CHICKEN_URL}" == "" ]; then
     (cd ${DOWNLOADS};wget http://code.call-cc.org/releases/${CHICKEN_VERSION}/chicken-${CHICKEN_VERSION}.tar.gz)
     CHICKEN_URL=http://code.call-cc.org/releases/${CHICKEN_VERSION}/chicken-${CHICKEN_VERSION}.tar.gz
  else
     (cd ${DOWNLOADS};wget ${CHICKEN_URL})
  fi
  echo "Downloading $CHICKEN_URL"
  (cd ${DOWNLOADS};wget ${CHICKEN_URL})
fi 

ls -l ${DOWNLOADS}/chicken-${CHICKEN_VERSION}.tar.gz

tar xfvz ${DOWNLOADS}/chicken-${CHICKEN_VERSION}.tar.gz

ls -l chicken-${CHICKEN_VERSION}













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