Megatest

(require-extension (srfi 18) extras tcp rpc)

(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))

(declare (unit common))


(include "common_records.scm")

;; (require-library margs)
;; (include "margs.scm")

;; (define old-exit exit)

;;
(define (common:cleanup-db dbstruct)
  (db:multi-db-sync 
   dbstruct
   ;; 'new2old
   'killservers
   'dejunk
   'adj-target
   ;; 'old2new
   'new2old
   'schema)
  (if (common:version-changed?)
      (common:set-last-run-version)))

;; Rotate logs, logic: 

    (8 "RUNNING")
    ))

(define *common:std-statuses*
  '(;; (0 "DELETED")
    (1 "n/a")
    (2 "PASS")

    (3 "SKIP")
    (4 "WARN")
    (5 "WAIVED")
    (6 "CHECK")
    (7 "STUCK/DEAD")
    (8 "FAIL")
    (9 "ABORT")))

(define *common:ended-states*       ;; states which indicate the test is stopped and will not proceed
  '("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE"))

(define (common:args-get-testpatt rconf)
  (let* (;; (tagexpr       (args:get-arg "-tagexpr"))
         ;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f))
         (testpatt-key  (if (args:get-arg "--modepatt") (args:get-arg "--modepatt") "TESTPATT"))
         (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%"))
         (rtestpatt     (if rconf (runconfigs-get rconf testpatt-key) #f)))
    (cond
     ((args:get-arg "--modepatt") ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
      (if rconf
	  (runconfigs-get rconf testpatt-key)
	  #f))     ;; We do NOT fall back to "%"
     ;; (tags-testpatt
     ;;  (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
     ;;  tags-testpatt)
     ((and (equal? args-testpatt "%") rtestpatt)
      (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
      rtestpatt)
     (else args-testpatt))))

(define (common:directory-exists? path-string)
  ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg:  system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
  (common:false-on-exception (lambda () (directory-exists? path-string))
                             message: (conc "Unable to access path: " path-string)
                             ))

;; does the directory exist and do we have write access?
;;
;;    returns the directory or #f
;;
(define (common:directory-writable? path-string)
  (handle-exceptions
   exn
   #f
   (if (and (directory-exists? path-string)
            (file-write-access? path-string))
       path-string
       #f)))

(define (common:get-linktree)
  (or (getenv "MT_LINKTREE")
      (if *configdat*
	  (configf:lookup *configdat* "setup" "linktree")
	  (if *toppath*
	      (conc *toppath* "/lt")


	      #f))))

(define (common:args-get-runname)
  (let ((res (or (args:get-arg "-runname")
		 (args:get-arg ":runname")
		 (getenv "MT_RUNNAME"))))
    ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
    res))

(define (common:get-fields cfgdat)
  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
    (map car fields)))

(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
  (let* ((keys    (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
	 (numkeys (length keys))
	 (target  (or (args:get-arg "-reqtarg")
		      (args:get-arg "-target")
		      (getenv "MT_TARGET")))
	 (tlist   (if target (string-split target "/" #t) '()))
	 (valid   (if target
		      (or (null? keys) ;; probably don't know our keys yet

	    target)
	(if target
	    (begin
	      (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
	      (if exit-if-bad (exit 1))
	      #f)
	    #f))))

;; looking only (at least for now) at the MT_ variables craft the full testname
;;
(define (common:get-full-test-name)
  (if (getenv "MT_TEST_NAME")
      (if (and (getenv "MT_ITEMPATH")
               (not (equal? (getenv "MT_ITEMPATH") "")))
          (getenv "MT_TEST_NAME")
          (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH")))
      #f))

;; logic for getting homehost. Returns (host . at-home)
;; IF *toppath* is not set, wait up to five seconds trying every two seconds
;; (this is to accomodate the watchdog)
;;
(define (common:get-homehost #!key (trynum 5))
  ;; called often especially at start up. use mutex to eliminate collisions

    (if hh
	(cdr hh)
	#f)))

;; do we honor the caches of the config files?
;;
(define (common:use-cache?)
  (let ((res #t)) ;; priority by order of evaluation
    (if *configdat*
	(if (equal? (configf:lookup *configdat* "setup" "use-cache") "no")
	    (set! res #f)
	    (if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes")
		(set! res #t))))
    (if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup"
    (if (getenv "MT_USE_CACHE")
	(if (equal? (getenv "MT_USE_CACHE") "yes")
	    (set! res #t)
	    (if (equal? (getenv "MT_USE_CACHE") "no")
		(set! res #f))))    ;; overrides -no-cache switch
    res))
  
;; force use of server?
;;
(define (common:force-server?)
  (let* ((force-setting (configf:lookup *configdat* "server" "force"))
	 (force-type    (if force-setting (string->symbol force-setting) #f))
	 (force-result  (case force-type
			  ((#f)     #f)
			  ((always) #t)
			  ((test)   (if (args:get-arg "-execute") ;; we are in a test
					#t
					#f))
			  (else
			   (debug:print 0 *default-log-port* "ERROR: Bad server force setting " force-setting ", forcing server.")
			   #t)))) ;; default to requiring server
    (if force-result
	(begin
	  (debug:print-info 0 *default-log-port* "forcing use of server, force setting is \"" force-setting "\".")
	  #t)
	#f)))








;;======================================================================
;; M I S C   L I S T S
;;======================================================================

;; items in lista are matched value and position in listb
;; return the remaining items in listb or #f
;;