#
# $Source: /home/nlfm/Working/Zircon/Released/lib/RCS/Tags.tcl,v $
# $Date: 2001/07/17 09:30:32 $
# $Revision: 1.18.1.12 $
#
# ----------------------------------------------------------------------
#   AUTHOR:  Lindsay Marshall <lindsay.marshall@newcastle.ac.uk>
# ----------------------------------------------------------------------
# Copyright 2000 The University of Newcastle upon Tyne (see COPYRIGHT)
# ======================================================================
#
#
#
package provide zircon 1.18
#
proc URLOpen {chid win x y} {
    foreach {line ch} [split [$win index @$x,$y] .] break
    foreach {l r} [$win tag ranges @url@] {
       foreach {ll cl} [split $l .] break
       if {$ll != $line} continue
       if {$cl <= $ch} {
           foreach {lr cr} [split $r .] break
	   if {$ch <= $cr} {
	       handleURL [$chid net] [$win get $l $r]
	       break
	   }
       }
    }
}
#
proc setProps {chan args} {
    foreach win $args {
	foreach x {font background foreground} {
            switch {} [set v [$chan $x]] continue
	    $win configure -$x $v
	}
        switch {} [$chan colour] {} default { makeColourTags $win }
	$win tag configure @url@ -foreground [[$chan net] urlcolour]
	$win tag bind @url@ <Double-1> "URLOpen $chan %W %x %y"
    }
}
#
proc getOValue {this win opt lc uc} {
    upvar #0 $this cdata
    if {[info exists cdata($lc)]} {
	if {$cdata($lc) != {}} { return $cdata($lc) }
    }
    switch {} [set x [option get $win $lc $uc]] {set x [$win cget -$opt]}
    return $x
}
#
proc getTValue {this win win2 opt lc uc} {
    switch {} [set x [option get $win $lc $uc]] {
	upvar #0 $this cdata
    	if {[info exists cdata($opt)]} {
	    if {$cdata($opt) != {}} { return $cdata($opt) }
	}
	if {[catch {$win2 cget -$opt} x]} {
	    error "Weird error!!!! ($x) - please tell \
Lindsay.Marshall@ncl.ac.uk exactly what you were doing when this happened."
	} 
    }
    return $x
}
#
proc channel_defaultTags {this} {
    global TFn TFg TBg BF
    set txt [$this text]
    foreach x {@BAN @CTCP @ERROR @INFO @QUIT @WARN} {
	setTags $this $x
	confTag $txt $x $TFg($this,$x) $TBg($this,$x) $TFn($this,$x) $BF($this)
    }
}
#
proc setTags {this nk} {
    global TFn TFa TFg TBg TAF TAB TBl Bl
    set w [$this text]
    set x "$this,$nk"
    set ch [$this tagWindow]
    set TFn($x) [getTValue $this $ch $w font ${nk}Font Font]
    set TFg($x) [getTValue $this $ch $w foreground ${nk}Foreground Foreground]
    set TBg($x) [getTValue $this $ch $w background ${nk}Background Background]
    set TFa($x) [getTValue $this $ch $w font ${nk}ActionFont Font]
    set TAF($x) [getTValue $this $ch $w foreground ${nk}ActionForeground Foreground]
    set TAB($x) [getTValue $this $ch $w background ${nk}ActionBackground Background]
    switch {} [set TBl($x) [option get $ch ${nk}Bell Bell]] {
	if {[info exists Bl($this)]} { set TBl($x) $Bl($this) }
    }
}
#
proc tagConf {txt tag fg bg ft} {
    catch {$txt tag configure $tag -foreground $fg}
    catch {$txt tag configure $tag -background $bg}
    switch {} $ft {} default {catch {$txt tag configure $tag -font $ft}}
}
#
proc confTag {txt tag fg bg cfont bold} {
    switch {} $tag {} default {tagConf $txt $tag $fg $bg $cfont}
    tagConf $txt @b@$tag $fg $bg $bold
    tagConf $txt @v@$tag $bg $fg {}
    tagConf $txt @u@$tag $fg $bg {}
    $txt tag configure @u@$tag -underline 1
    tagConf $txt @a@$tag $bg $fg {}
    $txt tag configure @a@$tag -relief raised -borderwidth 2
}
#
proc channel_makeTag {this usr} {
    global Fg Bg BF
    if {[[$this net] me $usr]} {
	set tagInfo [$this tagInfo [set tag @me]]
    } {
	set tagInfo [$this tagInfo [[set tag $usr] lname]]
    }
    set name [$this text]
    confTag $name $tag [lindex $tagInfo 0] [lindex $tagInfo 1] \
       [lindex $tagInfo 2] [expr {[string match {} $BF($this)] ? [lindex $tagInfo 2] : $BF($this)}]
}
#
proc channel_delTag {this usr} {
    global TFn TFa TFg TBg TAF TAB TBl
    if {[[$this net] me $usr]} { set tag @me } { set tag [$usr lname] }
    foreach x {TFn TFa TFg TBg TAF TAB TBl} { safeUnset ${x}($this,$tag) }
}
#
proc channel_tagInfo {this tag} {
    switch -- $tag {} {return {}}
    global TFn TFg TBg
    set indx "$this,$tag"
    if {![info exists TFn($indx)]} { setTags $this $tag }
    return [list $TFg($indx) $TBg($indx) $TFn($indx)]
}
#
proc cmkw {path} {
    if {![winfo exists $path] && [catch {frame $path} msg]} {
	tellError {} {Option Host Error} "Error in your X resources - $msg"
	return 1
    }
    return 0
}
#
proc channel_tagWindow {this} {
   set w [$this lname]
   set type [string tolower [$this type]]
   if {![winfo exists .$type.$w]} {
	if {[cmkw [set path .$type]]} { return . }
	set r $w
	while {[regexp {([^.]*)\.(.*)} $r match f r]} {	
	    append path .$f
	    if {[cmkw $path]} { return .$type }
	}
	if {[cmkw $path.$r]} { return .$type }
   }
   return .$type.$w
}
#
proc makeColourTags {win} {
    foreach v {mIRCCol vt100Colour} {
        foreach {x y} [uplevel #0 array get $v] {
	    $win tag configure @f$y@ -foreground $y
	    $win tag configure @b$y@ -background $y
	}
    }
}
#
proc handleColour {name tl var val fb mod} {
    upvar $tl tagList
    upvar #0 $var colr
    set val [expr {$val % $mod}]
    listkill tagList @${fb}#*@
    lappend tagList @$fb$colr($val)@
    $name tag raise @$fb$colr($val)@
}
#
proc insertText {this name text tag} {
    lappend taglist $tag
    switch -glob -- $text "*\[\002\003\007\017\026\033\037\]*" {
	set bellcnt 0
	while {[regexp \
	  "^(\[^\002\003\007\017\026\033\037\]*)(\[\002\003\007\017\026\033\037\])(.*)$" \
	  $text match m1 ch text]} {
	    URLInsert $name $m1 $taglist
	    switch -- $ch {
	    \002 { set spc @b@ }
	    \007 {
		    if {![set bl [[$this net] beeplimit]] || [incr bellcnt] < $bl} {
		        if {![$this quiet]} { playBell $this $tag }
		        $name insert end { } $taglist [[$this net] beep] \
		          [concat $taglist @a@$tag] { } $taglist
		    }
		    continue
		}
	    \017 { set taglist {} ; lappend taglist $tag ; continue }
	    \026 { set spc @v@ }
	    \037 { set spc @u@ }
	    \003 {
		# colour stuff
		    global mIRCCol
		    if {[regexp {^([0-9][0-9]?)(,([0-9][0-9]?))?(.*)} \
		      $text m fg bl bg text]} {
		        if {[listmember [$this colour] mirc]} {
			    regexp {0(.)} $fg m fg
			    handleColour $name taglist mIRCCol $fg f 15
			    switch {} $bg {} default {
			        regexp {0(.)} $bg m bg
			        handleColour $name taglist mIRCCol $bg b 15
			    }
			}
		    } {
			listkill taglist @f#*@*
			listkill taglist @b#*@*
		    }
		    continue
		}
	    \033 {
		    # ansi colour stuff
		    if {[regexp {^\[([0-7][0-7]?)m(.*)} $text m n text]} {
		        switch -glob -- $n {
			    0 { # normal
				set taglist {}
				lappend taglist $tag
				continue
 			    }
			    1 { # bold
			        set spc @b@
			    }
			    4 { # underscore
			        set spc @u@
			    }
			    5 { continue ; # blink }
			    7 { # reverse
			        set spc @v@
			    }
			    3* { # foreground
		    		if {[listmember [$this colour] ansi]} {
				    handleColour $name taglist vt100Colour \
				      [string index $n 1] f 7
				}
				continue
			     }
			    4* { # background
		    		if {[listmember [$this colour] ansi]} {
				    handleColour $name taglist vt100Colour \
				      [string index $n 1] b 7
				}
				continue
			     }
			}
		    } {
		        continue
		    }
		}
	    }
	    if {[set x [lsearch $taglist ${spc}*]] < 0} {
		lappend taglist $spc$tag
	    } {	set taglist [lreplace $taglist $x $x] }
	}
    }
    URLInsert $name $text $taglist
}
#
proc URLInsert {win text taglist} {
    switch {} $text return
    while {[regexp -indices \
      "(http|https|ftp|news|telnet|file)(:/+\[^ \n\t\"\>\]+\[^ \n\t,\.\)>\'\"\])" \
      $text match]} {
        foreach {lft rgt} $match break
        if {$lft > 0} {
            $win insert end [string range $text 0 [expr {$lft - 1}]] $taglist
	}
	$win insert end [string range $text $lft $rgt] [join [list @url@] $taglist]
        set text [string range $text [expr {$rgt + 1}] end]
    }
    $win insert end $text $taglist
}
