Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -628,14 +628,28 @@ ;;====================================================================== ;; S Y S T E M S T U F F ;;====================================================================== ;; return a nice clean pathname made absolute -(define (nice-path dir) - (normalize-pathname (if (absolute-pathname? dir) - dir - (conc (current-directory) "/" dir)))) +(define (common:nice-path dir) + (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) + (if match ;; using ~ for home? + (common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match))) + (normalize-pathname (if (absolute-pathname? dir) + dir + (conc (current-directory) "/" dir)))))) + +(define (common:read-link-f path) + (handle-exceptions + exn + (begin + (debug:print 0 "ERROR: command \"/bin/readlink -f " path "\" failed.") + path) ;; just give up + (with-input-from-pipe + (conc "/bin/readlink -f " path) + (lambda () + (read-line))))) (define (get-cpu-load) (car (common:get-cpu-load))) ;; (let* ((load-res (process:cmd-run->list "uptime")) ;; (load-rx (regexp "load average:\\s+(\\d+)")) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -212,11 +212,11 @@ (hash-table-set! settings setting val) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) (configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path)) (full-conf (if (absolute-pathname? include-file) include-file - (nice-path + (common:nice-path (conc (if curr-conf-dir curr-conf-dir ".") "/" include-file))))) (if (file-exists? full-conf) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -12,11 +12,11 @@ ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== (use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv) -(use defstruct) +(use defstruct pathname-expand) (import (prefix base64 base64:)) (import (prefix sqlite3 sqlite3:)) (declare (unit launch)) @@ -946,11 +946,12 @@ #f))) (hash-table-set! *toptest-paths* testname curr-test-path) ;; NB// Was this for the test or for the parent in an iterated test? (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath (if (file-exists? lnkpath) - (resolve-pathname lnkpath) + ;; (resolve-pathname lnkpath) + (common:nice-path lnkpath) lnkpath) testname "") ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path) (if (or (not curr-test-path) (not (directory-exists? toptest-path))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -8,11 +8,12 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) + posix-extras directory-utils pathname-expand) (import (prefix sqlite3 sqlite3:)) (declare (unit runs)) (declare (uses db)) (declare (uses common)) @@ -28,11 +29,11 @@ (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") -(include "debugger.scm") +;; (include "debugger.scm") (define (runs:test-get-full-path test) (let* ((testname (db:test-get-testname test)) (itempath (db:test-get-item-path test))) (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) @@ -161,18 +162,18 @@ (if (runs:lownoise (conc "maxjobgroup " jobgroup) 60) (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit)) #t) (else #f)))) - ;; lets use the debugger eh? - (debugger-start start: 15) - (debugger-trace-var "runs:can-run-more-tests" "") - (debugger-trace-var "can-not-run-more" can-not-run-more) - (debugger-trace-var "num-running" num-running) - (debugger-trace-var "num-running-in-jobgroup" num-running-in-jobgroup) - (debugger-trace-var "job-group-limit" job-group-limit) - (debugger-pauser) +;; ;; lets use the debugger eh? +;; (debugger-start start: 15) +;; (debugger-trace-var "runs:can-run-more-tests" "") +;; (debugger-trace-var "can-not-run-more" can-not-run-more) +;; (debugger-trace-var "num-running" num-running) +;; (debugger-trace-var "num-running-in-jobgroup" num-running-in-jobgroup) +;; (debugger-trace-var "job-group-limit" job-group-limit) +;; (debugger-pauser) (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. @@ -498,16 +499,16 @@ "\n reruns: " reruns "\n items: " items "\n can-run-more: " can-run-more) ;; lets use the debugger eh? - (debugger-start start: 2) - (debugger-trace-var "runs:expand-items" "") - (debugger-trace-var "can-run-more" can-run-more) - (debugger-trace-var "hed" hed) - (debugger-trace-var "prereqs-not-met" (runs:pretty-string prereqs-not-met)) - (debugger-pauser) +;; (debugger-start start: 2) +;; (debugger-trace-var "runs:expand-items" "") +;; (debugger-trace-var "can-run-more" can-run-more) +;; (debugger-trace-var "hed" hed) +;; (debugger-trace-var "prereqs-not-met" (runs:pretty-string prereqs-not-met)) +;; (debugger-pauser) (cond ;; all prereqs met, fire off the test ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch @@ -1050,18 +1051,18 @@ "\n reglen: " reglen "\n length reg: " (length reg) "\n reg: " reg) ;; lets use the debugger eh? - (debugger-start start: 7) - (debugger-trace-var "runs:run-tests-queue" "") - (debugger-trace-var "hed" hed) - (debugger-trace-var "tal" tal) - (debugger-trace-var "items" items) - (debugger-trace-var "item-path" item-path) - (debugger-trace-var "waitons" waitons) - (debugger-pauser) +;; (debugger-start start: 7) +;; (debugger-trace-var "runs:run-tests-queue" "") +;; (debugger-trace-var "hed" hed) +;; (debugger-trace-var "tal" tal) +;; (debugger-trace-var "items" items) +;; (debugger-trace-var "item-path" item-path) +;; (debugger-trace-var "waitons" waitons) +;; (debugger-pauser) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (member test-name waitons) @@ -1677,11 +1678,12 @@ #t) (define (runs:remove-test-directory test mode) ;; remove-data-only) (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree (real-dir (if (file-exists? run-dir) - (resolve-pathname run-dir) + ;; (resolve-pathname run-dir) + (common:nice-path run-dir) #f))) (case mode ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f)) ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f)))