Cacheable class

This code shows how a cache can be built in XOTcl, which can then be transparently used with any other classes to cache methods. Bug reports to Kristoffer Lawson, setok@fishpool.com. Category XOTcl Code
 #############################################################################
 @ Class Memorization {
    description {
        By setting his class as a super-class of another class, all instances
        of the latter class will become memorisable. The programmer can set
        up methods to be automatically cached and their expiration time.
        If those methods are then called twice with the same
        arguments before the the expiration time passes, the result will
        be given from a cache instead of actually calling the method.
        Other methods can be set that are specified to invalidate the cache.

        In XOTcl, all class relations are dynamic so this can indeed be dynamically added anywhere
        where a method Cache could be useful.

        Note that a small speed penalty occurs for all method calls to a
        Memorization object and a slightly larger one for methods that are
        specified to be cacheable. Cache invalidation methods also take
        extra time. Ie. a programmer should try to have a good idea of when
        this class is really needed, instead of making all classes use
        Memorization.
    }
 }
 #############################################################################

 Class Memorization

 ## Filter proc called for all method calls in object. Checks to see if method
 ## result is in cache, and returns it if so. Otherwise calls method normally.

 Memorization instproc checkCache {args} {
    [self] instvar cacheMethods invalidationMethods

    ::set called [[self] info calledproc]
    if {[[self] exists cacheMethods($called)]} {
        # The method is specified to be cached.
        set callIndex $called,withArgs,$args
        if {[[self] exists cacheMethods($callIndex)]} {
            # There was a previous call with the same arguments, so it should
            # be in the cache.
            ::array set lastCallData [[self] set cacheMethods($callIndex)]
            if {(([clock seconds]-$lastCallData(time)) <
                 $cacheMethods($called)) ||
                ($cacheMethods($called) == -1)} {

                # Fetch result from cached data
                return $lastCallData(result)
            } else {
                # The method result has been in the cache for longer than the
                # max cache period.

                ::set lastCallData(time) [clock seconds]
                ::set r [next]
                ::set lastCallData(result) $r
                [self] set cacheMethods($callIndex) [::array get lastCallData]
                return $r
            }
        } else {
            ::set lastCallData [list time [clock seconds]]
            ::set r [next]
            lappend lastCallData result $r
            [self] set cacheMethods($callIndex) $lastCallData
            return $r
        }
    } else {
        # Not a cached method

        if {[[self] exists invalidationMethods($called)]} {
            [self] invalidateCache
        }
        return [next]
    }
 }
 Memorization filter checkCache

 @ Memorization instproc invalidateCache {
    description {
        Invalidates cache of object.
    }
 }

 Memorization instproc invalidateCache {} {
    foreach cacheEntry [[self] array names cacheMethods *,withArgs,*] {
        [self] unset cacheMethods($cacheEntry)
    }

    return
 }

 @ Memorization instproc addCacheMethods {
    methodList {
        A list with alternating method names to cache and expiration
        periods (in seconds), after which the cache is not considered to
        be up to date.
    }
 } {
    description {
        Setup methods to be cached.
    }
 }

 Memorization instproc addCacheMethods {methodList} {
    foreach {method expPeriod} $methodList {
        [self] set cacheMethods($method) $expPeriod
    }

    return
 }

 @ Memorization instproc addInvalidationMethods {
    methodList {List of methods.}
 } {
    description {
        Sets up a list methods that invalidate the cache when they're called.
    }
 }

 Memorization instproc addInvalidationMethods {methodList} {
    foreach method $methodList {
        [self] set invalidationMethods($method) ""
    }

    return
 }
Category Caching
Category XOTcl Code