''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 XOTcl Code]