#
# $Source: /home/nlfm/Working/Zircon/Released/lib/RCS/Util.tcl,v $
# $Date: 2001/06/13 07:20:27 $
# $Revision: 1.18.1.87 $
#
package provide zircon 1.18
#
proc makeArray {args} {
    foreach x $args {
        uplevel #0 "set ${x}(1) 1; unset ${x}(1)"
    }
}
#
proc window {chan} {return [[find $chan] window]}
#
proc normal {w} { switch normal [$w cget -state] {return 1} ; return 0}
#
proc capitalise {str} {return [string toupper [string index $str 0]][string range $str 1 end]}
#
proc getOption {vn dflt} {
    upvar #0 $vn var
    switch {} [set var [option get . $vn [capitalise $vn]]] {set var $dflt}
}
#
# List utilities
#
proc listmember {list val} {return [expr {[lsearch $list $val] >= 0}]}
#
proc listkill {list val} {
    upvar $list lst
    if {[set x [lsearch $lst $val]] >= 0} { set lst [lreplace $lst $x $x]}
    return $lst
}
#
proc listremove {lst val} {
    if {[set x [lsearch $lst $val]] >= 0} { set lst [lreplace $lst $x $x]}
    return $lst
}
#
proc listincl {list val} {
    upvar $list lst
    if {![listmember $lst $val]} { lappend lst $val }
    return $lst
}
#
proc listmatch {list val} {
    set i 0
    foreach item $list {
	switch -- [lindex $item 0] $val {return $i}
	incr i
    }
    return -1
}
#
proc listdel {v item} {
    upvar $v lst
    catch {set lst [lreplace $lst $item $item]}
    return $lst
}
#
proc listput {list posn val} {
    upvar $list lst
    return [set lst [linsert $lst $posn $val]]
}
#
proc listupdate {list item val} {
    upvar $list lst
    while {[llength $lst] <= $item} {lappend lst {} }
    return [set lst [lreplace $lst $item $item $val]]
}
#
proc listmove {list from to val} {
    upvar $list lst
    return [set lst [linsert [lreplace $lst $from $from] $to $val]]
}
#
# Procedure used to shorten menu labels to 10 characters. Used
# when adding user provided items to menus
#
proc prune {name lng} {
    regsub -all "\[\002\017\026\037\]" $name {} name
    return [expr {[string length $name] > $lng ? \
      "[string range $name 0 [expr {$lng - 3}]]..." : $name}]
}
#
proc killWindow {win} {
    safeUnset Icon($win) IconBM($win)
    catch {destroy $win}
}
#
#	proc me : Returns true if nk is this user
#		  Assumes that nk is in lower case!!!
#
proc me {nk net} {
    switch -- [string tolower $nk] [[$net myid] lname] {return 1}
    return 0
}
#
proc addCTCPMenu {net name usr} {
    global ctcpCmds DEBUG specialCmds
    $name add cascade -label [trans ctcp] -menu $name.ctcp
    menu $name.ctcp 
    set cmdlst $ctcpCmds
    switch {} [$net players] {} default { lappend cmdlst Sound }
    if {$DEBUG} { lappend cmdlst Zircon }
    foreach cmd $cmdlst {
	switch {{}} $usr {
	    set prc "usersCTCP $net [string toupper $cmd]"
	    $name.ctcp configure -tearoff 0
	} default {
	    set prc "doCtcp $net [string toupper $cmd] \[$usr name\]"
	    catch {$name.ctcp configure -tearoffcommand "retitle \"CTCP menu for \[$usr name\]\""}
	}
	$name.ctcp add command -label [trans $cmd] -command $prc
    }
}
#
proc addChanCTCPMenu {name ctl} {
    global ctcpCmds DEBUG specialCmds
    $name add cascade -label [trans ctcp] -menu $name.ctcp
    menu $name.ctcp -tearoff 0
    foreach cmd [expr {$DEBUG ? [concat $ctcpCmds $specialCmds] : $ctcpCmds}] {
	$name.ctcp add command -label [trans $cmd] \
	  -command "chanCTCP [string toupper $cmd] $ctl"
    }
}
#
proc addDCCMenu {name usr} {
    $name add cascade -label [trans dcc] -menu $name.dcc
    menu $name.dcc -tearoff 0
    foreach cmd {Send Chat} { $name.dcc add command -label [trans $cmd] \
      -command "doDCC [$usr net] [string toupper $cmd] \[$usr name\]" }
}
#
proc newNickAction {net win usr chid} {
    mkEntryBox .@${usr}action [trans action] "Enter your action for [$usr name]:" \
      [list [list action {} {} palette]] \
      [list send "NickAction 1 0 $net $win $usr $chid"] [list {send & keep} "NickAction 1 1 $net $win $usr $chid"] \
      [list keep "NickAction 0 1 $net $win $usr $chid"] [list cancel {}]
}
#
proc NickAction {send keep net win usr chid action} {
    if {$send} { $chid doNickAction $usr $action }
    if {$keep} {
        $chid configure +nickactions [list [$usr name] $action]
	$win.action add command -label [prune $action 15] \
	  -command "$chid doNickAction $usr [list $action]"
    }
}
#
proc addActionMenu {net win usr chid} {
    if {![$chid isa Channel]} return
    $win add cascade -label [trans action] -menu $win.action
    menu $win.action -tearoff 0
    $win.action add command -label [trans New] \
      -command "newNickAction $net $win $usr $chid"
    $win.action add separator
    foreach x [$net nickactions] {
        foreach {chan nick label action} $x break
	switch {} $action {
	    set action $label
	    set label [prune $action 12]
	}
	if {[regexp -- $chan [$chid name]] && [regexp -- $nick [$usr name]]} {
	    $win.action add command -label $label \
	      -command "$chid doNickAction $usr [list $action]"
	}
    }
    foreach x [$chid nickactions] {
        foreach {nick label action} $x break
	switch {} $action {
	    set action $label
	    set label [prune $action 12]
	}
	if {[regexp -- $nick [$usr name]]} {
	    $win.action add command -label $label \
	      -command "$chid doNickAction $usr [list $action]"
	}
    }
    switch nil [set frd [$usr fobj]] {} default {
        foreach x [$frd actions] {
            foreach {chan label action} $x break
	    switch {} $action {
	        set action $label
	        set label [prune $action 12]
	    }
	    if {[regexp -- $chan [$chid name]]} {
	        $win.action add command -label $label \
	          -command "$chid doNickAction $usr [list $action]"
	    }
	}
    }
}
#
proc makeUserMenu {chid win usr} {
    if {[winfo exists $win]} { return $win }
    return [menu $win -postcommand "postUM $chid $win $usr"]
}
#
#
proc postUM {chid win usr} {
    global ucmds Ops
    set w [winfo parent $win]
    set net [$usr net]
    set nrm [string compare nil $chid]
    array set ucmds "
	Whois	{$net WHOIS \[$usr lname\]}
	Message	{Message :: make $net \[$usr name\]}
	Notice	{channelNotice $net \[$usr lname\]}
	Action	{}
	Time	{$net TIME \[$usr name\]}
	CTCP	{}
	DCC	{}
	Notify	{}
	Ignore	{}
	Finger	{}
	Speak	{}
	ChanOp	{}
	Kick	{$chid kick $usr}
	Ban	{doBan $net + $chid \[$usr name\]!*@*}
	BanKick {$chid banKick $usr}
	Kill	{}
    "
    foreach cmd $Ops(userMenu) {
	switch $cmd {
	Action { addActionMenu $net $win $usr $chid}
	CTCP { addCTCPMenu $net $win $usr }
	DCC { addDCCMenu $win $usr }
	Notify {
		$win add checkbutton -label [trans notify] \
		  -variable ${usr}(notify) -command "$usr doNotify"
	    }
	Whois -
	Message -
	Notice -
	Time { $win add command -label [trans $cmd] -command $ucmds($cmd) }
	Ignore { if {$nrm} {addIgnoreMenu $win $usr} }
	Finger {
		if {$nrm} {
		    $win add command -label [trans finger] -command "$usr finger"
		}
	   }
	Silence {
		if {[$net undernet]} {
		    $win add cascade -label [trans silence] \
		      -menu $win.silence
		    menu $win.silence -tearoff 0
		    $win.silence add command -label [trans (silence] \
		      -command "underUSilence + $net $usr"
		    $win.silence add command -label [trans delete] \
		      -command "underUSilence - $net $usr"
		}
	    }
	}
    }
    addPluginMenu $win $net $chid $usr
    if {$nrm} {
	set st [expr {(![$net restricted] && [$chid operator]) ? "normal" : "disabled"}]
	foreach cmd $Ops(chanop) {
	    switch $cmd {
	    Speak {
		$win add checkbutton -label [trans speak] \
		  -variable ${chid}(lclSpk,$usr) \
		  -command "$chid userMode $usr v" -state $st
	      }
	    ChanOp {
		$win add checkbutton -label [trans chanop] \
		  -variable ${chid}(lclOp,$usr) \
		  -command "$chid userMode $usr o" -state $st
	      }
	    Kick -
	    Ban -
	    BanKick {
		$win add command -label [trans $cmd] \
		  -command $ucmds($cmd) -state $st
	      }
	    }
        }
	foreach cmd $Ops(ircop) {
	    switch $cmd {
	    Kill {
		$win add command -label [trans kill] -command "$usr kill" \
		  -state [expr {[$net ircop] ? {normal} : {disabled}}] \
		  -foreground red
	      }
	    }
	}
    }
    $win configure -postcommand {}
}
#
proc invert {b} {
    $b conf -fg [$b cget -bg] -bg [$b cget -fg] -activef [$b cget -activeb] \
      -activeb [$b cget -activef]
}
#
proc makeLB {win args} {
    frame $win -borderwidth 0 -relief flat
    grid columnconfigure $win 0 -weight 1
    grid rowconfigure $win 0 -weight 1
    scrollbar $win.vs -command "$win.l yview" -relief sunken -highlightthickness 0
    scrollbar $win.hs -command "$win.l xview" -orient horizontal \
      -relief sunken -highlightthickness 0
    eval listbox $win.l -xscrollcommand "{ghsSet $win.hs}" \
      -yscrollcommand "{gvsSet $win.vs}" -selectmode single -setgrid 1 $args
    grid $win.l -row 0 -column 0 -sticky nsew
    bind $win <Enter> {focus %W.l}
    return $win
}
#
proc ghsSet {sb f l} {
    switch 0 $f {switch 1 $l {catch {grid forget $sb ; return}}}
    catch {grid $sb -row 1 -column 0 -sticky ew}
    $sb set $f $l
}
#
proc gvsSet {sb f l} {
    switch 0 $f {switch 1 $l {catch {grid forget $sb ; return}}}
    catch {grid $sb -row 0 -column 1 -sticky ns}
    $sb set $f $l
}
#
proc utest {net win x y cmd} {
    set name [lindex [$win tag names @$x,$y] 0]
    switch -glob -- $name {
    user* { eval $cmd $net \{[$name lname]\}}
    @?@user* { eval $cmd $net \{[[string range $name 3 end] lname]\}}
    }
    notIdle $win $net
}
#
proc who2 {net name} {$net WHOIS $name $name}
#
proc rebind {txt net} {
    $txt configure -state disabled -takefocus 0
    bind $txt <Any-KeyPress> "notIdle %W $net; break"
    bind $txt <Double-Button-2> "utest $net %W %x %y {Message :: make}"
    bind $txt <Shift-Double-Button-2> "utest $net %W %x %y who2"
    bind $txt <Control-Double-Button-2> "utest $net %W %x %y finger"
    bind $txt <Double-3> "findURL %W %x %y $net"
}
#
# retitle is used by tearoff code...
#
proc retitle {t w1 w2} { wm title $w2 $t }
#
proc makeMB {win text} {
    menubutton $win -text [trans $text] -menu $win.menu -padx 4 -pady 5
    return [menu $win.menu]
}
#
proc addSeparator {w args} {
    global zircon
    eval grid [frame $w.[newName s] -background $zircon(sepColor) \
      -borderwidth 4]  -sticky ew -pady 4 $args
}
#
proc getDate {} { return [clock format [clock seconds]] }
#
proc ipPack {ip} {
    set val 0
    foreach x [split $ip .] { set val [expr {($val << 8) | ($x & 0xff)}] }
    return [format %u $val]
}
#
proc IPaccept {p1 p2 args} {
    global hostIPaddress
    set hostIPaddress $p2
    catch {close $p1}
}
#
proc ipAddress {} {
    global hostIPaddress
    if {![info exists hostIPaddress]} {
	set hostIPaddress {}
	set sock [socket -server IPaccept 0]
	set sock2 [socket [info hostname] \
	  [lindex 1 [fconfigure $sock -sockname]]]
	vwait hostIPaddress
	catch {close $sock}
	catch {close $sock2}
	switch -- $hostIPaddress {0.0.0.0} - {127.0.0.1} {
	    tkwait [mkDialog {} .@ip {IP Number} \
	      {Please enter the IP number for your host} \
	      [list [list {IP Number} {}]] [list ok "set hostIPaddress"]]
	}
    }
    return $hostIPaddress
}
#
proc makeServer {cmd} {
    if {[catch {socket -server $cmd 0} sock]} { error $sock }
    if {[catch {fconfigure $sock -sockname} xx]} {
	error "Cannot get port for server - $xx"
    }
    return [list $sock $xx]
}
#
proc zping {res} {
    if {![regexp {^[0-9]+$} [string trim $res]]} { return $res }
    if {[catch  {set v [expr {[clock seconds] - $res}]}]} {
	return $res
    }
    return $v
}
#
proc safeClean {txt} {return [split [string trim $txt]]}
#
proc notIdle {win args} {
    switch {} $args {
	global currentNet
	catch {$currentNet configure -idle 0}
    } default {
	catch {$args configure -idle 0}
    }
    catch {[Window :: id $win] extendTime}
}
#
proc popup {win} {
    wm deiconify [set win [winfo toplevel $win]]
    raise $win
    catch {[Window :: id $win] extendTime}
}
#
proc checkIndicator {net win flag} {
    if {[$net ircIIops]} {
        set txt [$win cget -text]
	regexp {^(@?)(\+?)(.*)} $txt m op spk txt
        switch $flag operator { set txt @$txt } speaker { set txt +$txt }
	$win configure -text $txt
    }
}
#
proc markButton {net name which} {
    if {![winfo exists $name]} return
    foreach {opt uopt lopt} {font Font font \
	foreground Foreground foreground \
	background Background background \
	activeForeground ActiveForeground activeforeground \
	activeBackground ActiveBackground activebackground} {
	set fopt $which[switch {} $which {set opt} default {set uopt}]
	switch {} [set cl [option get $name $fopt $uopt]] {
	    switch {} $which {
		switch {} [set cl [lindex [$name conf -$lopt] 3]] {} default {
		    if {[catch {$name conf -$lopt $cl} msg]} {
			tellError {} {Option Error} "$opt configuration error - \"$msg\""
		    }
		}
	    }
	} default {
	    if {[catch {$name conf -$lopt $cl} msg]} {
		tellError {} {Option Error} "$opt configuration error - \"$msg\""
	    }
	} \
    }
    checkColour $name
    checkIndicator $net $name $which
}
#
proc lchange {x} {
    set inc 20
    if {(255 - $x) < 20} { set inc -20 }
    return [expr {(($x + $inc) & 255)}]
}
#
proc lighten {w cl} {
    set res #
    foreach x [winfo rgb $w $cl] { append res [format %04x [lchange $x]] }
    return $res
}
#
proc markEntry {name index which} {
    if {![winfo exists $name] || $index == -1} return
    foreach {opt uopt lopt} {font Font font \
      background Background background \
      activeBackground ActiveBackground activebackground} {
	set fopt $which[switch {} $which {set opt} default {set uopt}]
	switch {} [set cl [option get $name $fopt $uopt]] {
	    switch {} $which {
		switch {} [set cl [lindex [$name conf -$lopt] 3]] {} default {
		    $name entryconfigure $index -$lopt $cl
		}
	    }
	} default {
	    $name entryconfigure $index -$lopt $cl
	} \
    }
    checkColour $name
}
#
proc checkColour {name} {
    switch -- [$name cget -activef] [$name cget -fg] {
	switch -- [$name cget -activeba] [set bg [$name cget -bg]] {
	    $name configure -activeba [lighten $name $bg]
	}
    }
}
proc bgIns {col chan prt} {
    switch $prt {
    Topic {
	    set w [$chan window].topic.entry
	    set txt [$w get 1.0 end]
	    set indx [string range [$w index insert] 2 end]
	}
    Entry {
	    set w [$chan window].cmd.entry
	    set txt [$w get]
	    set indx [$w index insert]
	}
    default {
	    set w $prt
	    set txt [$w get]
	    set indx [$w index insert]
	}
    }
    if {[regexp "\003\[0-9\]\[0-9\]?$" [string range $txt 0 [incr indx -1]]]} {
	set str ,$col
    } {
	set str "\0031,$col"
    }
    $w insert insert $str
}
#
proc palIns {char chan prt} {
    switch $prt Topic { set w [$chan window].topic.entry } \
      Entry { set w [$chan window].cmd.entry } default {set w $prt}
    $w insert insert $char
}
#
proc popPalette {m chn prt col x y} {
    global mIRCCol vt100Colour
    if {![winfo exists $m]} {
	menu $m -tearoff 0
	$m add command -label [trans bold] -command "palIns \002 {$chn} {$prt}"
	$m add command -label [trans inverse] -command "palIns \026 {$chn} {$prt}"
	$m add command -label [trans underline] -command "palIns \037 {$chn} {$prt}"
	$m add command -label [trans normal] -command "palIns \017 {$chn} {$prt}"
        foreach ct $col {
	    switch $ct mirc {
	        $m add separator
		$m add command -label {mIRC Colour}
	        $m add cascade -label [trans foreground] -menu $m.fg
	        $m add cascade -label [trans background] -menu $m.bg
	        menu $m.fg -tearoff 0
		set cls [lsort [array names mIRCCol]]
	        foreach cnt $cls {
		    $m.fg add command -background $mIRCCol($cnt) \
		       -command "palIns [list \003$cnt] $chn [list $prt]"
	        }
	        menu $m.bg -tearoff 0
	        foreach z $cls {
		    $m.bg add command -background $mIRCCol($z) \
		       -command "bgIns $z $chn [list $prt]"
	        }
	    } ansi {
	        $m add separator
		$m add command -label {ANSI Colour}
	        $m add cascade -label [trans foreground] -menu $m.vfg
	        $m add cascade -label [trans background] -menu $m.vbg
	        menu $m.vfg -tearoff 0
	        foreach cnt {0 1 2 3 4 5 6 7} {
		    $m.vfg add command -background $vt100Colour($cnt) \
		       -command "palIns [list \033\[3${cnt}m] $chn [list $prt]"
	        }
	        menu $m.vbg -tearoff 0
	        foreach cnt {0 1 2 3 4 5 6 7} {
		    $m.vbg add command -background $vt100Colour($cnt) \
		       -command "palIns [list \033\[4${cnt}m] $chn [list $prt]"
	        }
	    } ctcp2 {
	        $m add separator
		$m add command -label {CTCP2 Colour}
	    }
	}
    }
    tk_popup $m $x $y
}
#
proc makePalette {w chn prt name ft col} {
    if {[winfo exists $w]} {popup $w ; return} 
    global Ft
    killWindow $w
    makeToplevel $w "$name Palette" {} {}
    wm resizable $w 0 0
    set row 0
    switch {} $ft {set ft [$prt cget -font]}
    foreach i {8 9 10 11 12 13 14 15} {
	foreach j {0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
	    set qc [set c [format "%c" [expr {$i * 16 + $j}]]]
	    set qc [list $c]
	    grid [button $w.${i}l$j -text $c -relief raised -width 1 \
	      -command "palIns $qc {$chn} {$prt}" -font $ft] -row $row \
	      -column $j
	}
	incr row
    }
    grid [frame $w.s0] -columnspan 16 -pady 4
    incr row
    foreach {x y} {Bold \002 Inverse \026 Underline \037 Normal \017} {
	button $w.f$x -text $x -width 10 -command "palIns $y {$chn} {$prt}"
    }
    grid $w.fBold $w.fInverse $w.fUnderline $w.fNormal -columnspan 4
    foreach c $col {
        switch $c mirc {
	    set row [colourBtns $w $row $chn $prt mIRCCol mIRC \
	      palIns \003 {} bgIns {} {}]
	} ansi {
	    set row [colourBtns $w $row $chn $prt vt100Colour ANSI \
	      palIns "\033\[3" m palIns "\033\[4" m]
	    foreach {x y} {Bold 1 Inverse 7 Underline 4 Normal 0} {
		button $w.v$x -text "ANSI\n$x" -width 10 \
		-command "palIns [list \033\[${y}m] $chn {$prt}"
	    }
	    grid $w.vBold $w.vInverse $w.vUnderline $w.vNormal -columnspan 4
	} ctcp2 {
	}
    }
    grid [frame $w.s3] -columnspan 16 -pady 4
    grid [button $w.ok -text [trans dismiss] -command "destroy $w" -width 6] -columnspan 16
}
#
proc colourBtns {w row chn prt var txt fgc fg1 fg2 bgc bg1 bg2} {
    upvar #0 $var colrs
    grid [frame $w.${var}s1] -columnspan 16 -pady 4
    grid [label $w.${var}fl -text "$txt [trans {foreground colour}]"] -columnspan 16
    incr row 4
    set cls [lsort [array names colrs]]
    set cl 0
    set cinc [expr {16 / [llength $cls]}] 
    foreach x $cls {
        grid [button $w.$var$x -bg $colrs($x) \
          -command "$fgc [list $fg1$x$fg2] $chn {$prt}"] \
	  -row $row -column $cl -columnspan $cinc
	incr cl $cinc
    }
    grid [frame $w.${var}s2 ] -columnspan 16 -pady 4
    grid [label $w.${var}bl -text "$txt [trans {background colour}]"] -columnspan 16
    incr row 3
    set cl 0
    foreach x $cls {
        grid [button $w.${var}b$x -bg $colrs($x) \
          -command "$bgc [list $bg1$x$bg2] $chn {$prt}"] \
	  -row $row -column $cl -columnspan $cinc
	incr cl $cinc
    }
    return $row
}
#
proc fixList {lst} {
    set nl {}
    regsub -all {\\} $lst {\\\\} l1
    foreach x $l1 {lappend nl $x}
    regsub -all {\\\\} $nl {\\} nl
    return $nl
}
#
proc uExpand {w net chid} {
    global pick zircon
    set txt [$w get]
    set end [$w index insert]
    set start [string wordstart $txt $end]
    switch {} [set hd [string tolower [string range $txt $start $end]]] {
        return {}
    }
    set hits {}
    foreach u [$chid users] {
	if {[string match $hd* [$u lname]]} {lappend hits $u}
    }
    switch {} $hits { return {} }
    if {[llength $hits] > 1} {
	set m [menu .@[newName Exp] -tearoff 0]
	set f 0
	foreach u $hits {
	    set cmd "set pick($w) $u ; destroy $m"
	    incr f
	    if {[catch {bind $m <F$f> $cmd}]} {
	        $m add command -label [$u name] -command $cmd
	    } {
	      $m add command -label [$u name] -accelerator F$f \
	      -command $cmd
	    }
	}
	set xy [$w bbox insert]
	set x [expr {[lindex $xy 0] + [winfo rootx $w]}]
	set y [expr {[lindex $xy 1] + [winfo rooty $w]}]
	tk_popup $m $x $y [$m index end]
	focus $m
	tkwait window $m
	focus $w
	set res $pick($w)
	unset pick($w)
    } {
	set res $hits
    }
    return [string range [$res name] [string length $hd] end]
}
#
proc evenGrid {w what start end} {
    for {set i $start} {$i <= $end} {incr i} {
	grid ${what}configure $w $i -weight 1
    }
}
#
proc fullName {file} {
    switch [file pathtype $file] {
    relative { return [file join [pwd] $file] }
    }
    return $file
}
#
proc safeDestroy {args} { foreach x $args { catch {destroy $x} } }
#
proc makeToplevel {w title del save} {
    toplevel $w -class Zircon
    wm title $w $title
    switch {} $del {} default {
        wm protocol $w WM_DELETE_WINDOW $del
    }
    switch {} $save {set save "wm command $w { }"}
    wm protocol $w WM_SAVE_YOURSELF $save
    wm resizable $w 1 1
    return $w
}
#
proc colonLast {arg} {
    switch {} [set rest [string trim $arg]] { return {} }
    if {[set ix [string last { } $rest]] < 0} {
	return :$rest
    }
    return [string range $rest 0 $ix]:[string range $rest [expr {$ix+1}] end]
}