critcl::config language c++Re version: see changelog at [1] -jcw
But what's the point? Since Critcl is at its best coding tiny bits of what inventor JCW calls "grease", what's the advantage of C++ over C? A concrete example will probably be instructive ...
KBK Perhaps the point is that many applications, especially on Windows, export APIs that are accessible only from C++? if you're using Critcl to build a Tcl interface to one of them, you'll need something like Bill's patch.Another use is to glue to existing libraries which have a C++ API -jcw
How does this work? Are there any examples? When i insert the above code my library will not build complains about ns_XX_Init not being found(where XX is the name of the namespace) tgruben@flightlock.com24apr03 jcw - Ah, thanks for pointing this out. Turns out that you also need to add "critcl::clibraries -lstdc++". Here's an example (output is "123"):
package require critcl
critcl::config language c++
critcl::clibraries -lstdc++
critcl::ccode {
class A {
int value;
public:
A() : value (123) {}
operator int() const { return value; }
};
}
critcl::cproc tryplus {} int {
A var;
return var;
}
puts [tryplus]13jun03 wgm - with some additional Tcl glue it's possible to easily build a direct interface to a C++ class. The Tcl glue (using sections of code out of "critcl" and beginners Tcl) is:
package require critcl
proc processargs {typesArray names cnames} {
upvar $typesArray types
set body ""
foreach x $names c $cnames {
set t $types($x)
switch -- $t {
int - long - float - double - char* - Tcl_Obj* {
append body " $t $c;\n"
}
default {
append body " void* $c;\n"
}
}
}
set n 1
foreach x $names c $cnames {
set t $types($x)
incr n
switch -- $t {
int {
append body " if (Tcl_GetIntFromObj(ip, objv\[$n], &$c) != TCL_OK)\n"
append body " return TCL_ERROR;\n"
}
long {
append body " if (Tcl_GetLongFromObj(ip, objv\[$n], &$c) != TCL_OK)\n"
append body " return TCL_ERROR;\n"
}
float {
append body " \{ double tmp;\n"
append body " if (Tcl_GetDoubleFromObj(ip, objv\[$n], &tmp) != TCL_OK)\n"
append body " return TCL_ERROR;\n"
append body " $c = (float) tmp;\n"
append body " \}\n"
}
double {
append body " if (Tcl_GetDoubleFromObj(ip, objv\[$n], &$c) != TCL_OK)\n"
append body " return TCL_ERROR;\n"
}
char* {
append body " $c = Tcl_GetString(objv\[$n]);\n"
}
default {
append body " $c = objv\[$n];\n"
}
}
}
return $body
}
proc c++command {tclname class constructors methods} {
#
# Build the body of the function to define a new tcl command for the C++ class
set helpline {}
set classptr ptr_$tclname
set comproc " $class* $classptr;\n"
append comproc " switch (objc) \{\n"
foreach adefs $constructors {
array set types {}
set names {}
set cargs {}
set cnames {}
foreach {t n} $adefs {
set types($n) $t
lappend names $n
lappend cnames _$n
lappend cargs "$t $n"
}
lappend helpline "$tclname pathName [join $names { }]"
set nargs [llength $names]
set ncargs [expr $nargs+2]
append comproc " case $ncargs: \{\n"
if {$nargs == 0} {
append comproc " $classptr = new $class\();\n"
} else {
append comproc [processargs types $names $cnames]
append comproc " $classptr = new $class\([join $cnames {, }]);\n"
}
append comproc " break;\n"
append comproc " \}\n"
}
append comproc " default: \{\n"
append comproc " Tcl_SetResult(ip, \"wrong # args: should be either [join $helpline { or }]\",TCL_STATIC);\n"
append comproc " return TCL_ERROR;\n"
append comproc " \}\n"
append comproc " \}\n"
append comproc " if ( $classptr == NULL ) \{\n"
append comproc " Tcl_SetResult(ip, \"Not enough memory to allocate a new $tclname\", TCL_STATIC);\n"
append comproc " return TCL_ERROR;\n"
append comproc " \}\n"
append comproc " Tcl_CreateObjCommand(ip, Tcl_GetString(objv\[1]), cmdproc_$tclname, (ClientData) $classptr, delproc_$tclname);\n"
append comproc " return TCL_OK;\n"
#
# Build the body of the c function called when the object is deleted
#
set delproc "void delproc_$tclname\(ClientData cd) \{\n"
append delproc " if (cd != NULL)\n"
append delproc " delete ($class*) cd;\n"
append delproc "\}\n"
#
# Build the body of the function that processes the tcl commands for the class
#
set cmdproc "int cmdproc_$tclname\(ClientData cd, Tcl_Interp* ip, int objc, Tcl_Obj *CONST objv\[]) \{\n"
append cmdproc " int index;\n"
append cmdproc " $class* $classptr = ($class*) cd;\n"
set rtypes {}
set tnames {}
set mnames {}
set adefs {}
foreach method $methods {
foreach {rt n a} $method {
lappend rtypes $rt
lappend tnames [lindex [split $n | ] 0]
set tmp [lindex [split $n | ] 1]
if { $tmp == ""} {
lappend mnames [lindex [split $n | ] 0]
} else {
lappend mnames [lindex [split $n | ] 1]
}
lappend adefs $a
}
}
append cmdproc " const char* cmds\[]=\{\"[join $tnames {","}]\",NULL\};\n"
append cmdproc " if (objc<2) \{\n"
append cmdproc " Tcl_WrongNumArgs(ip, 1, objv, \"expecting pathName option\");\n"
append cmdproc " return TCL_ERROR;\n"
append cmdproc " \}\n\n"
append cmdproc " if (Tcl_GetIndexFromObj(ip, objv\[1], cmds, \"option\", TCL_EXACT, &index) != TCL_OK)\n"
append cmdproc " return TCL_ERROR;\n"
append cmdproc " switch (index) \{\n"
set ndx 0
foreach rtype $rtypes tname $tnames mname $mnames adef $adefs {
array set types {}
set names {}
set cargs {}
set cnames {}
switch -- $rtype {
ok { set rtype2 "int" }
string -
dstring -
vstring { set rtype2 "char*" }
default { set rtype2 $rtype }
}
foreach {t n} $adef {
set types($n) $t
lappend names $n
lappend cnames _$n
lappend cargs "$t $n"
}
set helpline "$tname [join $names { }]"
set nargs [llength $names]
set ncargs [expr $nargs+2]
append cmdproc " case $ndx: \{\n"
append cmdproc " if (objc==$ncargs) \{\n"
append cmdproc [processargs types $names $cnames]
append cmdproc " "
if {$rtype != "void"} {
append cmdproc "$rtype2 rv = "
}
append cmdproc "$classptr->$mname\([join $cnames {, }]);\n"
append cmdproc " "
switch -- $rtype {
void { }
ok { append cmdproc "return rv;" }
int { append cmdproc "Tcl_SetIntObj(Tcl_GetObjResult(ip), rv);" }
long { append cmdproc " Tcl_SetLongObj(Tcl_GetObjResult(ip), rv);" }
float -
double { append cmdproc "Tcl_SetDoubleObj(Tcl_GetObjResult(ip), rv);" }
char* { append cmdproc "Tcl_SetResult(ip, rv, TCL_STATIC);" }
string -
dstring { append cmdproc "Tcl_SetResult(ip, rv, TCL_DYNAMIC);" }
vstring { append cmdproc "Tcl_SetResult(ip, rv, TCL_VOLATILE);" }
default { append cmdproc "Tcl_SetObjResult(ip, rv); Tcl_DecrRefCount(rv);" }
}
append cmdproc "\n"
append cmdproc " "
if {$rtype != "ok"} { append cmdproc "return TCL_OK;\n" }
append cmdproc " \} else \{\n"
append cmdproc " Tcl_WrongNumArgs(ip, 1, objv, \"$helpline\");\n"
append cmdproc " return TCL_ERROR;\n"
append cmdproc " \}\n"
append cmdproc " \}\n"
incr ndx
}
append cmdproc " \}\n\}\n"
critcl::ccode $delproc
critcl::ccode $cmdproc
critcl::ccommand $tclname {dummy ip objc objv} $comproc
}Then a C++ class like the one defined below: critcl::config language c++
critcl::clibraries -lstdc++
critcl::ccode {
class Counter {
public:
Counter(int startValue=0);
Counter operator++();
void set( int newValue);
void reset();
int value() const;
private:
int count;
int resetValue;
};
Counter::Counter(int startValue) : count(startValue), resetValue(startValue) {}
Counter Counter::operator++() {
count++;
}
void Counter::set(int newValue) {
count=newValue;
}
void Counter::reset() {
count=resetValue;
}
int Counter::value() const {
return count;
}
}Can have a Tcl interface generated by using the Tcl glue proc "c++command": c++command counter Counter {
{}
{int start_value}
} {
{void set {int new_value}}
{void reset {}}
{void incr|operator++ {}}
{int value {}}
}The arguments to "c++command" are:- the name of the Tcl command to create instances of the C++ class.
- the C++ class name.
- a list describing the arguments of the C++ constructors to be included in the interface.
- a list describing the C++ methods to be included in the Tcl interface. Note that "|" can be used map a different Tcl name for the C++ method and "void" is acceptable if you don't need the return result of the method.
counter p 10 puts "Initial Counter: [p value]" p incr p incr p incr puts "Counter after 3 increments: [p value]" p set 20 puts "Counter after set to 20: [p value]" p reset puts "Counter after reset: [p value]"
critcl 2 has been updated to support the above - changes now in the SVN repository, slightly modified to preserve the invoking namespace - stevel - June 12, 2008
