ADDED   archive_util/Makefile
Index: archive_util/Makefile
==================================================================
--- /dev/null
+++ archive_util/Makefile
@@ -0,0 +1,26 @@
+#  Copyright 2006-2017, Matthew Welland.
+# 
+# This file is part of Megatest.
+# 
+#     Megatest is free software: you can redistribute it and/or modify
+#     it under the terms of the GNU General Public License as published by
+#     the Free Software Foundation, either version 3 of the License, or
+#     (at your option) any later version.
+# 
+#     Megatest is distributed in the hope that it will be useful,
+#     but WITHOUT ANY WARRANTY; without even the implied warranty of
+#     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+#     GNU General Public License for more details.
+# 
+#     You should have received a copy of the GNU General Public License
+#     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
+
+# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
+# rm <files>.o ; make install CSCOPTS='-profile' ; ... ;  chicken-profile | less
+SHELL=/bin/bash
+PREFIX=$(PWD)
+CSCOPTS=
+INSTALL=install
+
+all: archive.scm
+	csc -static -L -static -L -lsqlite3 -L -lm -L -ldl -L -lpthread archive.scm

ADDED   archive_util/archive.scm
Index: archive_util/archive.scm
==================================================================
--- /dev/null
+++ archive_util/archive.scm
@@ -0,0 +1,76 @@
+(import 
+  big-chicken
+  regex 
+  sqlite3
+)
+
+(define (copy-database workweek)
+  (print "Copy megatest.db to mt_archive/" workweek "/megatest.db")
+  (if (file-exists? (conc "mt_archive/" workweek "/megatest.db"))
+    (begin (print "Archive already exists.  Exiting") (quit))
+  )
+  (if (not (file-exists? (conc "mt_archive/" workweek)))
+    (begin 
+      (print "Create archive dir")
+      (create-directory (conc "mt_archive/" workweek) #t)
+    )
+    (print "Archive dir already exists")
+  )
+  (copy-file "megatest.db" (conc "mt_archive/" workweek "/megatest.db"))
+  (with-output-to-file (conc "mt_archive/" workweek "/megatest.config") 
+    (lambda() (print "[include ../../megatest.config]"))
+  )
+  ;;(create-symbolic-link "megatest.config" (conc "mt_archive/" workweek "/megatest.config"))
+  ;;(create-symbolic-link "configs" (conc "mt_archive/" workweek "/configs"))
+  ;;(create-symbolic-link "runconfigs.config" (conc "mt_archive/" workweek "/runconfigs.config"))
+)
+
+(define (delete-orphan-tests db)
+  (execute db (conc "DELETE FROM tests where run_id NOT IN (select distinct id from runs)"))
+)
+ 
+(define (delete-orphan-steps db)
+  (execute db (conc "DELETE FROM test_steps where test_id NOT IN (select distinct id from tests)"))
+)
+
+(define (vacuum-db db)
+  (execute db (conc "VACUUM;"))
+)
+
+(define (trim-runs file operand timestamp)
+  (print "Trim Runs from " file " where timestamp is " operand " " timestamp)
+  (let* ((db (open-database file))
+         (cmd (conc "DELETE FROM runs WHERE event_time " operand " " timestamp)))
+    (print (database? db))
+    (print "CMD: " cmd)
+    (with-transaction db 
+      (lambda () 
+        (execute db cmd)
+        (delete-orphan-tests db)
+        (delete-orphan-steps db)
+      )
+    )
+    (vacuum-db db)
+  )
+)
+
+(let* ((workweek (string-chomp (call-with-input-pipe "date +%yww%V" (lambda (port) (read-string #f  port))  ) ))
+       (fortyfive-days-ago (- (current-seconds) (* 60 60 24 45)) )
+       ;;(user (get-environment-variable "USER"))
+       (area "libanatmpltsqa")
+       (user (current-user-name))
+       (path (string-translate (current-directory) "/" ".")))
+  (print "Path: " path)
+  (print "User: " user)
+  (print "Megatest.db: "  (conc "/tmp/" user "/megatest_localdb/" area "/" path "/megatest.db") )
+  (print "Megatest_ref.db: "  (conc "/tmp/" user "/megatest_localdb/" area "/" path "/megatest_ref.db") )
+  ;;(quit)
+  (copy-database workweek)
+  (trim-runs "megatest.db" "<" fortyfive-days-ago)
+  (trim-runs (conc "/tmp/" user "/megatest_localdb/" area "/" path "/megatest.db") "<" fortyfive-days-ago)
+  (trim-runs (conc "/tmp/" user "/megatest_localdb/" area "/" path "/megatest_ref.db") "<" fortyfive-days-ago)
+  (trim-runs (conc "mt_archive/" workweek "/megatest.db") ">=" fortyfive-days-ago)
+)
+
+
+