The package
namespace eval ::textURL \
{
# exports
namespace export textURL
# packages
package require Tk
package provide TextURL 0.2
package provide textURL 0.2
# 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 newattr {-foreground navy -underline 1}
set oldattr {-foreground gray -underline 1}
set list {command enter leave range url tag type}
foreach key $list { set ($w:$key) "" }
# get args
foreach {key value} $args \
{
switch -glob -- $key \
{
# {# textURL options }
+* \
{
switch -glob $key \
{
+cmd -
+com* { set ($w:command) $value }
+ent* { set ($w:enter) $value }
+lea* { set ($w:leave) $value }
+old* { set oldattr $value }
+new* { set newattr $value }
default { error "unknown option \"$key\": should be +newcolor, +oldcolor, +command or +cmd" }
}
}
# {# text options }
default { lappend cmd $key $value }
}
}
# create & configure text
eval $cmd
# redefine ref
rename $w ::textURL::_$w
interp alias {} $w {} ::textURL::dispatch $w
# tags config
eval $w tag config newURL $newattr
eval $w tag config oldURL $oldattr
# bindings
$w tag bind oldURL <Enter> [namespace code [list tagEvent $w oldURL enter]]
$w tag bind oldURL <Leave> [namespace code [list tagEvent $w oldURL leave]]
$w tag bind oldURL <Motion> [namespace code [list move $w oldURL]]
$w tag bind newURL <Enter> [namespace code [list tagEvent $w newURL enter]]
$w tag bind newURL <Leave> [namespace code [list tagEvent $w newURL leave]]
$w tag bind newURL <Motion> [namespace code [list move $w newURL]]
bind $w <1> [namespace code [list checkURL $w]]
# return ref
return $w
}
# ---------------
# dispatch operation
# ---------------
proc dispatch {w operation args} \
{
switch -glob -- $operation \
{
# {# text operations }
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]] }
# {# textURL operations }
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\"" }
}
uplevel 1 [linsert $args 0 $op $w]
}
# ---------------
# get the current URL
# ---------------
proc getURL {w type} \
{
variable {}
# get current index
set current [$w index current]
# get corresponding range
foreach {start end} [$w tag nextrange $type $current] break
if {![info exists start] || $current < $start} \
{
foreach {start end} [$w tag prevrange $type $current] break
if {![info exists start] || $current >= $end} { return }
}
# save range & type
set ($w:range) [list $start $end]
set ($w:type) $type
# return url
return [$w get $start $end]
}
# ---------------
# event
# ---------------
proc tagEvent {w type event {url ""}} \
{
variable {}
set cursor ""
switch $event \
{
enter \
{
# entering an URL
if {$url == ""} { set url [getURL $w $type] }
set cursor hand2
set ($w:url) $url
set ($w:type) $type
eval _$w tag add URL $($w:range)
}
leave \
{
# leaving an URL
set url $($w:url)
set cursor ""
set ($w:url) ""
set ($w:type) ""
eval _$w tag remove URL $($w:range)
}
}
# set/reset cursor
_$w config -cursor $cursor
# invoke corresponding callback
set cmd $($w:$event)
if {$cmd != ""} { uplevel 1 $cmd $type $url }
}
# ---------------
# move inside URL
# ---------------
proc move {w type} \
{
variable {}
set oldrange $($w:range)
set url [getURL $w $type]
set newrange $($w:range)
# check if URL range changed
if {$newrange != $oldrange} \
{
# yes, simulate enter, leave events
set ($w:range) $oldrange
::textURL::tagEvent $w $type leave
set ($w:range) $newrange
::textURL::tagEvent $w $type enter $url
}
}
# ---------------
# check if URL
# ---------------
proc checkURL {w} \
{
variable {}
# get current URL type
set type $($w:type)
if {$type == ""} { return }
# get URL text
set url $($w:url)
if {$type == "newURL"} \
{ # new URL
foreach {tag value} $($w:urls:$url) break
foreach {start end} [$w tag ranges $tag] \
{ # transform new to old URLs
$w tag add oldURL $start $end
$w tag remove newURL $start $end
}
}
# invoke URL
invokeURL $w $url
}
# ---------------
# invoke URL
# ---------------
proc invokeURL {w url args} \
{
variable {}
set cmd $($w:command)
if {$cmd != ""} \
{
# get URL value
set value [lindex $($w:urls:$url) 1]
# invoke command
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)]} \
{
# existing URL, get tag & value
foreach {tag value} $($w:urls:$url) break
} \
else \
{
# new URL, save tag & value
set tag URL[incr ($w:urlID)]
lappend ($w:urls:$url) $tag $value
}
$w insert $($w:index) $url [list $tag newURL]
}
}The demo
# ==============
# demo
# ==============
package require TextURL
namespace import ::textURL::textURL
proc myenter {type url} { .t tag config URL -underline 1 }
proc myleave {type url} { .t tag config URL -underline 0 }
proc mycmd {value} { tk_messageBox -message $value }
textURL .t -bd 1 -bg beige +enter myenter +leave myleave \
+cmd mycmd +new {-foreground red} +old {-foreground gray}
pack .t
.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"