By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
464,602 Members | 1,003 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 464,602 IT Pros & Developers. It's quick & easy.

TCL/PHP problem involving a PHP function that has to utilize a TCL proc

P: n/a
I wrote this PHP function in the hopes that it would properly use a TCL
proc I wrote about 4 years ago:

if (!function_exists('proper_case')) {
/**
* Ths function will convert a string into a proper case format using
the customized TCL proc "PROPER_CASE" from the included TCL string
tools libraries
*
* @access public
* @param mixed $text
* @param mixed $tclLibPath Path to TCL Library files
* @param DBActionPerformer $dbAP You must generate a descendant of
MethodGeneratorForActionPerformer to retrieve customized command-line
formatting to call TCL shell
* @return mixed $text properly formatted in Proper Case Form
* @see DBActionPerformer
* @uses tcl_string_tools::PROPER_CASE
*/
function &proper_case($text, $tclLibPath, $dbAP) {
if (!is_object($dbAP)) $dbAP =& new DBActionPerformer(); // NO NEED TO
CONNECT NOR DISCONNECT
list('tclKommand', 'tclRedirect') =
@array_values($dbAP->getKommandOSArray('tcl'));
$tclSourceString = @tcl_lib_include($tclLibPath);
if (!preg_match('/;[\n\r\s\t]*$/i', $tclSourceString))
$tclSourceString .= ';'; // ADD ";" TO ADD ONE MORE TCL COMMAND TO THE
SINGLE LINE
$msg = exec("$tclKommand \"$tclSourceString puts [PROPER_CASE
{$text}]\" $tclRedirect");
if (preg_match('/^[eE](rror:)/i', $msg)) {
trigger_error("Error involving TCL proc \"PROPER_CASE\" on \"$text\":
" . nl2br($msg), E_USER_WARNING); // GENERATE WARNING ONLY
return $text;
} else {
return $msg;
}
}
}

-----------------------------

Problem is very simple: <b>tclsh</b>. I have no idea how to put all of
the TCL commands onto the same line as "tclsh" command. ELSE I have no
idea how to work with the generated <b>tclsh</b> environment from
Apache/PHP.

In short, I'm stuck. I have to get this up and running and rather than
rewriting an entire series of TCL procs into PHP, I need a faster and
more practical solution to this one!

thanx
Phil

Mar 8 '06 #1
Share this Question
Share on Google+
4 Replies

P: n/a
# Problem is very simple: <b>tclsh</b>. I have no idea how to put all of
# the TCL commands onto the same line as "tclsh" command. ELSE I have no
# idea how to work with the generated <b>tclsh</b> environment from
# Apache/PHP.

How about
exec(".../tclsh <<':eof'\ntcl script\ntcl script\n...\n:eof",&output)

Also probably needs updating:

/*
PHP=/usr/local/src/php-4.0.4pl1
ZEND=/usr/local/src/php-4.0.4pl1/Zend
tclphp.o: $(GENERIC_DIR)/tclphp.c
$(CC) -w -DCOMPILE_DL=1 -I$(PHP) -I$(PHP)/main -I$(PHP)/TSRM -I$(ZEND) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclphp.c
tclphp.so: ${OBJS} tclphp.o ${STUB_LIB_FILE}
rm -f ${TCL_LIB_FILE}
${SHLIB_LD} -o tclphp.so ${OBJS} tclphp.o ${LIBS}
$(RANLIB) tclphp.so

<?php
//dl("tclphp.so");

$param = "MiXeD cAsE";
$return = tclphp("string tolower \{$param}");

print("We sent \"$param\" and got \"$return\"");
?>
*/
/*
tclphp [type] script

Standard Tcl plus one function:
php expression ...

tclphp.so
This function.
tcl8.3.so
*/

#define IS_EXT_MODULE

#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include "php.h"
#include "tcl.h"

static int isLong(Tcl_Obj *obj,long *lval) {
char *s = Tcl_GetStringFromObj(obj,0),*t;
*lval = strtol(s,&t,0);
return s!=t && !*t;
}
static Tcl_Interp *interp = 0;

/* declaration of functions to be exported */
ZEND_FUNCTION(tclphp);
ZEND_MINIT_FUNCTION(tclphp);
ZEND_MSHUTDOWN_FUNCTION(tclphp);

/* compiled function list so Zend knows what's in this module */
zend_function_entry tclphp_functions[] = {
ZEND_FE(tclphp,NULL)
{NULL,NULL,NULL}
};

/* compiled module information */
zend_module_entry tclphp_module_entry = {
"tclphp module",
tclphp_functions,
ZEND_MINIT(tclphp),ZEND_MSHUTDOWN(tclphp),NULL,NUL L,NULL,
STANDARD_MODULE_PROPERTIES
};

/* implement standard "stub" routine to introduce ourselves to Zend */
#if COMPILE_DL
ZEND_GET_MODULE(tclphp)
#endif

ZEND_MINIT_FUNCTION(tclphp) {
char initialisation[] =
"source $tcl_pkgPath/tcl$tcl_version/init.tcl\n"
;
interp = Tcl_CreateInterp();
#ifdef TCL_MEM_DEBUG
Tcl_InitMemory(interp);
#endif
if (Tcl_Init(interp)==TCL_ERROR) {
Tcl_DString S;
Tcl_DStringInit(&S);
Tcl_DStringAppend(&S,"interpretter Tcl_Init failed: ",-1);
Tcl_DStringAppend(&S,Tcl_GetStringResult(interp),-1);
zend_error(E_WARNING,Tcl_DStringValue(&S));
Tcl_DStringFree(&S);
return FAILURE;
}
Tcl_SetVar(interp,"tcl_rcFileName","~/.tclshrc",TCL_GLOBAL_ONLY);
Tcl_SourceRCFile(interp);
if (Tcl_Eval(interp,initialisation)!=TCL_OK) {
Tcl_DString S;
Tcl_DStringInit(&S);
Tcl_DStringAppend(&S,"interpretter initialisation failed: ",-1);
Tcl_DStringAppend(&S,Tcl_GetStringResult(interp),-1);
Tcl_DStringAppend(&S,": ",-1);
Tcl_DStringAppend(&S,initialisation,-1);
zend_error(E_WARNING,Tcl_DStringValue(&S));
Tcl_DStringFree(&S);
return FAILURE;
}
return SUCCESS;
}

ZEND_MSHUTDOWN_FUNCTION(tclphp) {
Tcl_DeleteInterp(interp);
interp = 0;
return SUCCESS;
}

/* implement function that is meant to be made available to PHP */
ZEND_FUNCTION(tclphp) {
int argc = ZEND_NUM_ARGS();
zval **script;
zval **type;
char Type;
int rc;
Tcl_Obj *Script,*result;

/*
Argument processing.
*/
if (argc==1) {
if (zend_get_parameters_ex(1,&script)!=SUCCESS) WRONG_PARAM_COUNT;
Type = 's';
}else if (argc==2) {
if (zend_get_parameters_ex(2,&type,&script)!=SUCCESS) WRONG_PARAM_COUNT;
if (argc==2 && (*type)->type!=IS_STRING) convert_to_string_ex(type);
Type = tolower(Z_STRVAL_PP(type)[0]);
}else {
WRONG_PARAM_COUNT;
}
if ((*script)->type!=IS_STRING) {
convert_to_string_ex(script);
}

/*
Evaluate the script and coerce to the desired return value.
*/
Script = Tcl_NewStringObj(Z_STRVAL_PP(script),Z_STRLEN_PP(s cript));
Tcl_IncrRefCount(Script);
rc = Tcl_EvalObjEx(interp,Script,TCL_EVAL_DIRECT|TCL_EV AL_GLOBAL);
Tcl_DecrRefCount(Script);
result = Tcl_GetObjResult(interp);
switch (rc==TCL_OK ? Type : 0) {
case 0: /*error*/ error: {
char *s = Tcl_GetStringResult(interp);
zend_error(E_WARNING,s);
RETVAL_NULL();
} break;
case 'd': /*double*/ {
double d;
if (Tcl_GetDoubleFromObj(interp,result,&d)!=TCL_OK) goto error;
RETVAL_DOUBLE(d);
} break;
case 'i': case 'l': /*long int*/ {
long l;
if (Tcl_GetLongFromObj(interp,result,&l)!=TCL_OK) goto error;
RETVAL_LONG(l);
} break;
case 'b': /*boolean*/ {
int b;
if (Tcl_GetBooleanFromObj(interp,result,&b)!=TCL_OK) goto error;
if (b) {RETVAL_TRUE;}
else {RETVAL_FALSE;}
} break;
case 'a': /*array*/ {
int N; Tcl_Obj **P;
if (Tcl_ListObjGetElements(interp,result,&N,&P)!=TCL_ OK) goto error;
else if (N&1) {
Tcl_SetResult(interp,"returned list for array has odd number of elements",TCL_STATIC);
goto error;
}
array_init(return_value);
for (; N>0; N-=2,P+=2) {
long lval; int bval; double dval; char *sval; int slen;
if (isLong(P[0],&lval)) {
long index = lval;
if (isLong(P[1],&lval)) {
add_index_long(return_value,index,lval);
}else if (Tcl_GetDoubleFromObj(0,P[1],&dval)==TCL_OK) {
add_index_double(return_value,index,dval);
}else if (Tcl_GetLongFromObj(0,P[1],&lval)==TCL_OK) {
add_index_long(return_value,index,lval);
}else if (Tcl_GetBooleanFromObj(0,P[1],&bval)==TCL_OK) {
add_index_long(return_value,index,(long)bval);
}else {
sval = Tcl_GetStringFromObj(P[1],&slen);
add_index_stringl(return_value,index,sval,slen,1);
}
}else {
char *key = Tcl_GetStringFromObj(P[0],0);
if (isLong(P[1],&lval)) {
add_assoc_long(return_value,key,lval);
}else if (Tcl_GetDoubleFromObj(0,P[1],&dval)==TCL_OK) {
add_assoc_double(return_value,key,dval);
}else if (Tcl_GetLongFromObj(0,P[1],&lval)==TCL_OK) {
add_assoc_long(return_value,key,lval);
}else if (Tcl_GetBooleanFromObj(0,P[1],&bval)==TCL_OK) {
add_assoc_long(return_value,key,(long)bval);
}else {
sval = Tcl_GetStringFromObj(P[1],&slen);
add_assoc_stringl(return_value,key,sval,slen,1);
}
}
}
} break;
default: /*string*/ {
int n; char *s = Tcl_GetStringFromObj(result,&n);
RETVAL_STRINGL(s,n,1);
} break;
}

/*
Clean up and quit.
*/
Tcl_ResetResult(interp);
return;
}


--
SM Ryan http://www.rawbw.com/~wyrmwif/
Where do you get those wonderful toys?
Mar 8 '06 #2

P: n/a

SM Ryan wrote:
# Problem is very simple: <b>tclsh</b>. I have no idea how to put all of
# the TCL commands onto the same line as "tclsh" command. ELSE I have no
# idea how to work with the generated <b>tclsh</b> environment from
# Apache/PHP.

How about
exec(".../tclsh <<':eof'\ntcl script\ntcl script\n...\n:eof",&output)

Ok this is what I did based on yoru suggestion:

if (!function_exists('proper_case')) {
/**
* Ths function will convert a string into a proper case format using
the customized TCL proc "PROPER_CASE" from the included TCL string
tools libraries
*
* @access public
* @param mixed $text
* @param mixed $tclLibPath Path to TCL Library files
* @param DBActionPerformer $dbAP You must generate a descendant of
MethodGeneratorForActionPerformer to retrieve customized command-line
formatting to call TCL shell
* @return mixed $text properly formatted in Proper Case Form
* @see DBActionPerformer
* @uses tcl_string_tools::PROPER_CASE
*/
function &proper_case($text, $tclLibPath, $dbAP) {
if (!is_object($dbAP)) $dbAP =& new DBActionPerformer(); // NO NEED TO
CONNECT NOR DISCONNECT
list($tclKommand, $tclRedirect) =
@array_values($dbAP->getKommandOSArray('tcl'));
$tclSourceString = @tcl_lib_include($tclLibPath);
if (!preg_match('/;[\n\r\s\t]*$/i', $tclSourceString))
$tclSourceString .= ';'; // ADD ";" TO ADD ONE MORE TCL COMMAND TO THE
SINGLE LINE
$tclSourceString = str_replace(';', ";\n", $tclSourceString);
$msg = exec("$tclKommand \"':eof'\n$tclSourceString puts [PROPER_CASE
\{$text}]\n:eof\" $tclRedirect");
if (preg_match('/^[eE](rror:)/i', $msg) ||
strcmp(strtolower(trim($msg)), strtolower(trim($text))) != 0) {
trigger_error("Error involving TCL proc \"PROPER_CASE\" on \"$text\":
" . nl2br($msg), E_USER_WARNING); // GENERATE WARNING ONLY
return $text;
} else {
return $msg;
}
}
}

produces this warning:

Warning: Error involving TCL proc "PROPER_CASE" on "John
O'Neill-Labrador": :eof": no such file or directory

Didn't try tclphp, that was beyond me completely, have no idea what to
do with that, sorry, please help.

Thanx
Phil

Also probably needs updating:

/*
PHP=/usr/local/src/php-4.0.4pl1
ZEND=/usr/local/src/php-4.0.4pl1/Zend
tclphp.o: $(GENERIC_DIR)/tclphp.c
$(CC) -w -DCOMPILE_DL=1 -I$(PHP) -I$(PHP)/main -I$(PHP)/TSRM -I$(ZEND) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclphp.c
tclphp.so: ${OBJS} tclphp.o ${STUB_LIB_FILE}
rm -f ${TCL_LIB_FILE}
${SHLIB_LD} -o tclphp.so ${OBJS} tclphp.o ${LIBS}
$(RANLIB) tclphp.so

<?php
//dl("tclphp.so");

$param = "MiXeD cAsE";
$return = tclphp("string tolower \{$param}");

print("We sent \"$param\" and got \"$return\"");
?>
*/
/*
tclphp [type] script

Standard Tcl plus one function:
php expression ...

tclphp.so
This function.
tcl8.3.so
*/

#define IS_EXT_MODULE

#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include "php.h"
#include "tcl.h"

static int isLong(Tcl_Obj *obj,long *lval) {
char *s = Tcl_GetStringFromObj(obj,0),*t;
*lval = strtol(s,&t,0);
return s!=t && !*t;
}
static Tcl_Interp *interp = 0;

/* declaration of functions to be exported */
ZEND_FUNCTION(tclphp);
ZEND_MINIT_FUNCTION(tclphp);
ZEND_MSHUTDOWN_FUNCTION(tclphp);

/* compiled function list so Zend knows what's in this module */
zend_function_entry tclphp_functions[] = {
ZEND_FE(tclphp,NULL)
{NULL,NULL,NULL}
};

/* compiled module information */
zend_module_entry tclphp_module_entry = {
"tclphp module",
tclphp_functions,
ZEND_MINIT(tclphp),ZEND_MSHUTDOWN(tclphp),NULL,NUL L,NULL,
STANDARD_MODULE_PROPERTIES
};

/* implement standard "stub" routine to introduce ourselves to Zend */
#if COMPILE_DL
ZEND_GET_MODULE(tclphp)
#endif

ZEND_MINIT_FUNCTION(tclphp) {
char initialisation[] =
"source $tcl_pkgPath/tcl$tcl_version/init.tcl\n"
;
interp = Tcl_CreateInterp();
#ifdef TCL_MEM_DEBUG
Tcl_InitMemory(interp);
#endif
if (Tcl_Init(interp)==TCL_ERROR) {
Tcl_DString S;
Tcl_DStringInit(&S);
Tcl_DStringAppend(&S,"interpretter Tcl_Init failed: ",-1);
Tcl_DStringAppend(&S,Tcl_GetStringResult(interp),-1);
zend_error(E_WARNING,Tcl_DStringValue(&S));
Tcl_DStringFree(&S);
return FAILURE;
}
Tcl_SetVar(interp,"tcl_rcFileName","~/.tclshrc",TCL_GLOBAL_ONLY);
Tcl_SourceRCFile(interp);
if (Tcl_Eval(interp,initialisation)!=TCL_OK) {
Tcl_DString S;
Tcl_DStringInit(&S);
Tcl_DStringAppend(&S,"interpretter initialisation failed: ",-1);
Tcl_DStringAppend(&S,Tcl_GetStringResult(interp),-1);
Tcl_DStringAppend(&S,": ",-1);
Tcl_DStringAppend(&S,initialisation,-1);
zend_error(E_WARNING,Tcl_DStringValue(&S));
Tcl_DStringFree(&S);
return FAILURE;
}
return SUCCESS;
}

ZEND_MSHUTDOWN_FUNCTION(tclphp) {
Tcl_DeleteInterp(interp);
interp = 0;
return SUCCESS;
}

/* implement function that is meant to be made available to PHP */
ZEND_FUNCTION(tclphp) {
int argc = ZEND_NUM_ARGS();
zval **script;
zval **type;
char Type;
int rc;
Tcl_Obj *Script,*result;

/*
Argument processing.
*/
if (argc==1) {
if (zend_get_parameters_ex(1,&script)!=SUCCESS) WRONG_PARAM_COUNT;
Type = 's';
}else if (argc==2) {
if (zend_get_parameters_ex(2,&type,&script)!=SUCCESS) WRONG_PARAM_COUNT;
if (argc==2 && (*type)->type!=IS_STRING) convert_to_string_ex(type);
Type = tolower(Z_STRVAL_PP(type)[0]);
}else {
WRONG_PARAM_COUNT;
}
if ((*script)->type!=IS_STRING) {
convert_to_string_ex(script);
}

/*
Evaluate the script and coerce to the desired return value.
*/
Script = Tcl_NewStringObj(Z_STRVAL_PP(script),Z_STRLEN_PP(s cript));
Tcl_IncrRefCount(Script);
rc = Tcl_EvalObjEx(interp,Script,TCL_EVAL_DIRECT|TCL_EV AL_GLOBAL);
Tcl_DecrRefCount(Script);
result = Tcl_GetObjResult(interp);
switch (rc==TCL_OK ? Type : 0) {
case 0: /*error*/ error: {
char *s = Tcl_GetStringResult(interp);
zend_error(E_WARNING,s);
RETVAL_NULL();
} break;
case 'd': /*double*/ {
double d;
if (Tcl_GetDoubleFromObj(interp,result,&d)!=TCL_OK) goto error;
RETVAL_DOUBLE(d);
} break;
case 'i': case 'l': /*long int*/ {
long l;
if (Tcl_GetLongFromObj(interp,result,&l)!=TCL_OK) goto error;
RETVAL_LONG(l);
} break;
case 'b': /*boolean*/ {
int b;
if (Tcl_GetBooleanFromObj(interp,result,&b)!=TCL_OK) goto error;
if (b) {RETVAL_TRUE;}
else {RETVAL_FALSE;}
} break;
case 'a': /*array*/ {
int N; Tcl_Obj **P;
if (Tcl_ListObjGetElements(interp,result,&N,&P)!=TCL_ OK) goto error;
else if (N&1) {
Tcl_SetResult(interp,"returned list for array has odd number of elements",TCL_STATIC);
goto error;
}
array_init(return_value);
for (; N>0; N-=2,P+=2) {
long lval; int bval; double dval; char *sval; int slen;
if (isLong(P[0],&lval)) {
long index = lval;
if (isLong(P[1],&lval)) {
add_index_long(return_value,index,lval);
}else if (Tcl_GetDoubleFromObj(0,P[1],&dval)==TCL_OK) {
add_index_double(return_value,index,dval);
}else if (Tcl_GetLongFromObj(0,P[1],&lval)==TCL_OK) {
add_index_long(return_value,index,lval);
}else if (Tcl_GetBooleanFromObj(0,P[1],&bval)==TCL_OK) {
add_index_long(return_value,index,(long)bval);
}else {
sval = Tcl_GetStringFromObj(P[1],&slen);
add_index_stringl(return_value,index,sval,slen,1);
}
}else {
char *key = Tcl_GetStringFromObj(P[0],0);
if (isLong(P[1],&lval)) {
add_assoc_long(return_value,key,lval);
}else if (Tcl_GetDoubleFromObj(0,P[1],&dval)==TCL_OK) {
add_assoc_double(return_value,key,dval);
}else if (Tcl_GetLongFromObj(0,P[1],&lval)==TCL_OK) {
add_assoc_long(return_value,key,lval);
}else if (Tcl_GetBooleanFromObj(0,P[1],&bval)==TCL_OK) {
add_assoc_long(return_value,key,(long)bval);
}else {
sval = Tcl_GetStringFromObj(P[1],&slen);
add_assoc_stringl(return_value,key,sval,slen,1);
}
}
}
} break;
default: /*string*/ {
int n; char *s = Tcl_GetStringFromObj(result,&n);
RETVAL_STRINGL(s,n,1);
} break;
}

/*
Clean up and quit.
*/
Tcl_ResetResult(interp);
return;
}


--
SM Ryan http://www.rawbw.com/~wyrmwif/
Where do you get those wonderful toys?


Mar 8 '06 #3

P: n/a

SM Ryan wrote:
# Problem is very simple: <b>tclsh</b>. I have no idea how to put all of
# the TCL commands onto the same line as "tclsh" command. ELSE I have no
# idea how to work with the generated <b>tclsh</b> environment from
# Apache/PHP.

How about
exec(".../tclsh <<':eof'\ntcl script\ntcl script\n...\n:eof",&output)

I got it, thanx!

if (!function_exists('proper_case')) {
/**
* Ths function will convert a string into a proper case format using
the customized TCL proc "PROPER_CASE" from the included TCL string
tools libraries
*
* @access public
* @param mixed $text
* @param mixed $tclLibPath Path to TCL Library files
* @param DBActionPerformer $dbAP You must generate a descendant of
MethodGeneratorForActionPerformer to retrieve customized command-line
formatting to call TCL shell
* @return mixed $text properly formatted in Proper Case Form
* @see DBActionPerformer
* @uses tcl_string_tools::PROPER_CASE
*/
function &proper_case($text, $tclLibPath, $dbAP) {
if (!is_object($dbAP)) $dbAP =& new DBActionPerformer(); // NO NEED TO
CONNECT NOR DISCONNECT
list($tclKommand, $tclRedirect) =
@array_values($dbAP->getKommandOSArray('tcl'));
$tclSourceString = tcl_lib_include($tclLibPath);
if (!preg_match('/;[\n\r\s\t]*$/i', $tclSourceString))
$tclSourceString .= ';'; // ADD ";" TO ADD ONE MORE TCL COMMAND TO THE
SINGLE LINE
$tclSourceString = str_replace(';', ";\n", $tclSourceString);
$msg = exec("$tclKommand << ':eof'\n$tclSourceString puts [PROPER_CASE
\{$text}]\n:eof $tclRedirect");
if (preg_match('/^[eE](rror:)/i', $msg) ||
strcmp(strtolower(trim($msg)), strtolower(trim($text))) != 0) {
trigger_error("Error involving TCL proc \"PROPER_CASE\" on \"$text\":
" . nl2br($msg), E_USER_WARNING); // GENERATE WARNING ONLY
return $text;
} else {
return $msg;
}
}
}

I have one last question: How will this be optimized to equally work in
Windows?

Thanx
Phil
Also probably needs updating:

/*
PHP=/usr/local/src/php-4.0.4pl1
ZEND=/usr/local/src/php-4.0.4pl1/Zend
tclphp.o: $(GENERIC_DIR)/tclphp.c
$(CC) -w -DCOMPILE_DL=1 -I$(PHP) -I$(PHP)/main -I$(PHP)/TSRM -I$(ZEND) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclphp.c
tclphp.so: ${OBJS} tclphp.o ${STUB_LIB_FILE}
rm -f ${TCL_LIB_FILE}
${SHLIB_LD} -o tclphp.so ${OBJS} tclphp.o ${LIBS}
$(RANLIB) tclphp.so

<?php
//dl("tclphp.so");

$param = "MiXeD cAsE";
$return = tclphp("string tolower \{$param}");

print("We sent \"$param\" and got \"$return\"");
?>
*/
/*
tclphp [type] script

Standard Tcl plus one function:
php expression ...

tclphp.so
This function.
tcl8.3.so
*/

#define IS_EXT_MODULE

#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include "php.h"
#include "tcl.h"

static int isLong(Tcl_Obj *obj,long *lval) {
char *s = Tcl_GetStringFromObj(obj,0),*t;
*lval = strtol(s,&t,0);
return s!=t && !*t;
}
static Tcl_Interp *interp = 0;

/* declaration of functions to be exported */
ZEND_FUNCTION(tclphp);
ZEND_MINIT_FUNCTION(tclphp);
ZEND_MSHUTDOWN_FUNCTION(tclphp);

/* compiled function list so Zend knows what's in this module */
zend_function_entry tclphp_functions[] = {
ZEND_FE(tclphp,NULL)
{NULL,NULL,NULL}
};

/* compiled module information */
zend_module_entry tclphp_module_entry = {
"tclphp module",
tclphp_functions,
ZEND_MINIT(tclphp),ZEND_MSHUTDOWN(tclphp),NULL,NUL L,NULL,
STANDARD_MODULE_PROPERTIES
};

/* implement standard "stub" routine to introduce ourselves to Zend */
#if COMPILE_DL
ZEND_GET_MODULE(tclphp)
#endif

ZEND_MINIT_FUNCTION(tclphp) {
char initialisation[] =
"source $tcl_pkgPath/tcl$tcl_version/init.tcl\n"
;
interp = Tcl_CreateInterp();
#ifdef TCL_MEM_DEBUG
Tcl_InitMemory(interp);
#endif
if (Tcl_Init(interp)==TCL_ERROR) {
Tcl_DString S;
Tcl_DStringInit(&S);
Tcl_DStringAppend(&S,"interpretter Tcl_Init failed: ",-1);
Tcl_DStringAppend(&S,Tcl_GetStringResult(interp),-1);
zend_error(E_WARNING,Tcl_DStringValue(&S));
Tcl_DStringFree(&S);
return FAILURE;
}
Tcl_SetVar(interp,"tcl_rcFileName","~/.tclshrc",TCL_GLOBAL_ONLY);
Tcl_SourceRCFile(interp);
if (Tcl_Eval(interp,initialisation)!=TCL_OK) {
Tcl_DString S;
Tcl_DStringInit(&S);
Tcl_DStringAppend(&S,"interpretter initialisation failed: ",-1);
Tcl_DStringAppend(&S,Tcl_GetStringResult(interp),-1);
Tcl_DStringAppend(&S,": ",-1);
Tcl_DStringAppend(&S,initialisation,-1);
zend_error(E_WARNING,Tcl_DStringValue(&S));
Tcl_DStringFree(&S);
return FAILURE;
}
return SUCCESS;
}

ZEND_MSHUTDOWN_FUNCTION(tclphp) {
Tcl_DeleteInterp(interp);
interp = 0;
return SUCCESS;
}

/* implement function that is meant to be made available to PHP */
ZEND_FUNCTION(tclphp) {
int argc = ZEND_NUM_ARGS();
zval **script;
zval **type;
char Type;
int rc;
Tcl_Obj *Script,*result;

/*
Argument processing.
*/
if (argc==1) {
if (zend_get_parameters_ex(1,&script)!=SUCCESS) WRONG_PARAM_COUNT;
Type = 's';
}else if (argc==2) {
if (zend_get_parameters_ex(2,&type,&script)!=SUCCESS) WRONG_PARAM_COUNT;
if (argc==2 && (*type)->type!=IS_STRING) convert_to_string_ex(type);
Type = tolower(Z_STRVAL_PP(type)[0]);
}else {
WRONG_PARAM_COUNT;
}
if ((*script)->type!=IS_STRING) {
convert_to_string_ex(script);
}

/*
Evaluate the script and coerce to the desired return value.
*/
Script = Tcl_NewStringObj(Z_STRVAL_PP(script),Z_STRLEN_PP(s cript));
Tcl_IncrRefCount(Script);
rc = Tcl_EvalObjEx(interp,Script,TCL_EVAL_DIRECT|TCL_EV AL_GLOBAL);
Tcl_DecrRefCount(Script);
result = Tcl_GetObjResult(interp);
switch (rc==TCL_OK ? Type : 0) {
case 0: /*error*/ error: {
char *s = Tcl_GetStringResult(interp);
zend_error(E_WARNING,s);
RETVAL_NULL();
} break;
case 'd': /*double*/ {
double d;
if (Tcl_GetDoubleFromObj(interp,result,&d)!=TCL_OK) goto error;
RETVAL_DOUBLE(d);
} break;
case 'i': case 'l': /*long int*/ {
long l;
if (Tcl_GetLongFromObj(interp,result,&l)!=TCL_OK) goto error;
RETVAL_LONG(l);
} break;
case 'b': /*boolean*/ {
int b;
if (Tcl_GetBooleanFromObj(interp,result,&b)!=TCL_OK) goto error;
if (b) {RETVAL_TRUE;}
else {RETVAL_FALSE;}
} break;
case 'a': /*array*/ {
int N; Tcl_Obj **P;
if (Tcl_ListObjGetElements(interp,result,&N,&P)!=TCL_ OK) goto error;
else if (N&1) {
Tcl_SetResult(interp,"returned list for array has odd number of elements",TCL_STATIC);
goto error;
}
array_init(return_value);
for (; N>0; N-=2,P+=2) {
long lval; int bval; double dval; char *sval; int slen;
if (isLong(P[0],&lval)) {
long index = lval;
if (isLong(P[1],&lval)) {
add_index_long(return_value,index,lval);
}else if (Tcl_GetDoubleFromObj(0,P[1],&dval)==TCL_OK) {
add_index_double(return_value,index,dval);
}else if (Tcl_GetLongFromObj(0,P[1],&lval)==TCL_OK) {
add_index_long(return_value,index,lval);
}else if (Tcl_GetBooleanFromObj(0,P[1],&bval)==TCL_OK) {
add_index_long(return_value,index,(long)bval);
}else {
sval = Tcl_GetStringFromObj(P[1],&slen);
add_index_stringl(return_value,index,sval,slen,1);
}
}else {
char *key = Tcl_GetStringFromObj(P[0],0);
if (isLong(P[1],&lval)) {
add_assoc_long(return_value,key,lval);
}else if (Tcl_GetDoubleFromObj(0,P[1],&dval)==TCL_OK) {
add_assoc_double(return_value,key,dval);
}else if (Tcl_GetLongFromObj(0,P[1],&lval)==TCL_OK) {
add_assoc_long(return_value,key,lval);
}else if (Tcl_GetBooleanFromObj(0,P[1],&bval)==TCL_OK) {
add_assoc_long(return_value,key,(long)bval);
}else {
sval = Tcl_GetStringFromObj(P[1],&slen);
add_assoc_stringl(return_value,key,sval,slen,1);
}
}
}
} break;
default: /*string*/ {
int n; char *s = Tcl_GetStringFromObj(result,&n);
RETVAL_STRINGL(s,n,1);
} break;
}

/*
Clean up and quit.
*/
Tcl_ResetResult(interp);
return;
}


--
SM Ryan http://www.rawbw.com/~wyrmwif/
Where do you get those wonderful toys?


Mar 8 '06 #4

P: n/a
In article <11*********************@j52g2000cwj.googlegroups. com>,
comp.lang.tcl <ph**************@gmail.com> wrote:
I wrote this PHP function in the hopes that it would properly use a TCL
proc I wrote about 4 years ago:

Mar 9 '06 #5

This discussion thread is closed

Replies have been disabled for this discussion.