chatwindow.tcl

Linux下的MSN聊天程序源码

	}

	###################################################
	# CreateTopFrame
	# This proc creates the top frame of a chatwindow
	#
	proc CreateTopFrame { w } {

		# Create our frame
		set top [GetTopFrame $w]
		
		framec $top -type canvas -relief solid -borderwidth [::skin::getKey chat_top_border] -bordercolor [::skin::getKey topbarborder] -background [::skin::getKey topbarbg] -state disabled
		
		if { [::skin::getKey chat_top_pixmap] } {
			set bg "::$top.bg"
			set topimg [image create photo [TmpImgName]] ;#gets destroyed
			$topimg copy [::skin::loadPixmap cwtopback]
			::picture::Colorize $topimg [::skin::getKey topbarbg]
			scalable-bg $bg -source $topimg -n [::skin::getKey topbarpady] -e [::skin::getKey topbarpadx] -s [::skin::getKey topbarpady] -w [::skin::getKey topbarpadx] -width 0 -height 0
			$top create image 0 0 -image [$bg name] -anchor nw -tag backgnd
			bind $top <Configure> "$bg configure -width %w -height %h"
			bind $top <Destroy> "$bg destroy; image delete $topimg"
		}
		
		set toX [::skin::getKey topbarpadx]
		set usrsX [expr {$toX + [font measure bplainf "[trans to]:"] + 5}]
		set txtY [::skin::getKey topbarpady]
		
		$top create text $toX $txtY -fill [::skin::getKey topbartext] -state disabled -font bplainf -text "[trans to]:" -anchor nw -tag to

		$top create text $usrsX $txtY -fill [::skin::getKey topbartext] -state disabled -font sboldf -anchor nw -tag text
		
		#As the contact list isn't filled we set the height to fit with the To field
		$top configure -height [expr {[::ChatWindow::MeasureTextCanvas $top "to" [$top itemcget to -text] "h"] + 2*[::skin::getKey topbarpady]}]

		return $top
	}


	###################################################
	# CreateStatusBar
	# This proc creates the status bar of a chatwindow
	#
	proc CreateStatusBar { w } {
		
		#Create the frame
		set statusbar $w.statusbar
		framec $statusbar -class Amsn -relief solid\
				-borderwidth [::skin::getKey chat_status_border] \
				-bordercolor [::skin::getKey chat_status_border_color] \
				-background [::skin::getKey statusbarbg]

		# set our inner widget's names
		set status [$statusbar getinnerframe].status
		set charstyped [$statusbar getinnerframe].charstyped

		#Create text insert frame
		text $status  -width 5 -height 1 -wrap none \
			-font bplainf -borderwidth 0 -background [::skin::getKey statusbarbg] -foreground [::skin::getKey statusbartext]\
			-highlightthickness 0 -selectbackground [::skin::getKey statusbarbg_sel] -selectborderwidth 0 \
			-selectforeground [::skin::getKey statusbartext] -exportselection 1 -pady 4
		text $charstyped  -width 4 -height 1 -wrap none \
			-font splainf -borderwidth 0 -background [::skin::getKey statusbarbg] -foreground [::skin::getKey statusbartext]\
			-highlightthickness 0 -selectbackground [::skin::getKey statusbarbg_sel] -selectborderwidth 0 \
			-selectforeground [::skin::getKey statusbartext] -exportselection 1 -pady 4


		# Configure them
		$charstyped tag configure center -justify left
		$status configure -state disabled
		$charstyped configure -state disabled

		# Pack them
		pack $status -side left -expand true -fill x -padx 0 -pady 0 -anchor w

		if { [::config::getKey charscounter] } {
			pack $charstyped -side right -expand false -padx 0 -pady 0 -anchor e
		}

		return $statusbar
	}

	proc CreatePanedWindow { w } {
		
		set paned $w.f
		if { $::tcl_version >= 8.4 } {
			panedwindow $paned \
				-background [::skin::getKey chatwindowbg] \
				-borderwidth 0 \
				-relief flat \
				-orient vertical
		} else {
			frame $paned -background [::skin::getKey chatwindowbg] -borderwidth 0 -relief flat 
		}
		set output [CreateOutputWindow $w $paned]
		set input [CreateInputWindow $w $paned]

		if { $::tcl_version >= 8.4 } {
			$paned add $output $input
			$paned paneconfigure $output -minsize 50 -height 200
			$paned paneconfigure $input -minsize 100 -height 120
			$paned configure \
				-showhandle [::skin::getKey chat_sash_showhandle] \
				-sashpad [::skin::getKey chat_sash_pady] \
				-sashwidth [::skin::getKey chat_sash_width] \
				-sashrelief [::skin::getKey chat_sash_relief]
		} else {
			pack $output -expand true -fill both -padx 0 -pady 0
			pack $input \
				-side top \
				-expand false \
				-fill both \
				-padx [::skin::getKey chat_input_padx] \
				-pady [::skin::getKey chat_input_pady]
		}

		# Bind on focus, so we always put the focus on the input window
		bind $paned <FocusIn> "focus $input"

		bind $input <Configure> "::ChatWindow::InputPaneConfigured $paned $input $output %W %h"
		if { $::tcl_version >= 8.4 } {
			bind $output <Configure> "::ChatWindow::OutputPaneConfigured $paned $input $output %W %h"
			bind $paned <Configure> "::ChatWindow::PanedWindowConfigured $paned $input $output %W %h"
		}

		return $paned
	}


	proc GetSashHeight { paned } {
		set sashheight [expr { [$paned cget -sashpad ] + [$paned cget -sashwidth]}]
		if { [ $paned cget -showhandle ] } {
			set handleheight [expr { [$paned cget -sashpad ] + (([$paned cget -sashwidth]+1)/2) + ([$paned cget -handlesize]/2) }]
			if { $handleheight > $sashheight } {
				set sashheight $handleheight
			}
		}

		return $sashheight
	}

	proc SetSashPos { paned input output } {
		update idletasks

		set bottomsize [winfo height $input]
		if { $bottomsize < [$paned panecget $input -minsize] } {
			set bottomsize [$paned panecget $input -minsize]
		}
		set sashheight [::ChatWindow::GetSashHeight $paned]
		$paned sash place 0 0 [expr {[winfo height $paned] - ($bottomsize + $sashheight)}]
	}

	proc InputPaneConfigured { paned input output W newh } {
		#only run this if the window is the outer frame
		if { ![string equal $input $W]} { return }

		set win [string first "msg" $paned]
		set win [string first "." $paned $win]
		incr win -1
		set win [string range $paned 0 $win]

		set scrolling [getScrolling [::ChatWindow::GetOutText $win]]

		if { $::tcl_version >= 8.4 } {
			#check that the drag adhered to minsize input pane
			#first checking that there is enough room otherwise you get an infinite loop
			if { ( [winfo height $input] < [$paned panecget $input -minsize] ) \
					&& ( [winfo height $output] > [$paned panecget $output -minsize] ) \
					&& ( [winfo height $paned] > [$paned panecget $output -minsize] ) } {

				::ChatWindow::SetSashPos $paned $input $output
			}
		}


		if { $scrolling } { after 100 "catch {::ChatWindow::Scroll [::ChatWindow::GetOutText $win]}" }


		if { [::config::getKey savechatwinsize] } {
			::config::setKey winchatoutheight [winfo height $output]
		}
	}

	# this proc is only needed when the sash is moved manually
	# and the input pane is off the screen so the obove doesnt get called
	proc OutputPaneConfigured { paned input output W newh } {
		#only run this if the window is the outer frame
		if { ![string equal $output $W]} { return }

		#only run if input frame not visible
		if { [winfo height $paned] <= [lindex [$paned sash coord 0] 1] + [::ChatWindow::GetSashHeight $paned] } {
		
			#check that the drag adhered to minsize for the input pane
			if { ( [winfo height $input] < [$paned panecget $input -minsize] ) \
					&& ( [winfo height $output] > [$paned panecget $output -minsize] ) \
					&& ( [winfo height $paned] > [$paned panecget $output -minsize] ) } {

				::ChatWindow::SetSashPos $paned $input $output
			}
		}
	}
	
	proc PanedWindowConfigured { paned input output W newh } {
		#only run this if the window is the outer frame
		if { ![string equal $paned $W]} { return }

		#keep the input pane the same size, only change the output		
		#dont call the first time it is created
		#as the input size hasnt been set yet
		if {([winfo height $input] != 1) || ([winfo height $output] != 1) } {
			::ChatWindow::SetSashPos $paned $input $output
		}
	}

	proc CreateOutputWindow { w paned } {
		
		# Name our widgets
		set fr $paned.out
		set out $fr.scroll
		set text $out.text

		# Create the widgets
		frame $fr -class Amsn -borderwidth 0 -relief solid \
			-background [::skin::getKey chatwindowbg] -height [::config::getKey winchatoutheight]
		ScrolledWindow $out -auto vertical -scrollbar vertical -ipad 0
		framec $text -type text -relief solid -foreground white -background [::skin::getKey chat_output_back_color] -width 45 -height 3 \
			-setgrid 0 -wrap word -exportselection 1 -highlightthickness 0 -selectborderwidth 1 \
			-borderwidth [::skin::getKey chat_output_border] \
			-bordercolor [::skin::getKey chat_output_border_color]
		set textinner [$text getinnerframe]

		$out setwidget $text


		pack $out -expand true -fill both \
			-padx [::skin::getKey chat_output_padx] \
			-pady [::skin::getKey chat_output_pady]
		

		# Configure our widgets
		$text configure -state disabled
		$text tag configure green -foreground darkgreen -font sboldf
		$text tag configure red -foreground red -font sboldf
		$text tag configure blue -foreground blue -font sboldf
		$text tag configure gray -foreground #404040 -font splainf
		$text tag configure gray_italic -foreground #000000 -font sbolditalf
		$text tag configure white -foreground white -background black -font sboldf
		$text tag configure url -foreground #000080 -font splainf -underline true

		# Create our bindings
		bind $textinner <<Button3>> "tk_popup $w.copy %X %Y"

		# Do not bind copy command on button 1 on Mac OS X 
		if {![catch {tk windowingsystem} wsystem] && $wsystem != "aqua"} {
			bind $textinner <Button1-ButtonRelease> "copy 0 $w"
		}

		# When someone type something in out.text, regive the focus to in.input and insert that key
		bind $textinner <KeyPress> "::ChatWindow::lastKeytyped %A $w"


		#Added to stop amsn freezing when control-up pressed in the output window
		#If you can find why it is freezing and can stop it remove this line
		bind $textinner <Control-Up> "break"

		return $fr
	}

	#lastkeytyped 
	#Force the focus to the input text box when someone try to write something in the output
	proc lastKeytyped {typed w} {
		if {[regexp \[a-zA-Z\] $typed]} {
			focus -force [::ChatWindow::GetInputText $w]
			[::ChatWindow::GetInputText $w] insert insert $typed
		}
	}

	proc CreateInputWindow { w paned } {

		status_log "Creating input frame\n"
		# Name our widgets
		set bottom $paned.bottom
		set leftframe $bottom.left

		# Create the bottom frame widget
		frame $bottom -class Amsn -borderwidth 0 -relief solid \
			-background [::skin::getKey chatwindowbg]
		

		# Create The left frame
		frame $leftframe -class Amsn -background [::skin::getKey chatwindowbg] -relief solid -borderwidth 0

		# Create the other widgets for the bottom frame
		set input [CreateInputFrame $w $leftframe]
		set buttons [CreateButtonBar $w $leftframe]
		set picture [CreatePictureFrame $w $bottom]

		pack $buttons -side top -expand false -fill x -anchor n \
				-padx [::skin::getKey chat_buttons_padx] \
				-pady [::skin::getKey chat_buttons_pady]
		pack $input -side top -expand true -fill both -anchor n \
				-padx [::skin::getKey chat_input_padx] \
				-pady [::skin::getKey chat_input_pady]
		pack $leftframe -side left -expand true -fill both \
				-padx [::skin::getKey chat_leftframe_padx] \
				-pady [::skin::getKey chat_leftframe_pady]
		pack $picture -side right -expand false -anchor ne \
				-padx [::skin::getKey chat_dp_padx] \
				-pady [::skin::getKey chat_dp_pady]

		# Bind the focus
		bind $bottom <FocusIn> "focus $input"

		#send chatwininput postevent
		set evPar(input) $input
		set evPar(buttons) $buttons
		set evPar(picture) $picture
		set evPar(window) "$w"

		::plugins::PostEvent chatwininput evPar		

		return $bottom

	}

	proc CreateInputFrame { w bottom} { 
		global tcl_platform

		# Create The input frame
		set input $bottom.in
		framec $input -class Amsn -relief solid \
				-background [::skin::getKey sendbuttonbg] \
				-borderwidth [::skin::getKey chat_input_border] \
				-bordercolor [::skin::getKey chat_input_border_color]
		
		# set our inner widget's names
		set sendbuttonframe [$input getinnerframe].sbframe
		set sendbutton $sendbuttonframe.send
		set text [$input getinnerframe].text

		# Create the text widget and the send button widget
		text $text -background [::skin::getKey chat_input_back_color] -width 15 -height 3 -wrap word -font bboldf \
			-borderwidth 0 -relief solid -highlightthickness 0 -exportselection 1
		
		frame $sendbuttonframe -borderwidth 0 -bg [::skin::getKey sendbuttonbg]
		# Send button in conversation window, specifications and command. Only
		# compatible with Tcl/Tk 8.4. Disable it on Mac OS X (TkAqua looks better)
		if { ($::tcl_version >= 8.4) && ($tcl_platform(os) != "Darwin") } {
			# New pixmap-skinnable button (For Windows and Unix > Tcl/Tk 8.3)
			button $sendbutton -image [::skin::loadPixmap sendbutton] \
				-command "::amsn::MessageSend $w $text" \
				-fg black -bg [::skin::getKey sendbuttonbg] -bd 0 -relief flat \
				-activebackground [::skin::getKey sendbuttonbg] -activeforeground black -text [trans send] \
				-font sboldf -highlightthickness 0 -pady 0 -padx 0 -overrelief flat -compound center
		} elseif { $tcl_platform(os) == "Darwin" } {
			label $sendbutton -image [::skin::loadPixmap sendbutton] \
				-fg black -bg [::skin::getKey sendbuttonbg] -bd 0 -relief flat \
				-activebackground [::skin::getKey sendbuttonbg] -activeforeground black -text [trans send] \
				-font sboldf -highlightthickness 0 -pady 0 -padx 0 -relief flat -compound center
			bind $sendbutton <<Button1>> "::amsn::MessageSend $w $text"
		} else 	{
			# Standard grey flat button (For Tcl/Tk < 8.4 and Mac OS X)
			button $sendbutton  -text "\n[trans send]\n" -width 6 -borderwidth 1 \
				-relief solid -command "::amsn::MessageSend $w $text" \
				-font bplainf -highlightthickness 0 -highlightbackground [::skin::getKey sendbuttonbg]
		}


		# Configure my widgets
		$sendbutton configure -state normal
		$text configure -state normal

		# Create my bindings
		bind $sendbutton <Return> "::amsn::MessageSend $w $text; break"
		#Don't insert picture if TCL 8.3 or Mac OS X because it's the old-style button
		if { $::tcl_version >= 8.4 } {
			bind $sendbutton <Enter> "$sendbutton configure -image [::skin::loadPixmap sendbutton_hover]"
			bind $sendbutton <Leave> "$sendbutton configure -image [::skin::loadPixmap sendbutton]"
		}
		bind $text <Shift-Return> {%W insert insert "\n"; %W see insert; break}
		bind $text <Control-KP_Enter> {%W insert insert "\n"; %W see insert; break}
		bind $text <Shift-KP_Enter> {%W insert insert "\n"; %W see insert; break}

		# Change shortcuts on Mac OS X (TKAqua). ALT=Option Control=Command on Mac
		if {![catch {tk windowingsystem} wsystem] && $wsystem == "aqua"} {
			bind $text <Command-Return> {%W insert insert "\n"; %W see insert; break}
			bind $text <Command-Optio