plugins.tcl

Linux下的MSN聊天程序源码

######################################################
##                                                 ##
##   aMSN Plugins System - 0.96-Release Version    ##
##                                                 ##
#####################################################

proc plugins_log {plugin msg} {
#return
	if {[info procs "::pluginslog::plugins_log"] == "::pluginslog::plugins_log"} {
		::pluginslog::plugins_log $plugin $msg
	} else {
		status_log "Plugins System: $plugin: $msg"
	}
}

namespace eval ::plugins {
	namespace export PostEvent

	if { $initialize_amsn == 1 } {
		# Name of the current selected plugin
		set selection "" 
		# The path to the plugin selector window
		variable w                      
		# Info about plugins
		array set plugins [list]
		# List of current plugins
		variable loadedplugins [list]
		# Holds the configuration of unloaded plugins
		array set config [list]

		# tmp variable to be used by the XML parser
		variable cur_plugin
	}


	###############################################################
	# PostEvent (event, argarray)
	#
	# This proc can be put anywhere within amsn to call a event.
	#
	# Arguments
	# event - the event that is being called
	# argarray - name of the array holding the arguments
	#
	# Return
	# none
	#
	proc PostEvent { event var } {
		variable pluginsevents 

		plugins_log core "Calling event $event with variable $var\n"
	
		if { [info exists pluginsevents(${event}) ] } { # do we have any procs for the event?
			foreach cmd $pluginsevents(${event}) { # let's call all of them
				plugins_log core "Executing $cmd\n"
				catch { eval $cmd $event $var } res ; # call
				plugins_log core "Return $res from event handler $cmd\n"
			}
		}
	}


	###############################################################
	# RegisterPlugin (plugin)
	#
	# Dummy proc, not needed any more. Is replaced by "loadedplugins"
	#
	# Arguments
	# plugin - name of the plugin
	#
	# Return
	# 0 - plugin already registered
	# 1 - first time plugin registered
	#    
	proc RegisterPlugin { plugin } {
	    
	}
    

	###############################################################
	# RegisterEvent (plugin, event, cmd)
	#
	# This proc registeres a command to a event
	#
	# Arguments
	# plugin - name of the plugin that the command belongs to
	# event - the event to register for
	# cmd - command to register
	#
	# Return
	# -1 - error registering event
	# 1 - all good!
	#      
	proc RegisterEvent { plugin event cmd } {
		variable pluginsevents

		plugins_log core "Plugin Systems: RegisterEvent called with $plugin $event $cmd\n"

	    #check if the plugin is loaded, if not don't register the event and return 0 for false
		if { [lsearch $::plugins::loadedplugins "$plugin"] == -1 } { 
			plugins_log core "Registering an event for an unloaded plugin...\n"
			return -1; # Bye Bye
		}

		#get the namespace of the plugin via it's data in loadedplugins
		set namespace [getInfo $plugin plugin_namespace]

		#Check if the given proc is already registered to the given event
		if {[array names pluginsevents $event] != ""} { 
			if {[lsearch $pluginsevents(${event}) "\:\:$namespace\:\:$cmd"] != -1 } { # Event already registered?
				plugins_log core "Trying to register a event twice"
				return -1; # Bye Bye
			}
		}

		plugins_log core "Binding $event to $cmd\n"
		lappend pluginsevents(${event}) "\:\:$namespace\:\:$cmd"; # Add the command to the list

		return 1
	}


	###############################################################
	# UnRegisterEvent (plugin, event, cmd)
	# 
	# Unregisters a event from a plugin
	#
	# Arguments
	# plugin - the plugin to unregister for
	# event - the event to unregister from
	# cmd - the command to unregister
	#
	# Return
	# -1 - on error
	# 1 - on success
	#
	proc UnRegisterEvent { plugin event cmd } {
		variable pluginsevents

		if { [lsearch $::plugins::loadedplugins $plugin] == -1 } {
			return -1
		}
		
		set namespace [getInfo $plugin plugin_namespace]

		# do stuff only if there is a such a command for the event
		#TODO: do we need to check if such a event exists?
		set pos [lsearch $pluginsevents(${event}) "\:\:$namespace\:\:$cmd"]
		if {$pos != -1} {
			# the long erase way to remove a item from the list
			set pluginsevents(${event}) [lreplace $pluginsevents(${event}) $pos $pos]
			plugins_log core "Event \:\:$namespace\:\:$cmd on $event unregistered ...\n"
		} else {
			plugins_log core "Trying to unregister a unknown event...\n"
		}
		return 1
	}
    
	###############################################################
	# UnRegisterEvents (plugin)
	#
	# Unregistres all the events for a plugin. It is used when unloading a plugin
	#
	# Arguments
	# plugin - the plugin to unregister for
	#
	# Return
	# none
	#
	proc UnRegisterEvents { plugin } {
		# event list
		variable pluginsevents
		if { [lsearch $::plugins::loadedplugins $plugin] == -1 } {
			return
		}
		set namespace [getInfo $plugin plugin_namespace]

		# go through each event
       		foreach {event} [array names pluginsevents] {
			# While there is a command in the list that belongs to the 
			# plugins namespace, give it's index to x and delete it
			while { [set x [lsearch -regexp $pluginsevents(${event}) "\:\:$namespace\:\:*" ]] != -1 } {
				plugins_log core "UnRegistering command $x from $pluginsevents(${event})...\n"
				# the long remove item procedure
				# TODO: move this into a proc?
				set pluginsevents(${event}) [lreplace $pluginsevents(${event}) $x $x]
			}
		}
	}

	###############################################################
        # calledFrom ()
        #
        # Finds out if a proc was called by a plugin.
	#
        # Arguments
        # none
        #
        # Return
        # -1 - not called by a plugin
	# $pluginnamespace - the namespace of the plugin calling the proc
        #

	proc calledFrom {} {
	    set namespace [string trimleft "[uplevel 2 namespace current]" "::"]
	    
	    if {[::plugins::namespaceExists $namespace] == 1} {
		return $namespace
	    } else {
		#this namespace dosn't belong to any plugin
		return -1
	    }
	}

	###############################################################
        # namespaceExists (namespace)
        #
	# finds out if a namespace belongs to a plugin
        #
        # Arguments
        # namespace - namespace to check for (without ::)
        #
        # Return
	# -1 - nope
	# 1 - yup
        #

	proc namespaceExists {namespace} {
		variable plugins
		# go through each namespace
       		foreach {current} [array names plugins *_plugin_namespace] {
		    if { $plugins(${current}) == $namespace } {
			return 1
		    }
		}
		return -1
	}


	###############################################################
	# getInfo (plugin,param)
	#
	# Checks the plugins array and return the parameter in the 
	# plugininfo.xml file that is symbolized by param
	#
	# Arguments
	# plugin - name of plugin
	# param - name of parameter to check for
	#
	# Return
	# string - the value of the parameter, empty if not found
	#
	
	proc getInfo {plugin param} {
		variable plugins
		plugins_log core "Getting $plugin and $param"
		plugins_log core [array names ::plugins::plugins ${plugin}_${param}]
		if {[array names ::plugins::plugins ${plugin}_${param}] != ""} {
			return $plugins(${plugin}_${param})
		}
		return ""
	}

	proc getVarInfo {plugin param} {
		return "::plugins::plugins(${plugin}_${param})"
	}

	###############################################################
        # getPlugins ()
        #
	# Returns a list of existing plugins
        #
	# Arguments
	# none
	#
	# Return
	# list of plugins
	#
	proc getPlugins {} {
		set plugins [list]
		foreach {key plugin} [array get ::plugins::plugins *_name] {
			lappend plugins $plugin
		}
		return $plugins
	}

	###############################################################
        # updatePluginsArray ()
        #
        # Updates the plugins array which holds info about plugins
	# by searching possible plugin directories
        #
        # Arguments
        # none
        #
        # Return
        # none
        #
	
	proc updatePluginsArray { } {

	       	global HOME HOME2

		#clear the current array
		array set ::plugins::plugins [list]

		# make a list of all the possible places to search
		#TODO: Allow user to choose where to search
		set search_path [list] 
		lappend search_path [file join [set ::program_dir] plugins]
		lappend search_path [file join $HOME plugins]
		if { $HOME != $HOME2} {
			lappend search_path [file join $HOME2 plugins]
		}
		lappend search_path [file join $HOME2 amsn-extras plugins]
	    
		# loop through each directory to search
		foreach dir $search_path {
			# for each file names plugininfo.xml that is in any directory, do stuff
			# -nocomplain is used to shut errors up if no plugins found
			foreach file [glob -nocomplain -directory $dir */plugininfo.xml] {
				plugins_log core "Found plugin files in $file\n"
				::plugins::LoadInfo $file
				::plugins::LoadInfoAutoupdate $file
			}
		}

       	}


	###############################################################
	# LoadInfo ()
	#
	# Loads the XML information file of each plugin and parses it, registering
	# each new plugin with proc ::plugins::XMLInfo
	#
	# Arguments
	# path - the path to the pluginsinfo.xml containing the information in XML format
	#
	# Return
	# list containng the information
	#
	proc LoadInfo { path } {

		set fd [file join [file dirname $path] plugininfo.xml]

		if { [file readable $fd] } {
			
			if { [catch {
				set plugin_info [sxml::init $fd]
				sxml::register_routine $plugin_info "plugin" "::plugins::XMLInfo"
				sxml::parse $plugin_info
				sxml::end $plugin_info
				plugins_log core "PLUGINS INFO READ\n"
			} res] } {
				msg_box "ERROR: PLUGIN HAS MALFORMED XML PLUGININFO ($path)"
				return 0
			}
		}

		return 1

	}

	###############################################################
	# XMLInfo (cstack, cdata, saved_data, cattr saved_attr, args)
	#
	# Raises the information parsed by the sxml component and appends
	# each new plugin to $::plugins::plugins array
	#
	# Arguments
	# supplied by the sxml component (its only executor)
	#
	# Return
	# none
	#

	proc XMLInfo { cstack cdata saved_data cattr saved_attr args } {

		variable plugins
		upvar $saved_data sdata
		#get the path from 2 levels up (::plugins::LoadInfo -> ::sxml::parse -> thisproc)
		#dir is used to set the full path of the file
		upvar 2 path dir

		set name $sdata(${cstack}:name)
		set cur_plugin $name
		set author $sdata(${cstack}:author)

		#Now plugins have an other field in plugininfo.xml in which the description can be translated.
		#It should be used as
		#<description_fr>the description in french</description_fr>
		#The defaut description must be written in english
		#The file should be encoded in utf-8
		set langcode [::config::getGlobalKey language]
		if { ($langcode != "en") && [info exists sdata(${cstack}:description_${langcode}) ] } {
			set desc $sdata(${cstack}:description_${langcode})
		} else {
			set desc $sdata(${cstack}:description)
		}

		set amsn_version $sdata(${cstack}:amsn_version)
		set plugin_version $sdata(${cstack}:plugin_version)
		set plugin_file $sdata(${cstack}:plugin_file)
		set plugin_namespace $sdata(${cstack}:plugin_namespace)
		set init $sdata(${cstack}:init_procedure)

		if { ![info exists sdata(${cstack}:deinit_procedure)] } {
			set deinit ""
		} else {
			set deinit $sdata(${cstack}:deinit_procedure)
		}
		
		set plugins(${name}_name) $name
		set plugins(${name}_author) $author
		set plugins(${name}_description) $desc
		set plugins(${name}_amsn_version) $amsn_version
		set plugins(${name}_plugin_version) $plugin_version
		#dir is the path to pluginsinfo.xml, so we need to use [file dirname] to get the actual dir path
		set plugins(${name}_plugin_file) [file join [file dirname $dir] $plugin_file]
		set plugins(${name}_plugin_dir) [file dirname $dir]
		set plugins(${name}_plugin_namespace) $plugin_namespace
		set plugins(${name}_init_proc) $init
		set plugins(${name}_deinit_proc) $deinit

		return 0
	}


	###############################################################
	# PluginGui ()
	#
	# The Plugin Selector, allows users to load, unload, and configure plugins
	#
	# Arguments
	# none
	#
	# Return
	# none
	#
	proc PluginGui { } {
		# array that will hold information of plugins
		variable plugins
		# the variable that holds the path to the selection window
		variable w
		# list of all the loaded plugins
		variable loadedplugins
		# array that holds info about currently selected plugin
		variable selection
		# the path to the frame where are displayed pieces of information for a plugin
		variable mF

		# clear the selection
		set selection ""
		# set the window path
		set w .plugin_selector

		# if the window already exists, focus it, otherwise create it
		if {[winfo exists $w]} {
			raise $w
			return
		}

		# update the information and list of plugins
		::plugins::updatePluginsArray
		# create window and give it it's title
		toplevel $w
		wm title $w [trans pluginselector]
		wm geometry $w 500x400
		# create widgets
		# listbox with all the plugins
		listbox $w.plugin_list -background "white" -height 15 -yscrollcommand "$w.ys set" -relief flat -highlightthickness 0
		scrollbar $w.ys -command "$w.plugin_list yview"

		#Scrollableframe that will contain pieces of information about a plugin
		ScrolledWindow $w.sw 
		ScrollableFrame $w.sw.sf -areaheight 0 -areawidth 0 
		$w.sw setwidget $w.sw.sf
		set mF [$w.sw.sf getframe]	
			
		# holds the plugins info like name and description
		label $mF.name_title -text [trans name] -font sboldf
		label $mF.name  -wraplength 280 
		label $mF.version_title -text [trans version] -font sboldf
		label $mF.version
		label $mF.author_title -text [trans author] -font sboldf
		label $mF.author  -wraplength 280 
		label $mF.desc_title -text [trans description] -font sboldf
		# TODO make the -wraplength fit the label's width
		label $mF.desc -wraplength 280 -justify left -anchor w
		# holds the 'command center' buttons
		label $w.getmore -text "[trans getmoreplugins]" -fg #0000FF

		button $w.load -text "[trans load]" -command "::plugins::GUI_Load" -state disabled
		button $w.config -text "[trans configure]" -command "::plugins::GUI_Config" ;#-state disabled
		button $w.close -text [trans close] -command "::plugins::GUI_Close"
 
		#loop through all the plugins and add them to the list
		foreach {plugin} [array names ::plugins::plugins *_name] {
		    set name $plugins(${plugin})
		    # add the plugin name to the list at counterid position
		    $w.plugin_list insert end $name
		    # if the plugin is loaded, color it one color. otherwise use other colors
		    #TODO: Why not use skins?
		    if {[lsearch "$loadedplugins" $plugins(${name}_name)] != -1} {
			$w.plugin_list itemconfigure end -background #DDF3FE
		    } else {
			$w.plugin_list itemconfigure end -background #FFFFFF
		    }
		}
		if {[$w.plugin_list size] > "15"} {
			$w.plugin_list configure -height [$w.plugin_list size]
		}
		#do the bindings
		bind $w.plugin_list <<ListboxSelect>> "::plugins::GUI_NewSel"
		bind $w <<Escape>> "::plugins::GUI_Close"

		pack $w.plugin_list -fill both -side left
		pack $w.ys -fill both -side left
		pack $mF.name_title -padx 5 -anchor w
		pack $mF.name -padx 5 -anchor w
		pack $mF.version_title -padx 5 -anchor w
		pack $mF.version -padx 5 -anchor w 
		pack $mF.author_title -padx 5 -anchor w
		pack $mF.author -padx 5 -anchor w
		pack $mF.desc_title -padx 5 -anchor w
		pack $mF.desc -anchor nw -expand true -fill x -padx 5
		pack $w.sw -anchor w -side top -expand true -fill both
		pack $w.getmore -side top -anchor e -padx 5
		bind $w.getmore <Enter> "$w.getmore configure -font sunderf"
		bind $w.getmore <Leave> "$w.getmore configure -font splainf"
		set lang [::config::getGlobalKey language]
		bind $w.getmore <ButtonRelease> "launch_browser $::weburl/plugins.php?lang=$lang"

		pack $w.close $w.config $w.load -padx 5 -pady 5 -side right -anchor se


		moveinscreen $w 30
		return

	}

    
	###############################################################
	# GUI_NewSel ()
	#
	# This handles new selections in the listbox aka updates the selection array
	#
	# Arguments
	# none
	#
	# Return
	# none
	#
	proc GUI_NewSel { } {
		# window path
		variable w
		# selection array
		variable selection
		# plugins' info
		variable plugins