Megatest

Check-in [860e483c35]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Added localmode support
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.6584-nanomsg
Files: files | file ages | folders
SHA1: 860e483c357d670790bdf9161237ffc52e843319
User & Date: matt on 2021-08-06 04:14:07
Other Links: branch diff | manifest | tags
Context
2021-08-13
16:59
Basics almost working check-in: f625c38ded user: matt tags: v1.6584-nanomsg
2021-08-06
04:14
Added localmode support check-in: 860e483c35 user: matt tags: v1.6584-nanomsg
2021-06-23
08:58
Turn off inmem and fix run-id which should have been dbfile check-in: 89e269ed33 user: matt tags: v1.6584-nanomsg
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified configfmod.scm from [6693a9270b] to [514a742c76].

︙
33
34
35
36
37
38
39

40
41
42
43
44
45
46

33
34
35
36
37
38
39
40
41
42
43
44
45
46
47








+








	chicken.file
	chicken.io
	chicken.pathname
	chicken.port
	chicken.pretty-print
	chicken.process
	chicken.process-context
	chicken.process-context.posix
	chicken.sort
	chicken.string
	chicken.time
	chicken.eval
	
	debugprint
	(prefix mtargs args:)
︙
967
968
969
970
971
972
973


974
975
976
977
978
979
980

968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983








+
+








		     (cmd     (list-ref matchdat 3))
		     (poststr (list-ref matchdat 4))
		     (result  #f)
		     (start-time (current-seconds))
		     (cmdsym  (string->symbol cmdtype))
		     (fullcmd
		      (conc  configf:std-imports
			     "(import chicken.process-context.posix)"
			     "(define setenv set-environment-variable)"
			     (case cmdsym
			       ((scheme scm) (conc "(lambda (ht)" cmd ")"))
			       ((system)     (conc "(lambda (ht)(configf:system ht \"" cmd "\"))"))
			       ((shell sh)   (conc "(lambda (ht)(string-translate (shell \""  cmd "\") \"\n\" \" \"))"))
			       ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))"))
			       ((getenv gv)  (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))"))
			       ((mtrah)      (conc "(lambda (ht)"
︙

Modified dbmod.scm from [b670c82b28] to [b74957e222].

︙
228
229
230
231
232
233
234















235
236
237
238
239
240
241

228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256








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








;;
(define (db:open-inmem-db dbinit-proc)
  (let* ((db      (sqlite3:open-database ":memory:"))
	 (handler (sqlite3:make-busy-timeout 3600)))
    (sqlite3:set-busy-handler! db handler)
    (dbinit-proc db) ;; NOTE: inmem must always be initialized (db:initialize-db db)
    db))

;; for debugging we have a local mode. these routines support that mode
(define *dbcache* (make-hash-table))

(define (db:cache-get-dbstruct rid apath)
  (let* ((dbname (db:run-id->dbname rid))
	 (dbfile (db:dbname->path apath dbname)))
    (or (hash-table-ref/default *dbcache* dbfile #f)
	(let* ((dbstruct (db:setup dbfile))) ;; (db:open-dbdat apath dbfile db:initialize-db)))
	  (hash-table-set! *dbcache* dbfile dbstruct)
	  dbstruct))))

(define (db:finalize-all-cache-dbstruct)
  #f)
	  

;; get and initalize dbstruct for a given run-id
;;
;;  - uses db:initialize-db to create the schema
;;
;; Make the dbstruct, call for main db at least once
;; sync disk db to inmem
︙

Modified megatest.scm from [8b7ce4750f] to [b3f54e302d].

︙
180
181
182
183
184
185
186
187
188
189
190
191
192
193







194
195
196

197
198
199
200
201
202
203

180
181
182
183
184
185
186







187
188
189
190
191
192
193
194
195

196
197
198
199
200
201
202
203








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


-
+








(include "env.scm")
(include "diff-report.scm")
(include "ods.scm")

(define *usage-log-file* #f)    ;; put path to file for logging usage in this var in the ~/.megatestrc file
(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file

     ;;======================================================================
     ;; Test commands (i.e. for use inside tests)
     ;;======================================================================
     
     (define (megatest:step step state status logfile msg)
       (if (not (getenv "MT_CMDINFO"))
           (begin
;;======================================================================
;; Test commands (i.e. for use inside tests)
;;======================================================================

(define (megatest:step step state status logfile msg)
  (if (not (getenv "MT_CMDINFO"))
      (begin
     	(debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
     	(exit 5))
           (let* ((cmdinfo   (common:read-encoded-string (getenv "MT_CMDINFO")))
      (let* ((cmdinfo   (common:read-encoded-string (getenv "MT_CMDINFO")))
     	     (transport (assoc/default 'transport cmdinfo))
     	     (testpath  (assoc/default 'testpath  cmdinfo))
     	     (test-name (assoc/default 'test-name cmdinfo))
     	     (runscript (assoc/default 'runscript cmdinfo))
     	     (db-host   (assoc/default 'db-host   cmdinfo))
     	     (run-id    (assoc/default 'run-id    cmdinfo))
     	     (test-id   (assoc/default 'test-id   cmdinfo))
︙
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227








228
229
230
231
232
233
234

213
214
215
216
217
218
219








220
221
222
223
224
225
226
227
228
229
230
231
232
233
234








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








     	    (let ((comment (launch:load-logpro-dat run-id test-id step)))
     	      ;; (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
     	      (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile))
     	    (begin
     	      (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step")
     	      (exit 6))))))

     ;;======================================================================
     ;; full run
     ;;======================================================================
     
     (define (handle-run-requests target runname keys keyvals need-clean)	 
       (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
           ;; For rerun-clean do we or do we not support the testpatt?
           (let ((states   (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
;;======================================================================
;; full run
;;======================================================================

(define (handle-run-requests target runname keys keyvals need-clean)	 
  (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
      ;; For rerun-clean do we or do we not support the testpatt?
      (let ((states   (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
     			  "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
     	    (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
     			  "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
     	(hash-table-set! args:arg-hash "-preclean" #t)
     	(runs:operate-on 'set-state-status
     			 target
     			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
︙
242
243
244
245
246
247
248
249
250
251



252
253
254
255
256
257
258
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

242
243
244
245
246
247
248



249
250
251
252
253
254
255
256
257
258
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








-
-
-
+
+
+
















-
+




-
-
+
+








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


-
-
-
-
-
+
+
+
+
+






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








     			 target
     			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
     			 ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
     			 (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
     			 ;; state:  states
     			 status: statuses
     			 new-state-status: "NOT_STARTED,n/a")))
       ;; RERUN ALL
       (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
           (let* ((rconfig (full-runconfigs-read)))
  ;; RERUN ALL
  (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
      (let* ((rconfig (full-runconfigs-read)))
     	(hash-table-set! args:arg-hash "-preclean" #t)
     	(runs:operate-on 'set-state-status
     			 target
     			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
     			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
     			 state:  #f
     			 ;; status: statuses
     			 new-state-status: "NOT_STARTED,n/a")
     	(runs:clean-cache target runname *toppath*)
     	(runs:operate-on 'set-state-status
     			 target
     			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
     			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
     			 ;; state:  states
     			 status: #f
     			 new-state-status: "NOT_STARTED,n/a")))
       (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
  (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
     			       (if x (string->number x) #f)))
     	 (rerun-cnt (if config-reruns
     			config-reruns
     			1)))
     
         (runs:run-tests target
    
    (runs:run-tests target
     		    runname
     		    #f ;; (common:args-get-testpatt #f)
     		    ;; (or (args:get-arg "-testpatt")
     		    ;;     "%")
     		    (bdat-user *bdat*)
     		    args:arg-hash
     		    run-count: rerun-cnt)))

     ;; csv processing record
     (define (make-refdb:csv)
       (vector 
        (make-sparse-array)
        (make-hash-table)
        (make-hash-table)
        0
        0))
     (define-inline (refdb:csv-get-svec     vec)    (vector-ref  vec 0))
     (define-inline (refdb:csv-get-rows     vec)    (vector-ref  vec 1))
     (define-inline (refdb:csv-get-cols     vec)    (vector-ref  vec 2))
     (define-inline (refdb:csv-get-maxrow   vec)    (vector-ref  vec 3))
     (define-inline (refdb:csv-get-maxcol   vec)    (vector-ref  vec 4))
     (define-inline (refdb:csv-set-svec!    vec val)(vector-set! vec 0 val))
     (define-inline (refdb:csv-set-rows!    vec val)(vector-set! vec 1 val))
     (define-inline (refdb:csv-set-cols!    vec val)(vector-set! vec 2 val))
     (define-inline (refdb:csv-set-maxrow!  vec val)(vector-set! vec 3 val))
     (define-inline (refdb:csv-set-maxcol!  vec val)(vector-set! vec 4 val))
     
     (define (get-dat results sheetname)
       (or (hash-table-ref/default results sheetname #f)
           (let ((tmp-vec  (make-refdb:csv)))
;; csv processing record
(define (make-refdb:csv)
  (vector 
   (make-sparse-array)
   (make-hash-table)
   (make-hash-table)
   0
   0))
(define-inline (refdb:csv-get-svec     vec)    (vector-ref  vec 0))
(define-inline (refdb:csv-get-rows     vec)    (vector-ref  vec 1))
(define-inline (refdb:csv-get-cols     vec)    (vector-ref  vec 2))
(define-inline (refdb:csv-get-maxrow   vec)    (vector-ref  vec 3))
(define-inline (refdb:csv-get-maxcol   vec)    (vector-ref  vec 4))
(define-inline (refdb:csv-set-svec!    vec val)(vector-set! vec 0 val))
(define-inline (refdb:csv-set-rows!    vec val)(vector-set! vec 1 val))
(define-inline (refdb:csv-set-cols!    vec val)(vector-set! vec 2 val))
(define-inline (refdb:csv-set-maxrow!  vec val)(vector-set! vec 3 val))
(define-inline (refdb:csv-set-maxcol!  vec val)(vector-set! vec 4 val))

(define (get-dat results sheetname)
  (or (hash-table-ref/default results sheetname #f)
      (let ((tmp-vec  (make-refdb:csv)))
     	(hash-table-set! results sheetname tmp-vec)
     	tmp-vec)))
     
     ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
     (define (open-logfile logpath-in)
       (condition-case
        (let* ((log-dir (or (pathname-directory logpath-in) "."))

;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
(define (open-logfile logpath-in)
  (condition-case
   (let* ((log-dir (or (pathname-directory logpath-in) "."))
     	  (fname   (pathname-strip-directory logpath-in))
     	  (logpath (if (> (string-length fname) 250)
     		       (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log")))
     			 (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
     			 newlogf)
     		       logpath-in)))
          (if (not (directory-exists? log-dir))
              (system (conc "mkdir -p " log-dir)))
          (open-output-file logpath))
        (exn ()
             (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
             (define *didsomething* #t)  
             (exit 1))))
     (if (not (directory-exists? log-dir))
	 (system (conc "mkdir -p " log-dir)))
     (open-output-file logpath))
   (exn ()
	(debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
	(define *didsomething* #t)  
	(exit 1))))

(define (debug:setup)
  (let ((debugstr (or (args:get-arg "-debug")
      		      (args:get-arg "-debug-noprop")
      		      (getenv "MT_DEBUG_MODE"))))
    (set! *verbosity* (debug:calc-verbosity debugstr 'q))
    (debug:check-verbosity *verbosity* debugstr)
︙
347
348
349
350
351
352
353
354

355
356
357
358
359
360
361

347
348
349
350
351
352
353

354
355
356
357
358
359
360
361








-
+








     	#f)
      #t))

;; Disabled help items
;;  -rollup                 : (currently disabled) fill run (set by :runname)  with latest test(s)
;;                            from prior runs with same keys
;;  -daemonize              : fork into background and disconnect from stdin/out
     

(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2017
 
Usage: megatest [options]
  -h                      : this help
︙

Modified rmtmod.scm from [3a27177e7d] to [c58d29f4fc].

︙
295
296
297
298
299
300
301


302
303
304
305
306
307
308
309
310
311










312
313
314
315
316
317
318

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








+
+





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








		 res))))))
     

     )))

;;======================================================================

;; FOR DEBUGGING SET TO #t
(define *localmode* #t)

;; Defaults to current area
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f))
  (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote)))
  (let* ((apath *toppath*)
	 (conns *rmt:remote*)
	 (dbname (db:run-id->dbname rid)))
    (rmt:general-open-connection conns apath dbname)
    (rmt:send-receive-real conns apath dbname cmd params)))
  (let* ((apath      *toppath*)
	 (conns      *rmt:remote*)
	 (dbname     (db:run-id->dbname rid)))
    (if *localmode*
	(let* ((dbstruct (db:cache-get-dbstruct rid apath))
	       (indat    `((cmd . ,cmd)(params . ,params))))
	  (api:process-request dbstruct indat))
	(begin
	  (rmt:general-open-connection conns apath dbname)
	  (rmt:send-receive-real conns apath dbname cmd params)))))

#;(define (rmt:send-receive-setup conn)
  (if (not (rmt:conn-inport conn))
      (let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn)
				       (rmt:conn-port conn))))
	(rmt:conn-inport-set! conn i)
	(rmt:conn-outport-set! conn o))))
︙
1600
1601
1602
1603
1604
1605
1606
1607

1608
1609
1610
1611
1612
1613
1614

1607
1608
1609
1610
1611
1612
1613

1614
1615
1616
1617
1618
1619
1620
1621








-
+








	 (ipaddrstr       (let ((ipstr (if (string=? "-" hostn)
					   ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
					   (server:get-best-guess-address hostname)
					   #f)))
			    (if ipstr ipstr hostn))) ;; hostname))) 
	 (port            (portlogger:open-run-close portlogger:find-port))
	 (link-tree-path  (common:get-linktree))
	 (tmp-area        (common:get-db-tmp-area))
	 ;; (tmp-area        (common:get-db-tmp-area))
	 #;(start-file      (conc tmp-area "/.server-start")))
    (debug:print-info 0 *default-log-port* "portlogger recommended port: " port)
    (if *server-info*
	(begin
	  (servdat-host-set! *server-info* ipaddrstr)
	  (servdat-port-set! *server-info* port)
	  (servdat-status-set! *server-info* 'trying-port)
︙

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