[Tkabber-dev] r1773 - in trunk/tkabber: . plugins/general

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Wed Apr 1 19:41:51 MSD 2009


Author: sergei
Date: 2009-04-01 19:41:51 +0400 (Wed, 01 Apr 2009)
New Revision: 1773

Added:
   trunk/tkabber/plugins/general/comm.tcl
   trunk/tkabber/tkabber-remote.tcl
Modified:
   trunk/tkabber/ChangeLog
Log:
	* plugins/general/comm.tcl, tkabber-remote.tcl: Added proof-of-concept
	  plugin and client for remote controlling Tkabber via comm package
	  from Tcllib.


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2009-04-01 15:33:17 UTC (rev 1772)
+++ trunk/tkabber/ChangeLog	2009-04-01 15:41:51 UTC (rev 1773)
@@ -1,3 +1,9 @@
+2009-04-01  Sergei Golovan  <sgolovan at nes.ru>
+
+	* plugins/general/comm.tcl, tkabber-remote.tcl: Added proof-of-concept
+	  plugin and client for remote controlling Tkabber via comm package
+	  from Tcllib.
+
 2009-03-31  Sergei Golovan  <sgolovan at nes.ru>
 
 	* filetransfer.tcl: Added unregistering filetransfer trantports.

Added: trunk/tkabber/plugins/general/comm.tcl
===================================================================
--- trunk/tkabber/plugins/general/comm.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/general/comm.tcl	2009-04-01 15:41:51 UTC (rev 1773)
@@ -0,0 +1,118 @@
+# comm.tcl --
+#
+#	Remote control via comm module.
+#
+# $Id$
+
+package require comm
+
+namespace eval comm {
+    variable cookie [rand 1000000000][rand 1000000000][rand 1000000000]
+
+    variable cookieFile [file join $::configdir comm.[pid]]
+
+    file delete -force -- $cookieFile
+    set fd [open $cookieFile w]
+    puts $fd [list [::comm::comm self] $cookie]
+    close $fd
+    unset fd
+    catch {file attributes $cookieFile -permissions 0600}
+
+    hook::add quit_hook [namespace current]::cleanup
+
+    ::comm::comm hook incoming "[namespace current]::checkpass \$fid"
+
+    rename ::comm::commIncoming ::comm::commIncoming:orig
+
+    proc ::comm::commIncoming {args} {
+	if {![catch {eval ::comm::commIncoming:orig $args} res]} {
+	    return $res
+	} else {
+	    return
+	}
+    }
+}
+
+proc comm::cleanup {} {
+    variable cookieFile
+
+    file delete -force -- $cookieFile
+}
+
+proc comm::checkpass {fid} {
+    variable wait
+    variable cookie
+
+    set blocking [fconfigure $fid -blocking]
+    fconfigure $fid -blocking 0
+    fileevent $fid readable [namespace code [list getpass $fid]]
+
+    after 2000 [list set [namespace current]::wait($fid) ""]
+
+    vwait [namespace current]::wait($fid)
+    set ans $wait($fid)
+    unset wait($fid)
+
+    fconfigure $fid -blocking $blocking
+
+    if {$ans != $cookie} {
+	return -code error "Incorrect cookie"
+    }
+}
+
+proc comm::getpass {fid} {
+    variable wait
+
+    if {[gets $fid line] >= 0} {
+	set wait($fid) $line
+    }
+}
+
+proc comm::register_command {command proc arguments} {
+    variable commands
+
+    set commands($command) [list $proc $arguments]
+}
+
+proc comm::unregister_command {command} {
+    variable commands
+
+    catch {unset commands($command)}
+}
+
+proc comm::eval_command {command args} {
+    variable commands
+
+    if {![info exists commands($command)]} {
+	return -code error [format "Command %s not found" $command]
+    } else {
+	eval [lindex $commands($command) 0] $args
+    }
+}
+
+proc comm::list_commands {} {
+    variable commands
+
+    set res {}
+    foreach command [lsort -dictionary [array names commands]] {
+	lappend res "$command [lindex $commands($command) 1]"
+    }
+
+    return [join $res \n]
+}
+
+comm::register_command list-commands [namespace current]::comm::list_commands ""
+
+proc comm::set_status {status {text \u0000}} {
+    global userstatus
+    global textstatus
+
+    if {$text != "\u0000"} {
+	set textstatus $text
+    }
+
+    set userstatus $status
+}
+
+comm::register_command set-status [namespace current]::comm::set_status "status ?textstatus?"
+


Property changes on: trunk/tkabber/plugins/general/comm.tcl
___________________________________________________________________
Added: svn:keywords
   + Author Date Id Revision
Added: svn:eol-style
   + native

Added: trunk/tkabber/tkabber-remote.tcl
===================================================================
--- trunk/tkabber/tkabber-remote.tcl	                        (rev 0)
+++ trunk/tkabber/tkabber-remote.tcl	2009-04-01 15:41:51 UTC (rev 1773)
@@ -0,0 +1,70 @@
+#!/bin/sh
+# the next line restarts using the correct interpreter \
+exec tclsh "$0" "$@"
+
+# $Id$
+
+package require cmdline
+package require comm
+
+set options {
+    {user.arg   ""	"Control Tkabber run by a specified user, default is the current user"}
+    {pid.arg	0	"Control Tkabber with a specified pid, default is all PIDs"}
+    {eval.secret	"Evaluate arguments as a script"}
+    {command.secret	"Evaluate arguments as a command"}
+}
+
+set usage ":\ntkabber-remote \[options\] -eval script \[script\]\
+...\ntkabber-remote \[options\] -command command \[arg\]\
+...\noptions:"
+
+if {[catch {
+	 array set params [::cmdline::getoptions argv $options $usage]
+     } msg]} {
+    puts stderr $msg
+    exit 1
+}
+
+switch -- [llength $argv] {
+    0 {
+	puts stderr [::cmdline::usage $options $usage]
+	exit 1
+    }
+    default {}
+}
+
+if {$params(eval) + $params(command) != 1} {
+    puts stderr [::cmdline::usage $options $usage]
+    exit 1
+}
+
+# TODO
+set configdir [file join ~$params(user) .tkabber]
+
+if {$params(pid) != 0} {
+    set files [list [file join $configdir comm.$params(pid)]]
+} else {
+    set files [glob -directory $configdir comm.*]
+}
+
+::comm::comm hook connected {
+    global cookie
+
+    puts $fid $cookie
+}
+
+foreach file $files {
+    set fd [open $file]
+    set id_cookie [read $fd]
+    close $fd
+
+    set id [lindex $id_cookie 0]
+    set cookie [lindex $id_cookie 1]
+
+    if {$params(eval)} {
+	puts [eval [list ::comm::comm send $id] $argv]
+    } else {
+	puts [eval [list ::comm::comm send $id] ::plugins::comm::eval_command $argv]
+    }
+}
+


Property changes on: trunk/tkabber/tkabber-remote.tcl
___________________________________________________________________
Added: svn:executable
   + *
Added: svn:keywords
   + Author Date Id Revision
Added: svn:eol-style
   + native



More information about the Tkabber-dev mailing list