#
# $Source: /home/nlfm/Working/Zircon/Released/plugins/Dcc/RCS/dcc.tcl,v $
# $Date: 2001/07/10 15:39:59 $
# $Revision: 1.18.1.65 $
#
package provide Dcc 1.18
#
proc doDCC {net cmd nk} {
    switch -glob -- $nk {} - {[#&+]*} return
    $net configure -lastuser $nk
    [User :: make $net $nk] dcc $cmd
}
#
proc deSpace {file} {
    regsub -all { } $file {_} file
    return $file
}
#
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 0 }
    if {[catch {dectonet $addr} host]} { return 0 }
    switch $wh Chat {
	if {[catch {$net 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
	$usr ref
	[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 {
	if {[file exists [set file [lindex $args 0]]]} {
	    if {![file writable $file]} {
		tellError {} {File error} "Cannot write file $file."
		return 0
	    }
	    switch $posn [set fp [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 [deSpace [file tail $file]] $port $fp"
		      global Resume
		      if {![info exists Resume($usr)]} {$usr ref}
		      lappend Resume($usr) [list $file $addr $port $leng $fp]
		      return 0
		  }
	        2 {
		      global DCCR
		      set DCCR({$net,$file}) {}
		      tkwait window [mkEntryBox {} {Rename incoming} \
		        "Enter new name for incoming $file:" \
		        [list [list filename $file]] \
		        [list ok "set DCCR([list $net,$file])"] \
		        [list cancel {}]]
		      set v $DCCR({$net,$file})
		      unset DCCR({$net,$file})
		      switch {} $v { return 0 }
		      set file $v
		  }
	        3 {
		      global DCCR
		      set DCCR($net,$file) 0
		      tkwait window [mkEntryBox {} {Rename} \
		        "Enter new name for $file:" \
		        [list [list filename $file]] \
		        [list ok "dodRename $net [list $file]"] [list 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 [[$net sockcmd] -async $host $port]
	fconfigure $sk -blocking 1
	fileevent $sk writable "startGet $sk $net [list $file] $usr $leng $posn"
    }
    return 1
}
#
proc dccPick {net win id} {
    global DCCList
    set ix [lsearch $DCCList($net) "$id *"]
    foreach {dm op usr addr port fln leng posn} [lindex $DCCList($net) $ix] break
    switch $op {
    Send {handleSend $net $fln $usr $addr $port $leng $posn 0}
    default { doGetDCC $net $op $usr $addr $port $leng $posn $fln }
    }
    dccDel $net $win $id $usr
}
#
proc dccDel {net w id usr} {
    global DCCList
    notIdle {}
    listdel DCCList($net) [lsearch $DCCList($net) "$id *"]
    $usr deref
    if {[winfo exists $w]} {
	destroy $w.t$id $w.u$id $w.f$id $w.a$id $w.c$id
	if {[llength [winfo children $w]] <= 1} {
	    set z [winfo parent $w]
	    closeFrame [winfo parent $z] [winfo name $z] $net
	}
	switch {} $DCCList($net) {destroy [winfo toplevel $w]}
    }
    if {[winfo exists .@dls$net]} { buildDCCList $net }
}
#
proc addDCCRequest {net op usr fln addr port leng} {
    global DCCList
    if {![winfo exists [set w .@drq$net]]} {
	set DCCList($net) {}
	makeToplevel $w "[$net name] - Incoming DCC Offers" { } {}
	addSeparator [switchFrame $w sChat {Chat Offers} 0] \
	  -columnspan 5
	addSeparator [switchFrame $w sSend {File Send Offers} 0] \
	  -columnspan 5
	grid columnconfigure $w.sChat.bdy 1 -weight 1
	grid columnconfigure $w.sChat.bdy 2 -weight 1
	grid columnconfigure $w.sSend.bdy 1 -weight 1
	grid columnconfigure $w.sSend.bdy 2 -weight 1
    } {
	if {[set dl [$net dcclimit]] && [llength $DCCList($net)] > $dl} return
    }
    set win $w.s$op.bdy
    set rw [lindex [grid size $win] 1]
    set ix [newName dcc]
    grid [label $win.t$ix -text [getDate]] -row $rw -column 0 -sticky w
    grid [label $win.u$ix -text [$usr name]] -row $rw -column 1 -sticky w -padx 5
    grid [label $win.f$ix -text $fln] -row $rw -column 2 -sticky w -padx 5
    grid [button $win.a$ix -text [trans accept] -command "dccPick $net $win $ix"]\
      -sticky ew -row $rw -column 3
    grid [button $win.c$ix -text [trans cancel] -command "dccDel $net $win $ix $usr"]\
      -sticky ew -row $rw -column 4
    popup $w
    openFrame $w s$op $net
    lappend DCCList($net) [list $ix $op $usr $addr $port $fln $leng 0 0]
    $usr ref
    if {[winfo exists .@dls$net]} { buildDCCList $net }
}
#
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 -- [string toupper [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 {
	    switch WBOARD [string toupper $fln] {
		$net inform "Zircon does not implement DCC WBOARD"
		return
	    }
	    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 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)"
}
#
switch -glob [info tclversion] 8.* {
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 {
	    listdel gs($usr) $i
	    switch {} $gs($usr) {unset gs($usr)}
	    set conn [lindex $p 2]
	    catch {fileevent $conn readable {}}
	    catch {close $conn}
	    return
	}
	incr i
    }
}
} default {
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 [pid [lindex $p 0]]} msg
	    listdel gs($usr) $i
	    switch {} $gs($usr) {unset gs($usr)}
	    set conn [lindex $p 2]
	    catch {fileevent $conn readable {}}
	    catch {close $conn}
	    return
	}
	incr i
    }
}
}
#
proc dccClose {net op usr file ix w} {
    set who [$usr name]
    switch -glob -- $op {
    Call {$usr unChat }
    Chat {catch {[Chat :: find $who $net] leave}}
    Get -
    Send -
    Offer {
	    upvar #0 $op$net av
	    foreach f $av($usr) {
		switch -- $file [lindex $f 1] {
		    killDel $op$net $usr $file
		    break
		}
	    }
	    destroy $w.f$ix
	}
    }
    destroy $w.l$ix $w.b$ix
    buildDCCList $net
}
#
proc doTitle {grd w sub net} {
    if {$grd > 1} { openFrame $w $sub $net} { closeFrame $w $sub $net}
}
#
proc buildDCCList {net args} {
    global tls
    if {[winfo exists [set w .@dls$net]]} {
	popup $w
	switch -- $args {} {
	    foreach x [winfo children $w] {
		catch {eval destroy [winfo children $x.bdy]}
		addSeparator $x.bdy -columnspan 3 -row 0
	    }
	}
    } {
	makeToplevel $w  "[$net name] - DCC Connections" {} {}
	wm resizable $w 0 0
	foreach x {coff achat fOffer fSend fGet} {
	    set w1 [switchFrame $w $x $tls($x) 0]
	    addSeparator $w1 -columnspan 3
	    grid columnconfigure $w1 1 -weight 1
	}
    }
    upvar #0 Offer$net Offer Send$net Send Get$net Get AChat$net AChat
    set w1 $w.coff.bdy
    set grd 1
    grid columnconfigure $w1 0 -weight 1
    foreach nn [array names AChat] {
	set ix [newName dcc]
	grid [label $w1.l$ix -text [$nn name]] -row $grd -column 0\
	  -sticky w -padx 5 -columnspan 2
	grid [button $w1.b$ix -text [trans cancel] \
	  -command "dccClose $net Call $nn {} $ix $w1"] -row $grd \
	  -column 2 -sticky ew
	incr grd
    }
    doTitle $grd $w coff $net
    set w1 $w.achat.bdy
    set grd 1
    foreach nn [$net chats] {
	switch -- [set nm [$nn name]] *default* {} default {
	    set ix [newName dcc]
	    grid [label $w1.l$ix -text $nm] -row $grd \
	      -column 0 -sticky w -padx 5 -columnspan 2
	    grid [button $w1.b$ix -text [trans cancel] \
	      -command "dccClose $net Chat $nn {} $ix $w1"] \
	      -sticky ew -row $grd -column 2
	    incr grd
	}
    }
    doTitle $grd $w achat $net
    foreach arr {Offer Send Get} {
	set w1 $w.f$arr.bdy
	grid columnconfigure $w1 1 -weight 1
	set grd 1
	foreach nn [array names $arr] {
	   # FRINK : nocheck
	   foreach fl [set ${arr}($nn)] {
		set ix [newName dcc]
		grid [label $w1.l$ix -text [$nn name]] \
		  -row $grd -column 0 -sticky w -padx 5
		grid [label $w1.f$ix -text [lindex $fl 1]] \
		  -row $grd -column 1 -sticky w -padx 5
		grid [button $w1.b$ix -text [trans cancel] \
		  -command "dccClose $net $arr $nn [list [lindex $fl 1]] $ix $w1"]\
		  -sticky ew -row $grd -column 2
		incr grd
	    }
	}
	doTitle $grd $w f$arr $net
    }
}
#
proc usersDCC {net cmd} {
    switch $cmd {
    List - Close { buildDCCList $net }
    default {
	    mkEntryBox .@$cmd $cmd "Enter user name for DCC $cmd:" \
	      [list [list user [$net lastuser]]] \
	      [list ok "after 0 doDCC $net [string toupper $cmd]"]\
	      [list 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
		catch {close [lindex $off 2]}
	    }
	}
	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 1] {
	    Chat -
	    Send {
		set time [lindex $x 8]
		if {[incr time $interval] < 600000} {	    
		    lappend dy [lreplace $x 8 8 $time]
		} {
		    set chng 1
		    lappend del [list [lindex $x 0] [lindex $x 2]]
		}
		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 {dccDel $net .@drq$net [lindex $x 0] [lindex $x 1]}
	}
    }
}
#
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} {
    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" {} \
		  [list send "DCCSend $this"] [list cancel {}]
	    } default {
		global SendDir zFileTypes
		if {[catch {set dir $SendDir($net)}]} {
		    set SendDir($net) [set dir [pwd]]
		}
		if {[catch {switch {} [set fl [tk_getOpenFile -initialdir $dir \
		  -title "DCC send file to $nk" -filetypes $zFileTypes]] {
# user hit cancel
		} default {
		    set SendDir($net) [file dirname $fl]
		    DCCSend $this $fl
		}} err]} {
		    $net errmsg "File error: $err"
		}
	    }
	}
    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 [set ff [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]}  {
		$net errmsg "[ipAddress] : $msg"
	    } \
	    elseif {[winfo exists .@dls$net ]} { buildDCCList $net }
	}
    }
}
#
proc unsetSGO {arr elem op} { $elem deref }
#
proc dccProgress {conn bytes pcnt min sec} {
    if {[winfo exists [set w .@$conn].txt]} {
	$w.txt.bytes configure -text "$bytes bytes transferred."
	$w.txt.pcnt configure -text "[format %3.2f $pcnt]% complete"
	$w.slide configure -state normal
	$w.slide set $pcnt
	$w.slide configure -state disabled
	update idletasks
    }
}
#
proc dccWindow {conn usr array file} {
    if {[winfo exists [set w .@$conn]]} return
    switch $array Send {
	set tl "DCC send $file to [$usr name]"
    } default {
	set tl "DCC get $file from [$usr name]"
    }
    makeToplevel $w $tl {} {}
    scale $w.slide -from 0 -to 100 -tickinterval 20 \
       -state disabled -length 200 -orient horizontal
    grid columnconfigure $w 0 -weight 1
    grid $w.slide -padx 10 -pady 5 -sticky ew
    frame $w.txt
    grid columnconfigure $w.txt 0 -weight 1
    grid columnconfigure $w.txt 1 -weight 1
    grid [label $w.txt.bytes -text {0 bytes transferred}] \
      [label $w.txt.pcnt -text {0% complete}] -padx 10 -sticky ew
    grid $w.txt -sticky ew -pady 5
    button $w.cancel -text [trans cancel] \
      -command "killDel $array[$usr net] $usr [list $file] ; destroy .@$conn"
    grid $w.cancel -sticky ew
}