Megatest

Check-in [517fde8bdf]
Login
Overview
Comment:Cherry picked the test matching (test vs. test/) fix to trunk
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk | v1.508
Files: files | file ages | folders
SHA1: 517fde8bdf840112874528e7a74d68f010beeb5a
User & Date: mrwellan on 2012-10-18 16:39:28
Other Links: manifest | tags
Context
2012-10-18
22:28
Merged in improvements to debug printing in readiness for db access nesting study check-in: 85f25caaa3 user: matt tags: trunk
16:39
Cherry picked the test matching (test vs. test/) fix to trunk check-in: 517fde8bdf user: mrwellan tags: trunk, v1.508
2012-10-17
20:11
Tweaked delays to reduce db load. Shrunk maxretries to match check-in: da9a8edadb user: mrwellan tags: trunk, v1.507
Changes

Modified common_records.scm from [d3914aa282] to [973da57ab3].

1
2
3
4
5
6
7
8
9
10
11










12
13
14
15
16
17



























18
19
20
21
22
23
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
42
43
44
45
46
47
48
49
50
51
52
53
54











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






;;======================================================================
;; Copyright 2006-2012, 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.
;;======================================================================

(define (debug:calc-verbosity vstr)
  (cond
   (vstr
    (let ((debugvals (string-split vstr ",")))
      (if (> (length debugvals) 1)
	  (map string->number debugvals)
	  (string->number (car debugvals)))))
   ((args:get-arg "-v")    2)
   ((args:get-arg "-q")    0)
   (else                   1)))
(define-inline (debug:print n . params)
  (begin
    (if (<= n *verbosity*)
	(apply print params))
    (if *logging*
	(apply db:log-event params))))

;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
  (if (not (or (number? verbosity)
	       (list?   verbosity)))
      (begin
	(print "ERROR: Invalid debug value " vstr)
	#f)
      #t))

(define (debug:debug-mode n)
  (or (and (number? *verbosity*)
	   (<= n *verbosity*))
      (and (list? *verbosity*)
	   (member n *verbosity*))))

(define (debug:print n . params)
  (if (debug:debug-mode n)
      (begin
	(apply print params)
	(if *logging* (apply db:log-event params)))))

(define (debug:print-info n . params)
  (if (debug:debug-mode n)
      (let ((res (format#format #f "INFO:~2d ~a" n (apply conc params))))
	(print res)
	(if *logging* (db:log-event res)))))

;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
  (if (or (number? val)(string? val)) val ""))

Modified tests.scm from [ecc1ac4ecb] to [f875f856f8].

64
65
66
67
68
69
70







71
72
73
74
75
76
77
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84







+
+
+
+
+
+
+







		       (tal  (cdr patts)))
	      ;; (print "loop: patt: " patt ", tal " tal)
	      (if (string=? patt "")
		  #f ;; nothing ever matches empty string - policy
		  (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt))
			 (test-patt  (cadr patt-parts))
			 (item-patt  (cadddr patt-parts)))
		    ;; special case: test vs. test/
		    ;;   test  => "test" "%"
		    ;;   test/ => "test" ""
		    (if (and (not (substring-index "/" patt)) ;; no slash in the original
			     (or (not item-patt)
				 (equal? item-patt "")))      ;; should always be true that item-patt is ""
			(set! item-patt "%"))
		    ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
		    (if (and (tests:glob-like-match test-patt testname)
			     (or (not itempath)
				 (tests:glob-like-match (if item-patt item-patt "") itempath)))
			#t
			(if (null? tal)
			    #f

Modified tests/tests.scm from [40eff4ae85] to [34d2ce0b3e].

36
37
38
39
40
41
42
43
44
45
46




47
48
49
50
51
52
53
36
37
38
39
40
41
42




43
44
45
46
47
48
49
50
51
52
53







-
-
-
-
+
+
+
+







;; tests:match
(test #f #t (tests:match "abc/def" "abc" "def"))
(for-each 
 (lambda (patterns testname itempath expected)
   (test (conc patterns " " testname "/" itempath "=>" expected)
	 expected 
	 (tests:match patterns testname itempath)))
 (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a")
 (list "abc" "abc"   "abcd"   "abc"     "abc"     "a"         "abc"     "def"    "ghi"  )
 (list   ""  ""      "cde"    "cde"     "cde"     ""            ""      "a"       "b"   )
 (list   #t    #t       #t    #f           #f      #t           #t       #t       #f    ))
 (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/")
 (list "abc" "abc"   "abcd"   "abc"     "abc"     "a"         "abc"     "def"    "ghi"   "a" "a"  "a"  "a")
 (list   ""  ""      "cde"    "cde"     "cde"     ""            ""      "a"       "b"    ""  "b"  ""   "b")
 (list   #t    #t       #t    #f           #f      #t           #t       #t       #f     #t  #t   #t    #f))

;; db:patt->like
(test #f "testname LIKE 't%'" (db:patt->like "testname" "t%" comparator: " AND "))
(test #f "testname LIKE 't%' AND testname LIKE '%t'" (db:patt->like "testname" "t%,%t" comparator: " AND "))
(test #f "item_path GLOB ''" (db:patt->like "item_path" ""))

;; test:match->sqlqry