Megatest

Check-in [1f0fec5a83]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Remove debugger stuff since feathers can now be used with Chicken 4.11. Replaced resolve-pathname with hack common:nice-path as resolve-pathname is broken in 4.11
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.61
Files: files | file ages | folders
SHA1: 1f0fec5a83cbba56b3c151e097dd10497be27951
User & Date: matt on 2016-05-14 17:39:14
Other Links: branch diff | manifest | tags
Context
2016-05-14
20:23
Added nice-path as alias for common:nice-path for ease of use in automation check-in: 12da0c130c user: matt tags: v1.61
17:39
Remove debugger stuff since feathers can now be used with Chicken 4.11. Replaced resolve-pathname with hack common:nice-path as resolve-pathname is broken in 4.11 check-in: 1f0fec5a83 user: matt tags: v1.61
17:36
Added pathname-expand egg to list of eggs to install check-in: 69de7b484f user: matt tags: v1.61
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified common.scm from [ba84b1bce0] to [f25ae233a2].

︙
626
627
628
629
630
631
632
633
634
635
636


















637
638
639
640
641
642
643

626
627
628
629
630
631
632




633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657








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








		    ))))))

;;======================================================================
;; S Y S T E M   S T U F F
;;======================================================================

;; return a nice clean pathname made absolute
(define (nice-path dir)
  (normalize-pathname (if (absolute-pathname? dir)
			  dir
			  (conc (current-directory) "/" dir))))
(define (common:nice-path dir)
  (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
    (if match ;; using ~ for home?
	(common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match)))
	(normalize-pathname (if (absolute-pathname? dir)
				dir
				(conc (current-directory) "/" dir))))))

(define (common:read-link-f path)
  (handle-exceptions
      exn
      (begin
	(debug:print 0 "ERROR: command \"/bin/readlink -f " path "\" failed.")
	path) ;; just give up
    (with-input-from-pipe
	(conc "/bin/readlink -f " path)
      (lambda ()
	(read-line)))))

(define (get-cpu-load)
  (car (common:get-cpu-load)))
;;   (let* ((load-res (process:cmd-run->list "uptime"))
;; 	 (load-rx  (regexp "load average:\\s+(\\d+)"))
;; 	 (cpu-load #f))
;;     (for-each (lambda (l)
︙

Modified configf.scm from [d0b9504482] to [805ef5eee8].

︙
210
211
212
213
214
215
216
217

218
219
220
221
222
223
224

210
211
212
213
214
215
216

217
218
219
220
221
222
223
224








-
+








	       (configf:blank-l-rx _                  (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
	       (configf:settings   ( x setting val  ) (begin
							(hash-table-set! settings setting val)
							(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
	       (configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path))
							     (full-conf     (if (absolute-pathname? include-file)
										include-file
										(nice-path 
										(common:nice-path 
										 (conc (if curr-conf-dir
											   curr-conf-dir
											   ".")
										       "/" include-file)))))
							(if (file-exists? full-conf)
							    (begin
							      ;; (push-directory conf-dir)
︙

Modified launch.scm from [1dfedbf893] to [daec9f5f05].

︙
10
11
12
13
14
15
16
17

18
19
20
21
22
23
24

10
11
12
13
14
15
16

17
18
19
20
21
22
23
24








-
+









;;======================================================================
;; launch a task - this runs on the originating host, tests themselves
;;
;;======================================================================

(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv)
(use defstruct)
(use defstruct pathname-expand)

(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))

(declare (unit launch))
(declare (uses common))
(declare (uses configf))
︙
944
945
946
947
948
949
950
951


952
953
954
955
956
957
958

944
945
946
947
948
949
950

951
952
953
954
955
956
957
958
959








-
+
+








				   ;; (rmt:sdb-qry 'getstr 
				   (db:test-get-rundir testinfo) ;; ) ;; )
				   #f)))
	  (hash-table-set! *toptest-paths* testname curr-test-path)
	  ;; NB// Was this for the test or for the parent in an iterated test?
	  (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath 
			    (if (file-exists? lnkpath)
				(resolve-pathname lnkpath)
				;; (resolve-pathname lnkpath)
				(common:nice-path lnkpath)
				lnkpath)
			    testname "")
	  ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path)
	  (if (or (not curr-test-path)
		  (not (directory-exists? toptest-path)))
	      (begin
		(debug:print-info 2 "Creating " toptest-path " and link " lnkpath)
︙

Modified runs.scm from [e8ab551c17] to [7cb6946e92]. 

1
2
3
4
5
6
7
8
9
10
11
12
13


14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33

34
35
36
37
38
39
40

1
2
3
4
5
6
7
8
9
10
11
12

13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33

34
35
36
37
38
39
40
41













-
+
+



















-
+









;; Copyright 2006-2013, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) 
     posix-extras directory-utils pathname-expand)
(import (prefix sqlite3 sqlite3:))

(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses mt))
(declare (uses archive))
;; (declare (uses filedb))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")

(include "debugger.scm")
;; (include "debugger.scm")

(define (runs:test-get-full-path test)
  (let* ((testname (db:test-get-testname   test))
	 (itempath (db:test-get-item-path test)))
    (conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))
︙
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173








174
175
176
177
178
179
180

160
161
162
163
164
165
166








167
168
169
170
171
172
173
174
175
176
177
178
179
180
181








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








				 ((and job-group-limit
				       (>= num-running-in-jobgroup job-group-limit))
				  (if (runs:lownoise (conc "maxjobgroup " jobgroup) 60)
				      (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup 
						   " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit))
				  #t)
				 (else #f))))
	  ;; lets use the debugger eh?
	  (debugger-start start: 15)
	  (debugger-trace-var "runs:can-run-more-tests" "")
	  (debugger-trace-var "can-not-run-more"         can-not-run-more)
	  (debugger-trace-var "num-running"              num-running)
	  (debugger-trace-var "num-running-in-jobgroup"  num-running-in-jobgroup)
	  (debugger-trace-var "job-group-limit"          job-group-limit)
	  (debugger-pauser)
;;	  ;; lets use the debugger eh?
;;	  (debugger-start start: 15)
;;	  (debugger-trace-var "runs:can-run-more-tests" "")
;;	  (debugger-trace-var "can-not-run-more"         can-not-run-more)
;;	  (debugger-trace-var "num-running"              num-running)
;;	  (debugger-trace-var "num-running-in-jobgroup"  num-running-in-jobgroup)
;;	  (debugger-trace-var "job-group-limit"          job-group-limit)
;;	  (debugger-pauser)
	  (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)))))


;;  test-names: Comma separated patterns same as test-patts but used in selection 
;;              of tests to run. The item portions are not respected.
;;              FIXME: error out if /patt specified
;;
︙
496
497
498
499
500
501
502
503
504
505
506
507
508






509
510
511
512
513
514
515

497
498
499
500
501
502
503






504
505
506
507
508
509
510
511
512
513
514
515
516








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








		      "\n (member 'toplevel testmode): " (member 'toplevel testmode)
		      "\n (null? non-completed):    " (null? non-completed)
		      "\n reruns:          " reruns
		      "\n items:           " items
		      "\n can-run-more:    " can-run-more)

    ;; lets use the debugger eh?
    (debugger-start start: 2)
    (debugger-trace-var "runs:expand-items" "")
    (debugger-trace-var "can-run-more"     can-run-more)
    (debugger-trace-var "hed"              hed)
    (debugger-trace-var "prereqs-not-met"  (runs:pretty-string prereqs-not-met))
    (debugger-pauser)
;;    (debugger-start start: 2)
;;    (debugger-trace-var "runs:expand-items" "")
;;    (debugger-trace-var "can-run-more"     can-run-more)
;;    (debugger-trace-var "hed"              hed)
;;    (debugger-trace-var "prereqs-not-met"  (runs:pretty-string prereqs-not-met))
;;    (debugger-pauser)

    (cond
     ;; all prereqs met, fire off the test
     ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch

     ((and (not (member 'toplevel testmode))
	   (member (hash-table-ref/default test-registry (db:test-make-full-name hed item-path) 'n/a)
︙
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062








1063
1064
1065
1066
1067
1068
1069

1049
1050
1051
1052
1053
1054
1055








1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070








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








		     "\n  reruns:      " reruns
		     "\n  regfull:     " regfull
		     "\n  reglen:      " reglen
		     "\n  length reg:  " (length reg)
		     "\n  reg:         " reg)

	;; lets use the debugger eh?
	(debugger-start start: 7)
	(debugger-trace-var "runs:run-tests-queue" "")
	(debugger-trace-var "hed"              hed)
	(debugger-trace-var "tal"              tal)
	(debugger-trace-var "items"            items)
	(debugger-trace-var "item-path"        item-path)
	(debugger-trace-var "waitons"          waitons) 
	(debugger-pauser)
;;	(debugger-start start: 7)
;;	(debugger-trace-var "runs:run-tests-queue" "")
;;	(debugger-trace-var "hed"              hed)
;;	(debugger-trace-var "tal"              tal)
;;	(debugger-trace-var "items"            items)
;;	(debugger-trace-var "item-path"        item-path)
;;	(debugger-trace-var "waitons"          waitons) 
;;	(debugger-pauser)


	;; check for hed in waitons => this would be circular, remove it and issue an
	;; error
	(if (member test-name waitons)
	    (begin
	      (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!")
︙
1675
1676
1677
1678
1679
1680
1681
1682


1683
1684
1685
1686
1687
1688
1689

1676
1677
1678
1679
1680
1681
1682

1683
1684
1685
1686
1687
1688
1689
1690
1691








-
+
+








    ;; (sqlite3:finalize! (db:delay-if-busy tdbdat))
    )
  #t)

(define (runs:remove-test-directory test mode) ;; remove-data-only)
  (let* ((run-dir       (db:test-get-rundir test))    ;; run dir is from the link tree
	 (real-dir      (if (file-exists? run-dir)
			    (resolve-pathname run-dir)
			    ;; (resolve-pathname run-dir)
			    (common:nice-path run-dir)
			    #f)))
    (case mode
      ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f))
      ((remove-all)      (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f))
      ((archive-remove)  (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f)))
    (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir)
    (if (and real-dir
︙

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