Megatest

run2mock.scm at [b7dfc5691b]
Login

File utils/run2mock.scm artifact 19fe62ea8b part of check-in b7dfc5691b


#!/p/foundry/env/pkgs/chicken/4.10.1_v1.63/bin/csi -s
; -*- Mode: Scheme; -*-

;;  Copyright 2006-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/>.
;;

(use ducttape-lib)
(use posix-extras pathname-expand regex matchable)
(use ini-file)
;; plugs a hole in posix-extras in latter chicken versions
(define ##sys#expand-home-path pathname-expand)
(define (realpath x) (resolve-pathname  (pathname-expand (or x "/dev/null")) ))

;; resolve fullpath to this script
(define (get-this-script-fullpath #!key (argv (argv)))
  (let* ((this-script
          (cond
           ((and (> (length argv) 2)
                 (string-match "^(.*/csi|csi)$" (car argv))
                 (string-match "^-(s|ss|sx|script)$" (cadr argv)))
            (caddr argv))
           (else (car argv))))
         (fullpath (realpath this-script)))
    fullpath))

(define *this-script-fullpath* (get-this-script-fullpath))
(define *this-script-dir* (pathname-directory *this-script-fullpath*))
(define *this-script-name* (pathname-strip-directory *this-script-fullpath*))

(define (false-on-exception thunk)
  (handle-exceptions exn #f (thunk) ))

(define (safe-file-exists? path-string)
  (false-on-exception (lambda () (file-exists? path-string))))


(define (crude-config-transformer infile outfile keep-sections-list append-text #!key (filter-patt #f))
  (let* ((inlines (with-input-from-file infile read-lines))
         (keep-lines (let loop ((lines-left inlines) (lines-out '()) (current-section #f) (section-lines-accumulator '()))
                       (let* ((this-line (if (not (null? lines-left))
                                             (car lines-left)
                                             ""))
                              (section-match (string-match "^\\s*\\[([^\\]]+)\\].*" this-line)))
                         (cond
                          ((null? lines-left)
                           (if (member current-section keep-sections-list)
                               (append lines-out (reverse section-lines-accumulator))
                               lines-out))
                          (section-match
                           (let* ((next-lines-left      (cdr lines-left))
                                  (next-lines-out       (if (member current-section keep-sections-list)
                                                            (append lines-out (reverse section-lines-accumulator))
                                                            lines-out))
                                  (next-current-section (cadr section-match))
                                  (next-section-lines-accumulator (list this-line)))
                             (loop next-lines-left next-lines-out next-current-section next-section-lines-accumulator)))
                          (else
                           (let* ((next-lines-left       (cdr lines-left))
                                  (next-lines-out        lines-out)
                                  (next-current-section  current-section)
                                  (next-section-lines-accumulator
                                   (cond
                                    ((and filter-patt (string-match (conc "^.*"filter-patt".*$") this-line))
                                     section-lines-accumulator)
                                    (else (cons this-line section-lines-accumulator)))))
                             (loop next-lines-left next-lines-out next-current-section next-section-lines-accumulator))))))))
    (with-output-to-file outfile (lambda ()
                                   (print (string-join keep-lines "\n"))
                                   (print)
                                   (print append-text)
                                   (print)))))
                                        
                           
(define (testconfig-transformer infile outfile)
  (crude-config-transformer
   infile
   outfile
   '("meta" "items" "requirements" "test_meta")
   
   (conc "

[ezsteps]
alwayspass /bin/true

")))





(let* ((mtexe         "/p/foundry/env/pkgs/megatest/1.64/31/bin/megatest")
       (faux-mtra     "/p/fdk/gwa/bjbarcla/issues/mtdev/ch/cap/faux")
       (src-mtra      "/nfs/pdx/disks/icf_fdk_asic_gwa002/asicfdkqa/fossil/megatestqa/afdkqa")
       (target        "p1275/5/ADF_r0.7_s/9p27t_tp0")
       (run           "ww38.4")
       (src-mtdb      (conc src-mtra "/megatest.db"))
       (extra-src-testdirs   '("/p/fdk/gwa/asicfdkqa/fossil/ext/afdkqa_ext/trunk/tests"))
       (mtconf        (with-input-from-pipe (conc "cd "src-mtra" && "mtexe" -show-config -target "target) read))
       (runconf       (with-input-from-pipe (conc "cd "src-mtra" && "mtexe" -show-runconfig -dumpmode sexp -target "target) read))
       (testdir-alist (alist-ref "tests-paths" mtconf equal?))
       (testdirs      (filter safe-file-exists?
                              (append extra-src-testdirs
                                      (list (conc src-mtra "/tests"))
                                      (if (and testdir-alist (not (null? testdir-alist)))
                                          (map cadr testdir-alist)
                                          '()))))
       (tconfigfiles
        (apply append (map (lambda (src-testdir)
                             (with-input-from-pipe (conc "ls -1 "src-testdir"/*/testconfig") read-lines))
                           testdirs)))
       (tconf-alist   (filter identity
                              (map (lambda (tcfile)
                                     (let* ((m (string-match "^.*/([^/]+)/testconfig$" tcfile)))
                                       (if (not (null? m))
                                           (cons (cadr m) tcfile)
                                           #f)))
                                   tconfigfiles))))

;  (pp mtconf)
;  (pp (list 'FOO testdir-alist)) (exit 1)
  ;; make megatest area
  (when (not (file-exists? src-mtdb))
    (ierr "Source does not exist.  Aborting.  [src-mtdb]")
    (exit 1))
  
  (when (file-exists? faux-mtra)
    (system (conc "cd "faux-mtra" && rm -rf $(/p/foundry/env/bin/mttmpdir)"))
    (system (conc "rm -rf "faux-mtra)))
  
  (system (conc "mkdir -p "faux-mtra))
  (system (conc "mkdir -p "faux-mtra"/links"))
  (system (conc "mkdir -p "faux-mtra"/disk0"))

  (system (conc "cd "src-mtra" && "mtexe" -show-config -target "target" -dumpmode ini > "faux-mtra"/megatest.config.in"))
  (crude-config-transformer
   (conc faux-mtra"/megatest.config.in")
   (conc faux-mtra"/megatest.config")
   '("fields" "server" "env-override" "dashboard" "validvalues")
    (conc "[setup]
linktree "faux-mtra"/links
max_concurrent_jobs 1000
launch-delay 5
use-wal 1

" ;; emacs has trouble if a string has [ at the beginning of line, so breaking it up.
"[disks]
disk0 "faux-mtra"/disk0")
    filter-patt: "MT_LINKTREE"
    )

  
  (system (conc "cd "src-mtra" && "mtexe" -show-runconfig -target "target" -dumpmode ini > "faux-mtra"/runconfigs.config"))


  (system (conc "mkdir -p "faux-mtra"/tests"))

  (for-each (lambda (tpair)
              (pp tpair)
              (let* ((testname (car tpair))
                     (src-tconfigfile (cdr tpair))
                     (destdir (conc faux-mtra"/tests/"testname)))
                (do-or-die (conc "mkdir -p "destdir))
                (do-or-die (conc "cp "src-tconfigfile" "destdir"/testconfig.in"))
                (testconfig-transformer
                 (conc destdir"/testconfig.in")
                 (conc destdir"/testconfig"))
                (print "processed test "testname)))
            tconf-alist)
  
  
  )