Megatest

subrunmod.scm at [bbac9c3682]
Login

File subrunmod.scm artifact f9fbf4371e part of check-in bbac9c3682


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

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

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

(declare (unit subrunmod))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses dbfile))
(declare (uses dbmod))
(declare (uses rmtmod))
(declare (uses servermod))
(declare (uses processmod))
(declare (uses pgdb))
(declare (uses mtmod))
(declare (uses megatestmod))
(declare (uses tasksmod))

(use srfi-69)

(module subrunmod
	(
	 )

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports
	  data-structures
	  extras
	  files
	  matchable
	  pathname-expand
	  posix
	  posix-extras
	  regex
	  regex-case
	  sparse-vectors
	  
	  )
  (use srfi-69))
 (chicken-5
  (import (prefix sqlite3 sqlite3:)
	  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
	  system-information

  )))

;; imports common to ck4 and ck5
(import srfi-1
	srfi-13
	srfi-18
	srfi-69
	typed-records
	(prefix base64 base64:)
	(prefix sqlite3 sqlite3:)
	md5
	message-digest
	z3
	directory-utils
	call-with-environment-variables
	regex
	irregex
	
	debugprint
	commonmod
	configfmod
	(prefix mtargs args:)
	dbmod
	dbfile
	rmtmod
	servermod
	processmod
	pgdb
	mtmod
	megatestmod
	tasksmod
	)

;(include "common_records.scm")
;;(include "key_records.scm")
;; (include "db_records.scm") ;; provides db:test-get-id
;;(include "run_records.scm")
;;(include "test_records.scm")

(define (subrun:subrun-test-initialized? test-run-dir)
  (if (and (common:file-exists? (conc test-run-dir "/subrun-area") )
           (common:file-exists? (conc test-run-dir "/testconfig.subrun") ))
      #t
      #f))

(define (subrun:launch-dashboard test-run-dir)
  (if (subrun:subrun-test-initialized? test-run-dir)
      (let* ((subarea (subrun:get-runarea test-run-dir)))
        (if (and subarea (common:file-exists? subarea))
            (system (conc "cd " subarea ";env -i PATH=\"$PATH\" DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &"))))))

(define (subrun:subrun-removed? test-run-dir)
  (if (subrun:subrun-test-initialized? test-run-dir)
      (let ((flagfile (conc test-run-dir "/subrun.removed")))
        (if (common:file-exists? flagfile)
            #t
            #f))
      #t))

(define (subrun:set-subrun-removed test-run-dir)
  (let ((flagfile (conc test-run-dir "/subrun.removed")))
    (if (and (subrun:subrun-test-initialized? test-run-dir) (not (common:file-exists? flagfile)))
        (with-output-to-file flagfile
          (lambda () (print (current-seconds)))))))

(define (subrun:unset-subrun-removed test-run-dir)
  (let ((flagfile (conc test-run-dir "/subrun.removed")))
    (if (and (subrun:subrun-test-initialized? test-run-dir) (common:file-exists? flagfile))
        (delete-file flagfile))))


(define (subrun:testconfig-defines-subrun? testconfig)
  (configf:lookup testconfig "subrun" "runwait")) ;; we use runwait as the flag that a subrun is requested

(define (subrun:initialize-toprun-test  testconfig test-run-dir)
  (let ((ra (configf:lookup testconfig "subrun" "run-area"))
        (logpro (configf:lookup testconfig "subrun" "logpro"))
        (symlink-target (conc test-run-dir "/subrun-area"))
        )
    (if (not ra)      ;; when runarea is not set we default to *toppath*. However 
	(let ((fallback-run-area (or *toppath* (conc test-run-dir "/subrun"))))
	  ;; we need to force the setting in the testconfig so it will
          ;; be preserved in the testconfig.subrun file
	  (configf:set-section-var testconfig "subrun" "run-area" fallback-run-area)
	  (set! ra fallback-run-area)))
    (configf:set-section-var testconfig "logpro" "subrun" logpro) ;; append the logpro rules to the logpro section as stepname subrun
    (if (common:file-exists? symlink-target)
        (delete-file symlink-target))
    (create-symbolic-link ra symlink-target)
    (configf:write-alist testconfig "testconfig.subrun")))

(define (subrun:set-state-status test-run-dir state status new-state-status)
  (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir))
      (let* ((action-switches-str
              (conc "-set-state-status "new-state-status
                    (if state (conc " -state "state) "")
                    (if status (conc " -status "status) "")))
             (log-prefix
              (subrun:sanitize-path
               (conc "set-state-status="new-state-status
                     (if state (conc ":state="state) "")
                     (if status (conc "+status="status) ""))))
             (submt-result 
              (subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix)))
        submt-result)))

(define (subrun:remove-subrun test-run-dir keep-records )
  (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir))
      (let* ((action-switches-str
              (conc "-remove-runs"
                    (if keep-records "-keep-records " "")
                    ))
             (remove-result
              (subrun:exec-sub-megatest test-run-dir action-switches-str "remove")))
        (if remove-result
            (begin
              (subrun:set-subrun-removed test-run-dir)
              #t)
            #f))
      #t))

(define (subrun:kill-subrun test-run-dir )
  (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir))
      (let* ((action-switches-str
              (conc "-kill-runs" ))
             (kill-result
              (subrun:exec-sub-megatest test-run-dir action-switches-str "kill")))
        kill-result)
      #t))

(define (subrun:launch-cmd test-run-dir run-mode #!optional (sub-cmd "-run")) ;; BUG: "-run" should be changed to "-rerun-clean" but current doesn't work
  (if (subrun:subrun-removed? test-run-dir)
      (subrun:unset-subrun-removed test-run-dir))      

  (let* ((log-prefix "run")
         (switches (subrun:selector+log-switches test-run-dir log-prefix))
         (run-wait (equal? run-mode "yes"))
         (cmd      (conc (common:get-mtexe)" "sub-cmd" "switches" "
                         (if run-wait "-run-wait " ""))))
    cmd))


(define (subrun:sanitize-path inpath)
  (let* ((insane-pattern (irregex "[^[a-zA-Z0-9_\\-]")))
    (regex#string-substitute insane-pattern "_" inpath #t)))

(define (subrun:get-runarea test-run-dir)
  (if (subrun:subrun-test-initialized? test-run-dir)
      (let* ((info-alist (subrun:selector+log-alist
                          test-run-dir
                          "foo"))
             (run-area   (if (list? info-alist)
                             (alist-ref "-start-dir" info-alist equal? #f)
                             #f)))
        run-area)
      #f))

(define (subrun:selector+log-alist test-run-dir log-prefix)
  (let* ((switch-def-alist (common:get-param-mapping flavor: 'config))
         (subrunfile   (conc test-run-dir "/testconfig.subrun" ))
         (subrundata   (with-input-from-file subrunfile read))
         (subrunconfig (configf:alist->config subrundata))
         (run-area     (configf:lookup subrunconfig "subrun" "run-area"))
         (defvals      `(("start-dir" . ,(or run-area  ;; default values if not specified in subrun section of tconf
                                             (get-environment-variable "MT_RUN_AREA_HOME")
                                             "/no/rundir/found")) 
                         ("run-name"  . ,(or (get-environment-variable "MT_RUNNAME") "NO-RUNNAME"))
                         ("target"    . ,(or (get-environment-variable "MT_TARGET")  "NO-TARGET"))))
         (switch-alist-pre  (filter-map (lambda (item)
                                          (let* ((config-key (car item))
                                                 (switch     (cdr item))
                                                 (defval     (alist-ref config-key defvals equal? #f))
                                                 (val        (or (configf:lookup subrunconfig "subrun" config-key)
                                                                 defval)))
                                            (if val
                                                (cons switch val)
                                                #f)))
                                        switch-def-alist))

         ;; testpatt may be modified if all three of mode-patt, tag-expr, and testpatt are null
         (mode-patt     (alist-ref "-modepatt" switch-alist-pre equal? #f))
         (tag-expr      (alist-ref "-tagexpr" switch-alist-pre equal? #f))
         (testpatt      (alist-ref "-testpatt" switch-alist-pre equal?
                                   (if (not (or mode-patt tag-expr)) "%" #f))) ;; testpatt is % if not
                                                                               ;; otherwise specified

         ;; define compact-stem for logfile
         (target        (alist-ref "-target" switch-alist-pre equal? #f)) ;; want data-structures alist-ref, not alist-lib alist-ref
         (runname       (alist-ref "-runname" switch-alist-pre equal? #f))


         (compact-stem  (subrun:sanitize-path
                         (conc
                          target
                          "-"
                          runname
                          "-" (or testpatt mode-patt tag-expr "NO-TESTPATT"))))
         (logfile       (conc
                         test-run-dir "/"
                         (if log-prefix
                             (conc (subrun:sanitize-path log-prefix) "-")
                             "")
                         compact-stem
                         ".log"))
         ;; swap out testpatt with modified test-patt and add -log
         (switch-alist  (cons
                         (cons "-log" logfile)
                         (map (lambda (item)
                                (if (equal? (car item) "-testpatt")
                                    (cons "-testpatt" testpatt)
                                    item))
                                switch-alist-pre))))
    switch-alist))
    ;; note - get precmd from subrun section
    ;;   apply to submegatest commands

(define (subrun:get-log-path test-run-dir log-prefix)
  (let* ((alist (subrun:selector+log-alist test-run-dir log-prefix))
         (res   (alist-ref "-log" alist equal? #f)))
    res))

(define (subrun:selector+log-switches test-run-dir log-prefix)
  (let* ((switch-alist (subrun:selector+log-alist test-run-dir log-prefix))
         (res
          (string-intersperse
           (apply
            append
            (map
             (lambda (x)
               (list (car x) (cdr x)))
             switch-alist))
           " ")))
    res))

;; NOTE: Here we run sub megatest but this is not intended for one version
;;       of megatest to test another version. Thus we propagate the 
(define (subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix)
  (let* ((mtpathdir          (common:get-megatest-exe-dir))
	 (mtexe              (common:get-mtexe))
	 (selector-switches  (subrun:selector+log-switches test-run-dir log-prefix))
         (cmd (conc mtexe" "selector-switches" "action-switches-str ))
         (pid #f)
         (proc (lambda ()
                 (debug:print-info 0 *default-log-port* "Running sub megatest command: "cmd)
                 ;;(set! pid (process-run "/usr/bin/xterm" (list ))))))
                 (set! pid (process-run "/bin/bash" (list "-c" cmd))))))
    (call-with-environment-variables 
     (list (cons "PATH"  (common:get-megatest-exe-path)))
     (lambda  ()
       (common:without-vars proc "^MT_.*")))
    (let processloop ((i 0))
      (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
        (if (eq? pid-val 0)
            (begin
              (thread-sleep! 2)
              (processloop (+ i 1)))
            (begin
              (debug:print-info 0 *default-log-port* "sub megatest " action-switches-str " completed with exit code " exit-code)
              (if (eq? 0 exit-code)
                  (begin
                    #t)
                  (begin
                    #f))))))))



;; (subrun:exec-sub-megatest "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/165/megatest/ext-tests/tests/subrun-usecases/toparea/links/SYSTEM_val/RELEASE_val/go/toptest" "-foo" "foo")


)