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