Megatest

Check-in [4380b6c011]
Login
Overview
Comment:Minor fix to test matching; test => %/% but test/ => %/
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | enhanced-debug
Files: files | file ages | folders
SHA1: 4380b6c011187bbc9f5b82715be0ff76de62e95b
User & Date: mrwellan on 2012-10-18 16:11:15
Other Links: branch diff | 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:11
Minor fix to test matching; test => %/% but test/ => %/ Closed-Leaf check-in: 4380b6c011 user: mrwellan tags: enhanced-debug
14:56
Added fine grained control over debug:print printing and added speciallized printer debug:print-info check-in: b1669bc3d1 user: mrwellan tags: enhanced-debug
Changes

Modified common_records.scm from [b1f7da643e] 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
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
55
56
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.
;;======================================================================

(use format)

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

;; 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-inline (debug:debug-mode n)
(define (debug:debug-mode n)
  (or (and (number? *verbosity*)
	   (<= n *verbosity*))
      (and (list? *verbosity*)
	   (member n *verbosity*))))

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

(define-inline (debug:print-info n . 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 [ab4ff9f51a] to [191c4109f9].

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 [452d388a28].

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")
 (list   ""  ""      "cde"    "cde"     "cde"     ""            ""      "a"       "b"    ""  "b")
 (list   #t    #t       #t    #f           #f      #t           #t       #t       #f     #t  #t))

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