msncam.tcl

Linux下的MSN聊天程序源码

		#	fileevent $socket readable "::MSNCAM::ReadFromSock $socket"

		#	if { [getObjOption $sid server] == 0 } {
		#		fileevent $socket writable "::MSNCAM::WriteToSock $socket"
		#	}

		#}

		after 5000 "::MSNCAM::CheckConnectSuccess $sid"
	}

	proc RemoveSocketFromList { list socket } {

		set ips $list
		for {set idx 0} { $idx < [llength $ips] } {incr idx } {
			set connection [lindex $ips $idx]
			set ip [lindex $connection 0]
			set port [lindex $connection 1]
			set sock [lindex $connection 2]

			if {$sock == $socket } {
				set ips [lreplace $ips $idx $idx]
				return $ips
			}
		}
		status_log "Returning list, no $socket in $list\n" red
		return $list
	}

	proc CloseUnusedSockets { sid used_socket {list ""}} {
		if { $list == "" } {
			set ips [getObjOption $sid ips]
			status_log "Closing ips $ips\n" red
			if { $ips != "" } {
				CloseUnusedSockets $sid $used_socket  $ips
				setObjOption $sid ips ""
			}

			set ips [getObjOption $sid connected_ips]
			status_log "Closing connected_ips $ips\n" red
			if { $ips != "" } {
				CloseUnusedSockets $sid $used_socket $ips
			}

			status_log "resetting ips and connected_ipss\n red"

			if { $used_socket != "" } {
				set ips ""
				if { ![catch {set ip [lindex [fconfigure $used_socket -peer] 0]
					set port [lindex [fconfigure $used_socket -peer] 2]}] } {
					lappend ips [list $ip $port $used_socket]
				}

				setObjOption $sid connected_ips $ips
			}
		} else {
			status_log "Closing in $list of length [llength $list]\n" red
			for {set idx 0 } { $idx < [llength $list] } {incr idx } {
				set connection [lindex $list $idx]
				set ip [lindex $connection 0]
				set port [lindex $connection 1]
				set sock [lindex $connection 2]

				status_log "verifying $ip : $port on $sock \n" red
				if {$sock == $used_socket } { continue }

				status_log "Closing $sock\n" red
				catch {
					fileevent $sock readable ""
					fileevent $sock writable ""
				}

				status_log "fileevents reset\n" red
				catch {close $sock}
				status_log "closed\n" red
			}

		}
		status_log "Finished\n" red
	}

	proc SendXML { chatid sid } {
		set producer [getObjOption $sid producer]
		set inviter [getObjOption $sid inviter]

		set xml [CreateInvitationXML $sid]
		set xml [ToUnicode $xml]

		setObjOption $sid my_xml $xml

		set int [binary format i [myRand 0 255]]
		if {$producer } {
			set h1 "\x80\x00\x00\x00"
			set h2 "\x08\x00"
		} else {
			set h1 "\x80\x00\x09\x00"
			set h2 "\x08\x00"
		}

		set size [string length $xml]

		set msg "${h1}${h2}[binary format i $size]${xml}"


		SendXMLChunk $chatid $sid $msg 0 [string length $msg]


		return

	}

	proc SendXMLChunk { chatid sid msg offset totalsize } {
		set MsgId [lindex [::MSNP2P::SessionList get $sid] 0]
		set dest [lindex [::MSNP2P::SessionList get $sid] 3]
		incr MsgId
		::MSNP2P::SessionList set $sid [list $MsgId -1 -1 -1 -1 -1 -1 -1 -1 -1 ]


		if { [expr {$offset + 1202}] < $totalsize } {
			set footer "\x00\x00\x00\x04"
			set to_send [string range $msg 0 1201]
			set size [string length $to_send]
			set data "[binary format ii $sid $MsgId][binword $offset][binword $totalsize][binary format iiii $size 0 [expr {int([expr {rand() * 1000000000}])%125000000 + 4}] 0][binword 0]${to_send}${footer}"

			set theader "MIME-Version: 1.0\r\nContent-Type: application/x-msnmsgrp2p\r\nP2P-Dest: $dest\r\n\r\n"

			set data "${theader}${data}"
			set msg_len [string length $data]

			::MSNP2P::SendPacket [::MSN::SBFor $chatid] "$data"
			set offset [expr {$offset + 1202}]
			set msg [string range $msg 1202 end]
			SendXMLChunk $chatid $sid $msg $offset $totalsize
		} else {
			set footer "\x00\x00\x00\x04"
			set to_send $msg
			set size [string length $to_send]
			set data "[binary format ii $sid $MsgId][binword $offset][binword $totalsize][binary format iiii $size 0 [expr {int([expr {rand() * 1000000000}])%125000000 + 4}] 0][binword 0]${to_send}${footer}"

			set theader "MIME-Version: 1.0\r\nContent-Type: application/x-msnmsgrp2p\r\nP2P-Dest: $dest\r\n\r\n"

			set data "${theader}${data}"
			set msg_len [string length $data]

			::MSNP2P::SendPacket [::MSN::SBFor $chatid] "$data"

		}
	}

	proc GetCamDataSize { data } {

		# struct header {
		#    char header_size;
		#    char is_pause_frame;
		#    short width;
		#    short height;
		#    short is_keyframe;
		#    int payload_size;
		#    int FCC; \\ ML20
		#    int unique_random_id;
		#    int timestamp;
		# }
		

		if { [string length $data] < 24 } {
			return -1
		}


		#binary scan $data ccsssiiii h_size paused w h is_keyframe p_size fcc uid timestamp
		binary scan $data cc@8i h_size paused p_size
		
		#binary scan "\x30\x32\x4C\x4D" I r_fcc

		#status_log "got webcam header :  $data" green
		if { $h_size != 24 } {
			status_log "invalid - $h_size - [string range $data 0 50]" red
			return -1
		}
		# Pause header
		if { $paused == 1} {
			#status_log "Got 'pause' header" red
			return 0
		}
		set fcc [string range $data 12 15]
		if { $fcc != "ML20" } {
		# if { $fcc != $r_fcc} 
			status_log "fcc invalide - $fcc - [string range $data 0 50]" red
			return -1
		}
		#status_log "resolution : $w x $h - $h_size $p_size \n" red

		return $p_size

	}

	proc SendFrame { sock encoder img } {
		#If the img is not at the right size, don't encode (crash issue..)

		if { [::config::getKey lowrescam] == 1 && [set ::tcl_platform(os)] == "Linux" } {
			set camwidth 160
			set camheight 120
                } else {
                        set camwidth 320
			set camheight 240
                }
		
		if { !([info exists ::test_webcam_send_log] && $::test_webcam_send_log != "")
		     && ([image width $img] != "$camwidth" || [image height $img] != "$camheight") } {
			#status_log "webcam: Wrong size: Width is [image width $img] and height is [image height $img]\n" red
			#return
			
			#We crop the image to avoid bad sizes
			#This is a test..seems to work well for bad-sized ratio camera
			if { [image width $img] != "0" || [image height $img] != "0" } {
				$img configure -width $camwidth -height $camheight
			} else {
				return
			}
			
		}
		if { !([info exists ::test_webcam_send_log] && $::test_webcam_send_log != "")
		     && [catch {set data [::Webcamsn::Encode $encoder $img]} res] } {
			status_log "Error encoding frame : $res\n"
		    return
		} else {
			if { ([info exists ::test_webcam_send_log] && $::test_webcam_send_log != "") } {
				set fd [getObjOption $sock send_log_fd]
				if { $fd == "" } {
					set fd [open $::test_webcam_send_log]
					fconfigure $fd -encoding binary -translation {binary binary}
					setObjOption $sock send_log_fd $fd
				}
				if {[eof $fd] } { 
					close $fd 
					set fd [open $::test_webcam_send_log]
					fconfigure $fd -encoding binary -translation {binary binary}
					setObjOption $sock send_log_fd $fd
					
				}
				    
				set header [read $fd 24]
				set size [GetCamDataSize $header]
				if { $size > 0 } {
					set data "$header[read $fd $size]"
				}
			} else {
				# struct header {
				#    char header_size;
				#    char is_pause_frame;
				#    short width;
				#    short height;
				#    short is_keyframe;
				#    int payload_size;
				#    int FCC; \\ ML20
				#    int unique_random_id;
				#    int timestamp;
				# }
				
				# determine if it's a keyframe..
				binary scan $data @12c keyframe_flag
				if {[info exists keyframe_flag] && $keyframe_flag == 0} {
					set is_keyframe 1 
				} else {
					set is_keyframe 0
				}
				set uid [getObjOption $encoder unique_id]
				if {$uid == "" } {
					set byte1 [myRand 1 255]
					set byte2 [myRand 1 255]
					set byte3 [myRand 1 255]
					set byte4 [myRand 1 255]
					set uid [binary format cccc $byte1 $byte2 $byte3 $byte4]					
					setObjOption $encoder unique_id $uid
				}

				# set basic header info
				set header "[binary format ccsssi 24 0 [::Webcamsn::GetWidth $encoder] [::Webcamsn::GetHeight $encoder] $is_keyframe [string length $data]]"
				# add ML20
				append header "\x4D\x4C\x32\x30"
				# add a unique identifier
				append header "$uid"
				# add a timestamp
				set timestamp [ expr { [clock clicks -milliseconds] % 315360000 } ]
				append header "[binary format i $timestamp]"
				set data "${header}${data}"

			}
		}
		catch {
		    if { ![eof $sock] && [fconfigure $sock -error] == "" } {
			puts -nonewline $sock "$data"
		    }
		
		}

	}




}

namespace eval ::CAMGUI {

	proc camPresent { } {
		if { ! [info exists ::webcamsn_loaded] } { ::CAMGUI::ExtensionLoaded }
		if { ! $::webcamsn_loaded } { status_log "Error when trying to load Webcamsn extension" red; return }
		if { ! [info exists ::capture_loaded] } { ::CAMGUI::CaptureLoaded }
		if { ! $::capture_loaded } { return }
		#Now we are sure that both webcamsn and capture are loaded
		set campresent 0
		if { [set ::tcl_platform(os)] == "Linux" } {
                        if { [llength [::Capture::ListDevices]] > 0 } {
                                set campresent 1
                        }
		} elseif { [set ::tcl_platform(platform)] == "windows" } {
			tkvideo .webcam_preview
			set devices [.webcam_preview devices]
			if { [llength $devices] > 0 } {
				set campresent 1
			}
			destroy .webcam_preview
		} elseif { [set ::tcl_platform(os)] == "Darwin" } {
			#Jerome said there's no easy Mac way to check...
			set campresent 1
		}
		return $campresent
	}

	proc ShowCamFrame { sid data } {
		if { ! [info exists ::webcamsn_loaded] } { ExtensionLoaded }
		if { ! $::webcamsn_loaded } { return }

		if { [getObjOption [getObjOption $sid socket] state] == "END" } { return }

		set window [getObjOption $sid window]
		set decoder [getObjOption $sid codec]

		if { $decoder == "" } {
			set decoder [::Webcamsn::NewDecoder]
			setObjOption $sid codec $decoder
		}

		if { $window == "" } {
			set window .webcam_$sid
			toplevel $window
			set chatid [getObjOption $sid chatid]
			wm title $window "$chatid - [::abook::getDisplayNick $chatid]"
			wm protocol $window WM_DELETE_WINDOW "::MSNCAM::CancelCam $chatid $sid"
			set img [image create photo [TmpImgName]]
			label $window.l -image $img
			pack $window.l
			bind $window.l <Destroy> "image delete $img"
			label $window.paused -fg red -text ""
			pack $window.paused -expand true -fill x
			button $window.q -command "::MSNCAM::CancelCam $chatid $sid" -text "[trans stopwebcamreceive]"
			pack $window.q -expand true -fill x
			setObjOption $sid window $window
			setObjOption $sid image $img
		} else {
			$window.paused configure -text ""
		}

		set img [getObjOption $sid image]

		catch {::Webcamsn::Decode $decoder $img $data}

	}
	
	proc GotPausedFrame {sid} {
		set window [getObjOption $sid window]
		if { $window != "" } {
			$window.paused configure -text "[trans pausedwebcamreceive]"
		}
	}

	proc GetCamFrame { sid socket } {

		if { ! [info exists ::webcamsn_loaded] } { ExtensionLoaded }
		if { ! $::webcamsn_loaded } { return }

		if { ! [info exists ::capture_loaded] } { CaptureLoaded }
		if { ! $::capture_loaded } { return }

		if { [getObjOption $socket state] == "END" } { return }

		set window [getObjOption $sid window]
		set img [getObjOption $sid image]
		set encoder [getObjOption $socket codec]
		set source [getObjOption $sid source]

		if { [set ::tcl_platform(os)] == "Linux" } {
			if {$source == "0" } { set source "/dev/video0:0" }
			set pos [string last ":" $source]
			set dev [string range $source 0 [expr {$pos-1}]]
			set channel [string range $source [expr {$pos+1}] end]
		}

		set grabber [getObjOption $sid grabber]
		if { $grabber == "" } {
			if { [set ::tcl_platform(platform)] == "windows" } {
				foreach grabberItm [array names ::grabbers] {
					if {[$grabberItm cget -source] == $source} {
						set grabber $grabberItm
						break
					}
				}
				if { $grabber == "" } {
					set grabber .grabber_$sid
				}
			} elseif { [set ::tcl_platform(os)] == "Darwin" } {
				set grabber .grabber.seq
			} elseif { [set ::tcl_platform(os)] == "Linux" } {
				set grabber [::Capture::GetGrabber $dev $channel]
			}
		}

		set chatid [getObjOption $sid chatid]

		set grab_proc [getObjOption $sid grab_proc]

		if { !([info exists ::test_webcam_send_log] && $::test_webcam_send_log != "") && ![::CAMGUI::IsGrabberValid $grabber] } {
			status_log "Invalid grabber : $grabber"

			if { [set ::tcl_platform(platform)] == "windows" } {

				set grabber .grabber_$sid
				set grabber [tkvideo $grabber]