# This H module contains routines that deal with hyperlinks. The make procs # deal with and tags; the other procs handle binding commands to # the links and producing the popup windows when the the pointer passes over # a link. global link target set target([set link 0]) {} # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # The most important HTML tag is the Anchor ... proc tagA {w att} { global V me curT curW msg in link if {$V>1} {set id "$me/tagA"} if {$V>2} {puts "$id: att=\"$att\""} if {[incr in(A)] > 1} {Msg "Warning: nested to level $in(A)"} if [regexp -nocase {name="([^"]+)"} $att {} name] { if {$V>1} {puts "$id: New mark \"$name\" (quoted)"} NewMark $curT $name } elseif [regexp -nocase {name=([^ >]+)} $att {} name] { if {$V>1} {puts "$id: New mark \"$name\" (bare)"} NewMark $curT $name } if [regexp -nocase {href[ ]*=[ ]*"([^"]+)"} $att {} href] { if {$V>2} {puts "$id: HREF \"$href\" (quoted)"} } elseif [regexp -nocase {href=([^>]+)} $att {} href] { if {$V>2} {puts "$id: HREF \"$href\" (bare)"} } else { if {$V>1} {puts "$id: HREF not found in \"$att\""} return } if [regexp -nocase {target="([^"]+)"} $att {} trgt] { if {$V>2} {puts "$id: TARGET \"$trgt\" (quoted)"} } elseif [regexp -nocase {target=([^ >]+)} $att {} trgt] { if {$V>2} {puts "$id: TARGET \"$trgt\" (bare)"} } else { if {$V>1} {puts "$id: TARGET not found in \"$att\""} set trgt {} } if {$href != {}} { incr link BindLink $curT $link $href $trgt } } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # proc endA {w a} { global V me Ltag Lnum in if {$V>1} {set id "$me/endA"} if {$V>4} {puts "$id: Change Ltag from $Ltag to Lnorm"} set Ltag Lnorm set Lnum Lnk0 incr in(A) -1 } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Handle tag. This is a kludge for including URLs in text in a way that # # it is recognized as such while being displayed as-is. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # proc tagURL {w t d a} { global V me link Lnum Ltag set id "$me/tagURL" if {$V>1} {puts "$id: t={$t} d={$d} a={$a}"} incr link Htxt "<$t$d" BindLink $w $link $a {} Htxt $a set Ltag Lnorm set Lnum Lnk0 Htxt > } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Produce the bindings that make a hyperlink work. The tk mechanism is to tag # # the text with a LnkN tag, where N is the link counter. The tag has actions # # that use the link number to access the information about the link. Note the # # fact that we receive a text widget as our first arg. # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # proc BindLink {txt link href trgt} { global V me Link Lnum Ltag curT target set id "$me/BindLink" set Link($link) $href if {$V>2} {puts "$id: HREF Link($link)=\"$href\" trgt=\"$trgt\""} $txt tag bind Lnk$link "LinkButton1 $txt $link %X %Y" $txt tag bind Lnk$link "LinkShiftB1 $txt $link %X %Y" $txt tag bind Lnk$link "LinkButton3 $txt $link %X %Y" $txt tag bind Lnk$link "LinkEnter $txt $link %X %Y %txt" $txt tag bind Lnk$link "LinkLeave $txt $link %X %Y %txt" set Lnum Lnk$link if {$V>4} {puts "$id: Change Ltag from $Ltag to Llink"} set Ltag Llink set target($link) $trgt tagDefs $txt } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # proc LinkEnter {w n X Y W} { global C V me Link off opt curL curN namN set id "$me/LinkEnter" if {$V>2} {puts "$id: Enter Link $n \"$Link($n)\" X=$X Y=$Y w=\"$w\" W=\"$W\""} if {$opt(POPUP) && $opt(LNK)} { if ![winfo exists .doclink$n] { if {$V>4} {puts "$id: Create .doclink$n"} incr X $off(X) incr Y $off(Y) toplevel .doclink$n wm geometry .doclink$n +$X+$Y switch $opt(POPUP) { 0 {} 1 {set curL $Link($n)} 2 {set curL [url2URL $Link($n)]} 3 {set curL "$Link($n)\n[url2URL $Link($n)]"} } label .doclink$n.t -text $curL -bd 3 -bg black -fg $C(hl) -relief ridge pack .doclink$n.t -in .doclink$n wm overrideredirect .doclink$n 1 } } set namN($W) "Link $n" EnterW $W $X $Y } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # proc LinkLeave {w n X Y W} { global V me Link curL curN namN set id "$me/LinkLeave" if {$V>5} {puts "$id: Leave Link $n \"$Link($n)\" X=$X Y=$Y W=$W"} if [winfo exists .doclink$n] { if {$V>4} {puts "$id: Destroy .doclink$n"} destroy .doclink$n } set namN($W) "document" set curL {} EnterW $w $X $Y } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # proc EnterW {w X Y} { global V me curN namN if {$V>2} {puts "$me/EnterW: w=$w X=$X Y=$Y"} set W [winfo containing $X $Y] if [info exists namN($W)] {set curN "$W $namN($W)"} else {set curN $W} return $curN } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # #proc LeaveW {w X Y} { # global V me curN # if {$V>2} {puts "$me/LeaveW: w=$w X=$X Y=$Y"} #} # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # proc ObjEnter {w n X Y d} { global C V me Obj off opt curN if {$V>1} {set id "$me/ObjEnter"} if {$V>1} {puts "$id: Enter Obj $n \"$Obj($n)\""} if {$V>4} {puts "$id: Enter n=\"$n\" at X=$X Y=$Y d={$d}"} set Obj($n) "$d" if {$opt(POPUP)} { if ![winfo exists .objdesc$n] { if {$V>4} {puts "$id: Create .objdesc$n"} incr X $off(X) incr Y -$off(Y) toplevel .objdesc$n wm geometry .objdesc$n +$X+$Y label .objdesc$n.t -text $Obj($n) -bd 3 -bg black -fg white -relief ridge pack .objdesc$n.t -in .objdesc$n wm overrideredirect .objdesc$n 1 } } set curN $n } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # proc ObjLeave {w n X Y} { global V me Obj if {$V>1} {set id "$me/ObjLeave"} if {$V>4} {puts "$id: Leave n=\"$n\" at X=$X Y=$Y"} if [winfo exists .objdesc$n] { if {$V>4} {puts "$id: Destroy .objdesc$n"} destroy .objdesc$n } }