dbohdan 2018-09-21:
PersistentCache is a key/value cache built on top of
SQLite 3. It lets you store values with an expiration date. The cache will be in-memory or on-disk depending on the SQLite database. It is implemented as a
TclOO class.
package require sqlite3
package require TclOO
namespace eval percache {
variable version 0.3.0
}
oo::class create percache::PersistentCache {
variable _db
variable _exp
variable _table
variable _keep
# $db is the SQLite database handle.
# $exp is after how many seconds a cache item expires by default.
# $table is the SQLite table to use and, if necessary, create.
# $keep is whether to keep the SQLite table when the object is destroyed.
constructor {db exp {table cache} {keep 0}} {
set _db $db
set _exp $exp
set _table $table
set _keep $keep
$_db eval [format {
CREATE TABLE IF NOT EXISTS "%s"(
key TEXT PRIMARY KEY,
value BLOB,
bestBefore INTEGER
);
} $_table]
}
destructor {
if {$_keep} return
$_db eval [format {
DROP TABLE "%s";
} $_table]
}
method set {key value {bestBefore {}}} {
if {$bestBefore eq {}} {
set bestBefore [expr {$_exp + [clock seconds]}]
}
$_db eval [format {
INSERT OR REPLACE INTO "%s"
VALUES (:key, :value, :bestBefore)
} $_table]
}
# If $key is absent or has expired, return the result of evaluating $script
# in the caller's frame. It is up to you to call the method [set] in
# $script and store your new value in the cache.
method get {key script} {
$_db eval [format {
SELECT value, bestBefore
FROM "%s"
WHERE key = :key
} $_table] result {
if {[clock seconds] < $result(bestBefore)} {
set value $result(value)
}
}
if {![info exists value]} {
set value [uplevel 1 $script]
}
return $value
}
method get-lambda {key {lambda {}} args} {
return [my get $key [list apply $lambda {*}$args]]
}
}
proc percache::test {} {
package require tcltest
sqlite3 db :memory:
proc cache-test args {
tcltest::test {*}$args -setup {
set cache [PersistentCache new db 1]
} -cleanup {
$cache destroy
}
}
cache-test set-get-1.1 {} -body {
$cache set foo 5
$cache get foo { error {not found} }
} -result 5
cache-test set-get-1.2 {} -body {
$cache get foo { error {not found} }
} -returnCodes error -result {not found}
cache-test set-get-2.1 {} -body {
$cache get doesNotExist {
return defaultValue
}
} -result defaultValue
cache-test set-get-2.2 {} -body {
$cache get-lambda doesNotExist {{x y} {
return $x-$y
}} foo bar
} -result foo-bar
cache-test expiration-1.1 {} -body {
$cache set foo value
after 1000
$cache get foo { return expired }
} -result expired
cache-test expiration-1.2 {} -body {
$cache set foo value [expr {[clock seconds] + 3}]
$cache get foo { error {this shouldn't happen} }
} -result value
cache-test expiration-1.3 {} -body {
$cache set foo value 0
$cache get foo { return expired }
} -result expired
tcltest::test keep-1.1 {} -setup {
set cache [PersistentCache new db 1 kash 1]
} -body {
$cache set bar 7
$cache destroy
set cache [PersistentCache new db 1 kash 1]
$cache get bar { error {not found} }
} -result 7 -cleanup {unset cache}
set success [expr {$tcltest::numTests(Failed) == 0}]
tcltest::cleanupTests
return $success
}
# If this is the main script...
if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
exit [expr {![percache::test]}]
}
package provide percache $percache::version Discussion edit
