Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -22,12 +22,12 @@
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \
server.scm configf.scm db.scm keys.scm margs.scm \
process.scm runs.scm tasks.scm tests.scm genexample.scm \
- http-transport.scm filedb.scm tdb.scm client.scm mt.scm \
- ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \
+ http-transport.scm tdb.scm client.scm mt.scm \
+ ezsteps.scm lock-queue.scm rmt.scm api.scm \
subrun.scm portlogger.scm archive.scm env.scm \
diff-report.scm cgisetup/models/pgdb.scm
# module source files
MSRCFILES = dbmod.scm dbfile.scm debugprint.scm mtargs.scm
@@ -459,12 +459,12 @@
fi
if csi -ne '(use postgresql)';then \
echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
fi
-portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
- csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o synchash.o tasks.o tdb.o tests.o tree.o
+ csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o synchash.o tasks.o tdb.o tests.o tree.o
# create a pdf dot graphviz diagram from notations in rmt.scm
rmt.pdf : rmt.scm
grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf
ADDED attic/filedb.scm
Index: attic/filedb.scm
==================================================================
--- /dev/null
+++ attic/filedb.scm
@@ -0,0 +1,255 @@
+;; Copyright 2006-2011, 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 .
+;;
+
+;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex)
+(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (unit filedb))
+
+(include "fdb_records.scm")
+;; (include "settings.scm")
+
+(define (filedb:open-db dbpath)
+ (let* ((fdb (make-filedb:fdb))
+ (dbexists (common:file-exists? dbpath))
+ (db (sqlite3:open-database dbpath)))
+ (filedb:fdb-set-db! fdb db)
+ (filedb:fdb-set-dbpath! fdb dbpath)
+ (filedb:fdb-set-pathcache! fdb (make-hash-table))
+ (filedb:fdb-set-idcache! fdb (make-hash-table))
+ (filedb:fdb-set-partcache! fdb (make-hash-table))
+ (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
+ (if (not dbexists)
+ (begin
+ (sqlite3:execute db "PRAGMA synchronous = OFF;")
+ (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id
+ (sqlite3:execute db "CREATE INDEX name_index ON names (name);")
+ ;; NB// We store a useful subset of file attributes but do not attempt to store all
+ (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY,
+ path TEXT,
+ parent_id INTEGER,
+ mode INTEGER DEFAULT -1,
+ uid INTEGER DEFAULT -1,
+ gid INTEGER DEFAULT -1,
+ size INTEGER DEFAULT -1,
+ mtime INTEGER DEFAULT -1);")
+ (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);")
+ (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);")))
+ ;; close the sqlite3 db and open it as needed
+ (filedb:finalize-db! fdb)
+ (filedb:fdb-set-db! fdb #f)
+ fdb))
+
+(define (filedb:reopen-db fdb)
+ (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb))))
+ (filedb:fdb-set-db! fdb db)
+ (sqlite3:set-busy-handler! db (make-busy-timeout 136000))))
+
+(define (filedb:finalize-db! fdb)
+ (sqlite3:finalize! (filedb:fdb-get-db fdb)))
+
+(define (filedb:get-current-time-string)
+ (string-chomp (time->string (seconds->local-time (current-seconds)))))
+
+(define (filedb:get-base-id db path)
+ (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;"))
+ (id-num #f))
+ (sqlite3:for-each-row
+ (lambda (num) (set! id-num num)) stmt path)
+ (sqlite3:finalize! stmt)
+ id-num))
+
+(define (filedb:get-path-id db path parent)
+ (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;"))
+ (id-num #f))
+ (sqlite3:for-each-row
+ (lambda (num) (set! id-num num)) stmt path parent)
+ (sqlite3:finalize! stmt)
+ id-num))
+
+(define (filedb:add-base db path)
+ (let ((existing (filedb:get-base-id db path)))
+ (if existing #f
+ (begin
+ (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string))))))
+
+;; index value field notes
+;; 0 inode number st_ino
+;; 1 mode st_mode bitfield combining file permissions and file type
+;; 2 number of hard links st_nlink
+;; 3 UID of owner st_uid as with file-owner
+;; 4 GID of owner st_gid
+;; 5 size st_size as with file-size
+;; 6 access time st_atime as with file-access-time
+;; 7 change time st_ctime as with file-change-time
+;; 8 modification time st_mtime as with file-modification-time
+;; 9 parent device ID st_dev ID of device on which this file resides
+;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number)
+;; 11 block size st_blksize
+;; 12 number of blocks allocated st_blocks
+
+(define (filedb:add-path-stat db path parent statinfo)
+ (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);")))
+ (sqlite3:execute stmt
+ path
+ parent
+ (vector-ref statinfo 1) ;; mode
+ (vector-ref statinfo 3) ;; uid
+ (vector-ref statinfo 4) ;; gid
+ (vector-ref statinfo 5) ;; size
+ (vector-ref statinfo 8) ;; mtime
+ )
+ (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string))))
+
+(define (filedb:add-path db path parent)
+ (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);")))
+ (sqlite3:execute stmt path parent)
+ (sqlite3:finalize! stmt)))
+
+(define (filedb:register-path fdb path #!key (save-stat #f))
+ (let* ((db (filedb:fdb-get-db fdb))
+ (pathcache (filedb:fdb-get-pathcache fdb))
+ (stat (if save-stat (file-stat path #t)))
+ (id (hash-table-ref/default pathcache path #f)))
+ (if (not db)(filedb:reopen-db fdb))
+ (if id id
+ (let ((plist (string-split path "/")))
+ (let loop ((head (car plist))
+ (tail (cdr plist))
+ (parent 0))
+ (let ((id (filedb:get-path-id db head parent))
+ (done (null? tail)))
+ (if id ;; we'll have a id if the path is already registered
+ (if done
+ (begin
+ (hash-table-set! pathcache path id)
+ id) ;; return the last path id for a result
+ (loop (car tail)(cdr tail) id))
+ (begin ;; add the path and then repeat the loop with the same data
+ (if save-stat
+ (filedb:add-path-stat db head parent stat)
+ (filedb:add-path db head parent))
+ (loop head tail parent)))))))))
+
+(define (filedb:update-recursively fdb path #!key (save-stat #f))
+ (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path))))
+ (print "processed 0 files...")
+ (let loop ((l (read-line p))
+ (lc 0)) ;; line count
+ (if (eof-object? l)
+ (begin
+ (print " " lc " files")
+ (close-input-port p))
+ (begin
+ (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info
+ (if (= (modulo lc 100) 0)
+ (print " " lc " files"))
+ (loop (read-line p)(+ lc 1)))))))
+
+(define (filedb:update fdb path #!key (save-stat #f))
+ ;; first get the realpath and add it to the bases table
+ (let ((real-path path) ;; (filedb:get-real-path path))
+ (db (filedb:fdb-get-db fdb)))
+ (filedb:add-base db real-path)
+ (filedb:update-recursively fdb path save-stat: save-stat)))
+
+;; not used and broken
+;;
+(define (filedb:get-real-path path)
+ (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path))))
+ (pth (read-line p)))
+ (if (eof-object? pth) path
+ (begin
+ (close-input-port p)
+ pth))))
+
+(define (filedb:drop-base fdb path)
+ (print "Sorry, I don't do anything yet"))
+
+(define (filedb:find-all fdb pattern action)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;"))
+ (result '()))
+ (sqlite3:for-each-row
+ (lambda (num)
+ (action num)
+ (set! result (cons num result))) stmt pattern)
+ (sqlite3:finalize! stmt)
+ result))
+
+(define (filedb:get-path-record fdb id)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (partcache (filedb:fdb-get-partcache fdb))
+ (dat (hash-table-ref/default partcache id #f)))
+ (if dat dat
+ (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;"))
+ (result #f))
+ (sqlite3:for-each-row
+ (lambda (path parent_id)(set! result (list path parent_id))) stmt id)
+ (hash-table-set! partcache id result)
+ (sqlite3:finalize! stmt)
+ result))))
+
+(define (filedb:get-children fdb parent-id)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (res '()))
+ (sqlite3:for-each-row
+ (lambda (id path parent-id)
+ (set! res (cons (vector id path parent-id) res)))
+ db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;"
+ parent-id)
+ res))
+
+;; retrieve all that have children and those without
+;; children that match patt
+(define (filedb:get-children-patt fdb parent-id search-patt)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (res '()))
+ ;; first get the children that have no children
+ (sqlite3:for-each-row
+ (lambda (id path parent-id)
+ (set! res (cons (vector id path parent-id) res)))
+ db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND
+ (id IN (SELECT parent_id FROM paths) OR path LIKE ?);"
+ parent-id search-patt)
+ res))
+
+(define (filedb:get-path fdb id)
+ (let* ((db (filedb:fdb-get-db fdb))
+ (idcache (filedb:fdb-get-idcache fdb))
+ (path (hash-table-ref/default idcache id #f)))
+ (if (not db)(filedb:reopen-db fdb))
+ (if path path
+ (let loop ((curr-id id)
+ (path ""))
+ (let ((path-record (filedb:get-path-record fdb curr-id)))
+ (if (not path-record) #f ;; this id has no path
+ (let* ((parent-id (list-ref path-record 1))
+ (pname (list-ref path-record 0))
+ (newpath (string-append "/" pname path)))
+ (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0
+ (begin
+ (hash-table-set! idcache id newpath)
+ newpath)
+ (loop parent-id newpath)))))))))
+
+(define (filedb:search db pattern)
+ (let ((action (lambda (id)(print (filedb:get-path db id)))))
+ (filedb:find-all db pattern action)))
+
ADDED attic/ftail.scm
Index: attic/ftail.scm
==================================================================
--- /dev/null
+++ attic/ftail.scm
@@ -0,0 +1,108 @@
+;;======================================================================
+;; Copyright 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 .
+
+;;======================================================================
+
+(declare (unit ftail))
+
+(module ftail
+ (
+ open-tail-db
+ tail-write
+ tail-get-fid
+ file-tail
+ )
+
+(import scheme chicken data-structures extras)
+(use (prefix sqlite3 sqlite3:) posix typed-records)
+
+(define (open-tail-db )
+ (let* ((basedir (create-directory (conc "/tmp/" (current-user-name))))
+ (dbpath (conc basedir "/megatest_logs.db"))
+ (dbexists (file-exists? dbpath))
+ (db (sqlite3:open-database dbpath))
+ (handler (sqlite3:make-busy-timeout 136000)))
+ (sqlite3:set-busy-handler! db handler)
+ (sqlite3:execute db "PRAGMA synchronous = 0;")
+ (if (not dbexists)
+ (begin
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+ (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
+ ))
+ db))
+
+(define (tail-write db fid lines)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (for-each
+ (lambda (line)
+ (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line))
+ lines))))
+
+(define (tail-get-fid db fname)
+ (let ((fid (handle-exceptions
+ exn
+ #f
+ (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname))))
+ (if fid
+ fid
+ (begin
+ (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname)
+ (tail-get-fid db fname)))))
+
+(define (file-tail fname #!key (db-in #f))
+ (let* ((inp (open-input-file fname))
+ (db (or db-in (open-tail-db)))
+ (fid (tail-get-fid db fname)))
+ (let loop ((inl (read-line inp))
+ (lines '())
+ (lastwr (current-seconds)))
+ (if (eof-object? inl)
+ (let ((timed-out (> (- (current-seconds) lastwr) 60)))
+ (if timed-out (tail-write db fid (reverse lines)))
+ (sleep 1)
+ (if timed-out
+ (loop (read-line inp) '() (current-seconds))
+ (loop (read-line inp) lines lastwr)))
+ (let* ((savelines (> (length lines) 19)))
+ ;; (print inl)
+ (if savelines (tail-write db fid (reverse lines)))
+ (loop (read-line inp)
+ (if savelines
+ '()
+ (cons inl lines))
+ (if savelines
+ (current-seconds)
+ lastwr)))))))
+
+;; offset -20 means get last 20 lines
+;;
+(define (tail-get-lines db fid offset count)
+ (if (> offset 0)
+ (sqlite3:map-row (lambda (id line)
+ (vector id line))
+ db
+ "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count)
+ (reverse ;; get N from the end
+ (sqlite3:map-row (lambda (id line)
+ (vector id line))
+ db
+ "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset)))))
+
+)
ADDED attic/sdb.scm
Index: attic/sdb.scm
==================================================================
--- /dev/null
+++ attic/sdb.scm
@@ -0,0 +1,116 @@
+;;======================================================================
+;; Copyright 2006-2013, 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 .
+
+;;======================================================================
+
+;;======================================================================
+;; Simple persistant strings lookup table. Keep out of the main db
+;; so writes/reads don't slow down central access.
+;;======================================================================
+
+(require-extension (srfi 18) extras)
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
+(import (prefix sqlite3 sqlite3:))
+(import (prefix base64 base64:))
+
+(declare (unit sdb))
+
+;;
+(define (sdb:open fname)
+ (let* ((dbpath (pathname-directory fname))
+ (dbexists (let ((fe (common:file-exists? fname)))
+ (if fe
+ fe
+ (begin
+ (create-directory dbpath #t)
+ #f))))
+ (sdb (sqlite3:open-database fname))
+ (handler (make-busy-timeout 136000)))
+ (sqlite3:set-busy-handler! sdb handler)
+ (if (not dbexists)
+ (sdb:initialize sdb))
+ (sqlite3:execute sdb "PRAGMA synchronous = 1;")
+ sdb))
+
+(define (sdb:initialize sdb)
+ (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs
+ (id INTEGER PRIMARY KEY,
+ str TEXT,
+ CONSTRAINT str UNIQUE (str));")
+ (sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);"))
+
+;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a)))
+
+(define (sdb:register-string sdb str)
+ (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str))
+
+(define (sdb:string->id sdb str-cache str)
+ (let ((id (hash-table-ref/default str-cache str #f)))
+ (if (not id)
+ (sqlite3:for-each-row
+ (lambda (sid)
+ (set! id sid)
+ (hash-table-set! str-cache str id))
+ sdb
+ "SELECT id FROM strs WHERE str=?;" str))
+ id))
+
+(define (sdb:id->string sdb id-cache id)
+ (let ((str (hash-table-ref/default id-cache id #f)))
+ (if (not str)
+ (sqlite3:for-each-row
+ (lambda (istr)
+ (set! str istr)
+ (hash-table-set! id-cache id str))
+ sdb
+ "SELECT str FROM strs WHERE id=?;" id))
+ str))
+
+;; Numbers get passed though in both directions
+;;
+(define (make-sdb:qry fname)
+ (let ((sdb #f)
+ (scache (make-hash-table))
+ (icache (make-hash-table)))
+ (lambda (cmd var)
+ (case cmd
+ ((setup) (set! sdb (if (not sdb)
+ (sdb:open (if var var fname)))))
+ ((setdb) (set! sdb var))
+ ((getdb) sdb)
+ ((finalize) (if sdb
+ (begin
+ (sqlite3:finalize! sdb)
+ (set! sdb #f))))
+ ((getid) (let ((id (if (or (number? var)
+ (string->number var))
+ var
+ (sdb:string->id sdb scache var))))
+ (if id
+ id
+ (begin
+ (sdb:register-string sdb var)
+ (sdb:string->id sdb scache var)))))
+ ((getstr) (if (or (number? var)
+ (string->number var))
+ (sdb:id->string sdb icache var)
+ var))
+ ((passid) var)
+ ((passstr) var)
+ (else #f)))))
+
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -3360,11 +3360,11 @@
(begin
(debug:print 0 *default-log-port* "ERROR: I only know sqlite3 databases for now: " dbstr)
#f)))))
(if (and dbpth (file-read-access? dbpth))
(let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth)))
- (sqlite3:set-busy-handler! db (make-busy-timeout 10000))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000))
db)
#f)))
;; sqlite3:path tablename timefieldname varfieldname field1 field2 ...
;;
Index: dbfile.scm
==================================================================
--- dbfile.scm
+++ dbfile.scm
@@ -261,15 +261,16 @@
;;
(define (dbfile:open-sqlite3-db dbpath init-proc)
(let* ((dbexists (file-exists? dbpath))
(db ;; need locking here so multiple open
;; do not collide
- (let* ((db (sqlite3:open-database dbpath)))
- (init-proc db))
- #;(dbfile:lock-create-open dbpath
- (lambda (db)
- (init-proc db))))
+ (let* ((db (sqlite3:open-database dbpath)))
+ (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000))
+ (init-proc db))
+ #;(dbfile:lock-create-open dbpath
+ (lambda (db)
+ (init-proc db))))
(write-access (file-write-access? dbpath)))
(dbfile:print-err "db:open-sqlite-db "dbpath)
#;(if (and dbexists (not write-access))
(set! *db-write-access* #f))
;; (cons db dbpath)))
DELETED filedb.scm
Index: filedb.scm
==================================================================
--- filedb.scm
+++ /dev/null
@@ -1,255 +0,0 @@
-;; Copyright 2006-2011, 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 .
-;;
-
-;; (require-extension synch sqlite3 posix srfi-13 srfi-1 utils regex)
-(use sqlite3 srfi-1 posix regex srfi-69 srfi-13 posix-extras)
-(import (prefix sqlite3 sqlite3:))
-
-(declare (unit filedb))
-
-(include "fdb_records.scm")
-;; (include "settings.scm")
-
-(define (filedb:open-db dbpath)
- (let* ((fdb (make-filedb:fdb))
- (dbexists (common:file-exists? dbpath))
- (db (sqlite3:open-database dbpath)))
- (filedb:fdb-set-db! fdb db)
- (filedb:fdb-set-dbpath! fdb dbpath)
- (filedb:fdb-set-pathcache! fdb (make-hash-table))
- (filedb:fdb-set-idcache! fdb (make-hash-table))
- (filedb:fdb-set-partcache! fdb (make-hash-table))
- (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
- (if (not dbexists)
- (begin
- (sqlite3:execute db "PRAGMA synchronous = OFF;")
- (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id
- (sqlite3:execute db "CREATE INDEX name_index ON names (name);")
- ;; NB// We store a useful subset of file attributes but do not attempt to store all
- (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY,
- path TEXT,
- parent_id INTEGER,
- mode INTEGER DEFAULT -1,
- uid INTEGER DEFAULT -1,
- gid INTEGER DEFAULT -1,
- size INTEGER DEFAULT -1,
- mtime INTEGER DEFAULT -1);")
- (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);")
- (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);")))
- ;; close the sqlite3 db and open it as needed
- (filedb:finalize-db! fdb)
- (filedb:fdb-set-db! fdb #f)
- fdb))
-
-(define (filedb:reopen-db fdb)
- (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb))))
- (filedb:fdb-set-db! fdb db)
- (sqlite3:set-busy-handler! db (make-busy-timeout 136000))))
-
-(define (filedb:finalize-db! fdb)
- (sqlite3:finalize! (filedb:fdb-get-db fdb)))
-
-(define (filedb:get-current-time-string)
- (string-chomp (time->string (seconds->local-time (current-seconds)))))
-
-(define (filedb:get-base-id db path)
- (let ((stmt (sqlite3:prepare db "SELECT id FROM bases WHERE base=?;"))
- (id-num #f))
- (sqlite3:for-each-row
- (lambda (num) (set! id-num num)) stmt path)
- (sqlite3:finalize! stmt)
- id-num))
-
-(define (filedb:get-path-id db path parent)
- (let ((stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path=? AND parent_id=?;"))
- (id-num #f))
- (sqlite3:for-each-row
- (lambda (num) (set! id-num num)) stmt path parent)
- (sqlite3:finalize! stmt)
- id-num))
-
-(define (filedb:add-base db path)
- (let ((existing (filedb:get-base-id db path)))
- (if existing #f
- (begin
- (sqlite3:execute db "INSERT INTO bases (base,updated) VALUES (?,?);" path (filedb:get-current-time-string))))))
-
-;; index value field notes
-;; 0 inode number st_ino
-;; 1 mode st_mode bitfield combining file permissions and file type
-;; 2 number of hard links st_nlink
-;; 3 UID of owner st_uid as with file-owner
-;; 4 GID of owner st_gid
-;; 5 size st_size as with file-size
-;; 6 access time st_atime as with file-access-time
-;; 7 change time st_ctime as with file-change-time
-;; 8 modification time st_mtime as with file-modification-time
-;; 9 parent device ID st_dev ID of device on which this file resides
-;; 10 device ID st_rdev device ID for special files (i.e. the raw major/minor number)
-;; 11 block size st_blksize
-;; 12 number of blocks allocated st_blocks
-
-(define (filedb:add-path-stat db path parent statinfo)
- (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);")))
- (sqlite3:execute stmt
- path
- parent
- (vector-ref statinfo 1) ;; mode
- (vector-ref statinfo 3) ;; uid
- (vector-ref statinfo 4) ;; gid
- (vector-ref statinfo 5) ;; size
- (vector-ref statinfo 8) ;; mtime
- )
- (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string))))
-
-(define (filedb:add-path db path parent)
- (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);")))
- (sqlite3:execute stmt path parent)
- (sqlite3:finalize! stmt)))
-
-(define (filedb:register-path fdb path #!key (save-stat #f))
- (let* ((db (filedb:fdb-get-db fdb))
- (pathcache (filedb:fdb-get-pathcache fdb))
- (stat (if save-stat (file-stat path #t)))
- (id (hash-table-ref/default pathcache path #f)))
- (if (not db)(filedb:reopen-db fdb))
- (if id id
- (let ((plist (string-split path "/")))
- (let loop ((head (car plist))
- (tail (cdr plist))
- (parent 0))
- (let ((id (filedb:get-path-id db head parent))
- (done (null? tail)))
- (if id ;; we'll have a id if the path is already registered
- (if done
- (begin
- (hash-table-set! pathcache path id)
- id) ;; return the last path id for a result
- (loop (car tail)(cdr tail) id))
- (begin ;; add the path and then repeat the loop with the same data
- (if save-stat
- (filedb:add-path-stat db head parent stat)
- (filedb:add-path db head parent))
- (loop head tail parent)))))))))
-
-(define (filedb:update-recursively fdb path #!key (save-stat #f))
- (let ((p (open-input-pipe (string-append "find -L " path)))) ;; (resolve-pathname path)))) ;; (string-append "find " path))))
- (print "processed 0 files...")
- (let loop ((l (read-line p))
- (lc 0)) ;; line count
- (if (eof-object? l)
- (begin
- (print " " lc " files")
- (close-input-port p))
- (begin
- (filedb:register-path fdb l save-stat: save-stat) ;; (get-real-path l)) ;; don't like losing the original path info
- (if (= (modulo lc 100) 0)
- (print " " lc " files"))
- (loop (read-line p)(+ lc 1)))))))
-
-(define (filedb:update fdb path #!key (save-stat #f))
- ;; first get the realpath and add it to the bases table
- (let ((real-path path) ;; (filedb:get-real-path path))
- (db (filedb:fdb-get-db fdb)))
- (filedb:add-base db real-path)
- (filedb:update-recursively fdb path save-stat: save-stat)))
-
-;; not used and broken
-;;
-(define (filedb:get-real-path path)
- (let* ((p (open-input-pipe (string-append real-path " " (regexp-escape path))))
- (pth (read-line p)))
- (if (eof-object? pth) path
- (begin
- (close-input-port p)
- pth))))
-
-(define (filedb:drop-base fdb path)
- (print "Sorry, I don't do anything yet"))
-
-(define (filedb:find-all fdb pattern action)
- (let* ((db (filedb:fdb-get-db fdb))
- (stmt (sqlite3:prepare db "SELECT id FROM paths WHERE path like ?;"))
- (result '()))
- (sqlite3:for-each-row
- (lambda (num)
- (action num)
- (set! result (cons num result))) stmt pattern)
- (sqlite3:finalize! stmt)
- result))
-
-(define (filedb:get-path-record fdb id)
- (let* ((db (filedb:fdb-get-db fdb))
- (partcache (filedb:fdb-get-partcache fdb))
- (dat (hash-table-ref/default partcache id #f)))
- (if dat dat
- (let ((stmt (sqlite3:prepare db "SELECT path,parent_id FROM paths WHERE id=?;"))
- (result #f))
- (sqlite3:for-each-row
- (lambda (path parent_id)(set! result (list path parent_id))) stmt id)
- (hash-table-set! partcache id result)
- (sqlite3:finalize! stmt)
- result))))
-
-(define (filedb:get-children fdb parent-id)
- (let* ((db (filedb:fdb-get-db fdb))
- (res '()))
- (sqlite3:for-each-row
- (lambda (id path parent-id)
- (set! res (cons (vector id path parent-id) res)))
- db "SELECT id,path,parent_id FROM paths WHERE parent_id=?;"
- parent-id)
- res))
-
-;; retrieve all that have children and those without
-;; children that match patt
-(define (filedb:get-children-patt fdb parent-id search-patt)
- (let* ((db (filedb:fdb-get-db fdb))
- (res '()))
- ;; first get the children that have no children
- (sqlite3:for-each-row
- (lambda (id path parent-id)
- (set! res (cons (vector id path parent-id) res)))
- db "SELECT id,path,parent_id FROM paths WHERE parent_id=? AND
- (id IN (SELECT parent_id FROM paths) OR path LIKE ?);"
- parent-id search-patt)
- res))
-
-(define (filedb:get-path fdb id)
- (let* ((db (filedb:fdb-get-db fdb))
- (idcache (filedb:fdb-get-idcache fdb))
- (path (hash-table-ref/default idcache id #f)))
- (if (not db)(filedb:reopen-db fdb))
- (if path path
- (let loop ((curr-id id)
- (path ""))
- (let ((path-record (filedb:get-path-record fdb curr-id)))
- (if (not path-record) #f ;; this id has no path
- (let* ((parent-id (list-ref path-record 1))
- (pname (list-ref path-record 0))
- (newpath (string-append "/" pname path)))
- (if (= parent-id 0) ;; fields 0=path, 1=parent. root parent=0
- (begin
- (hash-table-set! idcache id newpath)
- newpath)
- (loop parent-id newpath)))))))))
-
-(define (filedb:search db pattern)
- (let ((action (lambda (id)(print (filedb:get-path db id)))))
- (filedb:find-all db pattern action)))
-
DELETED ftail.scm
Index: ftail.scm
==================================================================
--- ftail.scm
+++ /dev/null
@@ -1,108 +0,0 @@
-;;======================================================================
-;; Copyright 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 .
-
-;;======================================================================
-
-(declare (unit ftail))
-
-(module ftail
- (
- open-tail-db
- tail-write
- tail-get-fid
- file-tail
- )
-
-(import scheme chicken data-structures extras)
-(use (prefix sqlite3 sqlite3:) posix typed-records)
-
-(define (open-tail-db )
- (let* ((basedir (create-directory (conc "/tmp/" (current-user-name))))
- (dbpath (conc basedir "/megatest_logs.db"))
- (dbexists (file-exists? dbpath))
- (db (sqlite3:open-database dbpath))
- (handler (sqlite3:make-busy-timeout 136000)))
- (sqlite3:set-busy-handler! db handler)
- (sqlite3:execute db "PRAGMA synchronous = 0;")
- (if (not dbexists)
- (begin
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_files (id INTEGER PRIMARY KEY,filename TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
- (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log_data (id INTEGER PRIMARY KEY,fid INTEGER,line TEXT,event_time TIMESTAMP DEFAULT (strftime('%s','now')));")
- ))
- db))
-
-(define (tail-write db fid lines)
- (sqlite3:with-transaction
- db
- (lambda ()
- (for-each
- (lambda (line)
- (sqlite3:execute db "INSERT INTO log_data (fid,line) VALUES (?,?);" fid line))
- lines))))
-
-(define (tail-get-fid db fname)
- (let ((fid (handle-exceptions
- exn
- #f
- (sqlite3:first-result db "SELECT id FROM log_files WHERE filename=?;" fname))))
- (if fid
- fid
- (begin
- (sqlite3:execute db "INSERT INTO log_files (filename) VALUES (?);" fname)
- (tail-get-fid db fname)))))
-
-(define (file-tail fname #!key (db-in #f))
- (let* ((inp (open-input-file fname))
- (db (or db-in (open-tail-db)))
- (fid (tail-get-fid db fname)))
- (let loop ((inl (read-line inp))
- (lines '())
- (lastwr (current-seconds)))
- (if (eof-object? inl)
- (let ((timed-out (> (- (current-seconds) lastwr) 60)))
- (if timed-out (tail-write db fid (reverse lines)))
- (sleep 1)
- (if timed-out
- (loop (read-line inp) '() (current-seconds))
- (loop (read-line inp) lines lastwr)))
- (let* ((savelines (> (length lines) 19)))
- ;; (print inl)
- (if savelines (tail-write db fid (reverse lines)))
- (loop (read-line inp)
- (if savelines
- '()
- (cons inl lines))
- (if savelines
- (current-seconds)
- lastwr)))))))
-
-;; offset -20 means get last 20 lines
-;;
-(define (tail-get-lines db fid offset count)
- (if (> offset 0)
- (sqlite3:map-row (lambda (id line)
- (vector id line))
- db
- "SELECT id,line FROM log_data WHERE fid=? OFFSET ? LIMIT ?;" fid offset count)
- (reverse ;; get N from the end
- (sqlite3:map-row (lambda (id line)
- (vector id line))
- db
- "SELECT id,line FROM log_data WHERE fid=? ORDER BY id DESC LIMIT ?;" fid (abs offset)))))
-
-)
DELETED sdb.scm
Index: sdb.scm
==================================================================
--- sdb.scm
+++ /dev/null
@@ -1,116 +0,0 @@
-;;======================================================================
-;; Copyright 2006-2013, 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 .
-
-;;======================================================================
-
-;;======================================================================
-;; Simple persistant strings lookup table. Keep out of the main db
-;; so writes/reads don't slow down central access.
-;;======================================================================
-
-(require-extension (srfi 18) extras)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
-(import (prefix sqlite3 sqlite3:))
-(import (prefix base64 base64:))
-
-(declare (unit sdb))
-
-;;
-(define (sdb:open fname)
- (let* ((dbpath (pathname-directory fname))
- (dbexists (let ((fe (common:file-exists? fname)))
- (if fe
- fe
- (begin
- (create-directory dbpath #t)
- #f))))
- (sdb (sqlite3:open-database fname))
- (handler (make-busy-timeout 136000)))
- (sqlite3:set-busy-handler! sdb handler)
- (if (not dbexists)
- (sdb:initialize sdb))
- (sqlite3:execute sdb "PRAGMA synchronous = 1;")
- sdb))
-
-(define (sdb:initialize sdb)
- (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs
- (id INTEGER PRIMARY KEY,
- str TEXT,
- CONSTRAINT str UNIQUE (str));")
- (sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);"))
-
-;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a)))
-
-(define (sdb:register-string sdb str)
- (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str))
-
-(define (sdb:string->id sdb str-cache str)
- (let ((id (hash-table-ref/default str-cache str #f)))
- (if (not id)
- (sqlite3:for-each-row
- (lambda (sid)
- (set! id sid)
- (hash-table-set! str-cache str id))
- sdb
- "SELECT id FROM strs WHERE str=?;" str))
- id))
-
-(define (sdb:id->string sdb id-cache id)
- (let ((str (hash-table-ref/default id-cache id #f)))
- (if (not str)
- (sqlite3:for-each-row
- (lambda (istr)
- (set! str istr)
- (hash-table-set! id-cache id str))
- sdb
- "SELECT str FROM strs WHERE id=?;" id))
- str))
-
-;; Numbers get passed though in both directions
-;;
-(define (make-sdb:qry fname)
- (let ((sdb #f)
- (scache (make-hash-table))
- (icache (make-hash-table)))
- (lambda (cmd var)
- (case cmd
- ((setup) (set! sdb (if (not sdb)
- (sdb:open (if var var fname)))))
- ((setdb) (set! sdb var))
- ((getdb) sdb)
- ((finalize) (if sdb
- (begin
- (sqlite3:finalize! sdb)
- (set! sdb #f))))
- ((getid) (let ((id (if (or (number? var)
- (string->number var))
- var
- (sdb:string->id sdb scache var))))
- (if id
- id
- (begin
- (sdb:register-string sdb var)
- (sdb:string->id sdb scache var)))))
- ((getstr) (if (or (number? var)
- (string->number var))
- (sdb:id->string sdb icache var)
- var))
- ((passid) var)
- ((passstr) var)
- (else #f)))))
-
Index: spublish.scm
==================================================================
--- spublish.scm
+++ spublish.scm
@@ -396,19 +396,19 @@
(if (< (sauth-common:space-left-at-dest target-path) (sauth-common:src-size src-path))
(begin
(sauth:print-error "Destination does not have enough disk space.")
(exit 1)))
(if (is_directory src-path)
- (begin
- (let* ((parent-dir src-path)
- (start-dir target-path))
- (run (pipe
- (begin (system (conc "cd " parent-dir " ;tar chf - ." )))
- (begin (change-directory start-dir)
- ;(print "123")
- (run-cmd "tar" (list "xf" "-")))))
- (print "Copied data to " start-dir)))
+ (begin
+ (let* ((parent-dir src-path)
+ (start-dir target-path))
+ (run (pipe
+ (begin (system (conc "cd " parent-dir " ;tar chf - ." )))
+ (begin (change-directory start-dir)
+ ;(print "123")
+ (run-cmd "tar" (list "xf" "-")))))
+ (print "Copied data to " start-dir)))
(begin
(let*((parent-dir (pathname-directory src-path))
(start-dir target-path)
(filename (if (pathname-extension src-path)
(conc(pathname-file src-path) "." (pathname-extension src-path))