Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -49,11 +49,11 @@ (else (debug:print 0 "ERROR: synchronous must be 0,1,2,OFF,NORMAL or FULL, you provided: " syncval) #f)))) (if val (begin - (debug:print 2 "INFO: Setting pragma synchronous to " val) + (debug:print 4 "INFO: Setting pragma synchronous to " val) (sqlite3:execute db (conc "PRAGMA synchronous = '" val "';")))))) (define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) (dbexists (file-exists? dbpath)) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.50) +(??)(define megatest-version 1.501") Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -217,10 +217,23 @@ (print "ERROR: Invalid debug value " (args:get-arg "-debug")) (exit))) (if (> *verbosity* 3) ;; we are obviously debugging (set! open-run-close open-run-close-no-exception-handling)) + +;; to try and not burden Kim too much... +(if (args:get-arg "-itempatt") + (let ((old-testpatt (args:get-arg "-testpatt"))) + (debug:print 0 "ERROR: parameter \"-itempatt\" has been deprecated. For now I will tweak your -testpatt for you") + (hash-table-set! args:arg-hash "-testpatt" (conc old-testpatt "/" (args:get-arg "-itempatt"))) + (debug:print 0 " old: " old-testpatt ", new: " (args:get-arg "-testpatt")) + (if (args:get-arg "-runtests") + (begin + (debug:print 0 "NOTE: Also modifying -runtests") + (hash-table-set! args:arg-hash "-runtests" (conc (args:get-arg "-runtests") "/" + (args:get-arg "-itempatt"))))) + )) ;;====================================================================== ;; Misc general calls ;;====================================================================== Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -749,41 +749,49 @@ (print "INFO: action not recognised " action))) (for-each (lambda (test) (let* ((item-path (db:test-get-item-path test)) (test-name (db:test-get-testname test)) - (run-dir (db:test-get-rundir test)) + (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) + #f)) (test-id (db:test-get-id test))) ;; (tdb (db:open-test-db run-dir))) - (debug:print 1 "INFO: test=" test) ;; " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path " action: " action) + (debug:print 4 "INFO: test=" test) ;; " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path " action: " action) (case action ((remove-runs) ;; the tdb is for future possible. (open-run-close db:delete-test-records db #f (db:test-get-id test)) - (debug:print 1 "INFO: Attempting to remove dir " run-dir) - (if (and (> (string-length run-dir) 5) - (file-exists? run-dir)) ;; bad heuristic but should prevent /tmp /home etc. - (let* ((realpath (resolve-pathname run-dir))) - (debug:print 1 "INFO: Real path of is " realpath) - (if (file-exists? realpath) - (if (> (system (conc "rm -rf " realpath)) 0) - (debug:print 0 "ERROR: There was a problem removing " realpath " with rm -f")) - (debug:print 0 "WARNING: test run dir " realpath " appears to not exist")) - (if (file-exists? run-dir) ;; the link - (if (symbolic-link? run-dir) - (delete-file run-dir) - (if (directory? run-dir) - (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0) - (debug:print 0 "WARNING: refusing to remove " run-dir " as it is not empty") - (delete-directory run-dir)) ;; it should be empty by here BUG BUG, add error catch - (debug:print 0 "ERROR: refusing to remove " run-dir " as it is neither a symlink nor a directory") - )))) - (debug:print 0 "WARNING: directory already removed " run-dir))) + (debug:print 1 "INFO: Attempting to remove dir " real-dir " and link " run-dir) + (if (and real-dir + (> (string-length real-dir) 5) + (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. + (begin ;; let* ((realpath (resolve-pathname run-dir))) + (debug:print 1 "INFO: Recursively removing " real-dir) + (if (file-exists? real-dir) + (if (> (system (conc "rm -rf " real-dir)) 0) + (debug:print 0 "ERROR: There was a problem removing " real-dir " with rm -f")) + (debug:print 0 "WARNING: test run dir " real-dir " appears to not exist"))) + (debug:print 0 "WARNING: directory " real-dir " does not exist")) + (if (symbolic-link? run-dir) + (begin + (debug:print 1 "INFO: Removing symlink " run-dir) + (delete-file run-dir)) + (if (directory? run-dir) + (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0) + (debug:print 0 "WARNING: refusing to remove " run-dir " as it is not empty") + (delete-directory run-dir)) ;; it should be empty by here BUG BUG, add error catch + (debug:print 0 "ERROR: refusing to remove " run-dir " as it either doesn't exist or is not a symlink or directory") + ))) ((set-state-status) (debug:print 2 "INFO: new state " (car state-status) ", new status " (cadr state-status)) (open-run-close db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f))))) - tests))) - + (sort tests (lambda (a b)(let ((dira (db:test-get-rundir a)) + (dirb (db:test-get-rundir b))) + (if (and (string? dira)(string? dirb)) + (> (string-length dira)(string-length dirb)) + #f))))))) ;; remove the run if zero tests remain (if (eq? action 'remove-runs) (let ((remtests (open-run-close db:get-tests-for-run db (db:get-value-by-header run header "id") #f '("DELETED") '("n/a") not-in: #t))) (if (null? remtests) ;; no more tests remaining (let* ((dparts (string-split lasttpath "/"))