Megatest

Diff
Login

Differences From Artifact [f7c0fef20e]:

To Artifact [11c996f69d]:


966
967
968
969
970
971
972
973
974

975
976
977
978
979
980
981
    (let* (;; (run-id     (args:get-arg "-run-id"))
	   (dbfname    (args:get-arg "-db"))
	   (tl         (launch:setup))
	   (keys       (keys:config-get-fields *configdat*)))
      (case (rmt:transport-mode)
	((tcp)
	 (let* ((timeout    (server:expiration-timeout)))
	   (debug:print 0 *default-log-port* "INFO: Running using tcp method with server timeout of "timeout)
	   (tt-server-timeout-param timeout)

	   (if dbfname
	       (tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys)
	       (begin
		 (debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -db is required.")
		 (exit 1)))))
	(else (debug:print 0 *default-log-port* "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode))))
      (set! *didsomething* #t)))







|

>







966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
    (let* (;; (run-id     (args:get-arg "-run-id"))
	   (dbfname    (args:get-arg "-db"))
	   (tl         (launch:setup))
	   (keys       (keys:config-get-fields *configdat*)))
      (case (rmt:transport-mode)
	((tcp)
	 (let* ((timeout    (server:expiration-timeout)))
	   (debug:print 0 *default-log-port* "INFO: Starting server for " dbfname " using tcp method with server timeout of "timeout)
	   (tt-server-timeout-param timeout)
	   (thread-start! (make-thread api:print-db-stats "print-db-stats"))
	   (if dbfname
	       (tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys)
	       (begin
		 (debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -db is required.")
		 (exit 1)))))
	(else (debug:print 0 *default-log-port* "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode))))
      (set! *didsomething* #t)))
1089
1090
1091
1092
1093
1094
1095




1096
1097
1098
1099
1100
1101
1102
                ) 
              )
              sfiles
            )
          )
       )
       dbfiles




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

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







>
>
>
>







1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
                ) 
              )
              sfiles
            )
          )
       )
       dbfiles
     )
     ;; remove this db, because otherwise metadata contains records for old servers, and this causes a problem with db:no-sync-get-lock-with-id.
     (if (file-exists? (conc *toppath* "/.mtdb/no-sync.db"))
       (delete-file (conc *toppath* "/.mtdb/no-sync.db"))
     )
     (set! *didsomething* #t)
     (exit)  
  )
)

;;======================================================================
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
             (begin 
             (debug:print-info 1 *default-log-port* "Missing required argument -source <archive path>")
             (exit 1)))
         (if (common:file-exists? (conc  *toppath* "/megatest.db"))
             (begin  
               (debug:print-info 1 *default-log-port* "File " (conc  *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db")
               (exit 1)))
         (if (and (common:get-db-tmp-area) (> (length (directory   (common:get-db-tmp-area) #f)) 0))
           (begin
           (debug:print-info 1 *default-log-port* (common:get-db-tmp-area) " not empty. Please remove it before trying to replicate db")
           (exit 1)))    
          ;; check if timestamp 
          (let* ((source (args:get-arg "-source"))
                (src     (if (not (equal? (substring source 0 1) "/"))
                             (conc (current-directory) "/" source)
                             source))
                (ts (if (args:get-arg "-time-stamp")   (args:get-arg "-time-stamp") "latest")))







|

|







2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
             (begin 
             (debug:print-info 1 *default-log-port* "Missing required argument -source <archive path>")
             (exit 1)))
         (if (common:file-exists? (conc  *toppath* "/megatest.db"))
             (begin  
               (debug:print-info 1 *default-log-port* "File " (conc  *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db")
               (exit 1)))
         (if (and (common:make-tmpdir-name *toppath* "") (> (length (directory   (common:make-tmpdir-name *toppath* "") #f)) 0))
           (begin
           (debug:print-info 1 *default-log-port* (common:make-tmpdir-name *toppath* "") " not empty. Please remove it before trying to replicate db")
           (exit 1)))    
          ;; check if timestamp 
          (let* ((source (args:get-arg "-source"))
                (src     (if (not (equal? (substring source 0 1) "/"))
                             (conc (current-directory) "/" source)
                             source))
                (ts (if (args:get-arg "-time-stamp")   (args:get-arg "-time-stamp") "latest")))
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
    (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 ((dbstructs (db:setup #f)))
        (common:cleanup-db dbstructs 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)))

;;      (if (not (server:choose-server *toppath* 'home?))
;;	  (begin
;;	    (debug:print 0 *default-log-port* "Servers are not running on this host or no servers alive. Cannot run cleanup-db")
;;	    (exit 1)))

      (let ((dbstructs (db:setup #f)))
        (common:cleanup-db dbstructs))
      (set! *didsomething* #t)))

(if (args:get-arg "-mark-incompletes")
    (begin
      (if (not (launch:setup))
	  (begin







|















|







2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
    (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 ((dbstructs (db:setup)))
        (common:cleanup-db dbstructs 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)))

;;      (if (not (server:choose-server *toppath* 'home?))
;;	  (begin
;;	    (debug:print 0 *default-log-port* "Servers are not running on this host or no servers alive. Cannot run cleanup-db")
;;	    (exit 1)))

      (let ((dbstructs (db:setup)))
        (common:cleanup-db dbstructs))
      (set! *didsomething* #t)))

(if (args:get-arg "-mark-incompletes")
    (begin
      (if (not (launch:setup))
	  (begin
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
	(args:get-arg "-repl")
	(args:get-arg "-load"))
    (let* ((toppath (launch:setup))
	   (dbstructs (if (and toppath
			       ;; NOTE: server:choose-server is starting a server
			       ;;   either add equivalent for tcp mode or ????
                               #;(server:choose-server toppath 'home?))
                          (db:setup #t)
                          #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
      (if *toppath*
	  (cond
	   ((getenv "MT_RUNSCRIPT")
	    ;; How to run megatest scripts
	    ;;
	    ;; #!/bin/bash







|







2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
	(args:get-arg "-repl")
	(args:get-arg "-load"))
    (let* ((toppath (launch:setup))
	   (dbstructs (if (and toppath
			       ;; NOTE: server:choose-server is starting a server
			       ;;   either add equivalent for tcp mode or ????
                               #;(server:choose-server toppath 'home?))
                          (db:setup)
                          #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
      (if *toppath*
	  (cond
	   ((getenv "MT_RUNSCRIPT")
	    ;; How to run megatest scripts
	    ;;
	    ;; #!/bin/bash
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
;; ;; ;; redo me        (list "uname" "rundir" "final_logf" "comment"))
;; ;; ;; redo me       (set! *didsomething* #t)))

(if (args:get-arg "-import-megatest.db")
    (begin
      (launch:setup)
      (db:multi-db-sync 
       (db:setup #f)
       'killservers
       'dejunk
       'adj-testids
       'old2new
       )
      (set! *didsomething* #t)))

(if (args:get-arg "-import-sexpr")
    (begin
      (launch:setup)
      (rmt:import-sexpr (args:get-arg "-import-sexpr"))
      (set! *didsomething* #t)))

(if (args:get-arg "-sync-to-megatest.db")
    (let* ((duh      (launch:setup))
	   (dbstruct (db:setup #t))
	   (tmpdbpth (dbr:dbstruct-tmppath dbstruct))
	   (lockfile (conc tmpdbpth ".lock"))
	   (locked   (common:simple-file-lock lockfile)) 
	   (res      (if locked
			 (db:multi-db-sync 
			  dbstruct
			  'new2old)







|















|







2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
;; ;; ;; redo me        (list "uname" "rundir" "final_logf" "comment"))
;; ;; ;; redo me       (set! *didsomething* #t)))

(if (args:get-arg "-import-megatest.db")
    (begin
      (launch:setup)
      (db:multi-db-sync 
       (db:setup)
       'killservers
       'dejunk
       'adj-testids
       'old2new
       )
      (set! *didsomething* #t)))

(if (args:get-arg "-import-sexpr")
    (begin
      (launch:setup)
      (rmt:import-sexpr (args:get-arg "-import-sexpr"))
      (set! *didsomething* #t)))

(if (args:get-arg "-sync-to-megatest.db")
    (let* ((duh      (launch:setup))
	   (dbstruct (db:setup))
	   (tmpdbpth (dbr:dbstruct-tmppath dbstruct))
	   (lockfile (conc tmpdbpth ".lock"))
	   (locked   (common:simple-file-lock lockfile)) 
	   (res      (if locked
			 (db:multi-db-sync 
			  dbstruct
			  'new2old)