Posted by comp.lang.tcl on 03/09/06 01:46

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,NULL,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(script));
> Tcl_IncrRefCount(Script);
> rc = Tcl_EvalObjEx(interp,Script,TCL_EVAL_DIRECT|TCL_EVAL_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?

[Back to original message]