Megatest

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

		       (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

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