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 .
+
+# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
+# rm .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)
+)
+
+
+
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -1968,10 +1968,20 @@
(let ((res (read-line)))
(if (string? res)
(string->number res)))))
(get-unix-df path)))
+(define (get-free-inodes path)
+ (if (configf:lookup *configdat* "setup" "free-inodes-script")
+ (with-input-from-pipe
+ (conc (configf:lookup *configdat* "setup" "free-inodes-script") " " path)
+ (lambda ()
+ (let ((res (read-line)))
+ (if (string? res)
+ (string->number res)))))
+ (get-unix-inodes path)))
+
(define (get-unix-df path)
(let* ((df-results (process:cmd-run->list (conc "df " path)))
(space-rx (regexp "([0-9]+)\\s+([0-9]+)%"))
(freespc #f))
;; (write df-results)
@@ -1981,10 +1991,24 @@
(let ((newval (string->number (cadr match))))
(if (number? newval)
(set! freespc newval))))))
(car df-results))
freespc))
+
+(define (get-unix-inodes path)
+ (let* ((df-results (process:cmd-run->list (conc "df -i " path)))
+ (space-rx (regexp "([0-9]+)\\s+([0-9]+)%"))
+ (freenodex #f))
+ ;; (write df-results)
+ (for-each (lambda (l)
+ (let ((match (string-search space-rx l)))
+ (if match
+ (let ((newval (string->number (cadr match))))
+ (if (number? newval)
+ (set! freenodes newval))))))
+ (car df-results))
+ freenodes))
(define (common:check-space-in-dir dirpath required)
(let* ((dbspace (if (directory? dirpath)
(get-df dirpath)
0)))
@@ -2021,11 +2045,12 @@
;; paths is list of lists ((name path) ... )
;;
(define (common:get-disk-with-most-free-space disks minsize)
(let ((best #f)
- (bestsize 0))
+ (bestsize 0)
+ (min-inodes (or (string->number (if (configf:lookup *configdat* "setup" "min_inodes") (configf:lookup *configdat* "setup" "min_inodes") "0")) 0)))
(for-each
(lambda (disk-num)
(let* ((dirpath (cadr (assoc disk-num disks)))
(freespc (cond
((not (directory? dirpath))
@@ -2039,15 +2064,18 @@
((not (eq? (string-ref dirpath 0) #\/))
(if (common:low-noise-print 300 "disks not a proper path " disk-num)
(debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it."))
-1)
(else
- (get-df dirpath)))))
- (if (> freespc bestsize)
+ (get-df dirpath))))
+ (free-inodes (get-free-inodes dirpath)))
+ (if (and (> freespc bestsize)(> free-inodes min-inodes ))
(begin
(set! best (cons disk-num dirpath))
- (set! bestsize freespc)))))
+ (set! bestsize freespc)))
+ ;;(print "Processing: " disk-num " bestsize: " bestsize " best: " best " freespc: " freespc " min-inodes: " min-inodes " free-inodes: " free-inodes)
+ ))
(map car disks))
(if (and best (> bestsize minsize))
best
#f))) ;; #f means no disk candidate found
Index: megatest-version.scm
==================================================================
--- megatest-version.scm
+++ megatest-version.scm
@@ -18,6 +18,6 @@
;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
(declare (unit megatest-version))
-(define megatest-version 1.6530)
+(define megatest-version 1.6531)