Megatest

Diff
Login

Differences From Artifact [2790622feb]:

To Artifact [290ef6c47a]:


377
378
379
380
381
382
383















384
385
386

387
388
389
390
391
392
393



394
395


396
397
398

399
400
401
402


403
404
405
406
407
408
409

410
411

412
413
414
415
416
417
418
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400

401

402
403
404
405


406
407
408


409
410
411
412

413
414
415
416

417
418
419
420
421
422
423
424

425
426

427
428
429
430
431
432
433
434







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+


-
+
-




-
-
+
+
+
-
-
+
+


-
+



-
+
+






-
+

-
+







	 (map car disks)))
    (if best
	best
	(begin
	  (debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section")
	  (exit 1)))))

;; Desired directory structure:
;;
;;  <linkdir> - <target> - <testname> -.
;;                                     |
;;                                     v
;;  <rundir>  -  <target>  -    <testname> -|- <itempath(s)>
;;
;;  dir stored in test is:
;; 
;;  <linkdir> - <target> - <testname> [ - <itempath> ]
;; 
;; All log file links should be stored relative to the top of link path
;;  
;; <target> - <testname> [ - <itempath> ] 
;;
(define (create-work-area db run-id test-path disk-path testname itemdat)
  (let* ((run-info (db:get-run-info db run-id))
	 (item-path (let ((ip (item-list->path itemdat)))
	 (item-path (item-list->path itemdat))
		      (if (equal? ip "") "" (conc "/" ip))))
	 (runname  (db:get-value-by-header (db:get-row run-info)
					   (db:get-header run-info)
					   "runname"))
	 (key-vals (rdb:get-key-vals db run-id))
	 (key-str  (string-intersperse key-vals "/"))
	 (dfullp   (conc disk-path "/" key-str "/" runname "/" testname
	 (target   (string-intersperse key-vals "/"))
	 ;; nb// if itempath is not "" then it is prefixed with "/"
	 (dfullp   (conc disk-path "/" target "/" runname "/" testname (if (equal? item-path "") "/" "") item-path))
			 item-path))
	 (toptest-path (conc disk-path "/" key-str "/" runname "/" testname))
	 ;; ensure this exists first as links to subtests must be created there
	 (toptest-path (conc disk-path "/" target "/" runname "/" testname))
	 (linktree  (let ((rd (config-lookup *configdat* "setup" "linktree")))
		     (if rd rd (conc *toppath* "/runs"))))
	 (lnkpath  (conc linktree "/" key-str "/" runname item-path)))
	 (lnkpath  (conc linktree "/" target "/" runname item-path)))
    (if (not (file-exists? linktree))
	(begin
	  (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree)
	  (system (conc "mkdir -p " linktree))))
	  (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree))))

    ;; since this is an iterated test this is as good a place as any to
    ;; update the toptest record with its location rundir
    (if (not (equal? item-path ""))
	(db:test-set-rundir! db run-id testname "" toptest-path))
    (debug:print 2 "Setting up test run area")
    (debug:print 2 " - creating run area in " dfullp)
    (system  (conc "mkdir -p " dfullp))
    (create-directory dfullp #t) ;; (system  (conc "mkdir -p " dfullp))
    (debug:print 2 " - creating link from " dfullp "/" testname " to " lnkpath)
    (system  (conc "mkdir -p " lnkpath))
    (create-directory lnkpath #t) ;; (system  (conc "mkdir -p " lnkpath))

    ;; I suspect this section was deleting test directories under some 
    ;; wierd sitations? This doesn't make sense - reenabling the rm -f 

    (let ((testlink (conc lnkpath "/" testname)))
      (if (and (file-exists? testlink)
	       (or (regular-file? testlink)