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