Megatest

Check-in [a8d26e966f]
Login
Overview
Comment:Reworked -remove-runs; remove directories immediately after removing record, remove run dir then remove link, added lots of error checking
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: a8d26e966f932eab0aec6542847b868245e2806d
User & Date: matt on 2012-04-19 00:00:53
Other Links: manifest | tags
Context
2012-04-19
00:09
Made xterms wider and shorter for run launching and test removal check-in: f195933f52 user: matt tags: trunk
00:00
Reworked -remove-runs; remove directories immediately after removing record, remove run dir then remove link, added lots of error checking check-in: a8d26e966f user: matt tags: trunk
2012-04-18
12:38
Added missing header check-in: 9d84a5eddb user: matt tags: trunk
Changes

Modified db.scm from [db3cfeefe8] to [d9d220533b].

429
430
431
432
433
434
435
436



437
438
439
440
441
442
443
444
445
446
447

448
449

450
451
452
453
454
455
456
;;  T E S T S
;;======================================================================

;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
;; i.e. these lists define what to NOT show.
;; states and statuses are required to be lists, empty is ok
;; not-in #t = above behaviour, #f = must match
(define (db:get-tests-for-run db run-id testpatt itempatt states statuses #!key (not-in #t))



  (let* ((res '())
	 ;; if states or statuses are null then assume match all when not-in is false
	 (states-str    (conc " state in ('" (string-intersperse states   "','") "')"))
	 (statuses-str  (conc " status in ('" (string-intersperse statuses "','") "')"))
	 (state-status-qry (if (or (not (null? states))
				   (not (null? states)))
			       (conc " AND " (if not-in "NOT" "") " (" states-str " AND " statuses-str ") ")
			       ""))
	 (qry      (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment "
			 " FROM tests WHERE run_id=? AND testname like ? AND item_path LIKE ? " 
			 state-status-qry

			 ;; " ORDER BY id DESC;"
			 " ORDER BY event_time ASC;" ;; POTENTIAL ISSUE! CHECK ME! Does anyting depend on this being sorted by id?

			 )))
    (debug:print 8 "INFO: db:get-tests-for-run qry=" qry)
    (sqlite3:for-each-row 
     (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
       (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
     db 
     qry







|
>
>
>











>
|
|
>







429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
;;  T E S T S
;;======================================================================

;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN
;; i.e. these lists define what to NOT show.
;; states and statuses are required to be lists, empty is ok
;; not-in #t = above behaviour, #f = must match
(define (db:get-tests-for-run db run-id testpatt itempatt states statuses 
			      #!key (not-in #t)
			      (sort-by #f) ;; 'rundir 'event_time
			      )
  (let* ((res '())
	 ;; if states or statuses are null then assume match all when not-in is false
	 (states-str    (conc " state in ('" (string-intersperse states   "','") "')"))
	 (statuses-str  (conc " status in ('" (string-intersperse statuses "','") "')"))
	 (state-status-qry (if (or (not (null? states))
				   (not (null? states)))
			       (conc " AND " (if not-in "NOT" "") " (" states-str " AND " statuses-str ") ")
			       ""))
	 (qry      (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment "
			 " FROM tests WHERE run_id=? AND testname like ? AND item_path LIKE ? " 
			 state-status-qry
			 (case sort-by
			   ((rundir)     " ORDER BY length(rundir) DESC;")
			   ((event_time) " ORDER BY event_time ASC;")
			   (else         ";"))
			 )))
    (debug:print 8 "INFO: db:get-tests-for-run qry=" qry)
    (sqlite3:for-each-row 
     (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment)
       (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res)))
     db 
     qry

Modified runs.scm from [757a50bdeb] to [e2a9d896d7].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20

;; Copyright 2006-2011, 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.

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18))
(import (prefix sqlite3 sqlite3:))

(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20

;; Copyright 2006-2011, 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.

;;  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)
(import (prefix sqlite3 sqlite3:))

(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
514
515
516
517
518
519
520
521





522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542


543
544
545
546
547
548
549
550
551
552
553
554
555
556



557

558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
     (lambda (run)
       (let ((runkey (string-intersperse (map (lambda (k)
						(db:get-value-by-header run header (vector-ref k 0))) keys) "/"))
	     (dirs-to-remove (make-hash-table)))
	 (let* ((run-id    (db:get-value-by-header run header "id"))
		(run-state (db:get-value-by-header run header "state"))
		(tests     (if (not (equal? run-state "locked"))
			       (rdb:get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt states statuses not-in: #f)





			       '()))
		(lasttpath "/does/not/exist/I/hope"))

	   (if (not (null? tests))
	       (begin
		 (case action
		   ((remove-runs)
		    (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   ((set-state-status)
		    (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   (else
		    (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)))
		      (debug:print 1 "  " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path)
		      (case action
			((remove-runs)
			 (rdb:delete-test-records db (db:test-get-id test))


			 (if (> (string-length run-dir) 5) ;; bad heuristic but should prevent /tmp /home etc.
			     (let ((fullpath run-dir)) ;; "/" (db:test-get-item-path test))))
			       (set! lasttpath fullpath)
			       (hash-table-set! dirs-to-remove fullpath #t)
			       ;; The following was the safe delete code but it was not being exectuted.
			       ;; (let* ((dirs-count (+ 1 (length keys)(length (string-split item-path "/"))))
			       ;;        (dir-to-rem (get-dir-up-n fullpath dirs-count))
			       ;;        (remainingd (string-substitute (regexp (conc "^" dir-to-rem "/")) "" fullpath))
			       ;;        (cmd (conc "cd " dir-to-rem "; rmdir -p " remainingd )))
			       ;;   (if (file-exists? fullpath)
			       ;;       (begin
			       ;;         (debug:print 1 cmd)
			       ;;         (system cmd)))
			       ;;   ))



			       )))

			((set-state-status)
			 (debug:print 4 "INFO: new state " (car state-status) ", new status " (cadr state-status))
			 (db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f)))))
		  tests)))

	   ;; look though the dirs-to-remove for candidates for removal. Do this after deleting the records
	   ;; for each test in case we get killed. That should minimize the detritus left on disk
	   ;; process the dirs from longest string length to shortest
	   (if (eq? action 'remove-runs)
	       (for-each 
		(lambda (dir-to-remove)
		  (if (file-exists? dir-to-remove)
		      (let ((dir-in-db '()))
			(sqlite3:for-each-row
			 (lambda (dir)
			   (set! dir-in-db (cons dir dir-in-db)))
			 db "SELECT rundir FROM tests WHERE rundir LIKE ?;" 
			 (conc "%" dir-to-remove "%")) ;; yes, I'm going to bail if there is anything like this dir in the db
			(if (null? dir-in-db)
			    (begin
			      (debug:print 2 "Removing directory with zero db references: " dir-to-remove)
			      (system (conc "rm -rf " dir-to-remove))
			      (hash-table-delete! dirs-to-remove dir-to-remove))
			    (debug:print 2 "Skipping removal of " dir-to-remove " for now as it still has references in the database")))))
		(sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string-length a)(string-length b))))))

	   ;; remove the run if zero tests remain
	   (if (eq? action 'remove-runs)
	       (let ((remtests (rdb:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '() '())))
		 (if (null? remtests) ;; no more tests remaining
		     (let* ((dparts  (string-split lasttpath "/"))
			    (runpath (conc "/" (string-intersperse 
						(take dparts (- (length dparts) 1))







|
>
>
>
>
>

















|



>
>
|
|
|
|
<
<
|
|
|
|
|
|
|
|
>
>
>
|
>

|


|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553


554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571





















572
573
574
575
576
577
578
     (lambda (run)
       (let ((runkey (string-intersperse (map (lambda (k)
						(db:get-value-by-header run header (vector-ref k 0))) keys) "/"))
	     (dirs-to-remove (make-hash-table)))
	 (let* ((run-id    (db:get-value-by-header run header "id"))
		(run-state (db:get-value-by-header run header "state"))
		(tests     (if (not (equal? run-state "locked"))
			       (rdb:get-tests-for-run db (db:get-value-by-header run header "id")
						      testpatt itempatt states statuses
						      not-in:  #f
						      sort-by: (case action
								 ((remove-runs) 'rundir)
								 (else          'event_time)))
			       '()))
		(lasttpath "/does/not/exist/I/hope"))

	   (if (not (null? tests))
	       (begin
		 (case action
		   ((remove-runs)
		    (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   ((set-state-status)
		    (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   (else
		    (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)))
		      (debug:print 1 "  " (db:test-get-testname test) " id: " (db:test-get-id test) " " item-path " action: " action)
		      (case action
			((remove-runs)
			 (rdb:delete-test-records db (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)))
			((set-state-status)
			 (debug:print 2 "INFO: new state " (car state-status) ", new status " (cadr state-status))
			 (db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f)))))
		  tests)))
	   





















	   ;; remove the run if zero tests remain
	   (if (eq? action 'remove-runs)
	       (let ((remtests (rdb:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '() '())))
		 (if (null? remtests) ;; no more tests remaining
		     (let* ((dparts  (string-split lasttpath "/"))
			    (runpath (conc "/" (string-intersperse 
						(take dparts (- (length dparts) 1))

Modified utils/installall.sh from [de06fe7884] to [4c61ffb6b8].

62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
    tar xfvz chicken-${CHICKEN_VERSION}.tar.gz
    cd chicken-${CHICKEN_VERSION}
    make PLATFORM=linux PREFIX=$PREFIX
    make PLATFORM=linux PREFIX=$PREFIX install
    cd $BUILDHOME
fi

for f in readline apropos base64 regex-literals format regex-case test coops trace csv dot-locking; do
  chicken-install $PROX $f
done

cd $BUILDHOME

for a in `ls */*.meta|cut -f1 -d/` ; do 
    echo $a







|







62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
    tar xfvz chicken-${CHICKEN_VERSION}.tar.gz
    cd chicken-${CHICKEN_VERSION}
    make PLATFORM=linux PREFIX=$PREFIX
    make PLATFORM=linux PREFIX=$PREFIX install
    cd $BUILDHOME
fi

for f in readline apropos base64 regex-literals format regex-case test coops trace csv dot-locking posix-utils directory-utils; do
  chicken-install $PROX $f
done

cd $BUILDHOME

for a in `ls */*.meta|cut -f1 -d/` ; do 
    echo $a