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

Collapse
This topic is closed.
X
X
 
  • Time
  • Show
Clear All
new posts
  • comp.lang.tcl

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

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

    if (!function_exis ts('proper_case ')) {
    /**
    * Ths function will convert a string into a proper case format using
    the customized TCL proc "PROPER_CAS E" from the included TCL string
    tools libraries
    *
    * @access public
    * @param mixed $text
    * @param mixed $tclLibPath Path to TCL Library files
    * @param DBActionPerform er $dbAP You must generate a descendant of
    MethodGenerator ForActionPerfor mer to retrieve customized command-line
    formatting to call TCL shell
    * @return mixed $text properly formatted in Proper Case Form
    * @see DBActionPerform er
    * @uses tcl_string_tool s::PROPER_CASE
    */
    function &proper_case($t ext, $tclLibPath, $dbAP) {
    if (!is_object($db AP)) $dbAP =& new DBActionPerform er(); // NO NEED TO
    CONNECT NOR DISCONNECT
    list('tclKomman d', 'tclRedirect') =
    @array_values($ dbAP->getKommandOSAr ray('tcl'));
    $tclSourceStrin g = @tcl_lib_includ e($tclLibPath);
    if (!preg_match('/;[\n\r\s\t]*$/i', $tclSourceStrin g))
    $tclSourceStrin g .= ';'; // ADD ";" TO ADD ONE MORE TCL COMMAND TO THE
    SINGLE LINE
    $msg = exec("$tclKomma nd \"$tclSourceStr ing puts [PROPER_CASE
    {$text}]\" $tclRedirect");
    if (preg_match('/^[eE](rror:)/i', $msg)) {
    trigger_error(" Error involving TCL proc \"PROPER_CAS E\" 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

  • SM Ryan

    #2
    Re: TCL/PHP problem involving a PHP function that has to utilize a TCL proc

    # 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:e of",&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_GetStringFr omObj(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(t clphp);
    ZEND_MINIT_FUNC TION(tclphp);
    ZEND_MSHUTDOWN_ FUNCTION(tclphp );

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

    /* compiled module information */
    zend_module_ent ry tclphp_module_e ntry = {
    "tclphp module",
    tclphp_function s,
    ZEND_MINIT(tclp hp),ZEND_MSHUTD OWN(tclphp),NUL L,NULL,NULL,
    STANDARD_MODULE _PROPERTIES
    };

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

    ZEND_MINIT_FUNC TION(tclphp) {
    char initialisation[] =
    "source $tcl_pkgPath/tcl$tcl_version/init.tcl\n"
    ;
    interp = Tcl_CreateInter p();
    #ifdef TCL_MEM_DEBUG
    Tcl_InitMemory( interp);
    #endif
    if (Tcl_Init(inter p)==TCL_ERROR) {
    Tcl_DString S;
    Tcl_DStringInit (&S);
    Tcl_DStringAppe nd(&S,"interpre tter Tcl_Init failed: ",-1);
    Tcl_DStringAppe nd(&S,Tcl_GetSt ringResult(inte rp),-1);
    zend_error(E_WA RNING,Tcl_DStri ngValue(&S));
    Tcl_DStringFree (&S);
    return FAILURE;
    }
    Tcl_SetVar(inte rp,"tcl_rcFileN ame","~/.tclshrc",TCL_G LOBAL_ONLY);
    Tcl_SourceRCFil e(interp);
    if (Tcl_Eval(inter p,initialisatio n)!=TCL_OK) {
    Tcl_DString S;
    Tcl_DStringInit (&S);
    Tcl_DStringAppe nd(&S,"interpre tter initialisation failed: ",-1);
    Tcl_DStringAppe nd(&S,Tcl_GetSt ringResult(inte rp),-1);
    Tcl_DStringAppe nd(&S,": ",-1);
    Tcl_DStringAppe nd(&S,initialis ation,-1);
    zend_error(E_WA RNING,Tcl_DStri ngValue(&S));
    Tcl_DStringFree (&S);
    return FAILURE;
    }
    return SUCCESS;
    }

    ZEND_MSHUTDOWN_ FUNCTION(tclphp ) {
    Tcl_DeleteInter p(interp);
    interp = 0;
    return SUCCESS;
    }

    /* implement function that is meant to be made available to PHP */
    ZEND_FUNCTION(t clphp) {
    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_param eters_ex(1,&scr ipt)!=SUCCESS) WRONG_PARAM_COU NT;
    Type = 's';
    }else if (argc==2) {
    if (zend_get_param eters_ex(2,&typ e,&script)!=SUC CESS) WRONG_PARAM_COU NT;
    if (argc==2 && (*type)->type!=IS_STRIN G) convert_to_stri ng_ex(type);
    Type = tolower(Z_STRVA L_PP(type)[0]);
    }else {
    WRONG_PARAM_COU NT;
    }
    if ((*script)->type!=IS_STRIN G) {
    convert_to_stri ng_ex(script);
    }

    /*
    Evaluate the script and coerce to the desired return value.
    */
    Script = Tcl_NewStringOb j(Z_STRVAL_PP(s cript),Z_STRLEN _PP(script));
    Tcl_IncrRefCoun t(Script);
    rc = Tcl_EvalObjEx(i nterp,Script,TC L_EVAL_DIRECT|T CL_EVAL_GLOBAL) ;
    Tcl_DecrRefCoun t(Script);
    result = Tcl_GetObjResul t(interp);
    switch (rc==TCL_OK ? Type : 0) {
    case 0: /*error*/ error: {
    char *s = Tcl_GetStringRe sult(interp);
    zend_error(E_WA RNING,s);
    RETVAL_NULL();
    } break;
    case 'd': /*double*/ {
    double d;
    if (Tcl_GetDoubleF romObj(interp,r esult,&d)!=TCL_ OK) goto error;
    RETVAL_DOUBLE(d );
    } break;
    case 'i': case 'l': /*long int*/ {
    long l;
    if (Tcl_GetLongFro mObj(interp,res ult,&l)!=TCL_OK ) goto error;
    RETVAL_LONG(l);
    } break;
    case 'b': /*boolean*/ {
    int b;
    if (Tcl_GetBoolean FromObj(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_ListObjGet Elements(interp ,result,&N,&P)! =TCL_OK) goto error;
    else if (N&1) {
    Tcl_SetResult(i nterp,"returned list for array has odd number of elements",TCL_S TATIC);
    goto error;
    }
    array_init(retu rn_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,in dex,lval);
    }else if (Tcl_GetDoubleF romObj(0,P[1],&dval)==TCL_OK ) {
    add_index_doubl e(return_value, index,dval);
    }else if (Tcl_GetLongFro mObj(0,P[1],&lval)==TCL_OK ) {
    add_index_long( return_value,in dex,lval);
    }else if (Tcl_GetBoolean FromObj(0,P[1],&bval)==TCL_OK ) {
    add_index_long( return_value,in dex,(long)bval) ;
    }else {
    sval = Tcl_GetStringFr omObj(P[1],&slen);
    add_index_strin gl(return_value ,index,sval,sle n,1);
    }
    }else {
    char *key = Tcl_GetStringFr omObj(P[0],0);
    if (isLong(P[1],&lval)) {
    add_assoc_long( return_value,ke y,lval);
    }else if (Tcl_GetDoubleF romObj(0,P[1],&dval)==TCL_OK ) {
    add_assoc_doubl e(return_value, key,dval);
    }else if (Tcl_GetLongFro mObj(0,P[1],&lval)==TCL_OK ) {
    add_assoc_long( return_value,ke y,lval);
    }else if (Tcl_GetBoolean FromObj(0,P[1],&bval)==TCL_OK ) {
    add_assoc_long( return_value,ke y,(long)bval);
    }else {
    sval = Tcl_GetStringFr omObj(P[1],&slen);
    add_assoc_strin gl(return_value ,key,sval,slen, 1);
    }
    }
    }
    } break;
    default: /*string*/ {
    int n; char *s = Tcl_GetStringFr omObj(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?

    Comment

    • comp.lang.tcl

      #3
      Re: TCL/PHP problem involving a PHP function that has to utilize a TCL proc


      SM Ryan wrote:[color=blue]
      > # 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:e of",&output)
      >[/color]

      Ok this is what I did based on yoru suggestion:

      if (!function_exis ts('proper_case ')) {
      /**
      * Ths function will convert a string into a proper case format using
      the customized TCL proc "PROPER_CAS E" from the included TCL string
      tools libraries
      *
      * @access public
      * @param mixed $text
      * @param mixed $tclLibPath Path to TCL Library files
      * @param DBActionPerform er $dbAP You must generate a descendant of
      MethodGenerator ForActionPerfor mer to retrieve customized command-line
      formatting to call TCL shell
      * @return mixed $text properly formatted in Proper Case Form
      * @see DBActionPerform er
      * @uses tcl_string_tool s::PROPER_CASE
      */
      function &proper_case($t ext, $tclLibPath, $dbAP) {
      if (!is_object($db AP)) $dbAP =& new DBActionPerform er(); // NO NEED TO
      CONNECT NOR DISCONNECT
      list($tclKomman d, $tclRedirect) =
      @array_values($ dbAP->getKommandOSAr ray('tcl'));
      $tclSourceStrin g = @tcl_lib_includ e($tclLibPath);
      if (!preg_match('/;[\n\r\s\t]*$/i', $tclSourceStrin g))
      $tclSourceStrin g .= ';'; // ADD ";" TO ADD ONE MORE TCL COMMAND TO THE
      SINGLE LINE
      $tclSourceStrin g = str_replace(';' , ";\n", $tclSourceStrin g);
      $msg = exec("$tclKomma nd \"':eof'\n$tclS ourceString puts [PROPER_CASE
      \{$text}]\n:eof\" $tclRedirect");
      if (preg_match('/^[eE](rror:)/i', $msg) ||
      strcmp(strtolow er(trim($msg)), strtolower(trim ($text))) != 0) {
      trigger_error(" Error involving TCL proc \"PROPER_CAS E\" on \"$text\":
      " . nl2br($msg), E_USER_WARNING) ; // GENERATE WARNING ONLY
      return $text;
      } else {
      return $msg;
      }
      }
      }

      produces this warning:

      Warning: Error involving TCL proc "PROPER_CAS E" 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

      [color=blue]
      > 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_GetStringFr omObj(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(t clphp);
      > ZEND_MINIT_FUNC TION(tclphp);
      > ZEND_MSHUTDOWN_ FUNCTION(tclphp );
      >
      > /* compiled function list so Zend knows what's in this module */
      > zend_function_e ntry tclphp_function s[] = {
      > ZEND_FE(tclphp, NULL)
      > {NULL,NULL,NULL }
      > };
      >
      > /* compiled module information */
      > zend_module_ent ry tclphp_module_e ntry = {
      > "tclphp module",
      > tclphp_function s,
      > ZEND_MINIT(tclp hp),ZEND_MSHUTD OWN(tclphp),NUL L,NULL,NULL,
      > STANDARD_MODULE _PROPERTIES
      > };
      >
      > /* implement standard "stub" routine to introduce ourselves to Zend */
      > #if COMPILE_DL
      > ZEND_GET_MODULE (tclphp)
      > #endif
      >
      > ZEND_MINIT_FUNC TION(tclphp) {
      > char initialisation[] =
      > "source $tcl_pkgPath/tcl$tcl_version/init.tcl\n"
      > ;
      > interp = Tcl_CreateInter p();
      > #ifdef TCL_MEM_DEBUG
      > Tcl_InitMemory( interp);
      > #endif
      > if (Tcl_Init(inter p)==TCL_ERROR) {
      > Tcl_DString S;
      > Tcl_DStringInit (&S);
      > Tcl_DStringAppe nd(&S,"interpre tter Tcl_Init failed: ",-1);
      > Tcl_DStringAppe nd(&S,Tcl_GetSt ringResult(inte rp),-1);
      > zend_error(E_WA RNING,Tcl_DStri ngValue(&S));
      > Tcl_DStringFree (&S);
      > return FAILURE;
      > }
      > Tcl_SetVar(inte rp,"tcl_rcFileN ame","~/.tclshrc",TCL_G LOBAL_ONLY);
      > Tcl_SourceRCFil e(interp);
      > if (Tcl_Eval(inter p,initialisatio n)!=TCL_OK) {
      > Tcl_DString S;
      > Tcl_DStringInit (&S);
      > Tcl_DStringAppe nd(&S,"interpre tter initialisation failed: ",-1);
      > Tcl_DStringAppe nd(&S,Tcl_GetSt ringResult(inte rp),-1);
      > Tcl_DStringAppe nd(&S,": ",-1);
      > Tcl_DStringAppe nd(&S,initialis ation,-1);
      > zend_error(E_WA RNING,Tcl_DStri ngValue(&S));
      > Tcl_DStringFree (&S);
      > return FAILURE;
      > }
      > return SUCCESS;
      > }
      >
      > ZEND_MSHUTDOWN_ FUNCTION(tclphp ) {
      > Tcl_DeleteInter p(interp);
      > interp = 0;
      > return SUCCESS;
      > }
      >
      > /* implement function that is meant to be made available to PHP */
      > ZEND_FUNCTION(t clphp) {
      > 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_param eters_ex(1,&scr ipt)!=SUCCESS) WRONG_PARAM_COU NT;
      > Type = 's';
      > }else if (argc==2) {
      > if (zend_get_param eters_ex(2,&typ e,&script)!=SUC CESS) WRONG_PARAM_COU NT;
      > if (argc==2 && (*type)->type!=IS_STRIN G) convert_to_stri ng_ex(type);
      > Type = tolower(Z_STRVA L_PP(type)[0]);
      > }else {
      > WRONG_PARAM_COU NT;
      > }
      > if ((*script)->type!=IS_STRIN G) {
      > convert_to_stri ng_ex(script);
      > }
      >
      > /*
      > Evaluate the script and coerce to the desired return value.
      > */
      > Script = Tcl_NewStringOb j(Z_STRVAL_PP(s cript),Z_STRLEN _PP(script));
      > Tcl_IncrRefCoun t(Script);
      > rc = Tcl_EvalObjEx(i nterp,Script,TC L_EVAL_DIRECT|T CL_EVAL_GLOBAL) ;
      > Tcl_DecrRefCoun t(Script);
      > result = Tcl_GetObjResul t(interp);
      > switch (rc==TCL_OK ? Type : 0) {
      > case 0: /*error*/ error: {
      > char *s = Tcl_GetStringRe sult(interp);
      > zend_error(E_WA RNING,s);
      > RETVAL_NULL();
      > } break;
      > case 'd': /*double*/ {
      > double d;
      > if (Tcl_GetDoubleF romObj(interp,r esult,&d)!=TCL_ OK) goto error;
      > RETVAL_DOUBLE(d );
      > } break;
      > case 'i': case 'l': /*long int*/ {
      > long l;
      > if (Tcl_GetLongFro mObj(interp,res ult,&l)!=TCL_OK ) goto error;
      > RETVAL_LONG(l);
      > } break;
      > case 'b': /*boolean*/ {
      > int b;
      > if (Tcl_GetBoolean FromObj(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_ListObjGet Elements(interp ,result,&N,&P)! =TCL_OK) goto error;
      > else if (N&1) {
      > Tcl_SetResult(i nterp,"returned list for array has odd number of elements",TCL_S TATIC);
      > goto error;
      > }
      > array_init(retu rn_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,in dex,lval);
      > }else if (Tcl_GetDoubleF romObj(0,P[1],&dval)==TCL_OK ) {
      > add_index_doubl e(return_value, index,dval);
      > }else if (Tcl_GetLongFro mObj(0,P[1],&lval)==TCL_OK ) {
      > add_index_long( return_value,in dex,lval);
      > }else if (Tcl_GetBoolean FromObj(0,P[1],&bval)==TCL_OK ) {
      > add_index_long( return_value,in dex,(long)bval) ;
      > }else {
      > sval = Tcl_GetStringFr omObj(P[1],&slen);
      > add_index_strin gl(return_value ,index,sval,sle n,1);
      > }
      > }else {
      > char *key = Tcl_GetStringFr omObj(P[0],0);
      > if (isLong(P[1],&lval)) {
      > add_assoc_long( return_value,ke y,lval);
      > }else if (Tcl_GetDoubleF romObj(0,P[1],&dval)==TCL_OK ) {
      > add_assoc_doubl e(return_value, key,dval);
      > }else if (Tcl_GetLongFro mObj(0,P[1],&lval)==TCL_OK ) {
      > add_assoc_long( return_value,ke y,lval);
      > }else if (Tcl_GetBoolean FromObj(0,P[1],&bval)==TCL_OK ) {
      > add_assoc_long( return_value,ke y,(long)bval);
      > }else {
      > sval = Tcl_GetStringFr omObj(P[1],&slen);
      > add_assoc_strin gl(return_value ,key,sval,slen, 1);
      > }
      > }
      > }
      > } break;
      > default: /*string*/ {
      > int n; char *s = Tcl_GetStringFr omObj(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?[/color]

      Comment

      • comp.lang.tcl

        #4
        Re: TCL/PHP problem involving a PHP function that has to utilize a TCL proc


        SM Ryan wrote:[color=blue]
        > # 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:e of",&output)
        >[/color]

        I got it, thanx!

        if (!function_exis ts('proper_case ')) {
        /**
        * Ths function will convert a string into a proper case format using
        the customized TCL proc "PROPER_CAS E" from the included TCL string
        tools libraries
        *
        * @access public
        * @param mixed $text
        * @param mixed $tclLibPath Path to TCL Library files
        * @param DBActionPerform er $dbAP You must generate a descendant of
        MethodGenerator ForActionPerfor mer to retrieve customized command-line
        formatting to call TCL shell
        * @return mixed $text properly formatted in Proper Case Form
        * @see DBActionPerform er
        * @uses tcl_string_tool s::PROPER_CASE
        */
        function &proper_case($t ext, $tclLibPath, $dbAP) {
        if (!is_object($db AP)) $dbAP =& new DBActionPerform er(); // NO NEED TO
        CONNECT NOR DISCONNECT
        list($tclKomman d, $tclRedirect) =
        @array_values($ dbAP->getKommandOSAr ray('tcl'));
        $tclSourceStrin g = tcl_lib_include ($tclLibPath);
        if (!preg_match('/;[\n\r\s\t]*$/i', $tclSourceStrin g))
        $tclSourceStrin g .= ';'; // ADD ";" TO ADD ONE MORE TCL COMMAND TO THE
        SINGLE LINE
        $tclSourceStrin g = str_replace(';' , ";\n", $tclSourceStrin g);
        $msg = exec("$tclKomma nd << ':eof'\n$tclSou rceString puts [PROPER_CASE
        \{$text}]\n:eof $tclRedirect");
        if (preg_match('/^[eE](rror:)/i', $msg) ||
        strcmp(strtolow er(trim($msg)), strtolower(trim ($text))) != 0) {
        trigger_error(" Error involving TCL proc \"PROPER_CAS E\" 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
        [color=blue]
        > 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_GetStringFr omObj(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(t clphp);
        > ZEND_MINIT_FUNC TION(tclphp);
        > ZEND_MSHUTDOWN_ FUNCTION(tclphp );
        >
        > /* compiled function list so Zend knows what's in this module */
        > zend_function_e ntry tclphp_function s[] = {
        > ZEND_FE(tclphp, NULL)
        > {NULL,NULL,NULL }
        > };
        >
        > /* compiled module information */
        > zend_module_ent ry tclphp_module_e ntry = {
        > "tclphp module",
        > tclphp_function s,
        > ZEND_MINIT(tclp hp),ZEND_MSHUTD OWN(tclphp),NUL L,NULL,NULL,
        > STANDARD_MODULE _PROPERTIES
        > };
        >
        > /* implement standard "stub" routine to introduce ourselves to Zend */
        > #if COMPILE_DL
        > ZEND_GET_MODULE (tclphp)
        > #endif
        >
        > ZEND_MINIT_FUNC TION(tclphp) {
        > char initialisation[] =
        > "source $tcl_pkgPath/tcl$tcl_version/init.tcl\n"
        > ;
        > interp = Tcl_CreateInter p();
        > #ifdef TCL_MEM_DEBUG
        > Tcl_InitMemory( interp);
        > #endif
        > if (Tcl_Init(inter p)==TCL_ERROR) {
        > Tcl_DString S;
        > Tcl_DStringInit (&S);
        > Tcl_DStringAppe nd(&S,"interpre tter Tcl_Init failed: ",-1);
        > Tcl_DStringAppe nd(&S,Tcl_GetSt ringResult(inte rp),-1);
        > zend_error(E_WA RNING,Tcl_DStri ngValue(&S));
        > Tcl_DStringFree (&S);
        > return FAILURE;
        > }
        > Tcl_SetVar(inte rp,"tcl_rcFileN ame","~/.tclshrc",TCL_G LOBAL_ONLY);
        > Tcl_SourceRCFil e(interp);
        > if (Tcl_Eval(inter p,initialisatio n)!=TCL_OK) {
        > Tcl_DString S;
        > Tcl_DStringInit (&S);
        > Tcl_DStringAppe nd(&S,"interpre tter initialisation failed: ",-1);
        > Tcl_DStringAppe nd(&S,Tcl_GetSt ringResult(inte rp),-1);
        > Tcl_DStringAppe nd(&S,": ",-1);
        > Tcl_DStringAppe nd(&S,initialis ation,-1);
        > zend_error(E_WA RNING,Tcl_DStri ngValue(&S));
        > Tcl_DStringFree (&S);
        > return FAILURE;
        > }
        > return SUCCESS;
        > }
        >
        > ZEND_MSHUTDOWN_ FUNCTION(tclphp ) {
        > Tcl_DeleteInter p(interp);
        > interp = 0;
        > return SUCCESS;
        > }
        >
        > /* implement function that is meant to be made available to PHP */
        > ZEND_FUNCTION(t clphp) {
        > 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_param eters_ex(1,&scr ipt)!=SUCCESS) WRONG_PARAM_COU NT;
        > Type = 's';
        > }else if (argc==2) {
        > if (zend_get_param eters_ex(2,&typ e,&script)!=SUC CESS) WRONG_PARAM_COU NT;
        > if (argc==2 && (*type)->type!=IS_STRIN G) convert_to_stri ng_ex(type);
        > Type = tolower(Z_STRVA L_PP(type)[0]);
        > }else {
        > WRONG_PARAM_COU NT;
        > }
        > if ((*script)->type!=IS_STRIN G) {
        > convert_to_stri ng_ex(script);
        > }
        >
        > /*
        > Evaluate the script and coerce to the desired return value.
        > */
        > Script = Tcl_NewStringOb j(Z_STRVAL_PP(s cript),Z_STRLEN _PP(script));
        > Tcl_IncrRefCoun t(Script);
        > rc = Tcl_EvalObjEx(i nterp,Script,TC L_EVAL_DIRECT|T CL_EVAL_GLOBAL) ;
        > Tcl_DecrRefCoun t(Script);
        > result = Tcl_GetObjResul t(interp);
        > switch (rc==TCL_OK ? Type : 0) {
        > case 0: /*error*/ error: {
        > char *s = Tcl_GetStringRe sult(interp);
        > zend_error(E_WA RNING,s);
        > RETVAL_NULL();
        > } break;
        > case 'd': /*double*/ {
        > double d;
        > if (Tcl_GetDoubleF romObj(interp,r esult,&d)!=TCL_ OK) goto error;
        > RETVAL_DOUBLE(d );
        > } break;
        > case 'i': case 'l': /*long int*/ {
        > long l;
        > if (Tcl_GetLongFro mObj(interp,res ult,&l)!=TCL_OK ) goto error;
        > RETVAL_LONG(l);
        > } break;
        > case 'b': /*boolean*/ {
        > int b;
        > if (Tcl_GetBoolean FromObj(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_ListObjGet Elements(interp ,result,&N,&P)! =TCL_OK) goto error;
        > else if (N&1) {
        > Tcl_SetResult(i nterp,"returned list for array has odd number of elements",TCL_S TATIC);
        > goto error;
        > }
        > array_init(retu rn_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,in dex,lval);
        > }else if (Tcl_GetDoubleF romObj(0,P[1],&dval)==TCL_OK ) {
        > add_index_doubl e(return_value, index,dval);
        > }else if (Tcl_GetLongFro mObj(0,P[1],&lval)==TCL_OK ) {
        > add_index_long( return_value,in dex,lval);
        > }else if (Tcl_GetBoolean FromObj(0,P[1],&bval)==TCL_OK ) {
        > add_index_long( return_value,in dex,(long)bval) ;
        > }else {
        > sval = Tcl_GetStringFr omObj(P[1],&slen);
        > add_index_strin gl(return_value ,index,sval,sle n,1);
        > }
        > }else {
        > char *key = Tcl_GetStringFr omObj(P[0],0);
        > if (isLong(P[1],&lval)) {
        > add_assoc_long( return_value,ke y,lval);
        > }else if (Tcl_GetDoubleF romObj(0,P[1],&dval)==TCL_OK ) {
        > add_assoc_doubl e(return_value, key,dval);
        > }else if (Tcl_GetLongFro mObj(0,P[1],&lval)==TCL_OK ) {
        > add_assoc_long( return_value,ke y,lval);
        > }else if (Tcl_GetBoolean FromObj(0,P[1],&bval)==TCL_OK ) {
        > add_assoc_long( return_value,ke y,(long)bval);
        > }else {
        > sval = Tcl_GetStringFr omObj(P[1],&slen);
        > add_assoc_strin gl(return_value ,key,sval,slen, 1);
        > }
        > }
        > }
        > } break;
        > default: /*string*/ {
        > int n; char *s = Tcl_GetStringFr omObj(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?[/color]

        Comment

        • Cameron Laird

          #5
          Re: TCL/PHP problem involving a PHP function that has to utilize a TCL proc

          In article <1141857256.724 176.40940@j52g2 000cwj.googlegr oups.com>,
          comp.lang.tcl <phillip.s.powe ll@gmail.com> wrote:[color=blue]
          >I wrote this PHP function in the hopes that it would properly use a TCL
          >proc I wrote about 4 years ago:[/color]

          Comment

          Working...