autoupdate.tcl

Linux下的MSN聊天程序源码

package require AMSN_BWidget

namespace eval ::autoupdate {

	proc installTLS {} {
		global tcl_platform
		global tlsplatform

		if { ($tcl_platform(os) == "Linux") && ($tcl_platform(machine) == "ppc")} {
			set tlsplatform "linuxppc"
		} elseif { ($tcl_platform(os) == "Linux") && ($tcl_platform(machine) == "sparc")} {
			set tlsplatform "linuxsparc"
		} elseif { ($tcl_platform(os) == "Linux") && ($tcl_platform(machine) == "x86_64")} {
			set tlsplatform "linuxx86_64"
		} elseif { $tcl_platform(os) == "Linux" } {
			set tlsplatform "linuxx86"
		} elseif { $tcl_platform(os) == "NetBSD"} {
			set tlsplatform "netbsdx86"
		} elseif { $tcl_platform(os) == "FreeBSD"} {
			set tlsplatform "freebsdx86"
		} elseif { $tcl_platform(os) == "Solaris"} {
			set tlsplatform "solaris28"
		} elseif { $tcl_platform(platform) == "windows"} {
			set tlsplatform "win32"
		} elseif { $tcl_platform(os) == "Darwin" } {
			set tlsplatform "mac"
		} else {
			set tlsplatform "src"
		}

		toplevel .tlsdown
		wm title .tlsdown "[trans tlsinstall]"

		label .tlsdown.caption -text "[trans tlsinstallexp]" -anchor w -font splainf

		label .tlsdown.choose -text "[trans choosearq]:" -anchor w -font sboldf

		pack .tlsdown.caption -side top -expand true -fill x -padx 10 -pady 10
		pack .tlsdown.choose -side top -anchor w -padx 10 -pady 10

		radiobutton .tlsdown.linuxx86 -text "Linux-x86" -variable tlsplatform -value "linuxx86" -font splainf
		radiobutton .tlsdown.linuxx86_64 -text "Linux-x86_64" -variable tlsplatform -value "linuxx86_64" -font splainf
		radiobutton .tlsdown.linuxppc -text "Linux-PowerPC" -variable tlsplatform -value "linuxppc" -font splainf
		radiobutton .tlsdown.linuxsparc -text "Linux-SPARC" -variable tlsplatform -value "linuxsparc" -font splainf
		radiobutton .tlsdown.netbsdx86 -text "NetBSD-x86" -variable tlsplatform -value "netbsdx86" -font splainf
		radiobutton .tlsdown.netbsdsparc64 -text "NetBSD-SPARC64" -variable tlsplatform -value "netbsdsparc64" -font splainf
		radiobutton .tlsdown.freebsdx86 -text "FreeBSD-x86" -variable tlsplatform -value "freebsdx86" -font splainf
		radiobutton .tlsdown.solaris26 -text "Solaris 2.6 SPARC" -variable tlsplatform -value "solaris26" -font splainf
		radiobutton .tlsdown.solaris28 -text "Solaris 2.8 SPARC" -variable tlsplatform -value "solaris28" -font splainf
		radiobutton .tlsdown.win32 -text "Windows" -variable tlsplatform -value "win32" -font splainf
		radiobutton .tlsdown.mac -text "Mac OS X" -variable tlsplatform -value "mac" -font splainf
		radiobutton .tlsdown.src -text "[trans sourcecode]" -variable tlsplatform -value "src" -font splainf
		radiobutton .tlsdown.nodown -text "[trans dontdownload]" -variable tlsplatform -value "nodown" -font splainf


		frame .tlsdown.f

		button .tlsdown.f.ok -text "[trans ok]" -command "::autoupdate::downloadTLS; bind .tlsdown <Destroy> {}; destroy .tlsdown"
		button .tlsdown.f.cancel -text "[trans cancel]" -command "destroy .tlsdown"

		pack .tlsdown.f.cancel -side right -padx 10 -pady 10
		pack .tlsdown.f.ok -side right -padx 10 -pady 10

		pack .tlsdown.linuxx86 -side top -anchor w -padx 15
		pack .tlsdown.linuxx86_64 -side top -anchor w -padx 15
		pack .tlsdown.linuxppc -side top -anchor w -padx 15
		pack .tlsdown.linuxsparc -side top -anchor w -padx 15
		pack .tlsdown.netbsdx86 -side top -anchor w -padx 15
		pack .tlsdown.netbsdsparc64 -side top -anchor w -padx 15
		pack .tlsdown.freebsdx86 -side top -anchor w -padx 15
		pack .tlsdown.solaris26 -side top -anchor w -padx 15
		pack .tlsdown.solaris28 -side top -anchor w -padx 15
		pack .tlsdown.mac -side top -anchor w -padx 15
		pack .tlsdown.win32 -side top -anchor w -padx 15
		pack .tlsdown.src -side top -anchor w -padx 15
		pack .tlsdown.nodown -side top -anchor w -padx 15

		pack .tlsdown.f -side top

		bind .tlsdown <Destroy> {
			if {"%W" == ".tlsdown"} {
				::amsn::infoMsg "[trans notls]"
			} 
		}

		catch {grab .tlsdown}
	}

	proc downloadTLS {} {
		global tlsplatform

		if { $tlsplatform == "nodown" } {
			::amsn::infoMsg [trans notls]
			return
		}

		set downloadurl "http://amsn.sourceforge.net/download-tls.php?arch=$tlsplatform"


		if {[ catch {set tok [::http::geturl $downloadurl -command "::autoupdate::downloadTLS2 $downloadurl"]} res ]} {
			::autoupdate::errorDownloadingTLS $res
			catch {::http::cleanup $tok}
		}
	}

	proc downloadTLS2 { downloadurl token } {
		status_log "status: [http::status $token]\n"
		if { [::http::ncode $token] == 302} {


			upvar #0 $token state
			array set meta $state(meta)
			set downloadurl $meta(Location)
			status_log "got referal to $downloadurl"

			set w .tlsprogress

			if {[winfo exists $w]} {
				destroy $w
			}

			toplevel $w
			wm group $w .

			label $w.l -text "[trans downloadingtls $downloadurl]" -font splainf
			pack $w.l -side top -anchor w -padx 10 -pady 10
			pack [::dkfprogress::Progress $w.prbar] -fill x -expand 0 -padx 5 -pady 5 -side top
			label $w.progress -text "[trans receivedbytes 0 ?]" -font splainf
			pack $w.progress -side top -padx 10 -pady 3

			button $w.close -text "[trans cancel]" -command ""
			pack $w.close -side bottom -pady 5 -padx 10

			wm title $w "[trans tlsinstall]"

			::dkfprogress::SetProgress $w.prbar 0

			if {[ catch {set tok [::http::geturl $downloadurl -progress "::autoupdate::downloadTLSProgress $downloadurl" -command "::autoupdate::downloadTLSCompleted $downloadurl"]} res ]} {
				::autoupdate::errorDownloadingTLS $res
				catch {::http::cleanup $tok}
			} else {
				$w.close configure -command "::http::reset $tok"
				wm protocol $w WM_DELETE_WINDOW "::http::reset $tok"
			}
		} else {
			::autoupdate::errorDownloadingTLS "No redirect from $downloadurl"
			catch {::http::cleanup $token}
		}
	}
		

	proc downloadTLSCompleted { downloadurl token } {
		global HOME2 tlsplatform
		status_log "status: [http::status $token]\n"
		if { [::http::status $token] == "reset" } {
			::http::cleanup $token

			destroy .tlsprogress
			return
		}

		if { [::http::status $token] != "ok" || [::http::ncode $token] != 200} {
			::autoupdate::errorDownloadingTLS "Couldn't get $downloadurl"
			return
		}

		set lastslash [expr {[string last "/" $downloadurl]+1}]
		set fname [string range $downloadurl $lastslash end]


		switch $tlsplatform {
			"solaris26" -
			"solaris28" -
			"linuxx86" -
			"linuxx86_64" -
			"linuxppc" -
			"linuxsparc" -
			"netbsdx86" -
			"netbsdsparc64" -
			"freebsdx86" -
			"mac" -
			"win32" {
				if { [catch {
					set file_id [open [file join [::config::getKey receiveddir] $fname] w]
					fconfigure $file_id -translation {binary binary} -encoding binary
					puts -nonewline $file_id [::http::data $token]
					close $file_id

					set olddir [pwd]
					cd [file join $HOME2 plugins]

					if { $tlsplatform == "win32" } {
						exec [file join [::config::getKey receiveddir] $fname] "x" "-o" "-y"
					} else {
						exec gzip -cd [file join [::config::getKey receiveddir] $fname] | tar xvf -
					}
					cd $olddir
					::amsn::infoMsg "[trans tlsinstcompleted]"
				} res ] } {

					::autoupdate::errorDownloadingTLS $res
				}
			}
			"src" {
			if { [catch {
					set file_id [open [file join [::config::getKey receiveddir] $fname] w]
					fconfigure $file_id -translation {binary binary} -encoding binary
					puts -nonewline $file_id [::http::data $token]
					close $file_id
					::amsn::infoMsg "[trans tlsdowncompleted $fname [::config::getKey receiveddir] [file join $HOME2 plugins]]"
				} res ] } {
					::autoupdate::errorDownloadingTLS $res
				}
			}
			default {
				::amsn::infoMsg "[trans tlsdowncompleted $fname [::config::getKey receiveddir] [file join $HOME2 plugins]]"
			}
		}

		destroy .tlsprogress
		::http::cleanup $token
	}

	proc downloadTLSProgress {url token {total 0} {current 0} } {

		if { $total == 0 } {
			::autoupdate::errorDownloadingTLS "Couldn't get $url"
			return
		}
		::dkfprogress::SetProgress .tlsprogress.prbar [expr {$current*100/$total}]
		.tlsprogress.progress configure -text "[trans receivedbytes [::amsn::sizeconvert $current] [::amsn::sizeconvert $total]]"

	}

	proc errorDownloadingTLS { errormsg } {
		::amsn::errorMsg "[trans errortls]: $errormsg"
		catch { destroy .tlsprogress }
	}

	#///////////////////////////////////////////////////////////////////////
	#Download window
	proc amsn_update { new_version } {
		
		set w .downloadwindow
		if {[winfo exists $w]} {
			raise $w
			return
		}
		#Create the window .downloadwindow
		toplevel $w
		wm title $w "Download"
		
		#Create 2 frames
		frame $w.top
		frame $w.bottom
		
		#Add bitmap and text at the top
		label $w.top.bitmap -image [::skin::loadPixmap download]
		label $w.top.text -text "Downloading new amsn version. Please Wait..." -font bigfont
		#Get the download URL
		set amsn_url [::autoupdate::get_download_link $new_version]
		
		#Add button at the bottom
		button $w.bottom.cancel -text "Cancel"
		
		#Pack all the stuff for the top
		pack $w.top.bitmap -pady 5
		pack $w.top.text -pady 10
		
		#Pack the progress bar and cancel button at the bottom
		pack [::dkfprogress::Progress $w.bottom.prbar] -fill x -expand 0 -padx 5 -pady 10
		pack $w.bottom.cancel -pady 5
		
		#Pack the frames
		pack $w.top -side top
		pack $w.bottom -side bottom -fill x
		
		#Start download
		set amsn_tarball [::http::geturl $amsn_url -progress "::autoupdate::amsn_download_progress $amsn_url" -command "::autoupdate::amsn_choose_dir $amsn_url"]
		
		moveinscreen $w 30
	}

	#///////////////////////////////////////////////////////////////////////
	proc update_window {tmp_data} {	
		set w .update
		#If the window was created before
		if {[winfo exists $w]} {
			raise $w
			return
		}
		#Create the update window
		toplevel $w
		wm title $w "[trans newveravailable $tmp_data]"
		set changeloglink "http://amsn.sourceforge.net/wiki/tiki-index.php?page=ChangeLog"
		set homepagelink "http://amsn.sourceforge.net/"
		#Create the frames
		frame $w.top
		frame $w.top.buttons
		frame $w.bottom
		frame $w.bottom.buttons
		
		#Top frame
		label $w.top.bitmap -image [::skin::loadPixmap warning]
		label $w.top.i -text "[trans newveravailable $tmp_data]" -font bigfont
		button $w.top.buttons.changelog -text "Change log" -command "launch_browser $changeloglink"
		button $w.top.buttons.homepage -text "aMSN homepage" -command "launch_browser $homepagelink"
		
		#Bottom frame
		label $w.bottom.bitmap -image [::skin::loadPixmap greyline]
		#label $w.bottom.q -text "Would you like to update aMSN immediatly?" -font bigfont
		#button $w.bottom.buttons.update -text "Update" -command "::autoupdate::amsn_update $tmp_data;destroy $w" -default active
		#button $w.bottom.buttons.cancel -text "Cancel" -command "::autoupdate::dont_ask_before;destroy $w"
		#label $w.bottom.lastbar -image [::skin::loadPixmap greyline]
		#Checkbox to verify if the user want to have an alert again or just in one week
		checkbutton $w.bottom.ignoreoneweek -text "Don't ask update again for one week" -variable "dont_ask_for_one_week" -font sboldf
		
		#Pack all the stuff for the top
		pack $w.top.bitmap -side top -padx 3m -pady 3m
		pack $w.top.i
		pack $w.top.buttons.changelog -side left
		pack $w.top.buttons.homepage -side right
		pack $w.top.buttons -fill x
		pack $w.top -side top -pady 5
		
		#Pack all the stuff for the bottom
		pack $w.bottom.bitmap
		#pack $w.bottom.q
		#pack $w.bottom.buttons.update -side left -padx 5
		#pack $w.bottom.buttons.cancel -side right -padx 5
		pack $w.bottom.buttons
		#pack $w.bottom.lastbar -pady 5
		pack $w.bottom.ignoreoneweek
		pack $w.bottom -side bottom -pady 15
		
		bind $w <<Escape>> "::autoupdate::dont_ask_before;destroy .update"
		bind $w <<Destroy>> "::autoupdate::dont_ask_before;destroy .update"
		wm protocol $w WM_DELETE_WINDOW "::autoupdate::dont_ask_before;destroy .update"
		moveinscreen $w 30
	}

	#Create the download link (change on the differents platforms)
	proc get_download_link {new_version} {
		set new_version [string replace $new_version 1 1 "_"]
		#set new_version [string replace $new_version 1 1 "-"]
		append amsn_url "http://aleron.dl.sourceforge.net/sourceforge/amsn/amsn-" $new_version
		if {![catch {tk windowingsystem} wsystem] && $wsystem == "aqua"} {
			append amsn_url ".dmg"
		} elseif { $::tcl_platform(platform)=="windows" } {
			append amsn_url ".exe"
		} else { 
			append amsn_url ".tar.gz"
		}
		
		return $amsn_url
	}

	#///////////////////////////////////////////////////////////////////////
	proc amsn_download_progress { url token {total 0} {current 0} } {
		set w .downloadwindow
		#Config cancel button to cancel the download
		$w.bottom.cancel configure -command "::http::reset $token"
		bind $w <<Escape>> "::http::reset $token"
		bind $w <<Destroy>> "::http::reset $token"
		wm protocol $w WM_DELETE_WINDOW "::http::reset $token"
		#Check if url is valid
		if { $total == 0 } {
			$w.top.text configure -text "Couldn't get $url"
			$w.bottom.cancel configure -text "Close" -command "destroy $w"
			bind $w <<Escape>> "destroy $w"
			bind $w <<Destroy>> "destroy $w"
			wm protocol $w WM_DELETE_WINDOW "destroy $w"
			return
		}
		#Update progress bar and text bar, use size in KB and MB
		::dkfprogress::SetProgress $w.bottom.prbar [expr {$current*100/$total}]
		$w.top.text configure -text "$url\n[trans receivedbytes [::amsn::sizeconvert $current] [::amsn::sizeconvert $total]]"
	}

	#///////////////////////////////////////////////////////////////////////
	proc amsn_choose_dir { url token } {
		set w .downloadwindow
		#If user cancel the download
		if { [::http::status $token] == "reset" } {
			::http::cleanup $token
			$w.top.text configure -text "Download canceled."
			$w.bottom.cancel configure -text "Close" -command "destroy $w"
			bind $w <<Escape>> "destroy $w"
			bind $w <<Destroy>> "destroy $w"
			wm protocol $w WM_DELETE_WINDOW "destroy $w"
			return
		}
		#If it's impossible to get the URL
		if { [::http::status $token] != "ok" || [::http::ncode $token] != 200 } {
			$w.top.text configure -text "Couldn't get $url"
			$w.bottom.cancel configure -text "Close" -command "destroy $w"
			bind $w <<Escape>> "destroy $w"
			bind $w <<Destroy>> "destroy $w"
			wm protocol $w WM_DELETE_WINDOW "destroy $w"
			return
		}
		#If the download is over, remove cancel button and progress bar
		destroy $w.bottom.prbar
		destroy $w.bottom.cancel
		
		#Get default location for each platform
		set location [::autoupdate::get_default_location]
		set namelocation [lindex $location 0]
		set defaultlocation [lindex $location 1]
		
		$w.top.text configure -text "Save file on $namelocation?"