home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 18 REXX
/
18-REXX.zip
/
rexxtk12.zip
/
rexxtk.c
< prev
next >
Wrap
Text File
|
2002-08-07
|
21KB
|
607 lines
/*
* Rexx/Tk
* Copyright (C) 1999 Roger O'Connor <ocon@metronet.com>
* Copyright (C) 2000-2001 Mark Hessling <M.Hessling@qut.edu.au>
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Library General Public
* License as published by the Free Software Foundation; either
* version 2 of the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Library General Public License for more details.
*
* You should have received a copy of the GNU Library General Public
* License along with this library; if not, write to the Free
* Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/
#include "rexxtk.h"
#define MAX_VARIABLE_NAME_LENGTH 350
/* take the 'start'th argument and check what kind of option parsing
* we are going to be doing and pass it off to the routine that will
* handle that type. */
int rtk_procOptArgs(RFH_ARG0_TYPE name,char czCommand[], RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG1_TYPE start) {
int rc;
/* If the first character of the first argument is
* a dash, then we process them in a row as is. */
if ( argv[start].strptr[0] == '-' )
rc = rtk_procOptArgDash(name,czCommand, argc, argv, start);
/* if the last character of the first arg is a dot,
* then we parse as option arrays */
else if ( argv[start].strptr[argv[start].strlength-1] == '.' )
rc =rtk_procOptArgArray(name,czCommand, argv, start);
/* otherwise, we assume the indirect opt arg name
* variable usage */
else
rc =rtk_procOptArgIndirect(name,czCommand, argc, argv, start);
return rc;
}
/* take the next args (starting at start) and parses them as 'option'
* and 'value' pairs for tk and adds them to the czCommand string */
int rtk_procOptArgDash(RFH_ARG0_TYPE name,char czCommand[], RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG1_TYPE start) {
ULONG i;
if ( argc > start
&& (argc-start) % 2 == 0 )
{
for (i=start; i<argc; i=i+2)
{
/* if this argument starts with a dash then its a valid
* switch; the next argt is a value and it should
* be quoted */
if (argv[i].strptr[0] == '-')
{
/* check the option name for options
* that require special handling. */
if (!strncmp(argv[i].strptr, "-rexx", argv[i].strlength))
{
/*
* If -rexx; convert to -command and value to
* {setRexxtk value}
*/
strcat(czCommand, " -command {setRexxtk ");
strncat(czCommand, argv[i+1].strptr, argv[i+1].strlength);
strcat(czCommand, "}");
}
else if (!strncmp(argv[i].strptr, "-xscrollrexx", argv[i].strlength))
{
/*
* If -xscrollrexx; convert to -xscrollcommand and value to
* {setRexxtk value}
*/
strcat(czCommand, " -xscrollcommand {setRexxtk ");
strncat(czCommand, argv[i+1].strptr, argv[i+1].strlength);
strcat(czCommand, "}");
}
else if (!strncmp(argv[i].strptr, "-yscrollrexx", argv[i].strlength))
{
/*
* If -yscrollrexx; convert to -yscrollcommand and value to
* {setRexxtk value}
*/
strcat(czCommand, " -yscrollcommand {setRexxtk ");
strncat(czCommand, argv[i+1].strptr, argv[i+1].strlength);
strcat(czCommand, "}");
}
else
{ /* normal quoting */
strcat(czCommand, " ");
strncat(czCommand, argv[i].strptr, argv[i].strlength);
strcat(czCommand, " {");
strncat(czCommand, argv[i+1].strptr, argv[i+1].strlength);
strcat(czCommand, "}");
}
}
else
{
RxDisplayError(name, "*ERROR* Option switches must be specified in pairs: -switch value");
return 1;
}
}
}
else
{
RxDisplayError(name, "*ERROR* Option switches must be specified in pairs: -switch value");
return 1;
}
return 0;
}
/* takes the remaining arguments and parses them as names
* of options with the matching value stored in the rexx
* variable of the same name. */
int rtk_procOptArgIndirect(RFH_ARG0_TYPE name,char czCommand[], RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG1_TYPE start) {
char varname[MAX_VARIABLE_NAME_LENGTH+1];
RXSTRING value;
ULONG i;
for (i=start; i<argc; i++)
{
/* get the rexx variable and if it has anything
* in it, treat that as the option value */
if ( argv[i].strlength > MAX_VARIABLE_NAME_LENGTH )
return 40;
varname[0] = '\0';
strncat(varname, argv[i].strptr, argv[i].strlength);
varname[argv[i].strlength] = '\0';
if (GetRexxVariable(varname,&value,-1) != NULL)
{
/* check the option name for options
* that require special handling. */
if (!strncmp(argv[i].strptr, "rexx", argv[i].strlength))
{
/*
* If rexx; convert to -command and value to
* {setRexxtk value}
*/
strcat(czCommand, " -command {setRexxtk ");
strncat(czCommand, value.strptr, value.strlength);
strcat(czCommand, "}");
}
else if (!strncmp(argv[i].strptr, "xscrollrexx", argv[i].strlength))
{
/*
* If xscrollrexx; convert to -xscrollcommand and value to
* {setRexxtk value}
*/
strcat(czCommand, " -xscrollcommand {setRexxtk ");
strncat(czCommand, value.strptr, value.strlength);
strcat(czCommand, "}");
}
else if (!strncmp(argv[i].strptr, "yscrollrexx", argv[i].strlength))
{
/*
* If yscrollrexx; convert to -yscrollcommand and value to
* {setRexxtk value}
*/
strcat(czCommand, " -yscrollcommand {setRexxtk ");
strncat(czCommand, value.strptr, value.strlength);
strcat(czCommand, "}");
}
else
{
strcat(czCommand, " -");
strncat(czCommand, argv[i].strptr, argv[i].strlength);
strcat(czCommand, " {");
strncat(czCommand, value.strptr, value.strlength);
strcat(czCommand, "}");
}
free(value.strptr);
}
}
return 0;
}
/* takes the next two args from the rexx argument list and treats them as
* the names of a pair of name/value arrays to fetch the remaining Tcl
* arguments from */
int rtk_procOptArgArray(RFH_ARG0_TYPE name,char czCommand[], RFH_ARG2_TYPE argv, RFH_ARG1_TYPE start) {
char nameName[MAX_VARIABLE_NAME_LENGTH+1]="\0";
char valueName[MAX_VARIABLE_NAME_LENGTH+1]="\0";
static char sbuff[1024];
RXSTRING varname;
RXSTRING value;
RXSTRING *rc_value;
ULONG i;
if ( argv[start].strlength > MAX_VARIABLE_NAME_LENGTH )
return 40;
if ( argv[start+1].strlength > MAX_VARIABLE_NAME_LENGTH )
return 40;
strncat(nameName, argv[start].strptr,argv[start].strlength);
nameName[argv[start].strlength] = '\0'; /* NULL terminate */
strncat(valueName, argv[start+1].strptr,argv[start+1].strlength);
valueName[argv[start+1].strlength] = '\0'; /* NULL terminate */
for (i=1;1;i++) {
if (GetRexxVariable(nameName,&varname,i) == NULL)
/* then it wasn't defined, so we're done */
break;
rc_value = GetRexxVariable(valueName,&value,i);
sbuff[0] = '\0';
strncat(sbuff, varname.strptr, varname.strlength);
/*
* Check the options and handle the value based on some
* special situations for various options.
*/
if (!strcmp(sbuff, "rexx"))
{
/*
* If rexx; convert to -command and value to
* {setRexxtk value}
*/
strcat(czCommand, " -command {setRexxtk ");
strncat(czCommand, value.strptr, value.strlength);
strcat(czCommand, "}");
}
else if (!strcmp(sbuff, "xscrollrexx"))
{
/*
* If xscrollrexx; convert to -xscrollcommand and value to
* {setRexxtk value}
*/
strcat(czCommand, " -xscrollcommand {setRexxtk ");
strncat(czCommand, value.strptr, value.strlength);
strcat(czCommand, "}");
}
else if (!strcmp(sbuff, "yscrollrexx"))
{
/*
* If yscrollrexx; convert to -yscrollcommand and value to
* {setRexxtk value}
*/
strcat(czCommand, " -yscrollcommand {setRexxtk ");
strncat(czCommand, value.strptr, value.strlength);
strcat(czCommand, "}");
}
else
{
/* cat the option name with a hyphen */
strcat(czCommand, " -");
strncat(czCommand, varname.strptr, varname.strlength);
/* cat the value if there is one */
if (rc_value!=NULL)
{
strcat(czCommand, " {");
sbuff[0] = '\0';
strncat(czCommand, value.strptr, value.strlength);
strcat(czCommand, "}");
}
}
free(varname.strptr);
free(value.strptr);
}
return 0;
}
/*
* Handle the Tcl RexxTkInterp error message...
* at this time we are just outputting to stdout.
*/
void SetIntError(REXXTKDATA *RexxTkData,int errnum, char *errstr )
{
char buf[20];
RexxTkData->REXXTK_IntCode = errnum;
InternalTrace("SetIntError", "Error Number: %d String: %s", errnum, errstr );
(void)sprintf(buf, "%ld", errnum);
(void)SetRexxVariable("TKRC", 4,buf, strlen(buf));
(void)sprintf(RexxTkData->REXXTK_ErrMsg, "Rexx/Tk:%ld: Tcl Line: %d: %s", errnum, RexxTkData->RexxTkInterp->errorLine,errstr);
}
/*
* Clear the internal error code, error message etc.
*/
void ClearIntError(REXXTKDATA *RexxTkData)
{
RexxTkData->REXXTK_IntCode = 0;
InternalTrace("ClearIntError", NULL );
/*
* Set RC variable
*/
(void)SetRexxVariable("TKRC", 4,"0", 1);
strcpy(RexxTkData->REXXTK_ErrMsg,"");
return;
}
int ReturnError
( REXXTKDATA *RexxTkData, RXSTRING *retstr, int errnum, char *errstr )
{
InternalTrace( "ReturnError", "%x,%d %s", retstr, errnum, errstr );
SetIntError(RexxTkData,errnum, errstr );
sprintf( (char *)retstr->strptr, "%ld", errnum );
retstr->strlength = strlen( (char *)retstr->strptr );
return( 0 );
}
/*
* A routine to handle a generic type of Tcl Function - TYPE A
* which are in the tcl form:
* command pathName ?options?
* and are in the rexx form:
* TkCommand(pathName, [options...])
*/
RFH_RETURN_TYPE rtk_TypeA
(REXXTKDATA *RexxTkData, char czTclCommand[], RFH_ARG0_TYPE name,char *czCommand, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG4_TYPE retstr )
{
if (RexxTkData->REXXTK_IntCode) ClearIntError(RexxTkData);
if ( my_checkparam( name, argc, 1, 0 ) )
return 1;
czTclCommand[0] = '\0';
strcat(czTclCommand, czCommand);
strcat(czTclCommand, " ");
strncat(czTclCommand, argv[0].strptr, argv[0].strlength);
if (argc >= 2)
{
if ( rtk_procOptArgs(name,czTclCommand,argc,argv,1) )
return 1;
}
DEBUGDUMP(fprintf(stderr,"%s-%d: (%s) command: %s\n",__FILE__,__LINE__,name,czTclCommand);)
if (Tcl_Eval(RexxTkData->RexxTkInterp, czTclCommand) != TCL_OK) {
return ReturnError( RexxTkData, retstr, -1, RexxTkData->RexxTkInterp->result );
}
return RxReturnString( retstr, RexxTkData->RexxTkInterp->result ) ;
}
/*
* A routine to handle a generic type of Tcl Function - TYPE B
* which are in the tcl form:
* command arg ?arg arg ...?
* and are in the rexx form:
* TkCommand(arg, [arg, arg, ...])
*/
RFH_RETURN_TYPE rtk_TypeB
(REXXTKDATA *RexxTkData, char czTclCommand[], RFH_ARG0_TYPE name,char *czCommand, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG4_TYPE retstr)
{
/*
* TODO: the quoting in this routine needs to be beefed up.
* Currently we are quoting everything with braces even if it's
* not needed. This means that you can't use a brace in an argument.
*/
int i;
if (RexxTkData->REXXTK_IntCode) ClearIntError(RexxTkData);
if ( my_checkparam( name, argc, 1, 0 ) )
return 1;
czTclCommand[0] = '\0';
strcat(czTclCommand, czCommand);
strcat(czTclCommand, " {"); /* we want to quote all the args -- in case */
strncat(czTclCommand, argv[0].strptr, argv[0].strlength);
for (i = 1; i < (int)argc; i++){
strcat(czTclCommand, "} {");
strncat(czTclCommand, argv[i].strptr, argv[i].strlength);
}
strcat(czTclCommand, "}");
DEBUGDUMP(fprintf(stderr,"%s-%d: (%s) command: %s\n",__FILE__,__LINE__,name,czTclCommand);)
if (Tcl_Eval(RexxTkData->RexxTkInterp, czTclCommand) != TCL_OK) {
return ReturnError( RexxTkData, retstr, -1, RexxTkData->RexxTkInterp->result );
}
return RxReturnString( retstr, RexxTkData->RexxTkInterp->result ) ;
}
/*
* A routine to handle a generic type of Tcl Function - TYPE C
* which are in the tcl form:
* pathName command ?arg arg ...?
* and are in the rexx form:
* TkCommand(pathName [,arg, arg, ...])
*/
RFH_RETURN_TYPE rtk_TypeC
(REXXTKDATA *RexxTkData, char czTclCommand[], RFH_ARG0_TYPE name,char *czCommand, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG4_TYPE retstr)
{
int i;
if (RexxTkData->REXXTK_IntCode) ClearIntError(RexxTkData);
if ( my_checkparam( name, argc, 1, 0 ) )
return 1;
czTclCommand[0] = '\0';
strncat(czTclCommand, argv[0].strptr, argv[0].strlength);
strcat(czTclCommand, " ");
strcat(czTclCommand, czCommand);
for (i = 1; i < (int)argc; i++){
strcat(czTclCommand, " \"");
strncat(czTclCommand, argv[i].strptr, argv[i].strlength);
strcat(czTclCommand, "\"");
}
DEBUGDUMP(fprintf(stderr,"%s-%d: (%s) command: %s\n",__FILE__,__LINE__,name,czTclCommand);)
if (Tcl_Eval(RexxTkData->RexxTkInterp, czTclCommand) != TCL_OK) {
return ReturnError( RexxTkData, retstr, -1, RexxTkData->RexxTkInterp->result );
}
return RxReturnString( retstr, RexxTkData->RexxTkInterp->result ) ;
}
/*
* A routine to handle a generic type of Tcl Function - TYPE D
* which are in the tcl form:
* pathName command arg ?options?
* and are in the rexx form:
* TkCommand(pathName, arg, [options...])
*/
RFH_RETURN_TYPE rtk_TypeD
(REXXTKDATA *RexxTkData, char czTclCommand[], RFH_ARG0_TYPE name, char *czCommand, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG4_TYPE retstr )
{
if (RexxTkData->REXXTK_IntCode) ClearIntError(RexxTkData);
if ( my_checkparam( name, argc, 2, 0 ) )
return 1;
czTclCommand[0] = '\0';
strncat(czTclCommand, argv[0].strptr, argv[0].strlength);
strcat(czTclCommand, " ");
strcat(czTclCommand, czCommand);
strcat(czTclCommand, " ");
strncat(czTclCommand, argv[1].strptr, argv[1].strlength);
if (argc > 2)
{
if ( rtk_procOptArgs(name,czTclCommand,argc,argv,2) )
return 1;
}
DEBUGDUMP(fprintf(stderr,"%s-%d: (%s) command: %s\n",__FILE__,__LINE__,name,czTclCommand);)
if (Tcl_Eval(RexxTkData->RexxTkInterp, czTclCommand) != TCL_OK) {
return ReturnError( RexxTkData, retstr, -1, RexxTkData->RexxTkInterp->result );
}
return RxReturnString( retstr, RexxTkData->RexxTkInterp->result ) ;
}
/*
* A routine to handle a generic type of Tcl Function - TYPE E
* which are in the tcl form:
* pathName command ?options?
* and are in the rexx form:
* TkCommand(pathName, [options...])
*/
RFH_RETURN_TYPE rtk_TypeE
(REXXTKDATA *RexxTkData, char czTclCommand[], RFH_ARG0_TYPE name,char *czCommand, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG4_TYPE retstr)
{
if (RexxTkData->REXXTK_IntCode) ClearIntError(RexxTkData);
if ( my_checkparam( name, argc, 1, 0 ) )
return 1;
czTclCommand[0] = '\0';
strncat(czTclCommand, argv[0].strptr, argv[0].strlength);
strcat(czTclCommand, " ");
strcat(czTclCommand, czCommand);
if (argc > 1)
{
if ( rtk_procOptArgs(name,czTclCommand,argc,argv,1) )
return 1;
}
DEBUGDUMP(fprintf(stderr,"%s-%d: (%s) command: %s\n",__FILE__,__LINE__,name,czTclCommand);)
if (Tcl_Eval(RexxTkData->RexxTkInterp, czTclCommand) != TCL_OK) {
return ReturnError( RexxTkData, retstr, -1, RexxTkData->RexxTkInterp->result );
}
return RxReturnString( retstr, RexxTkData->RexxTkInterp->result ) ;
}
/*
* A routine to handle a generic type of Tcl Function - TYPE F
* which are in the tcl form:
* command pathName ?pathName? ?options?
* or
* command arg ?arg? ?options?
* and are in the rexx form:
* TkCommand(pathName [,pathName...] [options...])
* or
* TkCommand(arg [,arg...] [options...])
*/
RFH_RETURN_TYPE rtk_TypeF
(REXXTKDATA *RexxTkData, char czTclCommand[], RFH_ARG0_TYPE name,char *czCommand, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG4_TYPE retstr)
{
int i;
FunctionPrologue( (char *)name, argc, argv );
if (RexxTkData->REXXTK_IntCode) ClearIntError( RexxTkData);
czTclCommand[0] = '\0';
strcat(czTclCommand, czCommand);
for (i = 0; i < (int)argc; i++){
/*
* check if the arg has a dash as the first char,
* if so, it's the start of the options
* This allows either pathnames or args before options
*/
if (argv[i].strptr[0] == '-')
{
if ( rtk_procOptArgs(name,czTclCommand,argc,argv,i) )
return 1;
break;
}
strcat(czTclCommand, " ");
strncat(czTclCommand, argv[i].strptr, argv[i].strlength);
}
DEBUGDUMP(fprintf(stderr,"%s-%d: (%s) command: %s\n",__FILE__,__LINE__,name,czTclCommand);)
if (Tcl_Eval(RexxTkData->RexxTkInterp, czTclCommand) != TCL_OK) {
return ReturnError( RexxTkData, retstr, -1, RexxTkData->RexxTkInterp->result );
}
return RxReturnString( retstr, RexxTkData->RexxTkInterp->result ) ;
}
/*
* A routine to handle a generic type of Tcl Function - TYPE G
* which are in the tcl form:
* command pathName arg ?options?
* and are in the rexx form:
* TkCommand(pathName, arg [,options...])
*/
RFH_RETURN_TYPE rtk_TypeG
(REXXTKDATA *RexxTkData, char czTclCommand[], RFH_ARG0_TYPE name,char *czCommand, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG4_TYPE retstr )
{
if (RexxTkData->REXXTK_IntCode) ClearIntError(RexxTkData);
if ( my_checkparam( name, argc, 2, 0 ) )
return 1;
strcpy(czTclCommand, czCommand);
strcat(czTclCommand, " ");
strncat(czTclCommand, argv[0].strptr, argv[0].strlength);
strcat(czTclCommand, " ");
strncat(czTclCommand, argv[1].strptr, argv[1].strlength);
if (argc >= 3)
{
if ( rtk_procOptArgs(name,czTclCommand,argc,argv,2) )
return 1;
}
DEBUGDUMP(fprintf(stderr,"%s-%d: (%s) command: %s\n",__FILE__,__LINE__,name,czTclCommand);)
if (Tcl_Eval(RexxTkData->RexxTkInterp, czTclCommand) != TCL_OK) {
return ReturnError( RexxTkData, retstr, -1, RexxTkData->RexxTkInterp->result );
}
return RxReturnString( retstr, RexxTkData->RexxTkInterp->result ) ;
}
/*
* A routine to handle a generic type of Tcl Function - TYPE H
* which are in the tcl form:
* command ?options?
* and are in the rexx form:
* TkCommand(option [,options...])
*/
RFH_RETURN_TYPE rtk_TypeH
(REXXTKDATA *RexxTkData, char czTclCommand[], RFH_ARG0_TYPE name,char *czCommand, RFH_ARG1_TYPE argc, RFH_ARG2_TYPE argv, RFH_ARG4_TYPE retstr )
{
if (RexxTkData->REXXTK_IntCode) ClearIntError(RexxTkData);
if ( my_checkparam( name, argc, 1, 0 ) )
return 1;
strcpy(czTclCommand, czCommand);
strcat(czTclCommand, " ");
if ( rtk_procOptArgs(name,czTclCommand,argc,argv,0) )
return 1;
DEBUGDUMP(fprintf(stderr,"%s-%d: (%s) command: %s\n",__FILE__,__LINE__,name,czTclCommand);)
if (Tcl_Eval(RexxTkData->RexxTkInterp, czTclCommand) != TCL_OK) {
return ReturnError( RexxTkData, retstr, -1, RexxTkData->RexxTkInterp->result );
}
return RxReturnString( retstr, RexxTkData->RexxTkInterp->result ) ;
}