Megatest

Diff
Login

Differences From Artifact [9e5e8b387a]:

To Artifact [b5b98a6d56]:


917
918
919
920
921
922
923
924


925
926
927
928
929
930
931
932
         (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead"))
     
     (on-exit std-exit-procedure)
     
     ;;======================================================================
     ;; Misc general calls
     ;;======================================================================
     


     (if (and (args:get-arg "-cache-db")
              (args:get-arg "-source-db"))
         (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_")))))
                (target-db (conc temp-dir "/cached.db"))
                (source-db (args:get-arg "-source-db")))        
           (db:cache-for-read-only source-db target-db)
           (set! *didsomething* #t)))
     







|
>
>
|







917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
         (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead"))
     
     (on-exit std-exit-procedure)
     
     ;;======================================================================
     ;; Misc general calls
     ;;======================================================================

;; TODO: Restore this functionality

     #; (if (and (args:get-arg "-cache-db")
              (args:get-arg "-source-db"))
         (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_")))))
                (target-db (conc temp-dir "/cached.db"))
                (source-db (args:get-arg "-source-db")))        
           (db:cache-for-read-only source-db target-db)
           (set! *didsomething* #t)))
     
1304
1305
1306
1307
1308
1309
1310



1311

1312
1313
1314
1315
1316
1317
1318
           (if (not (car *configinfo*))
     	  (begin
     	    (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found")
     	    (exit 1))
     	  ;; put test parameters into convenient variables
     	  (begin
     	    ;; check for correct version, exit with message if not correct



     	    (common:exit-on-version-changed)

     	    (runs:operate-on  action
     			      target
     			      runname
     			      testpatt
     			      state:  (common:args-get-state)
     			      status: (common:args-get-status)
     			      new-state-status: (args:get-arg "-set-state-status")







>
>
>
|
>







1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
           (if (not (car *configinfo*))
     	  (begin
     	    (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found")
     	    (exit 1))
     	  ;; put test parameters into convenient variables
     	  (begin
     	    ;; check for correct version, exit with message if not correct

	    ;; TODO: restore this functionality
	    
	    ;; (common:exit-on-version-changed)
	    
     	    (runs:operate-on  action
     			      target
     			      runname
     			      testpatt
     			      state:  (common:args-get-state)
     			      status: (common:args-get-status)
     			      new-state-status: (args:get-arg "-set-state-status")
2145
2146
2147
2148
2149
2150
2151
2152


2153
2154
2155
2156
2157
2158
2159
2160
            "Archive"
            (lambda (target runname keys keyvals)
     	 (operate-on 'archive target-in: target runname-in: runname )))))
     
     ;;======================================================================
     ;; Extract a spreadsheet from the runs database
     ;;======================================================================
     


     (if (args:get-arg "-extract-ods")
         (general-run-call
          "-extract-ods"
          "Make ods spreadsheet"
          (lambda (target runname keys keyvals)
            (let ((dbstruct   (make-dbr:dbstruct path: *toppath* local: #t))
     	     (outputfile (args:get-arg "-extract-ods"))
     	     (runspatt   (or (args:get-arg "-runname")(args:get-arg ":runname")))







|
>
>
|







2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
            "Archive"
            (lambda (target runname keys keyvals)
     	 (operate-on 'archive target-in: target runname-in: runname )))))
     
     ;;======================================================================
     ;; Extract a spreadsheet from the runs database
     ;;======================================================================

;; TODO: Reenable this functionality

     #;(if (args:get-arg "-extract-ods")
         (general-run-call
          "-extract-ods"
          "Make ods spreadsheet"
          (lambda (target runname keys keyvals)
            (let ((dbstruct   (make-dbr:dbstruct path: *toppath* local: #t))
     	     (outputfile (args:get-arg "-extract-ods"))
     	     (runspatt   (or (args:get-arg "-runname")(args:get-arg ":runname")))
2366
2367
2368
2369
2370
2371
2372
2373


2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
         (let ((testname (args:get-arg "-create-test")))
           (genexample:mk-megatest-test testname)
           (set! *didsomething* #t)))
     
     ;;======================================================================
     ;; Update the database schema, clean up the db
     ;;======================================================================
     


     (if (args:get-arg "-rebuild-db")
         (begin
           (if (not (launch:setup))
     	  (begin
     	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
     	    (exit 1)))
           ;; keep this one local
           ;; (open-run-close patch-db #f)
           (let ((dbstruct (db:setup #f areapath: *toppath*)))
             (common:cleanup-db dbstruct full: #t))
           (set! *didsomething* #t)))
     
     (if (args:get-arg "-cleanup-db")
         (begin
           (if (not (launch:setup))
     	  (begin
     	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
     	    (exit 1)))
           (let ((dbstruct (db:setup #f areapath: *toppath*)))
             (common:cleanup-db dbstruct))







|
>
>
|











|







2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
         (let ((testname (args:get-arg "-create-test")))
           (genexample:mk-megatest-test testname)
           (set! *didsomething* #t)))
     
     ;;======================================================================
     ;; Update the database schema, clean up the db
     ;;======================================================================

;; TODO: Restore this functionality

      #;(if (args:get-arg "-rebuild-db")
         (begin
           (if (not (launch:setup))
     	  (begin
     	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
     	    (exit 1)))
           ;; keep this one local
           ;; (open-run-close patch-db #f)
           (let ((dbstruct (db:setup #f areapath: *toppath*)))
             (common:cleanup-db dbstruct full: #t))
           (set! *didsomething* #t)))
     
     #;(if (args:get-arg "-cleanup-db")
         (begin
           (if (not (launch:setup))
     	  (begin
     	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
     	    (exit 1)))
           (let ((dbstruct (db:setup #f areapath: *toppath*)))
             (common:cleanup-db dbstruct))
2549
2550
2551
2552
2553
2554
2555
2556


2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
     ;; ;; ;; redo me 		      (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item)))
     ;; ;; ;; redo me 		  (sqlite3:execute qry newval (car item))))
     ;; ;; ;; redo me 	      dat)
     ;; ;; ;; redo me 	     (sqlite3:finalize! qry))))
     ;; ;; ;; redo me        (db:close-all dbstruct)
     ;; ;; ;; redo me        (list "uname" "rundir" "final_logf" "comment"))
     ;; ;; ;; redo me       (set! *didsomething* #t)))
     


     (if (args:get-arg "-import-megatest.db")
         (begin
           (db:multi-db-sync 
            (db:setup #f)
            'killservers
            'dejunk
            'adj-testids
            'old2new
            ;; 'new2old
            )
           (set! *didsomething* #t)))
     
     (when (args:get-arg "-sync-brute-force")
       ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t))
       (set! *didsomething* #t))
     
     (if (args:get-arg "-sync-to-megatest.db")
         (let* ((dbstruct (db:setup #f))
     	   (tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct)))
     	   (lockfile (conc tmpdbpth ".lock"))
     	   (locked   (common:simple-file-lock lockfile)) 
     	   (res      (if locked
     			 (db:multi-db-sync 
     			  dbstruct







|
>
>
|















|







2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
     ;; ;; ;; redo me 		      (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item)))
     ;; ;; ;; redo me 		  (sqlite3:execute qry newval (car item))))
     ;; ;; ;; redo me 	      dat)
     ;; ;; ;; redo me 	     (sqlite3:finalize! qry))))
     ;; ;; ;; redo me        (db:close-all dbstruct)
     ;; ;; ;; redo me        (list "uname" "rundir" "final_logf" "comment"))
     ;; ;; ;; redo me       (set! *didsomething* #t)))

;; TODO: restore this functionality

     #;(if (args:get-arg "-import-megatest.db")
         (begin
           (db:multi-db-sync 
            (db:setup #f)
            'killservers
            'dejunk
            'adj-testids
            'old2new
            ;; 'new2old
            )
           (set! *didsomething* #t)))
     
     (when (args:get-arg "-sync-brute-force")
       ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t))
       (set! *didsomething* #t))
     
     #;(if (args:get-arg "-sync-to-megatest.db")
         (let* ((dbstruct (db:setup #f))
     	   (tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct)))
     	   (lockfile (conc tmpdbpth ".lock"))
     	   (locked   (common:simple-file-lock lockfile)) 
     	   (res      (if locked
     			 (db:multi-db-sync 
     			  dbstruct