Megatest

Check-in [40b4f08239]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Minor tweaks that may help server mode
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | servermode
Files: files | file ages | folders
SHA1: 40b4f0823953871db3e69514c892205641978ba5
User & Date: matt on 2012-03-11 20:59:29
Other Links: branch diff | manifest | tags
Context
2012-03-11
22:00
tweak check-in: 044818b98f user: matt tags: servermode
20:59
Minor tweaks that may help server mode check-in: 40b4f08239 user: matt tags: servermode
20:01
Tweaks for server mode check-in: e51571f4ff user: matt tags: servermode
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified megatest.scm from [2d88d422bf] to [99a2f28f17].

︙
704
705
706
707
708
709
710

711

712
713
714
715
716
717
718

704
705
706
707
708
709
710
711

712
713
714
715
716
717
718
719








+
-
+








		(if (and (args:get-arg "-test-status")
			 (or (not state)
			     (not status)))
		    (begin
		      (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help)
		      (sqlite3:finalize! db)
		      (exit 6)))
		(let ((msg (args:get-arg "-m")))
		(rtests:test-set-status! db run-id test-name state newstatus itemdat (args:get-arg "-m") otherdata)))
		  (rtests:test-set-status! db test-id state newstatus msg otherdata))))
	  (sqlite3:finalize! db)
	  (set! *didsomething* #t))))

(if (args:get-arg "-showkeys")
    (let ((db #f)
	  (keys #f))
      (if (not (setup-for-run))
︙

Modified server.scm from [d8ddcb6ae7] to [adec0ec192].

︙
231
232
233
234
235
236
237
238

239
240

241
242
243
244
245
246
247

231
232
233
234
235
236
237

238
239

240
241
242
243
244
245
246
247








-
+

-
+








     'rdb:test-data-rollup
     (lambda (test-id status)
       (set! *last-db-access* (current-seconds))
       (db:test-data-rollup db test-id status)))
    
    (rpc:publish-procedure!
     'rtests:test-set-status!
     (lambda (run-id test-name state status itemdat-or-path comment dat)
     (lambda (test-id state status comment dat)
       (set! *last-db-access* (current-seconds))
       (test-set-status! db run-id test-name state status itemdat-or-path comment dat)))
       (test-set-status! db test-id state status comment dat)))

    ;;======================================================================
    ;; end of publish-procedure section
    ;;======================================================================

    (set! *rpc:listener* rpc:listener)
    (on-exit (lambda ()
︙

Modified tests.scm from [682b0daae9] to [0902ef46a0].

︙
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








-
+








		 (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
	  ;; for each run starting with the most recent look to see if there is a matching test
	  ;; if found then return that matching test record
	  (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
	  (if (null? prev-run-ids) #f
	      (let loop ((hed (car prev-run-ids))
			 (tal (cdr prev-run-ids)))
		(let ((results (rdb:get-tests-for-run db hed test-name item-path '() '())))
		(let ((results (db:get-tests-for-run db hed test-name item-path '() '())))
		  (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
		  (if (and (null? results)
			   (not (null? tal)))
		      (loop (car tal)(cdr tal))
		      (if (null? results) #f
			  (car results))))))))))
︙
106
107
108
109
110
111
112
113

114
115
116
117
118




119
120
121
122
123
124
125

106
107
108
109
110
111
112

113
114



115
116
117
118
119
120
121
122
123
124
125
126








-
+

-
-
-

+
+
+
+








			   (hash-table-set! tests-hash full-testname testdat))))
		   results)
		  (if (null? tal)
		      (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
		      (loop (car tal)(cdr tal))))))))))

;; 
(define (test-set-status! db run-id test-name state status itemdat-or-path comment dat)
(define (test-set-status! db test-id state status comment dat)
  (let* ((real-status status)
	 (item-path   (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path)))
	 (testdat     (rdb:get-test-info db run-id test-name item-path))
	 (test-id     (if testdat (db:test-get-id testdat) #f))
	 (otherdat    (if dat dat (make-hash-table)))
	 (testdat     (db:get-test-data-by-id db test-id))
	 (run-id      (db:test-get-run_id testdat))
	 (test-name   (db:test-get-testname   testdat))
	 (item-path   (db:test-get-item-path testdat))
	 ;; before proceeding we must find out if the previous test (where all keys matched except runname)
	 ;; was WAIVED if this test is FAIL
	 (waived   (if (equal? status "FAIL")
		       (let ((prev-test (test:get-previous-test-run-record db run-id test-name item-path)))
			 (if prev-test ;; true if we found a previous test in this run series
			     (let ((prev-status (db:test-get-status   prev-test))
				   (prev-state  (db:test-get-state    prev-test))
︙
384
385
386
387
388
389
390
391

392
393
394
395
396



385
386
387
388
389
390
391

392
393
394
395


396
397








-
+



-
-
+
+

(define (rtests:register-test db run-id test-name item-path)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rtests:register-test host port) run-id test-name item-path))
      (tests:register-test db run-id test-name item-path)))

(define (rtests:test-set-status!  db run-id test-name state status itemdat-or-path comment dat)
(define (rtests:test-set-status!  db test-id state status comment dat)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rtests:test-set-status! host port) run-id test-name state status itemdat-or-path comment dat))
      (test-set-status! db run-id test-name state status itemdat-or-path comment dat)))
	((rpc:procedure 'rtests:test-set-status! host port) test-id state status comment dat))
      (test-set-status! db test-id state status comment dat)))

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