1## -*- tcl -*- 2# ### ### ### ######### ######### ######### 3 4## A cache we put on top of a slippy fetcher, to satisfy requests for 5## tiles from the local filesystem first, if possible. 6 7# ### ### ### ######### ######### ######### 8## Requisites 9 10package require Tcl 8.4 ; # No {*}-expansion :(, no ** either, nor lassign 11package require Tk ; # image photo 12package require map::slippy ; # Slippy constants 13package require fileutil ; # Testing paths 14package require img::png ; # We write tile images using the PNG image file format. 15package require snit 16 17# ### ### ### ######### ######### ######### 18## Implementation 19 20snit::type map::slippy::cache { 21 # ### ### ### ######### ######### ######### 22 ## API 23 24 constructor {cachedir provider} { 25 if {![fileutil::test $cachedir edrw msg]} { 26 return -code error "$type constructor: $msg" 27 } 28 set mycachedir $cachedir 29 set myprovider $provider 30 set mylevels [uplevel \#0 [linsert $myprovider end levels]] 31 return 32 } 33 34 delegate method * to myprovider 35 delegate option * to myprovider 36 37 method valid {tile {msgv {}}} { 38 if {$msgv ne ""} { upvar 1 $msgv msg } 39 return [map::slippy tile valid $tile $mylevels msg] 40 } 41 42 method exists {tile} { 43 if {![map::slippy tile valid $tile $mylevels msg]} { 44 return -code error $msg 45 } 46 return [file exists [FileOf $tile]] 47 } 48 49 method get {tile donecmd} { 50 if {![map::slippy tile valid $tile $mylevels msg]} { 51 return -code error $msg 52 } 53 54 # Query the filesystem for a cached tile and return 55 # immediately if such was found. 56 57 set tilefile [FileOf $tile] 58 if {[file exists $tilefile]} { 59 set tileimage [image create photo -file $tilefile] 60 after 0 [linsert $donecmd end set $tile $tileimage] 61 return 62 } 63 64 # The requested tile is not known to the cache, so we forward 65 # the request to our provider and intercept the result to 66 # update the cache. Only one retrieval request will be issued 67 # if multiple arrive from above. 68 69 lappend mypending($tile) $donecmd 70 if {[llength $mypending($tile)] > 1} return 71 72 uplevel \#0 [linsert $myprovider end get $tile [mymethod Done]] 73 return 74 } 75 76 method {Done set} {tile tileimage} { 77 # The requested tile was known to the provider, we can cache 78 # the image we got and then hand it over to the original 79 # requestor. 80 81 set tilefile [FileOf $tile] 82 file mkdir [file dirname $tilefile] 83 $tileimage write $tilefile -format png 84 85 set requests $mypending($tile) 86 unset mypending($tile) 87 88 # Note. The cache accepts empty callbacks for requests, and if 89 # no actual callback 'took' the image it is assumed to be not 90 # wanted and destroyed. This allows higher layers to request 91 # tiles before needng them without leaking imagas and yet also 92 # not throwing them away when a prefetch and regular fetch 93 # collide. 94 95 set taken 0 96 foreach d $requests { 97 if {![llength $d]} continue 98 uplevel \#0 [linsert $d end set $tile $tileimage] 99 set taken 1 100 } 101 102 if {!$taken} { 103 image delete $tileimage 104 } 105 return 106 } 107 108 method {Do unset} {donecmd tile} { 109 # The requested tile is not known. Nothing has to change in 110 # the cache (it did not know the tile either), the result can 111 # be directly handed over to the original requestor. 112 113 uplevel \#0 [linsert $donecmd end unset $tile] 114 return 115 } 116 117 # ### ### ### ######### ######### ######### 118 ## Internal commands 119 120 proc FileOf {tile} { 121 upvar 1 mycachedir mycachedir 122 foreach {z r c} $tile break 123 return [file join $mycachedir $z $c $r.png] 124 } 125 126 # ### ### ### ######### ######### ######### 127 ## State 128 129 variable mycachedir {} ; # Directory to cache tiles in. 130 variable myprovider {} ; # Command prefix, provider of tiles to cache. 131 variable mylevels {} ; # Zoom-levels, retrieved from provider. 132 133 variable mypending -array {} ; # tile -> list (done-cmd-prefix) 134 135 # ### ### ### ######### ######### ######### 136} 137 138# ### ### ### ######### ######### ######### 139## Ready 140 141package provide map::slippy::cache 0.2 142