Megatest

mtmod.scm at [d895910f2e]
Login

File mtmod.scm artifact c5e4b82ce0 part of check-in d895910f2e


;;======================================================================
;; 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/>.

;;======================================================================

;;======================================================================
;; Megatestmod:
;;
;;   Put things here don't fit anywhere else
;;======================================================================

(declare (unit mtmod))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses commonmod))
(declare (uses configfmod))
;; (declare (uses tcp-transportmod)) ;; we don't want mtmod depending on tcp

(use srfi-69)

(module mtmod
	*

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports
	  (prefix base64 base64:)

	  (prefix sqlite3 sqlite3:)
	  data-structures 
	  directory-utils
	  extras
	  files
	  matchable
	  md5
	  message-digest
	  pathname-expand
	  posix
	  posix-extras
	  regex
	  regex-case
	  sparse-vectors
	  srfi-1
	  srfi-18
	  srfi-69
	  typed-records
	  z3
	  
	  debugprint
	  commonmod
	  configfmod
	  ;; tcp-transportmod
	  (prefix mtargs args:)
	  )
  (use srfi-69))
 (chicken-5
  (import (prefix sqlite3 sqlite3:)
	  ;; data-structures
	  ;; extras
	  ;; files
	  ;; posix
	  ;; posix-extras
	  chicken.base
	  chicken.condition
	  chicken.file
	  chicken.file.posix
	  chicken.io
	  chicken.pathname
	  chicken.port
	  chicken.process
	  chicken.process-context
	  chicken.process-context.posix
	  chicken.sort
	  chicken.string
	  chicken.time
	  chicken.time.posix
	  
	  matchable
	  md5
	  message-digest
	  pathname-expand
	  regex
	  regex-case
	  srfi-1
	  srfi-18
	  srfi-69
	  typed-records
	  system-information

	  debugprint
  )))

;; imports common to chk5 and ck4
(import srfi-13)

(include "db_records.scm")

;;======================================================================
;; stuff from keys that can't be in commonmod. Maybe move all from commonmod to here?
;;======================================================================

(define (keys:make-key/field-string confdat)
  (let ((fields (configf:get-section confdat "fields")))
    (string-join
     (map (lambda (field)(conc (car field) " " (cadr field)))
	  fields)
     ",")))

;;======================================================================
;; testsuite and area utilites
;;======================================================================

(define (common:get-linktree)
  (or (getenv "MT_LINKTREE")
      (if *configdat*
	  (configf:lookup *configdat* "setup" "linktree")
	  #f)
      (if (or *toppath* (getenv "MT_RUN_AREA_HOME"))
	  (conc (or *toppath* (getenv "MT_RUN_AREA_HOME")) "/lt")
	  #f)
      (let* ((tp (common:get-toppath #f))
	     (lt (conc tp "/lt")))
	(if (not tp)(debug:print 0 *default-log-port* "WARNING: cannot calculate best path for linktree, using " lt))
	lt)))

(define (get-testsuite-name toppath configdat)
  (or (lookup configdat "setup" "area-name")
      (lookup configdat "setup" "testsuite")
      (get-environment-variable "MT_TESTSUITE_NAME")
      (if (string? toppath)
          (pathname-file toppath)
          #f)))

(define (common:get-testsuite-name)
  (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
      (configf:lookup *configdat* "setup" "testsuite" )
      (getenv "MT_TESTSUITE_NAME")
      (pathname-file (or (if (string? *toppath* )
			     (pathname-file *toppath*)
			     #f)
			 (common:get-toppath #f)))
      "please-set-setup-area-name")) ;; (pathname-file (current-directory)))))

;; need generic find-record-with-var-nmatching-val
;;
(define (path->area-record cfgdat path)
  (let* ((areadat (get-cfg-areas cfgdat))
	 (all     (filter (lambda (x)
			    (let* ((keyvals (cdr x))
				   (pth     (alist-ref 'path keyvals)))
			      (equal? path pth)))
			  areadat)))
    (if (null? all)
	#f
	(car all)))) ;; return first match

(define (get-area-name configdat toppath #!optional (short #f))
  ;; look up my area name in areas table (future)
  ;; generate auto name
  (conc (get-area-path-signature toppath short)
	"-"
	(get-testsuite-name toppath configdat)))

;; given a config return an alist of alists
;;   area-name => data
;;
(define (get-cfg-areas cfgdat)
  (let ((adat (get-section cfgdat "areas")))
    (map (lambda (entry)
	   `(,(car entry) . 
	     ,(val->alist (cadr entry))))
	 adat)))

;;======================================================================
;; redefine for future cleanup (converge on area-name, the more generic
;;
(define common:get-area-name common:get-testsuite-name)

(define (common:get-db-tmp-area . junk)
  (if *db-cache-path*
      *db-cache-path*
      (if *toppath* ;; common:get-create-writeable-dir
	  (handle-exceptions
	      exn
	      (begin
		(debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path* ", exn=" exn)
		(exit 1))
	      (let* ((toppath (common:real-path *toppath*))
		     (tsname (common:get-testsuite-name))
		     (dbpath (common:get-create-writeable-dir
			      (list (conc "/tmp/" (current-user-name)
					  "/megatest_localdb/"
					  tsname "/"
					  (string-translate toppath "/" "."))
				    (conc "/tmp/" (current-process-id) ;; just in case we have an issue with the dir by own user name
					  "/"(current-user-name) "/megatest_localdb/"
					  tsname
					  (string-translate toppath "/" "."))
				    ))))
		(set! *db-cache-path* dbpath)
		;; ensure megatest area has .mtdb
		(let ((dbarea (conc *toppath* "/.mtdb")))
		  (if (not (file-exists? dbarea))
		      (create-directory dbarea)))
		;; ensure tmp area has .mtdb
		(let ((dbarea (conc dbpath "/.mtdb")))
		  (if (not (file-exists? dbarea))
		      (create-directory dbarea)))
		dbpath))
	  #f)))

;======================================================================
;;  T R I G G E R S
;;======================================================================

(define (mt:run-trigger cmd test-id test-rundir trigger logname test-name item-path event-time actual-state actual-status target runname)
  ;; Putting the commandline into ( )'s means no control over the shell. 
  ;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files
  ;; or equivalent. No need to do this. Just run it?
  (let* ((new-trigger-format (configf:lookup *configdat* "setup" "new-trigger-format"))
         (fullcmd 
          (if (and new-trigger-format (string=? new-trigger-format "yes"))
            (conc "nbfake "
			cmd           " "
			test-id       " "
			test-rundir   " "
			trigger       " "
			actual-state  " "
			actual-status " "
			event-time    " "
                        target        " "
                        runname       " "
			test-name     " "
			item-path
			)
            (conc "nbfake "
			cmd           " "
			test-id       " "
			test-rundir   " "
			trigger       " "
			test-name     " "
			item-path     " " 
			actual-state  " "
			actual-status " "
			event-time
			)
          ))
	 (prev-nbfake-log (get-environment-variable "NBFAKE_LOG")))
    (setenv "NBFAKE_LOG" (conc (cond
				((and (directory-exists? test-rundir)
				      (file-write-access? test-rundir))
				 test-rundir)
				((and (directory-exists? *toppath*)
				      (file-write-access? *toppath*))
				 *toppath*)
				(else (conc "/tmp/" (current-user-name))))
			       "/" logname))
    (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG"))
    (process-run fullcmd)
    (if prev-nbfake-log
	(setenv "NBFAKE_LOG" prev-nbfake-log)
	(unsetenv "NBFAKE_LOG"))
    ))


(define (mt:discard-blocked-tests run-id failed-test tests test-records)
  (if (null? tests)
      tests
      (begin
	(debug:print-info 1 *default-log-port* "Discarding tests from " tests " that are waiting on " failed-test)
	(let loop ((testn (car tests))
		   (remt  (cdr tests))
		   (res   '()))
	  (let* ((test-dat (hash-table-ref/default test-records testn (vector #f #f '())))
		 (waitons  (vector-ref test-dat 2)))
	    ;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons)
	    (if (null? remt)
		(let ((new-res (reverse res)))
		  ;; (print "       new-res: " new-res)
		  new-res)
		(loop (car remt)
		      (cdr remt)
		      (if (member failed-test waitons)
			  (begin
			    (debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test)
			    res)
			  (cons testn res)))))))))


;; 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 class item)
  (let ((valid-values (let ((s (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))


	

)