1# maptk.tcl
2# simple sample image map resolver
3# uses Netscape map files
4#
5# This version uses a Tk canvas to do hit detection.
6#
7# Stephen Uhler (c) 1997 Sun Microsystems
8# Brent Welch (c) 1998-2000 Ajuba Solutions
9# See the file "license.terms" for information on usage and redistribution
10# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
11#
12# RCS: @(#) $Id: maptk.tcl,v 1.4 2000/08/26 05:38:05 build Exp $
13
14package provide httpd::ismaptk 1.0
15
16# 	read in an image map file, and generate the appropriate canvas
17# 	# sample image map
18#	circle 	/sun-on-net/internet.sol/access.html  664,311 686,311
19#	default	http://www.hal.com/
20#	default 	/sunsoft/index.html
21#	point /sunworldonline/common/swol-subscribe.html 45,134
22#	poly / 182,11 184,88 301,77 365,86 393,57 393,10
23#	rect	/sunsoft/index.html 1,1 119,34
24
25# translate an x/y coordinate into a url
26
27proc Map_Lookup {request} {
28    if {[regexp {([^?]+)\?([0-9]+),([0-9]+)} $request {} map x y]} {
29	if [catch {file mtime $map} mtime] {
30	    return ""
31	}
32	if {![info exists ImageMaps($map)] ||
33		($mtime > $ImageMaps(mtime,$map))} {
34	    set ImageMaps($map) [MapRead $map]
35	    set ImageMaps(mtime,$map) $mtime
36	}
37	return [MapHit $ImageMaps($map) $x $y]
38    } else {
39	return ""
40    }
41}
42
43# Resolve hits by building a canvas (which is never mapped),
44# with the map objects.  Use the file name as the canvas tag.
45
46proc MapRead {file} {
47    if {[catch {open $file} fd]} {
48	Log "" "file open" $fd
49	return {}
50    }
51    regsub -all  {\.}  $file _ cookie
52    set data [read $fd]
53    close $fd
54    catch {destroy .image$cookie}
55    set can [canvas .image$cookie]
56    regsub -all "(^|\n+)#\[^\n]*" $data {} data
57    regsub -all {([][$\\])} $data {\\\1} data
58    set types circle|default|point|poly|rect
59    append exp {[ 	]*(} $types {)[ 	]+([^	}
60    append exp \n { ]+)[ 	]*([^} \n\r {]*)} \[\n\r]+
61    regsub -nocase -all $exp $data "\[MapInsert [list $can] \\1 {\\2} {\\3}]" cmd
62    $can lower default
63    set tags [$can itemconfigure default -tags]
64    $can itemconfigure default -tags [lindex $tags 0]
65    subst $cmd
66    return $can
67}
68
69# helper proc for generating the canvas
70
71proc MapInsert {can type href coords} {
72    regsub -all , $coords { } coords
73    if [catch {
74    switch -- $type {
75	default {
76	    upvar #0 $can default
77	    set default $href
78#	    $can create rectangle  0 0 1000 1000 -fill white -tags [list $href default]
79	}
80	circle {
81	    # The coords are the center and one point on the edge.
82	    # Tk ovals are defined by two corner points.
83	    foreach {x1 y1 x2 y2} $coords {break}
84	    set r [expr int(sqrt(($y2 - $y1) * ($y2 - $y1) + \
85				    ($x2 - $x1) * ($x2 - $x1)))]
86	    set x1 [expr $x1 - $r]
87	    set x2 [expr $x1 + 2*$r]
88	    set y1 [expr $y1 - $r]
89	    set y2 [expr $y1 + 2 * $r]
90	    $can create oval $x1 $y1 $x2 $y2 -fill black -tags $href
91	}
92	rect {
93	    eval {$can create rectangle} $coords -fill black -tags {$href}
94	}
95	poly {
96	    eval {$can create polygon} $coords -fill black -tags {$href}
97	}
98	point {
99	    eval {$can create oval} $coords $coords -width 2 -fill black \
100		    -tags {$href}
101	}
102    }} err] {
103	Log $can $href $err
104    }
105}
106
107proc MapHit {map x y} {
108    if {[catch {
109	$map gettags [lindex [$map find overlapping $x $y $x $y] 0]
110    } result]} {
111	set result {}
112    }
113    if {[string length $result] == 0} {
114	upvar #0 $map default
115	catch {set result $default}
116    }
117    return $result
118}
119