#
# $Source: /home/nlfm/Working/Zircon/Released/plugins/Dcc/RCS/dcc.tcl,v $
# $Date: 1997/02/20 08:55:44 $
# $Revision: 1.18.1.25 $
#
package provide Dcc 1.18
#
proc doDCC {net cmd nk} {
    switch -glob -- $nk {} - {[#&+]*} return
    $net configure -lastuser $nk
    [User :: make $nk $net] dcc $cmd
}
#
proc dodRename {net file new} {
   switch {} $new return
   filerename $file $new
   uplevel #0 set DCCR($net,$file) 1
}
#
proc doGetDCC {net wh usr addr port leng posn args} {
    switch -- $args {} return
    if [catch {set host [dectonet $addr]}] return
    switch $wh Chat {
	if [catch {connect $host $port} sok] {
	    $net display {} "*** Cannot connect to host $host ($sok)"
	    return 0
	}
	fconfigure $sok -translation {lf lf}
	upvar #0 $sok chdata
	set chdata(who) $usr
	[set chdata(obj) \
	    [set this [$net eval "Chat [list [$usr name]] -caller $usr"]]] show
	$this addUser $chdata(who) 0 0
	$this configure -sock $sok
	fileevent $sok readable "dccChat r $sok"
    } default {
	global ztrans
	if [file exists [set file [lindex $args 0]]] {
	    if ![file writable $file] {
		tellError {} {File error} "Cannot write file $file."
		return 0
	    }
	    switch $posn [file size $file] {} default {
	    switch [tk_dialog .@dg$net {DCC Get} \
	      "File \"$file\" already exists. Select the action you want to take." \
	      warning 0 Overwrite Resume {Rename incoming} \
	      {Rename Existing} Cancel] {
	    0 {}
	    1 {
		    $net CTCP DCC [$usr name] "RESUME [file tail $file] $port $ff(size)"
		    global Resume
		    lappend Resume($usr) \
		      [list $file $addr $port $leng $ff(size)]
		    $usr ref
		    return 0
		}
	    2 {
		    global DCCR
		    set DCCR({$net,$file}) {}
		    tkwait window [mkEntryBox {} {Rename incoming} \
		      "Enter new name for incoming $file:" \
		      "{$ztrans(filename) {$file}}" \
		      "$ztrans(ok) {set DCCR({$net,$file})}" \
		      "$ztrans(cancel) {}"]
		    set v $DCCR({$net,$file})
		    unset DCCR({$net,$file})
		    switch {} $v return
		    set file $v
		}
	    3 {
		    global DCCR
		    set DCCR($net,$file) 0
		    tkwait window [mkEntryBox {} {Rename} \
		      "Enter new name for $file:" \
		      "{$ztrans(filename) {$file}}" \
		      "$ztrans(ok) {dodRename $net $file}" "$ztrans(cancel) {}"]
		    set v $DCCR($net,$file);
		    unset DCCR($net,$file)
		    if !$v {return 0}
		}
	    4 {return 0}
	    }
	    }
	}
	set file [file join [file dirname $file] [file tail $file]]
	set sk [socket -async $host $port]
	fconfigure $sk -blocking 1
	fileevent $sk writable "startGet $sk $net $file $usr $leng $posn"
    }
    return 1
}
#
proc dccPick {net win y} {
    global ztrans DCCList
    notIdle {}
    switch -- [set t [$win curselection]] {} {set t [$win nearest $y]}
    set rt {}
    foreach x $t {
	lappend calls [lindex $DCCList($net) $x]
	lappend rt $x
    }
    foreach x $rt {listdel DCCList($net) $x}
    switch {} $DCCList($net) {destroy .@drq$net} default {
	$win delete [lindex $t 0] [lindex $t end]
    }
    foreach l $calls {
	set usr [lindex $l 1]
	set addr [lindex $l 2]
	set port [lindex $l 3]
	set fln [lindex $l 4]
	set leng [lindex $l 5]
	set posn [lindex $l 6]
	switch [set op [lindex $l 0]] {
	Send {handleSend $net $fln $usr $addr $port $leng $posn 0}
	default { doGetDCC $net $op $usr $addr $port $leng $posn $fln }
	}
	$usr deref
    }
}
#
proc dccDel {net win} {
    notIdle {}
    switch {} [set t [$win curselection]] return
    global DCCList
    $win delete [lindex $t 0] [lindex $t end]
    foreach x $t {
	catch {[lindex [lindex $DCCList($net) $t] 1] deref}
	listdel DCCList($net) $t
    }
    switch {} $DCCList($net) {destroy .@drq$net}
}
#
proc addDCCRequest {net op usr fln addr port leng} {
     global DCCList
     if ![winfo exists [set w .@drq$net]] {
	set DCCList($net) {}
	toplevel $w -class Zircon
	wm title $w {Incoming DCC Requests}
	wm protocol $w WM_DELETE_WINDOW { }
	makeLB $w.lb -setgrid 1 -width 40 -height 8 
	pack $w.lb
	bind $w.lb.l <Double-Button-1> "dccPick $net %W %y ; break"
	bind $w.lb.l <Delete> "dccDel  $net %W ; break"
	bind $w.lb.l <BackSpace> [bind %W <Delete>]
	bind $w.lb.l <Control-h> [bind %W <Delete>]
	bind $w.lb <Any-Enter> {focus %W.l ; notIdle {} ; break}
     }
     $w.lb.l insert end "[$usr name] : $op $fln"
     popup $w
     lappend DCCList($net) [list $op $usr $addr $port $fln $leng 0 0]
     $usr ref
}
#
proc handleDCC {net usr param prefix} {
    set pars [split $param]
    set fln [lindex $pars 1]
    set addr [lindex $pars 2]
    set port [lindex $pars 3]
    switch -exact -- [lindex $pars 0] {
    RESUME { handleResume $net $usr $fln $addr $port }
    ACCEPT { handleAccept $net $usr $fln $addr $port }
    SEND {
	    switch -glob -- $fln {.*} {set fln _[string range $fln 1 end]}
	    set leng [lindex $pars 4]
	    foreach x [$net autoget] {
		if [regexp $x $prefix] {
		    handleSend $net $fln $usr $addr $port $leng 0 1
		    return
		}
	    }
	    addDCCRequest $net Send $usr $fln $addr $port $leng
	}  
    CHAT {
	    foreach x [$net autochat] {
		if [regexp $x [string range $prefix 1 end]] {
		    doGetDCC $net Chat $usr $addr $port {} 0 {}
		    return
		}
	    }
	    addDCCRequest $net Chat $usr {} $addr $port {}
	}
    }
}
#
proc ipPack {ip} {
    set val 0
    foreach x [split $ip "."] {	set val [expr {($val << 8) + $x}] }
    return [format %u $val]
}
#
proc dectonet {dec} {
    if {[string length $dec] == 10 && [set first [string index $dec 0]] > 1} {
	switch -- $first {
	    2 {set overflow "0 148 53 119"}
	    3 {set overflow "0 94 208 178"}
	    4 {set overflow "0 40 107 238"}
	}
	set dec [string range $dec 1 end]
    } else {
	set overflow {0 0 0 0}
    }   

    scan [format "%08x" $dec] "%2x%2x%2x%2x" net(3) net(2) net(1) net(0)

    for {set part 0; set carry 0} {$part < 4} {incr part} {
	set sum [expr {$net($part) + [lindex $overflow $part] + $carry}]
	set internet($part) [expr {$sum % 256}]
	set carry [expr {$sum / 256}]
    }

    return "$internet(3).$internet(2).$internet(1).$internet(0)"
}
#
proc killDel {arr usr file} {
    upvar #0 $arr gs
    set i 0
    if ![info exists gs($usr)] return
    foreach p $gs($usr) {
	switch -- [lindex $p 1] $file {
	    catch {exec kill -9 [lindex $p 0]} msg
	    listdel gs($usr) $i
	    switch -- $gs($usr) {} {unset gs($usr) ; $usr deref}
	    set conn [lindex $p 2]
	    catch {fileevent $conn readable {}}
	    catch {close $conn}
	    return
	}
	incr i
    }
}
#
proc dccClose {net win} {
    foreach t [$win curselection] {
	set x [split [$win get $t]]
	set usr [User :: find [set who [lindex $x 2]] $net]
	set file [lindex $x 4]
	switch -glob -- $x {
	{Call -*} {$usr unChat }
	{Call from*} { }
	Chat* {catch {[Chat :: find $who $net] leave}}
	Get* -
	Send* -
	Offer* {
		set arr [lindex $x 0]
		upvar #0 $arr$net av
		foreach f $av($usr) {
		    switch -- $file [lindex $f 1] {
			killDel $arr$net $usr $file
			break
		    }
		}
	    }
	Request* { }
	}
    }
    foreach t [$win curselection] { $win delete $t }
}
#
proc buildDCCList {net args} {
    global ztrans
    set w .@dls$net
    if [winfo exists $w] {
	popup $w
	switch -- $args {} {$w.dcc.l delete 0 end}
    } {
	toplevel $w -class Zircon -relief raised -borderwidth 2
	wm title $w {DCC Connections}
	wm protocol $w WM_DELETE_WINDOW "destroy $w"
	makeLB $w.dcc -setgrid 1
	frame $w.btn
	button $w.btn.ok -text $ztrans(dismiss) -command "destroy $w" -relief raised
	button $w.btn.close -text $ztrans(close) -relief raised \
	  -command "dccClose $net $w.dcc.l"
	pack $w.btn.ok $w.btn.close -side left -expand 1 -fill x
	pack $w.dcc -fill both
	pack $w.btn -fill x
    }
    set cnt 0
    upvar #0 Offer$net Offer Send$net Send Get$net Get AChat$net AChat
    foreach nn [array names AChat] {
	$w.dcc.l insert end "$ztrans(call) - [$nn name]"
	incr cnt
    }
    foreach nn [$net chats] {
	switch -- [set nm [$nn name]] *default* {} default {
	    $w.dcc.l insert end "$ztrans(chat) - $nm"
	    incr cnt
	}
    }
    foreach arr {Offer Send Get} {
	foreach nn [array names $arr] {
	   foreach fl [set ${arr}($nn)] {
		$w.dcc.l insert end "[trans $arr] - [$nn name] : [lindex $fl 1]"
		incr cnt
	   }
	}
    }
}
#
proc usersDCC {net cmd} {
    global ztrans
    switch $cmd {
    List - Close { buildDCCList $net }
    default {
	    mkEntryBox .@$cmd $cmd "Enter user name for DCC $cmd:" \
	      [list [list $ztrans(user) [$net lastuser]]] \
	      "$ztrans(ok) {after 0 doDCC $net [string toupper $cmd]}" "$ztrans(cancel) {}"
	}
    }
}
#
proc dccCheck {net interval} {
    upvar #0 Offer$net Offer
    set chng 0
    set tm [$net dccTime]
    foreach {x y} [array get Offer] {
	set dy {}
	foreach off $y {
	    set time [lindex $off 5]
	    if {[incr time $interval] < $tm} {	    
		lappend dy [lreplace $off 5 5 $time]
	    } {
		set chng 1
	    }
	}
	switch {} [set Offer($x) $dy] {unset Offer($x)}
    }
    global DCCList
    set dy {}
    set del {}
    set indx 0
    if [info exists DCCList($net)] {
	foreach x $DCCList($net) {
	    switch [lindex $x 0] {
	    Chat -
	    Send {
		set time [lindex $x 7]
		if {[incr time $interval] < 600000} {	    
		    lappend dy [lreplace $x 7 7 $time]
		} {
		    set chng 1
		    set del [linsert $del 0 $indx]
		}
		continue
	    }
	    default { lappend dy $x }
	    }
	    incr indx
        }
        switch {} [set DCCList($net) $dy] {catch {destroy .@drq$net}}
    }
    if $chng {
	if [winfo exists .@dls$net] {buildDCCList $net}
	if [winfo exists .@drq$net] {
	    foreach x $del {
		.@drq$net.lb.l delete $x
	    }
	}
    }
}
#
proc net_dccClean {this} {
    foreach x {Get Offer Send} {
	upvar #0 $x$this arr
	catch {
	    foreach {n m} [array get arr] {
		foreach v $m {killDel $x$this $n [lindex $v 1]}
	    }
	}
    }
    catch {destroy .@dls$this}
    set DCCList($this) {}
    catch {destroy .@drq$this}
}
#
proc user_dcc {this cmd} {
    global ztrans
    set nk [$this name]
    set net [$this net]
    switch $cmd {
    SEND {
	    switch 7.5 [info tclversion] {
		mkFileBox {} SendDir($net) .* "Send $nk" \
		  "File to send to $nk" {} \
		  "$ztrans(send) {DCCSend $this}" "$ztrans(cancel) {}"
	    } default {
		global SendDir zFileTypes
		if [catch {set dir $SendDir($net)}] {
		    set SendDir($net) [set dir [pwd]]
		}
		set fl [tk_getOpenFile -initialdir $dir \
		  -title "DCC send file to $nk" -filetypes $zFileTypes]
		set SendDir($net) [file dirname $fl]
		DCCSend $this $fl
	    }
	}
    CHAT {
	    upvar #0 AChat$net AChat
	    if [info exist AChat($this)] {
		if [askUser {} Chat  \
		  "You already have a chat request pending for $nk. Close it?"] {
		    $this unChat
		}
	    } \
	    elseif {[string compare nil [Chat :: find $nk [$this net]]]} {
		if [askUser {} Chat  \
		  "You already have a chat request pending for $nk. Close it?"] {
		    $this unChat
		}
	    } \
	    elseif {[catch {ChatServer $this $nk} msg]}  {
		[$this net] errmsg "[ipAddress] : $msg"
	    } \
	    elseif {[winfo exists .@dls$net ]} { buildDCCList $net }

	}
    }
}
#
proc dccSaveA {w net} {
    set oag [$net autoget]
    set ag {}
    foreach x [$w.lb.l get 0 end] {
	switch -- *NEW* $x continue
	lappend ag $x
    }
    $net configure -autoget $ag
    switch -- $ag $oag {} default {$net configure -confChange 1}
    catch {destroy $w}
}
#
proc dccAutoUser {net} {
    global ztrans
    set w [toplevel .ag$net -class Zircon]
    wm title $w {Auto-accept Sends}
    grid rowconfigure $w 0 -weight 1
    makeLB $w.lb -height 10 -width 20
    foreach x [$net autoget] {$w.lb.l insert end $x}
    $w.lb.l insert end *NEW*
    bind $w.lb.l <Double-Button-1> "dccAAG $net %W %y"
    bind $w.lb.l <Delete> "dccDAG $net %W"
    bind $w.lb.l <BackSpace> [bind $w.lb.l <Delete>]
    bind $w.lb.l <Control-h> [bind $w.lb.l <Delete>]
    grid $w.lb - -sticky nsew
    frame $w.btns
    button $w.btns.ok -text $ztrans(ok) -command "dccSaveA $w $net" -width 6
    button $w.btns.cn -text $ztrans(cancel) -command "destroy $w" -width 6
    button $w.btns.hl -text $ztrans(help) -state disabled -width 6
    grid $w.btns.ok $w.btns.cn $w.btns.hl -sticky ew
    grid $w.btns -sticky ew
}
#
proc dccAAG {net w y} {
    global ztrans
    set x [$w nearest $y]
    switch *NEW* [set nm [$w get $x]] {
	mkEntryBox {} {User Pattern} \
	   "Enter a regular expression for matching a nickname:" \
	   "{Regexp {}}" "$ztrans(ok) {dccRXAG $w $net}" "$ztrans(cancel) {}"
    } default {
    }
}
#
proc dccRXAG {w net val} {
    switch {} $val return
    if [catch {regexp $val aaaa}] {
	tellError {} {Regexp error} {Invalid regular expression!}
    } {
	$w insert 0 $val
	$w selection clear 0 end
	$w selection set 0
    }
}
#
proc dccDAG {net w} {catch {$w delete [$w curselection]}}
