#
# $Source: /home/nlfm/Working/Zircon/Released/lib/RCS/Util.tcl,v $
# $Date: 1997/03/03 09:41:12 $
# $Revision: 1.18.1.36 $
#
package provide zircon 1.18
#
proc makeArray {args} {
    foreach x $args { global $x ; 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} {
    global $vn
    switch {} [set $vn [option get . $vn [capitalise $vn]]] {set $vn $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]}
}
#
proc listincl {list val} {
    upvar $list lst
    if ![listmember $lst $val] { lappend lst $val }
}
#
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]}
}
#
proc listput {list posn val} {
    upvar $list lst
    set lst [linsert $lst $posn $val]
}
#
proc listupdate {list item val} {
    upvar $list lst
    while {[llength $lst] <= $item} {lappend lst {} }
    set lst [lreplace $lst $item $item $val]
}
#
proc listmove {list from to val} {
    upvar $list lst
    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} {
    global Icon IconBM
    catch {unset Icon($win)}
    catch {unset 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
}
#
set ctcpCmds  {Clientinfo Finger Ping Time Version Userinfo Other}
set specialCmds {Zircon}
#
proc addCTCPMenu {net name usr} {
    global ctcpCmds DEBUG specialCmds ztrans
    $name add cascade -label $ztrans(ctcp) -menu $name.ctcp
    menu $name.ctcp 
    set cmdlst $ctcpCmds
    switch {} [$net wavplayer] {} 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 ztrans
    $name add cascade -label $ztrans(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} {
    global ztrans
    $name add cascade -label $ztrans(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 makeUserMenu {chid win usr} {
    if [winfo exists $win] { return $win }
    return [menu $win -postcommand "postUM $chid $win $usr"]
}
#
#
proc postUM {chid win usr} {
    global ztrans 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 \[$usr name\] $net}
	Notice	{channelNotice $net \[$usr lname\]}
	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 {
	CTCP { addCTCPMenu $net $win $usr }
	DCC { addDCCMenu $win $usr }
	Notify {
		$win add checkbutton -label $ztrans(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 $ztrans(finger) -command "$usr finger"
		}
	   }
	Silence {
		if [$net undernet] {
		    $win add cascade -label $ztrans(silence) \
		      -menu $win.silence
		    menu $win.silence -tearoff 0
		    $win.silence add command -label $ztrans(silence) \
		      -command "underUSilence + $net $usr"
		    $win.silence add command -label $ztrans(delete) \
		      -command "underUSilence - $net $usr"
		}
	    }
	}
    }
    if $nrm {
	set st [expr {(![$net restricted] && [$chid operator]) ? "normal" : "disabled"}]
	foreach cmd $Ops(chanop) {
	    switch $cmd {
	    Speak {
		$win add checkbutton -label $ztrans(speak) \
		  -variable ${chid}(Spk,$usr) \
		  -command "$chid userMode $usr v" -state $st
	      }
	    ChanOp {
		$win add checkbutton -label $ztrans(chanop) \
		  -variable ${chid}(Op,$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 $ztrans(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
    grid columnconfigure $win 0 -weight 1
    grid rowconfigure $win 0 -weight 1
    scrollbar $win.vs -command "$win.l yview"
    scrollbar $win.hs -command "$win.l xview" -orient horizontal
    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 \{[$name lname]\} $net}
    @?@user* { eval $cmd \{[[string range $name 3 end] lname]\} $net}
    }
    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"
}
#
proc retitle {t w1 w2} { wm title $w2 $t }
#
proc switchFrame {ctl net title args} {
    global zDIOff
    set rq [llength [grid slaves $ctl -column 0]]
    grid rowconfigure $ctl $rq -weight 1 -minsize 30
    grid [set mn [frame $ctl.$net -borderwidth 0]] -sticky nsew \
      -row $rq -column 0
#    switch {} $args {} default {
#	update idletasks
#	set h [frame $mn.h$net -bg blue -borderwidth 4]
#	place $h -relx 1.0 -x -5 -width 5 -height 5 -y 2
#	bindtags $h DragHandle
#    }
    grid columnconfigure $mn 0 -weight 1
    grid rowconfigure $mn 2 -weight 1
    addSeparator $mn -row 0 -column 0
    grid [set f [frame $mn.exp -borderwidth 0]] -sticky ew -row 1 -column 0
    grid columnconfigure $f 1 -weight 1
    grid [button $f.ctl -image $zDIOff -command "exposeFrame $ctl $net"] -row 0 -column 0
    grid [label $f.title -text $title] -row 0 -column 1 -sticky ew
    return [frame $mn.bdy -borderwidth 0]
}
#
proc checkHeight {w} {
    update idletasks
    set ht [winfo reqheight $w]
    if {$ht != [winfo height $w]} {
	wm geometry $w [winfo width $w]x$ht
    }
}
#
proc exposeFrame {ctl net} {
    global zDIOff zDIOn zDIOff1 zDIOn1
    set w $ctl.$net.exp
    set forget 1
    switch [$w.ctl cget -image] \
      $zDIOff	{set im $zDIOn ; set forget 0} \
      $zDIOff1	{set im $zDIOn1 ; set forget 0} \
      $zDIOn	{set im $zDIOff } \
      $zDIOn1	{set im $zDIOff1 }
    $w.ctl configure -image $im
    if $forget {
	grid forget $ctl.$net.bdy
    } {
	grid $ctl.$net.bdy -sticky nsew -row 2 -column 0
    }
}
#
proc retitleFrame {ctl net title args} {
    global zDIOff1 zDIOff zDIOn zDIOn1
    append ctl .$net.exp
    set im [$ctl.ctl cget -image]
    set fg black
    switch {} $args {} default {
	switch [$ctl.ctl cget -image] \
	  $zDIOff	{set im $zDIOff1 ; set fg red} \
	  $zDIOff1	{set im $zDIOff ; set fg black} \
	  $zDIOn	{set im $zDIOn1 ; set fg red} \
	  $zDIOn1	{set im $zDIOn ; set fg black}
    }
    $ctl.ctl configure -image $im
    $ctl.title configure -text $title -fg $fg
}
#
proc hideFrame {ctl net} { 
    foreach x [winfo children $ctl.$net] {
	switch -glob $x *.bdy {} default {grid forget $x}
    }
}
#
proc deleteFrame {ctl net} { destroy $ctl.$net }
#
proc makeMB {win text} {
    menubutton $win -text [trans $text] -menu $win.menu
    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 convTime {t} { return [clock format $t] }
#
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} {{{IP Number}{}}} \
	      "$ztrans(OK) {set hostIPaddress}"]
	}
    }
    return $hostIPaddress
}
#
proc acceptCon {cmd p1 p2} { fileevent $p1 readable $cmd }
#
proc server {cmd} {
    set fd [socket -server "acceptCon {$cmd}" 0]
    if [catch {fconfigure $fd -sockname} xx] {
	error "Cannot get port for server - $xx"
    }
    return [list $fd [lindex $xx 2]]
}
#
proc zping {res} {
    if ![regexp {^[0-9]+$} [string trim $res]] { return $res }
    return [expr {[clock seconds] - $res}]
}
#
proc safeClean {txt} {return [split [string trim $txt]]}
#
proc notIdle {win args} {
    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 markButton {name which} {
    if ![winfo exists $name] return
    foreach opt {font foreground background activeForeground \
      activeBackground} {
	set uopt [capitalise $opt]
	set fopt $which[switch {} $which {set opt} default {set uopt}]
	set lopt [string tolower $opt]
	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}] {
			tellError {} {Option Error} "$opt configuration error - \"$msg\""
		    }
		}
	    }
	} default {
	
	    if [catch {$name conf -$lopt $cl} msg] {
		tellError {} {Option Error} "$opt configuration error - \"$msg\""
	    }
	} \
    }
    checkColour $name
}
#
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 {font background activeBackground} {
	set uopt [capitalise $opt]
	set fopt $which[switch {} $which {set opt} default {set uopt}]
	set lopt [string tolower $opt]
	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]
	}
    Entry {
	    set w [$chan window].cmd.entry
	    set txt [$w get]
	}
    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
    if ![winfo exists $m] {
	menu $m -tearoff 0
	$m add command -label Bold -command "palIns \002 {$chn} {$prt}"
	$m add command -label Inverse -command "palIns \026 {$chn} {$prt}"
	$m add command -label Underline -command "palIns \037 {$chn} {$prt}"
	$m add command -label Normal -command "palIns \017 {$chn} {$prt}"
        switch {} $col {} default {
	    $m add cascade -label Foreground -menu $m.fg
	    $m add cascade -label Background -menu $m.bg
	    menu $m.fg -tearoff 0
	    foreach x {0 1 2 3 4 5 6 7 8 9 10 12 12 13 14 15} {
		$m.fg add command -background $mIRCCol($x) \
		   -command "palIns {\003$x} {$chn} {$prt}"
	    }
	    menu $m.bg -tearoff 0
	    foreach x {0 1 2 3 4 5 6 7 8 9 10 12 12 13 14 15} {
		$m.bg add command -background $mIRCCol($x) \
		   -command "bgIns $x {$chn} {$prt}"
	    }
	}
    }
    tk_popup $m $x $y
}
#
proc makePalette {w chn prt name ft col} {
    if [winfo exists $w] {popup $w ; return} 
    global mIRCCol ztrans Ft
    killWindow $w
    toplevel $w -class Zircon
    wm title $w "$name Palette"
    wm protocol $w WM_DELETE_WINDOW "destroy $w"
    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 1
    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
    switch {} $col {} default {
	grid [frame $w.s1] -columnspan 16 -pady 4
	grid [label $w.fl -text {Foreground Colour}] -columnspan 16
	incr row 4
	foreach x {0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
	    grid [button $w.f$x -bg $mIRCCol($x) \
	      -command "palIns {\003$x} {$chn} {$prt}"] -row $row -column $x
	}
	grid [frame $w.s2 ] -columnspan 16 -pady 4
	grid [label $w.bl -text {Background Colour}] -columnspan 16
	incr row 3
	foreach x {0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
	    grid [button $w.b$x -bg $mIRCCol($x) \
	      -command "bgIns $x {$chn} {$prt}"] -row $row -column $x
	}
    }
    grid [frame $w.s3] -columnspan 16 -pady 4
    grid [button $w.ok -text $ztrans(dismiss) -command "destroy $w" -width 6] -columnspan 16
}
#
proc fixList {lst} {
    set nl {}
    regsub -all {\\} $lst {\\\\} l1
    foreach x $l1 {lappend nl $x}
    regsub -all {\\\\} $nl {\\} nl
    return $nl
}
