1# interp.tcl 2# Some utility commands for creation of delegation procedures 3# (Delegation of commands to a remote interpreter via a comm 4# handle). 5# 6# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> 7# 8# See the file "license.terms" for information on usage and redistribution 9# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10# 11# RCS: @(#) $Id: deleg_proc.tcl,v 1.2 2006/09/01 19:58:21 andreas_kupries Exp $ 12 13package require Tcl 8.3 14 15# ### ### ### ######### ######### ######### 16## Requisites 17 18namespace eval ::interp::delegate {} 19 20# ### ### ### ######### ######### ######### 21## Public API 22 23proc ::interp::delegate::proc {args} { 24 # syntax: ?-async? name arguments comm id 25 26 set async 0 27 while {[string match -* [set opt [lindex $args 0]]]} { 28 switch -exact -- $opt { 29 -async { 30 set async 1 31 set args [lrange $args 1 end] 32 } 33 default { 34 return -code error "unknown option \"$opt\", expected -async" 35 } 36 } 37 } 38 if {[llength $args] != 4} { 39 return -code error "wrong # args" 40 } 41 foreach {name arguments comm rid} $args break 42 set base [namespace tail $name] 43 44 if {![llength $arguments]} { 45 set delegate "[list $base]" 46 } elseif {[string equal args [lindex $arguments end]]} { 47 if {[llength $arguments] == 1} { 48 set delegate "\[linsert \$args 0 [list $base]\]" 49 } else { 50 set delegate "\[linsert \$args 0 [list $base] \$[join [lrange $arguments 0 end-1] " \$"]\]" 51 } 52 } else { 53 set delegate "\[list [list $base] \$[join $arguments " \$"]\]" 54 } 55 56 set body "" 57 append body [list $comm] " " "send " 58 if {$async} {append body "-async "} 59 append body [list $rid] " " $delegate 60 61 uplevel 1 [list ::proc $name $arguments $body] 62 return $name 63} 64 65# ### ### ### ######### ######### ######### 66## Ready to go 67 68package provide interp::delegate::proc 0.2 69