Overview
Context
Changes
Added archive_util/Makefile version [e25a4a3c5e].
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
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 version [6072980f65].
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
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)
)
|
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |