Megatest

Artifact [01bb33e0f6]
Login

Artifact 01bb33e0f65c8d7eda0b715b5758aabc88999106:


;;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

;;======================================================================
;; Test info panel
;;======================================================================

(use format fmt)
(require-library iup)
(import (prefix iup iup:))

(use canvas-draw)

(use srfi-1 posix regex regex-case srfi-69)
(use (prefix sqlite3 sqlite3:))

(declare (unit dashboard-context-menu))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")


(define (dashboard:run-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info)
  (list
   (iup:menu-item
    (conc "Rerun " testpatt)
    #:action
    (lambda (obj)
      ;; (print  " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path)
      (common:run-a-command
       (conc "megatest -run -target " target
             " -runname " runname
             " -testpatt " testpatt
             " -preclean -clean-cache")
       )))
   (iup:menu-item
    "Rerun Complete Run"
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
             " -runname " runname
             " -testpatt % "
             " -preclean -clean-cache"))))
   (iup:menu-item
    "Clean Complete Run"
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -remove-runs -target " target
             " -runname " runname
             " -testpatt % "))))
   (iup:menu-item 
    "Kill Complete Run"
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt % "
             "  -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))
   (iup:menu-item 
    "Delete Run Data"
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -remove-runs -target " target
             " -runname " runname
             " -testpatt % "
             "  -keep-records"))))))

(define (dashboard:test-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info)
  (list
   (iup:menu-item
    (conc "Rerun " item-test-path)
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
             " -runname " runname
             " -testpatt " item-test-path
             " -preclean -clean-cache"))))
   (iup:menu-item
    (conc "Kill " item-test-path)
    #:action
    (lambda (obj)
      ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt " item-test-path 
             " -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
   (iup:menu-item
    (conc "Delete data : " item-test-path)
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -remove-runs -target " target
             " -runname " runname
             " -testpatt " item-test-path 
             " -keep-records"))))
   (iup:menu-item
    (conc "Clean "item-test-path)
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -remove-runs -target " target
             " -runname " runname
             " -testpatt " item-test-path))))
   (iup:menu-item
    "Start xterm"
    #:action
    (lambda (obj)
      (dcommon:examine-xterm run-id test-id)))
   ;;(let* ((cmd (conc (car (argv)) " -xterm " run-id "," test-id "&")))
   ;; (system cmd))))
   (iup:menu-item
    "Edit testconfig"
    #:action
    (lambda (obj)
      (let* ((all-tests (tests:get-all))
             (editor-rx (or (configf:lookup *configdat* "setup" "editor-regex") 
                            "\\b(vim?|nano|pico)\\b"))
             (editor (or (configf:lookup *configdat* "setup" "editor")
                         (get-environment-variable "VISUAL")
                         (get-environment-variable "EDITOR") "vi"))
             (tconfig (conc (hash-table-ref all-tests test-name) "/testconfig"))
             (cmd (conc (if (string-search editor-rx editor)
                            (conc "xterm -e " editor)
                            editor)
                        " " tconfig " &")))
        (system cmd))))))

(define (dashboard:toplevel-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info)
  (list
   (iup:menu-item
    (conc "Rerun " item-test-path)
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
             " -runname " runname
             " -testpatt " item-test-path
             " -preclean -clean-cache"))))
   
   (iup:menu-item
    "Start xterm"
    #:action
    (lambda (obj)
      (dcommon:examine-xterm run-id test-id)))
   
   (iup:menu-item
    (conc "Kill " item-test-path)
    #:action
    (lambda (obj)
      ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt " item-test-path 
             " -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))
   
   (let* ((rundir    (db:test-get-rundir      test-info))
          (has-subrun (subrun:subrun-test-initialized? rundir)))
     (if has-subrun
         (iup:menu-item
          "Launch subrun dashboard"
          #:action
          (lambda (obj)
            (subrun:launch-dashboard rundir)))
         (iup:vbox)))
   (iup:menu 
    (iup:menu-item
     "Test Control Panel"
     #:action
     (lambda (obj)
       (launch-testpanel run-id test-id)))
    
    (iup:menu-item
     (conc "View Log " item-test-path)
     #:action
     (lambda (obj)
       (let* ((rundir    (db:test-get-rundir      test-info))
              (logf      (db:test-get-final_logf  test-info))
              (fullfile  (conc rundir "/" logf)))
         (if (common:file-exists? fullfile)
             (dcommon:run-html-viewer fullfile)
             (message-window (conc "file " fullfile " not found.")))))
     )
    (let* ((steps (tests:get-compressed-steps run-id test-id))   ;; #<stepname start end status Duration Logfile Comment id>
           (rundir (db:test-get-rundir test-info)))
      (iup:menu-item
       "Step logs"
       (apply iup:menu
              (map (lambda (step)
                     (let ((stepname (vector-ref step 0))
                           (logfile  (vector-ref step 5))
                           (status   (vector-ref step 3)))
                       (iup:menu-item
                        (conc stepname "/" (if (string=? logfile "") "no log!" logfile) " (" status ")")
                        #:action (lambda (obj)
                                   (let ((fullfile (conc rundir "/" logfile)))
                                     (if (common:file-exists? fullfile)
                                         (dcommon:run-html-viewer fullfile)
                                         (message-window (conc "file " fullfile " not found"))))))))
                   steps)))))))

(define (dashboard:custom-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info)
  '())

(define (dashboard:context-menu  run-id test-id target runname test-name testpatt item-test-path test-info)
  (let* (
         (run-menu-items
          (dashboard:run-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info))
         (test-menu-items
          (dashboard:test-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info))
         (custom-menu-items
          (dashboard:custom-menu-items run-id test-id target runname test-name testpatt item-test-path test-info))
         (toplevel-menu-items
          (dashboard:toplevel-menu-items  run-id test-id target runname test-name testpatt item-test-path test-info))
         )
    (apply iup:menu
           `(,@toplevel-menu-items
             ,(iup:menu-item
              "Run"
              (apply iup:menu run-menu-items))
             ,(iup:menu-item
              "Test"
              (apply iup:menu test-menu-items))
             ,@(if (null? custom-menu-items)
                   '()
                   custom-menu-items)))))