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