[Tkabber-dev] r1625 - trunk/tkabber

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Sat Jan 10 15:26:36 MSK 2009


Author: sergei
Date: 2009-01-10 15:26:35 +0300 (Sat, 10 Jan 2009)
New Revision: 1625

Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/plugins.tcl
Log:
	* plugins.tcl: Added preliminary infrastructure for loading/unloading
	  external plugins.


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2008-12-20 13:23:09 UTC (rev 1624)
+++ trunk/tkabber/ChangeLog	2009-01-10 12:26:35 UTC (rev 1625)
@@ -1,3 +1,8 @@
+2009-01-10  Sergei Golovan  <sgolovan at nes.ru>
+
+	* plugins.tcl: Added preliminary infrastructure for loading/unloading
+	  external plugins.
+
 2008-12-20  Sergei Golovan  <sgolovan at nes.ru>
 
 	* msgs/de.msg: Updated German translation (thanks to Roger Sondermann).

Modified: trunk/tkabber/plugins.tcl
===================================================================
--- trunk/tkabber/plugins.tcl	2008-12-20 13:23:09 UTC (rev 1624)
+++ trunk/tkabber/plugins.tcl	2009-01-10 12:26:35 UTC (rev 1625)
@@ -23,13 +23,91 @@
 
 proc plugins::load_dir {plugins_dir} {
     foreach dir [lsort [glob -nocomplain -type {d l} [file join $plugins_dir *]]] {
-	set file [file join $dir [file tail $dir].tcl]
-	if {[file exists $file]} {
-	    debugmsg plugins "Loading plugin from $file"
-	    source $file
+	set preload_file [file join $dir preload.tcl]
+	if {[file exists $preload_file]} {
+	    debugmsg plugins "Loading plugin preload info from $preload_file"
+	    source $preload_file
 	} else {
-	    debugmsg plugins "Can't load plugin from $file"
+	    set file [file join $dir [file tail $dir].tcl]
+	    if {[file exists $file]} {
+		debugmsg plugins "Loading plugin from $file"
+		source $file
+	    } else {
+		debugmsg plugins "Can't load plugin from directory $dir"
+	    }
 	}
     }
 }
 
+proc plugins::register {name args} {
+    foreach {key val} $args {
+	switch -- $key {
+	    -namespace -
+	    -source -
+	    -description -
+	    -loadcommand -
+	    -unloadcommand {
+		set opts($key) $val
+	    }
+	    default {
+		return -code error [::msgcat::mc "Invalid option \"%s\"" $key]
+	    }
+	}
+    }
+
+    foreach key {-namespace -source -description -loadcommand -unloadcommand} {
+	if {![info exists opts($key)]} {
+	    return -code error [::msgcat::mc "Missing option \"%s\"" $key]
+	}
+    }
+
+    custom::defgroup {External Plugins} \
+		     [::msgcat::mc "External plugins options."] \
+		     -group Tkabber
+
+    custom::defvar loaded($name) 0 \
+		   $opts(-description) \
+		   -type boolean \
+		   -group {External Plugins} \
+		   -command [namespace code [list load_or_unload $name \
+								 $opts(-namespace) \
+								 $opts(-source) \
+								 $opts(-loadcommand) \
+								 $opts(-unloadcommand)]]
+}
+
+proc plugins::load_or_unload {name ns source load unload args} {
+    variable loaded
+
+    # Checking if a plugin is loaded by querying a list of commands in
+    # a corresponding namespace.
+
+    set commands [info commands ${ns}::*]
+
+    if {$loaded($name)} {
+	if {[llength $commands] == 0} {
+	    # Plugin isn't loaded, so loading it
+
+	    debugmsg plugins "Loading external plugin $name"
+
+	    source $source
+	    eval $load
+	} else {
+	    debugmsg plugins "External plugin $name is already loaded"
+	}
+    } else {
+	if {[llength $commands] > 0} {
+	    # Plugin is loaded, so unloading it
+
+	    debugmsg plugins "Unoading external plugin $name"
+
+	    eval $unload
+	    foreach cmd $commands {
+		rename $cmd ""
+	    }
+	} else {
+	    debugmsg plugins "External plugin $name is already unloaded"
+	}
+    }
+}
+



More information about the Tkabber-dev mailing list