@@ -15,31 +15,31 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) - posix-extras directory-utils pathname-expand typed-records format sxml-serializer - sxml-modifications matchable) - -(declare (unit runs)) -(declare (uses db)) -(declare (uses common)) -(declare (uses items)) -(declare (uses runconfig)) -(declare (uses tests)) -(declare (uses server)) -(declare (uses mt)) -(declare (uses archive)) -;; (declare (uses filedb)) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "test_records.scm") - +;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) +;; posix-extras directory-utils pathname-expand typed-records format sxml-serializer +;; sxml-modifications matchable) +;; +;; (declare (unit runs)) +;; (declare (uses db)) +;; (declare (uses common)) +;; (declare (uses items)) +;; (declare (uses runconfig)) +;; (declare (uses tests)) +;; (declare (uses server)) +;; (declare (uses mt)) +;; (declare (uses archive)) +;; ;; (declare (uses filedb)) +;; +;; (include "common_records.scm") +;; (include "key_records.scm") +;; (include "db_records.scm") +;; (include "run_records.scm") +;; (include "test_records.scm") +;; ;; (include "debugger.scm") ;; use this struct to facilitate refactoring ;; @@ -128,11 +128,11 @@ (endt (+ startt duration))) ((or proc runs:parallel-runners-mgmt) rdat) (let loop () (let* ((wstart (current-seconds))) (if (< wstart endt) - (let* ((work-time (random 10))) + (let* ((work-time (pseudo-random-integer 10))) #;(debug:print-info 0 *default-log-port* "working for " work-time " seconds. Total work: " rtime ", elapsed time: " (- wstart startt)) (thread-sleep! work-time) (set! rtime (+ rtime work-time)) ((or proc runs:parallel-runners-mgmt) rdat) @@ -508,11 +508,11 @@ (keyvals (keys:target->keyval keys target)) (run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name))) ;; (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config")) (dbfile (conc *toppath* "/megatest.db")) - (readonly-mode (not (file-write-access? dbfile))) + (readonly-mode (not (file-writable? dbfile))) (test-records (make-hash-table)) ;; need to process runconfigs before generating these lists (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names #f) ;; (hash-table-keys all-tests-registry)) (test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts)) @@ -2342,11 +2342,11 @@ (keep-records (args:get-arg "-keep-records")) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode". (test-records '())) ;; for tasks that we wish to operate on all tests in one fell swoop (let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs)) (dbfile (conc *toppath* "/megatest.db")) - (readonly-mode (not (file-write-access? dbfile)))) + (readonly-mode (not (file-writable? dbfile)))) (when (and readonly-mode (member action write-access-actions)) (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .") (exit 1))) @@ -2565,11 +2565,11 @@ (substring-index run-name rundir) (tests:glob-like-match (conc "%/" target "/%") rundir) ) (begin (set! lasttpath (db:test-get-rundir new-test-dat)) ;; remember this path for run removal - (set! lastrealpath (remove-last-path-directory (resolve-pathname lasttpath))) + (set! lastrealpath (remove-last-path-directory (realpath lasttpath))) (hash-table-set! run-paths-hash lastrealpath 1) (runs:remove-test-directory new-test-dat mode) ;; 'remove-all) ) (begin (debug:print 2 *default-log-port* "Not removing directory " rundir " because either it doesn't exist or has a bad name") @@ -2733,11 +2733,11 @@ ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f))) (debug:print-info 1 *default-log-port* "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) (if (and real-dir (> (string-length real-dir) 5) (common:file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. - (let* ((realpath (resolve-pathname run-dir))) + (let* ((realpath (realpath run-dir))) (debug:print-info 1 *default-log-port* "Recursively removing " realpath) (if (common:file-exists? realpath) (runs:safe-delete-test-dir realpath) (debug:print 0 *default-log-port* "WARNING: test dir " realpath " appears to not exist or is not readable"))) (if real-dir @@ -2959,12 +2959,11 @@ '(*TOP* (*PI* xml "version='1.0'") (testsuite))) (define (runs:update-junit-test-reporter-xml run-id) - (let* ( - (junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml")) + (let* ((junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml")) (junit-test-report-dir (configf:lookup *configdat* "runs" "junit-test-report-dir")) (xml-dir (if (and junit-test-reporter (equal? junit-test-reporter "yes" )) (if junit-test-report-dir junit-test-report-dir (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))) @@ -3003,33 +3002,33 @@ (test-state (vector-ref test 3)) (comment (vector-ref test 14)) (test-status (vector-ref test 4)) (exc-msg (conc "No bucket for State " test-state " Status " test-status)) (new-doc (cond - ((member test-state (list "RUNNING" )) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc)) - ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc)) - ((member test-status (list "PASS" "WARN" "WAIVED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc)) - ((member test-status (list "FAIL" "CHECK")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc)) - ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc)) - ((member test-status (list "SKIP")) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc)) - (else - (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status)) - ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc)))) - (new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) - (+ error-cnt 1) - error-cnt)) - (new-fail-cnt (if (member test-status (list "FAIL" "CHECK")) - (+ fail-cnt 1) - fail-cnt))) + ((member test-state (list "RUNNING" )) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc)) + ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc)) + ((member test-status (list "PASS" "WARN" "WAIVED")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc)) + ((member test-status (list "FAIL" "CHECK")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc)) + ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc)) + ((member test-status (list "SKIP")) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc)) + (else + (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status)) + ((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc)))) + (new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) + (+ error-cnt 1) + error-cnt)) + (new-fail-cnt (if (member test-status (list "FAIL" "CHECK")) + (+ fail-cnt 1) + fail-cnt))) (if (null? tail) - (let* ((final-doc ((sxml-modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc))) + (let* ((final-doc ((modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc))) (debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt) (handle-exceptions exn (let* ((msg ((condition-property-accessor 'exn 'message) exn))) (debug:print 0 *default-log-port* (conc "WARNING: Failed to update file" xml-path". Message:" msg ", exn=" exn)))