[dbohdan] 2018-09-21: `PersistentCache` is a key/value cache built on top of [sqlite3%|%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.


** Code **

======
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 **

<<categories>> Package | Caching | Data Structure | SQLite