Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -163,10 +163,15 @@ chmod a+x $@ deploytarg/nbfind : utils/nbfind $(INSTALL) $< $@ chmod a+x $@ + +$(PREFIX)/bin/mtest-reaper: helpers/mtest-reaper.scm helpers/ducttape-lib.scm helpers/inteldate.scm helpers/mimetypes.scm + make -C helpers $@ PREFIX=$(PREFIX) INSTALL=$(INSTALL) ARCHSTR=$(ARCHSTR) + +mtest-reaper: $(PREFIX)/bin/mtest-reaper # install dashboard as dboard so wrapper script can be called dashboard $(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard chmod a+x $(PREFIX)/bin/dashboard @@ -177,10 +182,11 @@ $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) + mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib test: tests/tests.scm cd tests;csi -I .. -b -n tests.scm ext-tests/.fslckout : $(MTQA_FOSSIL) @@ -282,5 +288,6 @@ echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ fi portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o + Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -619,21 +619,21 @@ (loop))) (if (common:low-noise-print 30) (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))))) (define (std-exit-procedure) - (on-exit (lambda () #t)) + (on-exit (lambda () 0)) (let ((no-hurry (if *time-to-exit* ;; hurry up #f (begin (set! *time-to-exit* #t) #t)))) (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.") (if (and no-hurry (debug:debug-mode 18)) (rmt:print-db-stats)) (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds - (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated + (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated (if *task-db* (let ((db (cdr *task-db*))) (if (sqlite3:database? db) (begin (sqlite3:interrupt! db) @@ -640,25 +640,32 @@ (sqlite3:finalize! db #t) ;; (vector-set! *task-db* 0 #f) (set! *task-db* #f))))) (if (and *runremote* (remote-conndat *runremote*)) - (close-all-connections!)) ;; for http-client - (close-output-port *default-log-port*) + (begin + (close-all-connections!))) ;; for http-client + (if (not (eq? *default-log-port* (current-error-port))) + (close-output-port *default-log-port*)) (set! *default-log-port* (current-error-port))) "Cleanup db exit thread")) (th2 (make-thread (lambda () (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...") (if no-hurry - (thread-sleep! 5) ;; give the clean up few seconds to do it's stuff - (thread-sleep! 2)) - (debug:print 4 *default-log-port* " ... done") - ) + (begin + (thread-sleep! 5)) ;; give the clean up few seconds to do it's stuff + (begin + (thread-sleep! 2))) + (debug:print 4 *default-log-port* " ... done") + ) "clean exit"))) (thread-start! th1) (thread-start! th2) - (thread-join! th1)) - )) + (thread-join! th1) + ) + ) + + 0) (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) (debug:print-error 0 *default-log-port* "Received signal " signum " exiting promptly") DELETED inteldate.scm Index: inteldate.scm ================================================================== --- inteldate.scm +++ /dev/null @@ -1,180 +0,0 @@ -(use srfi-19) -(use test) -(use format) -(use regex) -(declare (unit inteldate)) -;; utility procedures to convert among -;; different ways to express date (inteldate, seconds since epoch, isodate) -;; -;; samples: -;; isodate -> "2016-01-01" -;; inteldate -> "16ww01.5" -;; seconds -> 1451631600 - -;; procedures provided: -;; ==================== -;; seconds->isodate -;; seconds->inteldate -;; -;; isodate->seconds -;; isodate->inteldate -;; -;; inteldate->seconds -;; inteldate->isodate - -;; srfi-19 used extensively; this doc is better tha the eggref: -;; http://srfi.schemers.org/srfi-19/srfi-19.html - -;; Author: brandon.j.barclay@intel.com 16ww18.6 - -(define (date->seconds date) - (inexact->exact - (string->number - (date->string date "~s")))) - -(define (seconds->isodate seconds) - (let* ((date (seconds->date seconds)) - (result (date->string date "~Y-~m-~d"))) - result)) - -(define (isodate->seconds isodate) - "Takes a string input of the form 'YY-MM-DD' or 'YYYY-MM-DD' and returns epoch time; for YY, assume after Y2K" - (let* ((numlist (map string->number (string-split isodate "-"))) - (raw-year (car numlist)) - (year (if (< raw-year 100) (+ raw-year 2000) raw-year)) - (month (list-ref numlist 1)) - (day (list-ref numlist 2)) - (date (make-date 0 0 0 0 day month year)) - (seconds (date->seconds date))) - - seconds)) - -;; adapted from perl Intel::WorkWeek perl module -;; intel year consists of numbered weeks starting from week 1 -;; week 1 is the week containing jan 1 of the year -;; days of week are numbered starting from 0 on sunday -;; intel year does not match calendar year in workweek 1 -;; before jan1. -(define (seconds->inteldate-values seconds) - (define (date-difference->seconds d1 d2) - (- (date->seconds d1) (date->seconds d2))) - - (let* ((thisdate (seconds->date seconds)) - (thisdow (string->number (date->string thisdate "~w"))) - - (year (date-year thisdate)) - ;; intel workweek 1 begins on sunday of week containing jan1 - (jan1 (make-date 0 0 0 0 1 1 year)) - (jan1dow (date-week-day jan1)) - (ww01 (date-subtract-duration jan1 (seconds->time (* 60 60 24 jan1dow)))) - - (ww01_delta_seconds (date-difference->seconds thisdate ww01)) - (wwnum_initial (inexact->exact (add1 (floor (/ ww01_delta_seconds 24 3600 7) )))) - - ;; we could be in ww1 of next year - (this-saturday (seconds->date - (+ seconds - (* 60 60 24 (- 6 thisdow))))) - (this-week-ends-next-year? - (> (date-year this-saturday) year)) - (intelyear - (if this-week-ends-next-year? - (add1 year) - year)) - (intelweek - (if this-week-ends-next-year? - 1 - wwnum_initial))) - (values intelyear intelweek thisdow))) - -(define (seconds->inteldate seconds) - (define (string-leftpad in width pad-char) - (let* ((unpadded-str (->string in)) - (padlen_temp (- width (string-length unpadded-str))) - (padlen (if (< padlen_temp 0) 0 padlen_temp)) - (padding - (fold conc "" - (map (lambda (x) (->string pad-char)) (iota padlen))))) - (conc padding unpadded-str))) - (define (zeropad num width) - (string-leftpad num width #:0)) - - (let-values (((intelyear intelweek day-of-week-num) - (seconds->inteldate-values seconds))) - (let ((intelyear-str - (zeropad - (->string - (if (> intelyear 1999) - (- intelyear 2000) intelyear)) - 2)) - (intelweek-str - (zeropad (->string intelweek) 2)) - (dow-str (->string day-of-week-num))) - (conc intelyear-str "ww" intelweek-str "." dow-str)))) - -(define (isodate->inteldate isodate) - (seconds->inteldate - (isodate->seconds isodate))) - -(define (inteldate->seconds inteldate) - (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" inteldate))) - (if - (not match) - #f - (let* ( - (intelyear-raw (string->number (list-ref match 1))) - (intelyear (if (< intelyear-raw 100) - (+ intelyear-raw 2000) - intelyear-raw)) - (intelww (string->number (list-ref match 2))) - (dayofweek (string->number (list-ref match 3))) - - (day-of-seconds (* 60 60 24 )) - (week-of-seconds (* day-of-seconds 7)) - - - ;; get seconds at ww1.0 - (new-years-date (make-date 0 0 0 0 1 1 intelyear)) - (new-years-seconds - (date->seconds new-years-date)) - (new-years-dayofweek (date-week-day new-years-date)) - (ww1.0_seconds (- new-years-seconds - (* day-of-seconds - new-years-dayofweek))) - (workweek-adjustment (* week-of-seconds (sub1 intelww))) - (weekday-adjustment (* dayofweek day-of-seconds)) - - (result (+ ww1.0_seconds workweek-adjustment weekday-adjustment))) - result)))) - -(define (inteldate->isodate inteldate) - (seconds->isodate (inteldate->seconds inteldate))) - -(define (inteldate-tests) - (test-group - "date conversion tests" - (let ((test-table - '(("16ww01.5" . "2016-01-01") - ("16ww18.5" . "2016-04-29") - ("1999ww33.5" . "1999-08-13") - ("16ww18.4" . "2016-04-28") - ("16ww18.3" . "2016-04-27") - ("13ww01.0" . "2012-12-30") - ("13ww52.6" . "2013-12-28") - ("16ww53.3" . "2016-12-28")))) - (for-each - (lambda (test-pair) - (let ((inteldate (car test-pair)) - (isodate (cdr test-pair))) - (test - (conc "(isodate->inteldate "isodate ") => "inteldate) - inteldate - (isodate->inteldate isodate)) - - (test - (conc "(inteldate->isodate "inteldate ") => "isodate) - isodate - (inteldate->isodate inteldate)))) - test-table)))) - -;(inteldate-tests) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -858,11 +858,14 @@ (directory-exists? *toppath*)) (begin (setenv "MT_RUN_AREA_HOME" *toppath*) (setenv "MT_TESTSUITE_NAME" (common:get-testsuite-name))) (begin - (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area."))) + (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.") + ;;(exit 1) + #f + )) *toppath*)) (define (get-best-disk confdat testconfig) (let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f)) (hash-table-ref/default confdat "disks" #f)))