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