abook.tcl

Linux下的MSN聊天程序源码

#	User Administration (Address Book data)
#	by: Alvaro Jose Iradier Muro
#	D�imo Emilio Grimaldo Tu�n
# $Id: abook.tcl 6901 2006-06-16 13:37:34Z tjikkun $
#=======================================================================

::snit::type Group {

	variable users {}
	option -name
	option -id

	method showInfo { } {
		status_log ----
		status_log id:$options(-id)
		status_log name:$options(-name)
		status_log users:$users
	}

	method addUser { user } {
		llappend users $user
	} 
}



namespace eval ::abook {
#::abook namespace is used to store all information related to users
#and contact lists.

	if { $initialize_amsn == 1 } {
		#
		# P R I V A T E
		#
		variable demographics;	# Demographic Information about user
		
		#When set to 1, the information is in safe state and can be
		#saved to disk without breaking anything
		
		variable consistent 0

		# This list stores the names of the fields about the visual representation of the buddy.
		# When this fields gets changed, we fire an event to redraw that contact on our CL.
		variable VisualData [list nick customnick customfnick cust_p4c_name customcolor]

		global pgc pcc
	}
	
	#########################
	# P U B L I C
	#########################
	
	#An alias for "setContactData myself". Sets data for the "myself" user
	proc setPersonal { field value} {
		setContactData myself $field $value
	}
   
	#An alias for "getContactData myself". Gets data for the "myself" user	
	proc getPersonal { field } {
		return [getContactData myself $field]
	}
	
	#TODO: Remove this
	proc getContact { email cdata } {
		upvar $cdata data

		set groupName    [::groups::GetName [getContactData $email group]]
		set data(group)  [urldecode $groupName]
		set data(handle) [urldecode [getVolatileData $email nick]]
		set data(PHH) [urldecode [getVolatileData $email PHH]]
		set data(PHW) [urldecode [getVolatileData $email PHW]]
		set data(PHM) [urldecode [getVolatileData $email PHM]]
		set data(MOB) [urldecode [getVolatileData $email MOB]]
		set data(available) "Y"
	}

	# Get PSM and currentMedia
	proc getpsmmedia { { user_login "" } } {
		if { [::config::getKey protocol] < 11 } { return }
		set psmmedia ""
		if { $user_login == "" } {
	                set psm [::abook::getPersonal PSM]
        	        set currentMedia [parseCurrentMedia [::abook::getPersonal currentMedia]]
		} else {
                	set psm [::abook::getVolatileData $user_login PSM]
                	set currentMedia [parseCurrentMedia [::abook::getVolatileData $user_login currentMedia]]
		}
                if {$psm != ""} {
                        append psmmedia "$psm"
                }
                if {$currentMedia != ""} {
                        if { $psm != ""} {
                                append psmmedia " "
                        }
                        append psmmedia "$currentMedia"
                }
		return $psmmedia
	}

      
	# Sends a message to the notification server with the
	# new set of phone numbers. Notice this can only be done
	# for the user and not for the buddies!
	# The value is urlencoded by this routine
	proc setPhone { item value } {
		switch $item {
			home { ::MSN::WriteSB ns PRP "PHH $value" }
			work { ::MSN::WriteSB ns PRP "PHW $value" }
			mobile { ::MSN::WriteSB ns PRP "PHM $value" }
			pager { 
				::MSN::WriteSB ns PRP "MOB $value"
				if { $value == "Y" } {
					::MSN::setClientCap paging
				} else {
					::MSN::setClientCap paging 0
				}
				::MSN::changeStatus [::MSN::myStatusIs]
			 }
			default { status_log "setPhone error, unknown $item $value\n" }
		}
	}

	# This information is sent to us during the initial connection
	# with the server. It comes in a MSG content "text/x-msmsgsprofile"
	# TODO: Change this to use setVolatileData to user myself
	proc setDemographics { cdata } {
		variable demographics 
		upvar $cdata data

    		set demographics(langpreference) $data(langpreference);# 1033 = English
		set demographics(preferredemail) $data(preferredemail)
		set demographics(country) [string toupper $data(country)];# NL
		set demographics(gender) [string toupper $data(gender)]
		set demographics(kids) $data(kids);	  # Number of kids
		set demographics(age) $data(age)
		set demographics(mspauth) $data(mspauth); # MS Portal Authorization?
		set demographics(kv) $data(kv)
		set demographics(sid) $data(sid)
		set demographics(sessionstart) $data(sessionstart)
		set demographics(clientip) $data(clientip)
		set demographics(valid) Y
		abook::getIPConfig
	}

	proc getDemographicField { field } {
		variable demographics
		if { [info exists demographics($field)]} {
			return $demographics($field)
		} else {
			return ""
		}
	}

	proc getDemographics { cdata } {
		variable demographics 
		upvar $cdata d

		if {[info exists d(valid)]} {
			set d(langpreference) $demographics(langpreference);# 1033 = English
			set d(preferredemail) $demographics(preferredemail)
			set d(country) $demographics(country)
			set d(gender) $demographics(gender)
			set d(kids) $demographics(kids)
			set d(age) $demographics(age)
			set d(mspauth) $demographics(mspauth)
			set d(kv) $demographics(kv)
			set d(sid) $demographics(sid)
			set d(sessionstart) $demographics(sessionstart)
			set d(clientip) $demographics(clientip)
			set d(valid) Y
		} else {
			set d(valid) N
		}
	}

	################################################################################################################################
	################################################################################################################################
	################################################################################################################################
	############## MOVE ALL PROTOCOL/IP CHECK RELATED PROCEDURES OUT OF ABOOK!! ABOOK SHOULD CARE ONLY ABOUT #######################
	############## DATA STORAGE, NOT ABOUT SERVERS/IPS/CONNECTIONS OR WHATEVER !!                            #######################
	
	# This proc will configure all ip settings, get private ip, see if firewalled or not, and set netid
	proc getIPConfig { } {
		variable demographics

		status_log "Getting local IP\n"
		set demographics(localip) [getLocalIP]
		status_log "Finished\n"
		set demographics(upnpnat) "false"
		set demographics(conntype) [getConnectionType [getDemographicField localip] [getDemographicField clientip]]
		if { $demographics(conntype) == "Direct-Connect" || $demographics(conntype) == "Firewall" } {
			set demographics(netid) 0
			set demographics(upnpnat) "false"
		} else {
			set demographics(netid) [GetNetID [getDemographicField clientip]]
			if { [getFirewalled [::config::getKey initialftport]] == "Firewall" } {
				set demographics(upnpnat) "false"
			} else {
				set demographics(upnpnat) "true"	
			}
		}

		set demographics(listening) [getListening [getDemographicField conntype]]
	}

	# This proc will get the localip (private ip, NAT or not)
	proc getLocalIP { } {
		set sk [ns cget -sock]

		if { $sk != "" } {
			foreach ip $sk {break}
			return $ip
		} else {
			return ""
		}
	}

	# This will return the connection type : ip-restrict-nat, direct-connect or firewall
	proc getConnectionType { localip clientip } {
 
		if { $localip == "" || $clientip == "" } { 
			return [getFirewalled [::config::getKey initialftport]]
		} 
		if { $localip != $clientip } {
			return "IP-Restrict-NAT"
		} else { 
			return [getFirewalled [::config::getKey initialftport]]
		}
	}

	# This will create a server, and try to connect to it in order to see if firewalled or not
	proc getFirewalled { port } {
		global connection_success
		while { [catch {set sock [socket -server "abook::dummysocketserver" $port] } ] } {
			incr port
		}
		status_log "::abook::getFirewalled: Connecting to [getDemographicField clientip] port $port\n" blue
		
		#Need this timeout thing to avoid the socket blocking...
		set connection_success 0
		if {[catch {set clientsock [socket -async [getDemographicField clientip] $port]}]} {
			catch {close $sock}
			return "Firewall"
		}

		fileevent $clientsock readable [list ::abook::connectionHandler $clientsock]
		after 1000 ::abook::connectionTimeout
		vwait connection_success
		if { $connection_success == 0 } {
			catch {close $sock}
			catch { close $clientsock }
			return "Firewall"
		} else {
			catch {close $sock}
			catch { close $clientsock }
			return "Direct-Connect"
		}
	}
	
	proc connectionTimeout {} {
		global connection_success
		status_log "::abook::connectionTimeout\n"
		set connection_success 0
	}
	
	proc connectionHandler { sock } {
		#CHECK FOR AN ERROR
		global connection_success
		after cancel ::abook::connectionTimeout
		fileevent $sock readable ""
		if { [fconfigure $sock -error] != ""} {
			status_log "::abook::connectionHandler: connection failed\n" red
			set connection_success 0
		} else {
			gets $sock server_data
			if { "$server_data" != "AMSNPING" } {
				status_log "::abook::connectionHandler: port in use by another application!\n" red
				set connection_success 0
			} else {
				status_log "::abook::connectionHandler: connection succesful\n" green
				set connection_success 1
			}
		}
	}

	proc getListening { conntype } {
		if {$conntype == "Firewall" } {
			return "false"
		} elseif { $conntype == "Direct-Connect" } {
		        return "true"
		} else { 
			return [abook::getDemographicField upnpnat]
		}
	}

	# This proc is a dummy socket server proc, because we need a command to be called which the client connects to the test server (if not firewalled)
	proc dummysocketserver { sock ip port } {
		if {[catch {
			puts $sock "AMSNPING"
			flush $sock
			close $sock
		}]} {
			status_log "::abook::dummysocketserver: Error writing to socket\n"
		}
	}

	# This will transform the ip adress into a netID adress (which is the 32 bits unsigned integer represent the ip)
	proc GetNetID { ip } {
		set val 0
		set inverted_ip ""
		foreach x [split $ip .] { 
			set inverted_ip "${x} ${inverted_ip}"	
		}
		
		foreach x $inverted_ip { 
			set val [expr {($val << 8) | ($x & 0xff)}] 
		}
		return [format %u $val]
 
	}
	################################################################################################################################
	################################################################################################################################
	################################################################################################################################

	#Clears all ::abook stored information
	proc clearData {} {
		variable users_data
		array unset users_data *
		
		variable users_volatile_data
		array unset users_volatile_data *
		
		unsetConsistent
	}

	#Sets some data to a user.
	#user_login: the user_login you want to set data to
	#field: the field you want to set
	#data: the data that will be contained in the given field
	proc setContactData { user_login field data } {
		global pgc
		variable users_data

		set field [string tolower $field]
		
		# There can't be double arrays, so users_data(user) is just a
		# list like {entry1 data1 entry2 data2 ...}
		if { [info exists users_data($user_login)] } {
			#We convert the list to an array, to make it easier
			array set user_data $users_data($user_login)
		} else {
			array set user_data [list]
		}

		# An event used by guicontactlist to know when a user changed his nick (or state)
		if { [lsearch -exact $::abook::VisualData $field] > -1 } {
			if { [info exists user_data($field)] && $user_data($field) != $data } {
				#puts stdout "ATTENTION! Visual Data has changed! Redraw CL! $field - $data"
				::Event::fireEvent contactDataChange abook $user_login
			} elseif { ![info exists user_data($field)] && $data != ""} {
				#puts stdout "ATTENTION! Visual Data has changed! Redraw CL! $field - $data"
				::Event::fireEvent contactDataChange abook $user_login
			}
		}

		if { $data == "" } {
			if { [info exists user_data($field)] } {
				unset user_data($field)
			}
		} else {
			#post event for amsnplus
			set evPar(data) data
			::plugins::PostEvent parse_nick evPar

			set user_data($field) $data
		}
		
		set users_data($user_login) [array get user_data]
		
		#We make this to notify preferences > groups to be refreshed
		set pgc 1
	}

	proc setContactForGuid { guid user_login } {
		variable guid_contact
		if { $user_login == "" } {
			if { [info exists guid_contact($guid)] } {