1# maptcl.tcl 2# Pure Tcl imagemap handling. 3# 4# read in an image map file, and generate the appropriate canvas 5# # sample image map 6# circle /sun-on-net/internet.sol/access.html 664,311 686,311 7# default http://www.hal.com/ 8# default /sunsoft/index.html 9# point /sunworldonline/common/swol-subscribe.html 45,134 10# poly / 182,11 184,88 301,77 365,86 393,57 393,10 11# rect /sunsoft/index.html 1,1 119,34 12# 13# Brent Welch (c) 1997 Sun Microsystems 14# Brent Welch (c) 1998-2000 Ajuba Solutions 15# See the file "license.terms" for information on usage and redistribution 16# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 17# 18# RCS: @(#) $Id: maptcl.tcl,v 1.5 2000/10/02 16:58:53 welch Exp $ 19 20package provide httpd::ismaptcl 1.0 21package require httpd::imagemap 1.0 22 23# translate an x/y coordinate into a url 24 25proc Map_Lookup {request} { 26 global ImageMaps 27 if {[regexp {([^?]+)\?([0-9]+),([0-9]+)} $request {} map x y]} { 28 if [catch {file mtime $map} mtime] { 29 return "" 30 } 31 if {![info exists ImageMaps($map)] || 32 ($mtime > $ImageMaps(mtime,$map))} { 33 set ImageMaps($map) [MapRead $map] 34 set ImageMaps(mtime,$map) $mtime 35 } 36 return [MapHit $ImageMaps($map) $x $y] 37 } else { 38 return "" 39 } 40} 41 42# MapRead - this parses a map data file and converts it to 43# a Tcl array that contains state about each region. 44# This parser is another famous regsub-subst combo by Steve Uhler 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 regsub -all "(^|\n+)#\[^\n]*" $data {} data 55 regsub -all {([][$\\])} $data {\\\1} data 56 set types circle|default|point|poly|rect 57 append exp {[ ]*(} $types {)[ ]+([^ } 58 append exp \n { ]+)[ ]*([^} \n\r {]*)} \[\n\r]+ 59 regsub -nocase -all $exp $data "\[MapInsert [list $cookie] \\1 {\\2} {\\3}]" cmd 60 upvar #0 $cookie map 61 catch {unset map} 62 subst $cmd 63 return $cookie 64} 65 66# helper proc for generating the data structure 67 68proc MapInsert {cookie type href coords} { 69 upvar #0 $cookie map 70 if ![info exists map] { 71 set map(N) 0 72 } else { 73 incr map(N) 74 } 75 regsub -all , $coords { } coords 76 set c {} 77 set i 0 78 foreach {X Y} $coords { 79 lappend c $i,X $X $i,Y $Y 80 incr i 81 } 82 set map($map(N),type) $type 83 set map($map(N),coords) $c 84 set map($map(N),href) $href 85 if {$type == "default"} { 86 set map(default) $href 87 } 88} 89 90# MapHit looks up coordinates in a map 91 92proc MapHit {cookie x y} { 93 upvar #0 $cookie map 94 set sawpoint 0 95 for {set i 0} {$i < $map(N)} {incr i} { 96 array set pgon $map($i,coords) 97 switch $map($i,type) { 98 poly { 99 if [MapPointInPoly $x $y pgon] { 100 return $map($i,href) 101 } 102 } 103 circle { 104 if [MapPointInCircle $x $y pgon] { 105 return $map($i,href) 106 } 107 } 108 rect { 109 if [MapPointInRect $x $y pgon] { 110 return $map($i,href) 111 } 112 } 113 point { 114 set dist [expr ($x - $pgon(0,X)) * ($x - $pgon(0,X)) + \ 115 ($y - $pgon(0,Y)) * ($y - $pgon(0,Y))] 116 if {!$sawpoint || ($dist < $mindist)} { 117 set mindist $dist 118 set default $map($i,href) 119 } 120 } 121 } 122 } 123 if [info exists default] { 124 return $default 125 } 126 if [info exists map(default)] { 127 return $map(default) 128 } 129 return {} 130} 131 132