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