#
# $Source: /home/nlfm/Working/Zircon/Released/lib/RCS/Friend.tcl,v $
# $Date: 2001/07/12 15:35:50 $
# $Revision: 1.18.1.15 $
#
package provide zircon 1.18
#
# Handle all stuff related to Friends menu/window
#
#
proc Friend_save {desc net} {
    upvar #0 Configure.Friend defval
    set cm 1
    foreach x [$net friends] {
        if {![$x keep]} continue
	set ln "Friend [list [$x nick]]"
	foreach y [array names defval] {
	    switch -- [$x $y] $defval($y) continue
	    append ln " -$y [list [$x $y]]"
	}
	if {$cm} { puts $desc "#\n# Users\n#" ; set cm 0 }
	puts $desc $ln
    }
}
#
proc Friend_find {name net} {
    upvar #0 FTO$net FTO UTO$net UTO
    set ln [string tolower $name]
    if {[info exists FTO($ln)]} { return $FTO($ln) }
    if {[info exists UTO($ln)]} { return [$UTO($ln) fobj] }
    return nil
}
#
proc Friend_make {net name} {
    upvar #0 FTO$net FTO
    set ln [string tolower $name]
    if {[info exists FTO($ln)]} { return $FTO($ln) }
    return [$net eval [list Friend $name]]
}
#
proc Friend {name args} {
    switch -- $name :: {return [eval Friend_[lindex $args 0] [lrange $args 1 end]]}
    set this [objName Friend]
    initObj $this Friend
    upvar #0 currentNet net
    upvar #0 FTO$net FTO $this fdata
    set name [$net trimNick $name]
    array set fdata "
	nick	[list $name]
	lnick	[list [string tolower $name]]
	net	$net
    "
    $net register friends $this
    proc $this {unusedop args} "objCall friend $this \$unusedop \$args"
    eval $this configure $args
    if {[info exists FTO($fdata(lnick)]} {
	set other $FTO($fdata(lnick))
	switch -- $fdata(id) [$other id] {
	    $this delete
	    return nil
	} default {
	    switch {} $fdata(id) {$this delete ; return nil }
	    switch {} [$other id] {$other delete ; return nil }
# OOPS!!! Need to rewrite the friends mechanisms to cope with this
# one!!
	    tellError {} Friends {You have two Friend declarations \
with the same name but different id's. Currently Zircon cannot handle
this.

Sorry!!}
	    $this delete
	    return nil	    
	}
    } {
	set FTO([set fdata(lnick) [string tolower $name]]) $this
    }
    return $this
}
#
proc Friend_pack {net} {
    makeArray ${net}FTO
    foreach f [$net friends] { $f pack $net }
}
#
proc Friend_unpack {net} {
    upvar #0 ${net}FTO newFTO
    if {[info exists newFTO]} {
	foreach u [array names newFTO] { $newFTO($u) unpack $net }
	unset newFTO
    }
}
#
proc friend_doNotify {this} {
    upvar #0 $this fdata
    switch nil $fdata(usr) {} default {
	$fdata(usr) configure -notify $fdata(notify)
    }
    if {$fdata(notify)} { [$this net] ISON } {
	if {[$this ison]} { [[$this net] finfo] mark $this {} }
    }
}
#
proc friend_pack {this net} {
    upvar #0 ${net}FTO newt $this fdata
    uplevel #0 array set new$this \[array get $this\]
    set newt($fdata(lnick)) $this
}
#
proc friend_unpack {this net} {
    upvar #0 new$this newu ${net}FTO newt $this fdata
    foreach v {nick notify menu id} {$this configure -$v $newu($v)}
    unset newu newt($fdata(lnick))
    $this configure -usr [User :: find [$this nick] $net]
}
#
proc friend_name {this} {
    upvar #0 $this fdata
    switch nil $fdata(usr) {return $fdata(nick)}
    return [$fdata(usr) name]
}
#
proc friend_lname {this} {
    upvar #0 $this fdata
    switch nil $fdata(usr) {return $fdata(lnick)}
    return [$fdata(usr) lname]
}
#
proc friend_delete {this} {
    $this configure -notify 0 -usr nil
    upvar #0 $this fdata
    set net $fdata(net)
    upvar #0 FTO$net FTO
    unset FTO($fdata(lnick)) fdata
    $net deregister friends $this
}
#
proc friend_configure {this args} {
    upvar #0 $this fdata
    set net $fdata(net)
    foreach {op val} $args {
	switch -- $op {
	-nick {
		upvar #0 FTO$net FTO
		set ln $fdata(lnick)
		set fdata(nick) [set name [[$this net] trimNick $val]]
		set fdata(lnick) [string tolower $name]
		unset FTO($ln)
		set FTO($fdata(lnick)) $this
	    }
	-usr {
		switch nil $fdata(usr) {} default {
		    $fdata(usr) configure -fobj nil
		}
		switch nil $val {} default {$val configure -fobj $this}
		set fdata(usr) $val
	    }
	-id {
		if {[catch {regexp -nocase -- $val abcde}]} {
		    tellError {} {Id Error} "Invalid regular\
expression in -id option of Friend [$this name]"
		} {
		    set fdata(id) $val
		}
	    }
	-protect {
		if {![checkProtect $net $this $val]} { set val {} }
		set fdata(protect) $val
	    }
	-image {
		set fdata(image) $val
		foreach x $val {
		    lappend fdata(images) [image create photo -file $x]
		}
	    }
	default { set fdata([string range $op 1 end]) $val }
	}
    }
}
#
proc friend_appear {this uh} {
    upvar #0 $this fdata
    switch {} $fdata(id) {} default {
        if {![regexp -- $fdata(id) $uh]} return
    }
    if {!$fdata(ison) || $fdata(limbo)} {
    	set fdata(ison) 1
 	if {$fdata(limbo)} {
	    set fdata(limbo) 0
	    switch nil $fdata(usr) {} default { $fdata(usr) heal }
	} {
	    set frnd [$fdata(net) finfo]
	    if {[$fdata(net) friendsOn] && $fdata(menu)} { $frnd add $this }
		$frnd mark $this ison
	}
    }
}
#
proc GlobFriend {pattern} {
    global currentNet
    $currentNet configure +globfriend $pattern
}
#
proc globfon {net pargs args} {
    switch nil [Friend :: find [set nk [lindex $pargs 5]] $net] {
	$net eval "Friend [list $nk] -keep 0"
    }
}


