#
# $Source: /home/nlfm/Working/Zircon/Released/lib/RCS/IRC.tcl,v $
# $Date: 2002/05/09 21:19:59 $
# $Revision: 1.18.1.65 $
#
package provide zircon 1.18
#
#   Handle IRC cmds
#
proc ctcpAnswer {net usr nk cp} {
    handleOn $net CTCPREPLY [list $nk $cp]
    if {[string match ZIRCON* $cp]} {
	if {[zirconReply $net $usr $nk $cp]} return
    }
    set chn {}
    foreach x [$usr channels] {
	if {[$x active] && [[$x wid] visible]} {lappend chn $x}
    }
    regsub -all "\[\x01-\x1f\]" $nk {} nk
    if {$chn == {}} {
	tellInfo $net {CTCP Reply} "CTCP Reply from $nk:\n$cp" CTCP
    } {
	foreach x $chn {
	    $x addText @CTCP "*** CTCP Reply from $nk: $cp"
	}
    }
}
#
proc ircERROR {net prefix param pargs} { $net error $prefix $param $pargs }
#
proc ircPONG {net unusedprefix unusedparam unusedpargs} { $net handlePong }
#
proc mungNotice {msg} {
    if {[regexp \
      {Received KILL message for ([^ ]+). From ([^ ]+) Path: ([^ ]+) (.*)} \
      $msg match user from path rest]} {
	return "*** KILL from $from for $user $rest"
    }
    return $msg
}
#
proc pingVal {val} {
    if {[regexp "^PING\[ \t\]+(\[0-9\]+).*" $val m t]} {
	return "[zping $t] secs"
    }
    return {Corrupt PING value}
}
#
proc ircNOTICE {net prefix param pargs} {
    set nkinfo [mungPrefix $net $prefix]
    if {[ignoreSet [lindex $nkinfo 3] notices]} {ditchPrefix $nkinfo ; return}
    set id [find [set chan [lindex $pargs 0]] $net]
    if {{nil} == [set usr [lindex $nkinfo 0]]} {
	if {[$id active]} {
	    $id addText {} "-[string range $prefix 1 end]- $param"
	} {
	    switch nil $id {
	        $net inform [mungNotice $param]
	        set chan {}
	    }
	}
    } {
	set nk [$usr name]
	while {[regexp "(\[^\001\]*)\001(\[^\001\]*)\001(.*)" $param sub a cp b]} {
	    switch -glob -- $cp {
	    {ZIRCON Sorry*} { }
	    {PING *} {ctcpAnswer $net $usr $nk "PING - [pingVal $cp]"}
	    default { ctcpAnswer $net $usr $nk $cp }
	    }
	    switch {} [set param $a$b] return
	}
	if {[$id isa Channel]} {
	    $id addText $usr "-$nk- $param"
	} \
	elseif {![string compare nil [set id [Notice :: find $nk $net]]] &&
	  ![string compare nil [set id [Message :: find $nk $net]]]} {
	    if {[$net busy] || [listmember [$net toInfo] NOTICE]} {
		$net inform "Notice from $nk at [getDate] : $param"
	    } {
		set id [Notice :: make $net $nk]
		if {[$id timestamp]} {set ts {}} {set ts "[getDate]\n"}
		$id addText {} "$ts$param"
	    }
	} {
	    if {![$id active]} {$id show}
	    $id addText $usr $param
	}
    }
    handleOn $net NOTICE [list $prefix $param $chan]
    ditchPrefix $nkinfo
}
#
proc ircMODE {net prefix param pargs} {
    global userFlags
    set chan [lindex $pargs 0]
    if {{nil} == [set id [Channel :: find $chan $net]]} {
	if {[me $chan $net]} {
	    if {{} == [set md [lindex $pargs 1]]} {set md $param}
	    foreach m [split $md {}] {
		switch -- $m {
		- { set val 0 }
		+ { set val 1 }
		default { catch {$net configure -$userFlags($m) $val} }
		}
	    }
	}
	return
    }
    $id mode [set pd [lrange $pargs 1 end]] $prefix
    $id optText MODE "*** Mode change \"[string trim \
      [join $pd]]\" on channel $chan by [lindex [mung1Prefix $net $prefix] 0]"
}
#
proc doPatterns {where prefix param} {
    regsub {^:} $prefix {} prefix
    foreach p [$where patterns] {
	set pt [lindex $p 0]
	if {[regexp -nocase -- [lindex $pt 0] $prefix] && \
	  [regexp -- [lindex $pt 1] $param]} {
	    uplevel #0 set 0 [list $prefix]
	    uplevel #0 set 1 [list [$where name]]
	    uplevel #0 set 2 [list $param]
	    uplevel #0 set net [$where net]
	    if {[catch {uplevel #0 [lindex $p 1]} msg]} {
		tellError {} {Pattern Command Error} \
		  "Error when executing [$where name] pattern command \"[lindex $p 1]\" : $msg"
	    }
	    uplevel #0 safeUnset 0 1 2 net
	}
    }
}
#
proc ircPRIVMSG {net prefix param pargs} {
    set nkinfo [mungPrefix $net $prefix]
    set usr [lindex $nkinfo 0]
    set ign [lindex $nkinfo 3]
    set chan [lindex $pargs 0]
    set where [find $chan $net]
    set ctcnt [$net ctcpmax]
    while {$ctcnt > 0 && [regexp "(\[^\001\]*)\001\[ \t\]*(\[^ \t\001\]+)\[ \t\]*(\[^\001\]*)\001(.*)" $param sub a op cp b]} {
	switch {} \
	  [set param $a[handleCTCP $net $op $where $chan $usr $prefix $ign $cp]$b] {
	    ditchPrefix $nkinfo
	    return
	}
	incr ctcnt -1
    }
    regsub -all "\[\x01-\x1f\]" "<[set nk [$usr name]]>" {} pfx
    if {[me $chan $net]} {
	if {[ignoreSet $ign msgs] || [ignoreSet $ign notes]} return
	switch nil [set where [Message :: find $nk $net]] {
	    global zircon
	    set mmx [$net msgmax]
	    if {($mmx > 0 && $mmx < [llength [$net messages]]) || [$net busy]} {
		$net queue "NOTICE $nk :[$net busymsg]"
		$net inform "Message from $nk at [getDate] : $param"
	    } {
		handleOn $net POPUP [list $nk]
		set where [Message :: make $net $nk]
		if {[$where timestamp]} {set ts {}} {set ts "[getDate]\n"}
		$where addText $usr "$ts$pfx $param"
		doPatterns $where $prefix $param
	    }
	} default {
	    $where show
	    if {![$where isJoined $usr]} {$where addUser $usr 0 0}
	    $where addText $usr "$pfx $param"
	    doPatterns $where $prefix $param
	}
	handleOn $net MSG [list $prefix $param]
    } {
	if {[ignoreSet $ign public]} return
	set where [Channel :: find $chan $net]
	switch nil $where {
	    set where [$net info]
	    regsub -all "\[\x01-\x1f\]" "<$nk/$chan>" {} pfx
	}
	$where addText $usr "$pfx $param"
	doPatterns $where $prefix $param
	set onOp PUBLIC
	if {![$where isJoined $usr]} { set onOp PUBLIC_MSG }
	handleOn $net $onOp [list $prefix $chan $param]
    }
    ditchPrefix $nkinfo
}
#
proc ircJOIN {net prefix param pargs} {
    switch {} $param {
	set chan $pargs
	set ov {}
    } default {
	if {![regexp "^(.*)\a(\[ov\]+)\$" $param m chan ov]} {
	    set chan $param
	    set ov {}
        }
    }
    if {[notAnon $chan $prefix]} {
	set nkinfo [mungPrefix $net $prefix]
	if {[lindex $nkinfo 1]} {
	    [set chn [Channel :: make $net $chan]] show
	    $chn handleOV $ov [lindex $nkinfo 0]
	} {
	    set usr [lindex $nkinfo 0]
	    set nm [lindex $nkinfo 2]
	    switch nil [set frd [Friend :: find [$usr name] $net]] {} default {
		$frd appear $nm
	    }
	    [Channel :: find $chan $net ] doJoin $usr $nm $prefix $ov
	}
	ditchPrefix $nkinfo
    }
    handleOn $net JOIN [list $chan $prefix $ov]
}
#
proc ircNICK {net prefix param pargs} {
    set usr [lindex [set nkinfo [mungPrefix $net $prefix]] 0]
    switch {} $param {
#
# Some systems seem to send NICKS that omit the :
#
	set param [lindex $pargs end]
	set pargs [lreplace $pargs end end]
    }
    if {[lindex $nkinfo 1]} { $net configure -nickname $param } \
    elseif {[string compare nil [set orig [User :: find $param $net]]] &&
	[string compare $usr $orig]} {
	$usr substitute $orig
    } {
	foreach id [$usr channels] {
	    $id nickChange $usr $param
	    handleOn $net CHANNEL_NICK [list [$id name] $prefix $param]
	}
	foreach x {Message Notice Chat} {
	    switch nil [set old [$x :: find [$usr lname] $net]] {} default {
		$old nickChange $usr $param
	    }
	}
	$usr rename $param
    }
    handleOn $net CHANNEL_NICK [list $prefix $param]
    ditchPrefix $nkinfo
}
#
proc notAnon {c p} {
    switch :anonymous!anonymous@anonymous $p {
	switch -glob $c {[#+]*} { return 1 }
	return 0
    }
    return 1
}
#
proc ircPART {net prefix param pargs} {
    switch nil [set chan [Channel :: find [set chn [lindex $pargs 0]] $net]] return
    if {[notAnon $chn $prefix]} {
	set nkinfo [mungPrefix $net $prefix]
	if {[lindex $nkinfo 1]} {$chan delete} {
	    set usr [lindex $nkinfo 0]
	    set msg {}
	    switch {} $param {} default { set msg " : ($param)" }
	    $chan optText LEAVE "*** [$usr name] has left channel $chn$msg"
	    $chan killUser $usr
	}
	ditchPrefix $nkinfo
    }
    handleOn $net LEAVE [list $chn $prefix $param]
}
#
proc netsplit {str} {
    return [regexp -nocase \
      {^([a-z0-9*_-]+\.)+([a-z0-9_-]+) ([a-z0-9*_-]+\.)+([a-z0-9_-]+)$} $str]
}
#
proc ircQUIT {net prefix param unusedpargs} {
    if {![lindex [set nkinfo [mungPrefix $net $prefix]] 1]} {
	set nk [[set usr [lindex $nkinfo 0]] name]
	if {![$net nosplit] && [netsplit $param]} {
	    $usr split $param
	} {
	    switch nil [set fobj [Friend :: find $nk $net]] {} default {
		$fobj configure -ison 0 -usr nil
		[$net finfo] remove $fobj
	    }
	    $usr off

	    if {[set ti [listmember [$net toInfo] SIGNOFF]]} {
		$net display @QUIT "*** Signoff: $nk ($param)"
	    }
	    set lnk [$usr lname]
	    foreach x {channels messages notices chats} {
		foreach id [$net $x] {
		    if {[$id active]} {
			if {[$id isJoined $usr]} {
			    if {!$ti} {$id optText QUIT "*** Signoff: $nk ($param)"}
			    $id killUser $usr
		        } {
		            switch -- [$id lname] $lnk {
				$id addText @QUIT "*** $nk has signed off : $param"
			    }
			}
		    }
		}
	    }
	    handleOn $net QUIT [list $prefix $param]
	}
    }
    ditchPrefix $nkinfo
}
#
proc ircKICK {net prefix param pargs} {
    set kicker [lindex [mung1Prefix $net $prefix] 0]
    set chan [lindex $pargs 0]
    set who [[User :: make $net [set nk [lindex $pargs 1]]] ref]
    set id [Channel :: find $chan $net]
    if {[$net me $who]} {
	$id optText KICKME "*** You have been kicked off channel $chan by $kicker ($param)"
	if {[askUser KICKED "Kicked from $chan" \
	  "You have been kicked off channel $chan by $kicker\
($param). Do you want to rejoin?"]} {
	# the next code is in case the channel window was closed before
	# answering so we need to find the id again.
	    [Channel :: make $net $chan] rejoin
	} {
	    catch {$id delete}
	}
    } {
	$id optText KICK \
	  "*** $nk has been kicked off channel $chan by $kicker ($param)"
	$id kickUser $who $prefix 0
   }
   handleOn $net KICK [list $chan $prefix $nk $param]
   $who deref
}
#
proc ircINVITE {net prefix param unusedpargs} {
    if {![ignoreSet [lindex [set nkinfo [mungPrefix $net $prefix]] 3] invites]} {
	set name [[lindex $nkinfo 0] name]
	if {[askUser {} Invitation  "$name invites you to channel $param."]} {
	    set chid [Channel :: make $net $param]
	    catch {destroy .@kick$chid}
	    $chid sendJoin {}
	}
    }
    handleOn $net INVITE [list $prefix $param]
    ditchPrefix $nkinfo
}
#
proc ircKILL {net prefix param pargs} {
    set killer [lindex [mung1Prefix $net $prefix] 0]
    set who [[User :: make $net [lindex $pargs 0]] ref]
    $who off
    set nk [$who name]
    if {[$net me $who]} {
	tellInfo $net Killed "You have been killed by $killer ($param)" KILL
    } {
	foreach x {channels notices messages} {
	    foreach id [$net $x] {
		if {[$id isJoined $who]} {
		    $id optText KILL "*** $nk has been killed by $killer ($param)"
		    $id kickUser $who $prefix 1
		}
	    }
	}
    }
    handleOn $net KILL [list $prefix $nk]
    $who deref
}
#
proc ircTOPIC {net prefix param pargs} {
    set id [Channel :: find [set chan [lindex $pargs 0]] $net]
    $id setTopic $param
    set who [lindex [mung1Prefix $net $prefix] 0]
    $id optText TOPIC "*** $who has set the topic: \"$param\""
    $id log "*** $who has set the topic: $param"
    handleOn $net TOPIC [list $chan $prefix $param]
}
#
proc ircWALLOPS {net prefix param unusedpargs} {
   $net display WALLOP "[getDate] $prefix (WALLOPS) - $param"
   handleOn $net WALLOP [list $prefix $param]
}
#
proc ircNUM {net number pargs} {
    set number [string range $number 3 end]
    foreach arg [lrange [lindex $pargs 4] 1 end] {
	switch {} $arg {} default {append txt " $arg"}
    }
    append txt " [lindex $pargs 3]"
    switch -glob $number {
    [45]* {
	    set txt "Error $number from [string range [lindex $pargs 2] 1 end] : $txt"
	    tellError $net "[trans error] $number" $txt
	}
    default { $net inform $txt } 
    }
}
#
#	proc mungPrefix : breaks up the prefix to an IRC message
#	returns : {user object, me?, user@host, ignores}
#
proc mungPrefix {net prefix} {
    if {![regexp {^:([^!]+)!(.*)} $prefix m1 nk nm]} {
	return [list nil 0 {} {}]
    }
    set usr [[User :: make $net $nk $nm] ref]
    return [list $usr [$net me $usr] $nm [z_ignore $usr $nm]]
}
#
proc mung1Prefix {unusednet prefix} {
    if {![regexp {^:([^!]+)!(.*)} $prefix m1 nk nm]} {
	set nk [string range $prefix 1 end]
	set nm {}
    }
    return [list $nk $nm]
}
#
proc ditchPrefix {mng} { catch {[lindex $mng 0] deref} }