;;======================================================================
;; Copyright 2017, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit itemsmod))
(declare (uses mtargs))
(declare (uses debugprint))
(declare (uses configfmod))
(declare (uses commonmod))
(module itemsmod
*
(import scheme
chicken.base
chicken.condition
chicken.file
chicken.io
chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.sort
chicken.string
chicken.time
debugprint
mtargs
pkts
(prefix base64 base64:)
(prefix dbi dbi:)
(prefix sqlite3 sqlite3:)
(srfi 18)
directory-utils
format
matchable
md5
message-digest
regex
regex-case
sparse-vectors
srfi-1
srfi-13
srfi-69
stack
typed-records
z3
configfmod
)
;; (define itemdat '((ripeness "green ripe overripe")
;; (temperature "cool medium hot")
;; (season "summer winter fall spring")))
;; (declare (unit items))
;; (declare (uses common))
;;
;; (include "common_records.scm")
;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
(let ((res '()))
(if (not hierdepth)
(set! hierdepth (length itemlist)))
(let loop ((hed (car itemlist))
(tal (cdr itemlist)))
(if (null? tal)
(for-each (lambda (item)
(if (> (length curritemkey) (- hierdepth 2))
(set! res (append res (list (append curritemkey (list (list (car hed) item))))))))
(cadr hed))
(begin
(for-each (lambda (item)
(set! res (append res (process-itemlist hierdepth (append curritemkey (list (list (car hed) item))) tal))))
(cadr hed))
(loop (car tal)(cdr tal)))))
res))
;; (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall")))
;; => ((("ANIMAL" "Elephant") ("SEASON" "Spring"))
;; (("ANIMAL" "Elephant") ("SEASON" "Fall"))
;; (("ANIMAL" "Lion") ("SEASON" "Spring"))
;; (("ANIMAL" "Lion") ("SEASON" "Fall")))
(define (item-assoc->item-list itemsdat)
(if (and itemsdat (not (null? itemsdat)))
(let ((itemlst (filter (lambda (x)
(list? x))
(map (lambda (x)
(debug:print 6 *default-log-port* "item-assoc->item-list x: " x)
(if (< (length x) 2)
(begin
(debug:print-error 0 *default-log-port* "malformed items spec " (string-intersperse x " "))
(list (car x)'()))
(let* ((name (car x))
(items (cadr x))
(ilist (list name (if (string? items)
(string-split items)
'()))))
(if (null? ilist)
(debug:print-error 0 *default-log-port* "No items specified for " name))
ilist)))
itemsdat))))
(let ((debuglevel 5))
(debug:print 5 *default-log-port* "item-assoc->item-list: itemsdat => itemlst ")
(if (debug:debug-mode 5)
(begin
(pp itemsdat)
(print " => ")
(pp itemlst))))
(if (> (length itemlst) 0)
(process-itemlist #f '() itemlst)
'()))
'())) ;; return a list consisting on a single null list for non-item runs
;; Nope, not now, return null as of 6/6/2011
;; (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter")))
;; => ((("ANIMAL" "Elephant")("SEASON" "Spring"))
;; (("ANIMAL" "Lion") ("SEASON" "Winter")))
(define (item-table->item-list itemtable)
(let ((newlst (map (lambda (x)
(if (> (length x) 1)
(list (car x)
(string-split (cadr x)))
(list x '())))
itemtable))
(res '())) ;; a list of items
(let loop ((indx 0)
(item '()) ;; an item will be ((KEYNAME1 VAL1)(KEYNAME2 VAL2) ...)
(elflag #f))
(for-each (lambda (row)
(let ((rowname (car row))
(rowdat (cadr row)))
(set! item (append item
(list
(if (< indx (length rowdat))
(let ((new (list rowname (list-ref rowdat indx))))
;; (debug:print 0 *default-log-port* "New: " new)
(set! elflag #t)
new
) ;; i.e. had at least on legit value to use
(list rowname "-")))))))
newlst)
(if elflag
(begin
(set! res (append res (list item)))
(loop (+ indx 1)
'()
#f)))
res)))
;; Nope, not now, return null as of 6/6/2011
(define (items:check-valid-items valid-values class item)
(let ((valid-values (let ((s valid-values)) ;; (configf:lookup *configdat* "validvalues" class)))
(if s (string-split s) #f))))
(if valid-values
(if (member item valid-values)
item #f)
item)))
;; '(("k1" "k2" "k3")
;; ("a" "b" "c")
;; ("d" "e" "f"))
;;
;; => '((("k1" "a")("k2" "b")("k3" "c"))
;; (("k1" "d")("k2" "e")("k3" "f")))
;;
(define (items:first-row-intersperse data)
(if (< (length data) 2)
'()
(let ((header (car data))
(rows (cdr data)))
(map (lambda (row)
(map list header row))
rows))))
;; k1/k2/k3
;; a/b/c
;; d/e/f
;; => '(("k1" "k2" "k3")
;; ("a" "b" "c")
;; ("d" "e" "f"))
;;
;; => '((("k1" "a")("k2" "b")("k3" "c"))
;; (("k1" "d")("k2" "e")("k3" "f")))
;;
(define (items:read-items-file fname ftype) ;; 'sxml 'slash 'space
(if (and fname (file-exists? fname))
(items:first-row-intersperse (case ftype
((slash space)
(let ((splitter (case ftype
((slash) (lambda (x)(string-split x "/")))
(else string-split))))
(debug:print 0 *default-log-port* "Reading " fname " of type " ftype)
(with-input-from-file fname
(lambda ()
(let loop ((inl (read-line))
(res '()))
(if (eof-object? inl)
res
(loop (read-line)(cons (splitter inl) res))))))))
((sxml)(with-input-from-file fname read))
(else (debug:print 0 *default-log-port* "items file type " ftype " not recognised"))))
(begin
(if fname (debug:print 0 *default-log-port* "no items file " fname " found"))
'())))
(define (items:get-items-from-config tconfig)
(let* ((slashf (configf:lookup tconfig "itemopts" "slash")) ;; a/b/c\nd/e/f\n ...
(sxmlf (configf:lookup tconfig "itemopts" "sxml")) ;; '(("a" "b" "c")("d" "e" "f") ...)
(spacef (configf:lookup tconfig "itemopts" "space")) ;; a b c\nd e f\n ...
(have-items (hash-table-ref/default tconfig "items" #f))
(have-itable (hash-table-ref/default tconfig "itemstable" #f))
(items (hash-table-ref/default tconfig "items" '()))
(itemstable (hash-table-ref/default tconfig "itemstable" '())))
(debug:print 5 *default-log-port* "items: " items " itemstable: " itemstable)
(set! items (map (lambda (item)
(if (procedure? (cadr item))
(list (car item)((cadr item))) ;; evaluate the proc
item))
items))
(set! itemstable (map (lambda (item)
(if (procedure? (cadr item))
(list (car item)((cadr item))) ;; evaluate the proc
item))
itemstable))
(if (and have-items (null? items)) (debug:print 0 *default-log-port* "WARNING:[items] section in testconfig but no entries defined"))
(if (and have-itable (null? itemstable))(debug:print 0 *default-log-port* "WARNNG:[itemstable] section in testconfig but no entries defined"))
(if (or (not (null? items))
(not (null? itemstable))
slashf
sxmlf
spacef)
(append (item-assoc->item-list items)
(item-table->item-list itemstable)
(items:read-items-file slashf 'slash)
(items:read-items-file sxmlf 'sxml)
(items:read-items-file spacef 'space))
'(()))))
;; (pp (item-assoc->item-list itemdat))
)