ulis, 2003-09-05: A minimal package to simulate the URL behaviour in a text widget.
The package:
namespace eval ::textURL \
{
# exports
namespace export textURL
# packages
package require Tk
package provide TextURL 0.1
package provide textURL 0.1
# global vars
set () {}
# ---------------
# create text widget
# ---------------
proc textURL {w args} \
{
variable {}
set cmd [list text $w]
# init URL current ID
set ($w:urlID) 0
# default values
set newcolor navy
set oldcolor gray
set ($w:command) {tk_messageBox -message}
# get args
foreach {key value} $args \
{
switch -glob -- $key \
{
+* \
{
switch -glob $key \
{
+cmd -
+com* { set ($w:command) $value }
+old* { set oldcolor $value }
+new* { set newcolor $value }
default { error "unknown option \"$key\": should be +newcolor, +oldcolor, +command or +cmd" }
}
}
default { lappend cmd $key $value }
}
}
# create & configure text
eval $cmd
# redefine ref
rename $w ::textURL::_$w
interp alias {} $w {} ::textURL::dispatch $w
# tags config
$w tag config newURL -underline 1 -foreground $newcolor
$w tag config oldURL -underline 1 -foreground $oldcolor
# bindings
$w tag bind oldURL <Enter> [namespace code [list _$w config -cursor hand2]]
$w tag bind oldURL <Leave> [namespace code [list _$w config -cursor ""]]
$w tag bind newURL <Enter> [namespace code [list _$w config -cursor hand2]]
$w tag bind newURL <Leave> [namespace code [list _$w config -cursor ""]]
bind $w <1> [namespace code [list checkURL $w]]
# return ref
return $w
}
# ---------------
# dispatch operation
# ---------------
proc dispatch {w operation args} \
{
switch -glob -- $operation \
{
bbo* - cge* - com* - con* - deg* - del* - dli* - dum* -
edi* - get - ima* - ind* - ins* - mar* - sca* - sea* -
see - tag - win* - xvi* - yvi* \
{ return [uplevel 1 [linsert $args 0 ::textURL::_$w $operation]] }
che* { set op ::textURL::checkURL }
to { set op ::textURL::toIndex }
tex* { set op ::textURL::textInsert }
url { set op ::textURL::urlInsert }
inv* { set op ::textURL::invokeURL }
default { error "unknown operation \"$operation\"" }
}
puts "uplevel 1 [linsert $args 0 $op $w]"
uplevel 1 [linsert $args 0 $op $w]
}
# ---------------
# check if URL
# ---------------
proc checkURL {w} \
{
variable {}
set current [$w index current]
foreach {start end} [$w tag prevrange newURL $current] break
if {[info exists start] && $current <= $end} \
{
# new URL
set url [$w get $start $end]
foreach {tag value} $($w:urls:$url) break
foreach {start end} [$w tag ranges $tag] \
{
$w tag add oldURL $start $end
$w tag remove newURL $start $end
}
invokeURL $w $url
return
}
foreach {start end} [$w tag prevrange oldURL $current] break
if {[info exists start] && $current <= $end} \
{
# old URL
invokeURL $w [$w get $start $end]
}
}
# ---------------
# invoke URL
# ---------------
proc invokeURL {w url args} \
{
variable {}
set cmd $($w:command)
if {$cmd != ""} \
{
set value [lindex $($w:urls:$url) 1]
uplevel 1 $cmd $value $args
}
}
# ---------------
# set text index
# ---------------
proc toIndex {w index} \
{
variable {}
set ($w:index) $index
}
# ---------------
# insert text
# ---------------
proc textInsert {w text} \
{
variable {}
$w insert $($w:index) $text
}
# ---------------
# insert url
# ---------------
proc urlInsert {w url {value ""}} \
{
variable {}
if {[info exists ($w:urls:$url)]} \
{
foreach {tag value} $($w:urls:$url) break
} \
else \
{
set tag URL[incr ($w:urlID)]
lappend ($w:urls:$url) $tag $value
}
$w insert $($w:index) $url [list $tag newURL]
}
}A little demo:
# ============== # demo # ============== package require TextURL namespace import ::textURL::textURL pack [textURL .t +new red -bd 1] .t to 1.end .t text "a line with an " .t url URL1 value1 .t text " inside\n" .t to 2.end .t text "a line with an " .t url URL2 value2 .t text " inside\n" .t to 3.end .t text "a line with an " .t url URL1 value1 .t text " inside\n"