Megatest

Diff
Login

Differences From Artifact [99fb9b6d7d]:

To Artifact [786a96adc0]:


93
94
95
96
97
98
99


100
101
102
103
104
105
106
  -rebuild-db             : bring the database schema up to date
  -update-meta            : update the tests metadata for all tests
  -env2file fname         : write the environment to fname.csh and fname.sh
  -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
                                 overwritten by values set in config files.
  -server -|hostname      : start the server (reduces contention on megatest.db), use
                            - to automatically figure out hostname


  -repl                   : start a repl (useful for extending megatest)

Spreadsheet generation
  -extract-ods fname.ods  : extract an open document spreadsheet from the database
  -pathmod path           : insert path, i.e. path/runame/itempath/logfile.html
                            will clear the field if no rundir/testname/itempath/logfile
                            if it contains forward slashes the path will be converted







>
>







93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
  -rebuild-db             : bring the database schema up to date
  -update-meta            : update the tests metadata for all tests
  -env2file fname         : write the environment to fname.csh and fname.sh
  -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
                                 overwritten by values set in config files.
  -server -|hostname      : start the server (reduces contention on megatest.db), use
                            - to automatically figure out hostname
  -listservers            : list the servers 
  -killserver host:port|pid : kill server specified by host:port or pid
  -repl                   : start a repl (useful for extending megatest)

Spreadsheet generation
  -extract-ods fname.ods  : extract an open document spreadsheet from the database
  -pathmod path           : insert path, i.e. path/runame/itempath/logfile.html
                            will clear the field if no rundir/testname/itempath/logfile
                            if it contains forward slashes the path will be converted
151
152
153
154
155
156
157

158
159
160
161
162
163
164
			":variable"
			":value"
			":expected"
			":tol"
			":units"
			;; misc
			"-server"

			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-setvars"
			"-set-state-status"
			"-debug" ;; for *verbosity* > 2
			"-gen-megatest-test"







>







153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
			":variable"
			":value"
			":expected"
			":tol"
			":units"
			;; misc
			"-server"
			"-killserver"
			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-setvars"
			"-set-state-status"
			"-debug" ;; for *verbosity* > 2
			"-gen-megatest-test"
176
177
178
179
180
181
182

183
184
185
186
187
188
189
			"-summarize-items"
		        "-gui"
			;; misc
			"-archive"
			"-repl"
			"-lock"
			"-unlock"

			;; queries
			"-test-paths" ;; get path(s) to a test, ordered by youngest first

			"-runall"    ;; run all tests
			"-remove-runs"
			"-usequeue"
			"-rebuild-db"







>







179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
			"-summarize-items"
		        "-gui"
			;; misc
			"-archive"
			"-repl"
			"-lock"
			"-unlock"
			"-listservers"
			;; queries
			"-test-paths" ;; get path(s) to a test, ordered by youngest first

			"-runall"    ;; run all tests
			"-remove-runs"
			"-usequeue"
			"-rebuild-db"
255
256
257
258
259
260
261

262


263


































































264
265
266
267
268
269
270
271
272
      (save-environment-as-files (args:get-arg "-env2file"))
      (set! *didsomething* #t)))

;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;   we start the server if not running else start the client thread
;;======================================================================

(if (args:get-arg "-server")


    (server:launch)


































































    (server:client-launch))

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

;; since several actions can be specified on the command line the removal
;; is done first
(define (operate-on action)







>

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







259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
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
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
      (save-environment-as-files (args:get-arg "-env2file"))
      (set! *didsomething* #t)))

;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;   we start the server if not running else start the client thread
;;======================================================================

(if (args:get-arg "-server")
    (begin
      (debug:print 1 "Launching server...")
      (server:launch)))

(if (or (args:get-arg "-listservers")
	(args:get-arg "-killserver"))
    (let ((tl (setup-for-run)))
      (if tl 
	  (let ((servers (open-run-close tasks:get-all-servers tasks:open-db))
		(fmtstr  "~5a~8a~20a~5a~20a~9a~20a~5a\n")
		(servers-to-kill '()))
	    (format #t fmtstr "Id" "Pid" "Host" "Port" "Time" "Priority" "State" "Num Clients")
	    (format #t fmtstr "==" "===" "====" "====" "====" "========" "=====" "===========")
	    (for-each 
	     (lambda (server)
	       (let* ((killinfo   (args:get-arg "-killserver"))
		      (khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f))
		      (kpid       (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f))
		      (id         (vector-ref server 0))
		      (pid        (vector-ref server 1))
		      (hostname   (vector-ref server 2))
		      (port       (vector-ref server 3))
		      (start-time (vector-ref server 4))
		      (priority   (vector-ref server 5))
		      (state      (vector-ref server 6))
		      (numclients #f)
		      (stat-numc  ;; (handle-exceptions
				  ;;  exn
				  ;;  (list #f (conc "EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)))
				   (let ((zmq-socket (server:client-connect hostname port)))
				     (if zmq-socket
					 (if (server:client-login zmq-socket)
					     (let ((numclients (cdb:num-clients zmq-socket))
						   (killed     #f))
					       (if (and khost-port ;; kill by host/port
							(equal? hostname (car khost-port))
							(equal? port (string->number (cadr khost-port))))
						   (begin
						     (open-run-close tasks:server-deregister tasks:open-db  hostname port: port)
						     (cdb:kill-server zmq-socket)
						     (debug:print-info 1 "Killed server by host:port at " hostname ":" port)
						     (set! killed #t))
						   (if (and kpid
							    (equal? kpid pid))
						       (begin
							 (open-run-close tasks:server-deregister tasks:open-db hostname pid: pid)
							 (set! killed #t)
							 (cdb:kill-server zmq-socket)
							 (debug:print-info 1 "Killed server by pid at " hostname ":" port))))
					       (if (not killed)(server:client-logout zmq-socket))
					       (close-socket  zmq-socket)
					       (list numclients "ACCESSIBLE")) ;; (server:client-logout zmq-socket)
					     (begin
					       (close-socket zmq-socket)
					       (list #f "CAN'T LOGIN")))
					 (list #f "CAN'T CONNECT"))))) ;; )
		 (format #t fmtstr id pid hostname port start-time priority 
			 (cadr stat-numc)(car stat-numc))))
	     servers)
	    (set! *didsomething* #t))))
    ;; if not list or kill then start a client (if appropriate)
    (if (or (let ((res #f))
	      (for-each
	       (lambda (key)
		 (if (args:get-arg key)(set! res #t)))
	       (list "-h" "-version" "-gen-megatest-area" "-gen-megatest-test"))
	      res)
	    (eq? (length (hash-table-keys args:arg-hash)) 0))
	(debug:print-info 1 "Server connection not needed")
	(server:client-launch)))
    
;;======================================================================
;; Remove old run(s)
;;======================================================================

;; since several actions can be specified on the command line the removal
;; is done first
(define (operate-on action)
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
	  (server:client-setup)

	  (if (args:get-arg "-load-test-data")
	      ;; has sub commands that are rdb:
	      (open-run-close db:load-test-data db test-id))
	  (if (args:get-arg "-setlog")
	      (let ((logfname (args:get-arg "-setlog")))
		(open-run-close db:test-set-log! db test-id logfname)))
	  (if (args:get-arg "-set-toplog")
	      (open-run-close tests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog")))
	  (if (args:get-arg "-summarize-items")
	      (open-run-close tests:summarize-items db run-id test-name #t)) ;; do force here
	  (if (args:get-arg "-runstep")
	      (if (null? remargs)
		  (begin







|







744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
	  (server:client-setup)

	  (if (args:get-arg "-load-test-data")
	      ;; has sub commands that are rdb:
	      (open-run-close db:load-test-data db test-id))
	  (if (args:get-arg "-setlog")
	      (let ((logfname (args:get-arg "-setlog")))
		(cdb:test-set-log! *runremote* test-id logfname)))
	  (if (args:get-arg "-set-toplog")
	      (open-run-close tests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog")))
	  (if (args:get-arg "-summarize-items")
	      (open-run-close tests:summarize-items db run-id test-name #t)) ;; do force here
	  (if (args:get-arg "-runstep")
	      (if (null? remargs)
		  (begin
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
			       (oldexitstat exitstat)
			       (cmd         (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
			  (debug:print-info 2 "running \"" cmd "\"")
			  (change-directory startingdir)
			  (set! exitstat (system cmd))
			  (set! *globalexitstatus* exitstat) ;; no necessary
			  (change-directory testpath)
			  (open-run-close db:test-set-log! db test-id htmllogfile)))
		    (let ((msg (args:get-arg "-m")))
		      (open-run-close db:teststep-set-status! db test-id stepname "end" exitstat msg logfile))
		    )))
	  (if (or (args:get-arg "-test-status")
		  (args:get-arg "-set-values"))
	      (let ((newstatus (cond
				((number? status)       (if (equal? status 0) "PASS" "FAIL"))







|







787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
			       (oldexitstat exitstat)
			       (cmd         (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
			  (debug:print-info 2 "running \"" cmd "\"")
			  (change-directory startingdir)
			  (set! exitstat (system cmd))
			  (set! *globalexitstatus* exitstat) ;; no necessary
			  (change-directory testpath)
			  (cdb:test-set-log! *runremote* test-id htmllogfile)))
		    (let ((msg (args:get-arg "-m")))
		      (open-run-close db:teststep-set-status! db test-id stepname "end" exitstat msg logfile))
		    )))
	  (if (or (args:get-arg "-test-status")
		  (args:get-arg "-set-values"))
	      (let ((newstatus (cond
				((number? status)       (if (equal? status 0) "PASS" "FAIL"))