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 Unified 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

		(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)))

		(rtests:test-set-status! db run-id test-name state newstatus itemdat (args:get-arg "-m") otherdata)))
	  (sqlite3:finalize! db)
	  (set! *didsomething* #t))))

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








>
|








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 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

     '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)
       (set! *last-db-access* (current-seconds))
       (test-set-status! db run-id test-name state status itemdat-or-path comment dat)))

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

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








|

|








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 (test-id state status comment dat)
       (set! *last-db-access* (current-seconds))
       (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

		 (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 '() '())))
		  (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))))))))))
    








|








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 (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

			   (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)
  (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)))




	 ;; 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))








|

<
<
<

>
>
>
>








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 test-id state status comment dat)
  (let* ((real-status status)



	 (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

(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)
  (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)))








|



|
|

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 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) test-id state status comment dat))
      (test-set-status! db test-id state status comment dat)))

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