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

----
[Category Example] |
[Category Package] |
[Category Widget]