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.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"