/* * mkGeneric 1.3 * ------------- * * Please see the web pages for releases and documentation. * * Author: Michael Kraus * mailto:mmg_kraus@compuserve.com * http://ourworld.compuserve.com/homepages/mmg_kraus * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted. * The author makes no representations about the suitability of this * software for any purpose. It is provided "as is" without express * or implied warranty. By use of this software the user agrees to * indemnify and hold harmless the author from any claims or * liability for loss arising out of such use. * */ /* required to built a dll using stubs. should be a compiler option */ /* #define USE_TCL_STUBS */ #include #include #include #include #include #ifndef TRUE # define TRUE 1 # define FALSE 0 #endif /* copied from sun's example.c */ #ifdef __WIN32__ #if defined(__WIN32__) # define WIN32_LEAN_AND_MEAN # include # undef WIN32_LEAN_AND_MEAN # if defined(_MSC_VER) # define EXPORT(a,b) __declspec(dllexport) a b # define DllEntryPoint DllMain # else # if defined(__BORLANDC__) # define EXPORT(a,b) a _export b # else # define EXPORT(a,b) a b # endif # endif #else # define EXPORT(a,b) a b #endif EXTERN EXPORT(int,Mkgeneric_Init) _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN EXPORT(int,Mkgeneric_SafeInit) _ANSI_ARGS_((Tcl_Interp *interp)); BOOL APIENTRY DllEntryPoint(HINSTANCE hInst, DWORD reason, LPVOID reserved) { return TRUE; } #endif /* mkGeneric version number */ #define _VERSION "1.3" /* some acronyms for popular Tcl_xxx functions */ #define _NSO(pcText) Tcl_NewStringObj( pcText, -1 ) #define _SSO(pO,pcText) Tcl_SetStringObj( pO, pcText, -1 ) #define _GSO(pO) Tcl_GetStringFromObj( pO, NULL ) #define _NIO(iVal) Tcl_NewIntObj( iVal ) #define _SIO(pO,iVal) Tcl_SetIntObj( pO, iVal ) #define _GIO(pO,piVal) Tcl_GetIntFromObj( pI, pO, piVal ) #define _NBO(bVal) Tcl_NewBooleanObj( bVal ) #define _SBO(pO,bVal) Tcl_SetBooleanObj( pO, bVal ) #define _GBO(pO,pbVal) Tcl_GetBooleanFromObj( pI, pO, pbVal ) #define _NDO(fVal) Tcl_NewDoubleObj( fVal ) #define _SDO(pO,fVal) Tcl_SetDoubleObj( pO, fVal ) #define _GDO(pO,pfVal) Tcl_GetDoubleFromObj( pI, pO, pfVal ) #define _NAO(pcDt,iLen) Tcl_NewByteArrayObj( pcDt, iLen ) #define _SAO(pO,pcDt,iLen) Tcl_SetByteArrayObj( pO, pcDt, iLen ) #define _GAO(pO,piLen) Tcl_GetByteArrayFromObj( pO, piLen ) #define _LOAL(pO,pNewO) Tcl_ListObjAppendList( pI, pO, pNewO ) #define _LOAE(pO,pNewO) Tcl_ListObjAppendElement( pI, pO, pNewO ) #define _LOGL(pO,piLen) Tcl_ListObjLength( pI, pO, piLen ) #define _LOGI(pO,iI,poE) Tcl_ListObjIndex( pI, pO, iI, poE ) #define _LOGE(pO,piC,ppV) Tcl_ListObjGetElements( pI, pO, piC, ppV ) #define _LORE(pO,iPos,poE) Tcl_ListObjReplace( pI, pO, iPos, 1, 1, poE ) #define _LODE(pO,iPos) Tcl_ListObjReplace( pI, pO, iPos, 1, 0, NULL ) #define _OSV(po1,po2,poV) Tcl_ObjSetVar2( pI, po1, po2, poV, TCL_LEAVE_ERR_MSG ) #define _OGV(po1,po2) Tcl_ObjGetVar2( pI, po1, po2, TCL_LEAVE_ERR_MSG ) #define _OUV(po1,po2) Tcl_UnsetVar2( pI, _GSO(po1), (po2==NULL)?NULL:_GSO(po2), TCL_LEAVE_ERR_MSG ) #define _OSVG(po1,po2,poV) Tcl_ObjSetVar2( pI, po1, po2, poV, TCL_GLOBAL_ONLY ) #define _OGVG(po1,po2) Tcl_ObjGetVar2( pI, po1, po2, TCL_GLOBAL_ONLY ) #define _OUVG(po1,po2) Tcl_UnsetVar2( pI, _GSO(po1), (po2==NULL)?NULL:_GSO(po2), TCL_GLOBAL_ONLY ) #define _OGVG2(pc1,pc2) Tcl_GetVar2Ex( pI, pc1, pc2, TCL_GLOBAL_ONLY ) #define _NOB Tcl_NewObj() #define _DOB Tcl_DuplicateObj #define _SOB(pO) Tcl_IsShared( pO )? Tcl_DuplicateObj( pO ):pO #define _ASO Tcl_AppendStringsToObj #define _DRC Tcl_DecrRefCount #define _IRC Tcl_IncrRefCount #define _SEC(pO) Tcl_SetObjErrorCode( pI, pO ) #define _AEI(pC,iL) Tcl_AddObjErrorInfo( pI, pC, iL ) #define _GOR Tcl_GetObjResult( pI ) #define _SOR(pO) Tcl_SetObjResult( pI, pO ) #define _ROR Tcl_ResetResult( pI ) #define _GIFO(pO,pA,pcTxt,piRes) Tcl_GetIndexFromObj( pI, pO, pA, pcTxt, 0, piRes ) #define _WNA(objc,pcText) ( Tcl_WrongNumArgs( pI, objc, objv, pcText ), TCL_ERROR ) /* my very own exception handling */ #define try( Expr, Excep ) { if( Expr != TCL_OK ) throw Excep; } #define throw goto #define catch /* the following is needed for the sha-256 algorithm */ #define _R(x,n) (((x)>>(n))|((x)<<(32-(n)))) #define _S(x,n) ((x)>>(n)) #define _CH(x,y,z) (((x)&(y))|(~(x)&(z))) #define _MAJ(x,y,z) (((x)&(y))|((x)&(z))|((y)&(z))) #define _SIG0(x) (_R(x, 2)^_R(x,13)^_R(x,22)) #define _SIG1(x) (_R(x, 6)^_R(x,11)^_R(x,25)) #define _sig0(x) (_R(x, 7)^_R(x,18)^_S(x, 3)) #define _sig1(x) (_R(x,17)^_R(x,19)^_S(x,10)) /* the function prototypes. */ int Mkgeneric_Init( Tcl_Interp * ); int Mkgeneric_SafeInit( Tcl_Interp * ); int Mkg_Round2Func( ClientData, Tcl_Interp *, Tcl_Value *, Tcl_Value * ); int Mkg_MinMaxFunc( ClientData, Tcl_Interp *, Tcl_Value *, Tcl_Value * ); int Mkg_IsTypeFunc( ClientData, Tcl_Interp *, Tcl_Value *, Tcl_Value * ); int Mkg_IsEvenFunc( ClientData, Tcl_Interp *, Tcl_Value *, Tcl_Value * ); int Mkg_ConstFunc ( ClientData, Tcl_Interp *, Tcl_Value *, Tcl_Value * ); int Mkg_ThrowCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_TryCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_DecodeCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_CompleteCmd( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_LinlistCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_LdeleteCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_LextendCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_LshrinkCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_LchangeCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_LnextCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_LassignCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_LevalCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_LstatCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_LinterCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_LunionCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_LmirrorCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_LoopCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_DoCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_FincrCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_OptionsCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_HexdumpCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_EncryptCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_DecryptCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_ChecksumCmd( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_HashCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); int Mkg_IgnoreCmd ( ClientData, Tcl_Interp *, int, Tcl_Obj *CONST[] ); /* _MkgCompareInt comparison function for the qsort() in ldelete. compares two integers. see the documentation on qsort. */ int _MkgCompareInt( const void *piInt1, const void *piInt2 ) { if( *(int*)piInt1 < *(int*)piInt2 ) return -1; if( *(int*)piInt1 > *(int*)piInt2 ) return 1; else return 0; } /* _MkgCompareObj comparison function for the qsort() in lunion, linter. compares the string representation of two objects. see the documentation on qsort. */ int _MkgCompareObj( const void *poObj1, const void *poObj2 ) { return strcmp( _GSO( *(Tcl_Obj**)poObj1 ), _GSO( *(Tcl_Obj**)poObj2 ) ); } /* _MkgGetIndex utility function. transforms an index like "end-4" into an integer. iLen is the length of the list to which the index refers. used for ldelete. */ int _MkgGetIndex( Tcl_Interp *pI, Tcl_Obj *poObj, int iLen, int *piIndex ) { int iIndex; if( _GIO( poObj, &iIndex ) == TCL_OK ) *piIndex = iIndex; else if( ! strcmp( _GSO( poObj ), "end" ) || ! strcmp( _GSO( poObj ), "end-0" ) ) *piIndex = iLen-1; else if( ! strncmp( _GSO( poObj ), "end-", 4 ) && ( iIndex = atoi( _GSO( poObj ) + 4 ) ) != 0 ) *piIndex = iLen-iIndex-1; else throw eError; return TCL_OK; catch eError: _ROR; _ASO( _GOR, "bad index ", _GSO( poObj ), ": must be integer or end?-integer?", NULL ); return TCL_ERROR; } /* _MkgTEAencrypt this is TEA, the "Tiny Encryption Algorithm". TEA is public domain, very simple and fast. TEA en/deciphers 64 bit with a 128 bit key. the code below is taken right off the internet, e.g.: http://www.ftp.cl.cam.ac.uk/ftp/papers/djw-rmn/djw-rmn-tea.html http://www.vader.brad.ac.uk/tea/tea.shtml */ void _MkgTEAencrypt( unsigned long *v, unsigned long *k ) { register unsigned long y=v[0], z=v[1], sum=0, delta=0x9E3779B9, n=32; while( n-- > 0 ) { y += (z << 4 ^ z >> 5) + z ^ sum + k[sum&3]; sum += delta; z += (y << 4 ^ y >> 5) + y ^ sum + k[sum>>11 & 3]; } v[0]=y; v[1]=z; } /* _MkgTEAdecrypt see above. */ void _MkgTEAdecrypt( unsigned long *v, unsigned long *k ) { register unsigned long y=v[0], z=v[1], sum=0xC6EF3720, delta=0x9E3779B9, n=32; while( n-- > 0 ) { z -= (y << 4 ^ y >> 5) + y ^ sum + k[sum>>11 & 3]; sum -= delta; y -= (z << 4 ^ z >> 5) + z ^ sum + k[sum&3]; } v[0]=y; v[1]=z; } /* _MkgConvertEndian helper function for the hash and crypt commands. converts an array of longs into big endian, if the host machine is little endian (such as pentiums). iBytes must be an integer multiple of 4. */ static void _MkgConvertEndian( void* pvData, int iBytes ) { static int bTested, bLittleEndian; unsigned long *plLongs = (unsigned long*) pvData; int i; if( ! bTested ) { unsigned long lTest = 0x01; bLittleEndian = *((unsigned char*)(&lTest)); bTested = 1; } if ( bLittleEndian ) for ( i = 0; i < ( iBytes >> 2 ); i++ ) plLongs[i] = ( ( ( plLongs[i] & 0xffU ) << 24 ) | ( ( plLongs[i] & 0xff00U ) << 8 ) | ( ( plLongs[i] & 0xff0000U ) >> 8 ) | ( ( plLongs[i] & 0xff000000U ) >> 24 ) ); } /* _MkgShaTransform the transform function of sha-256. called by _MkgSha256. this is taken from source code that is publicly available on the internet. */ static void _MkgShaTransform( unsigned long *plH, unsigned char *pcM ) { int i; unsigned long lA = plH[ 0 ], lB = plH[ 1 ], lC = plH[ 2 ], lD = plH[ 3 ], lE = plH[ 4 ], lF = plH[ 5 ], lG = plH[ 6 ], lH = plH[ 7 ], lT1, lT2, plW[ 64 ]; static unsigned long plK[] = { 0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5, 0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5, 0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3, 0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174, 0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc, 0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da, 0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7, 0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967, 0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13, 0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85, 0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3, 0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070, 0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5, 0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3, 0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208, 0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2 }; memcpy( plW, pcM, 64 ); for ( i = 16; i < 64; i++ ) plW[i] = _sig1( plW[i-2] ) + plW[i-7] + _sig0( plW[i-15] ) + plW[i-16]; for ( i = 0; i < 64; i++ ) { lT1 = lH + _SIG1( lE ) + _CH( lE, lF, lG ) + plK[i] + plW[i]; lT2 = _SIG0( lA ) + _MAJ( lA, lB, lC ); lH = lG; lG = lF; lF = lE; lE = lD + lT1; lD = lC; lC = lB; lB = lA; lA = lT1 + lT2; } plH[0] += lA; plH[1] += lB; plH[2] += lC; plH[3] += lD; plH[4] += lE; plH[5] += lF; plH[6] += lG; plH[7] += lH; } /* _MkgSha256 the actual sha-256 implementation. normally this is split up into several functions (init, update, finish, digest). this here is a combination of all of them. some simplifications were possible. this is derived from source code that is publicly available on the internet. */ void _MkgSha256( char *pcData, int iBytes, char *pcResult ) { int iMlen; unsigned char pcM[64]; unsigned long plBits[2] = { 0, 0 }; unsigned long plH[8] = { 0x6a09e667, 0xbb67ae85, 0x3c6ef372, 0xa54ff53a, 0x510e527f, 0x9b05688c, 0x1f83d9ab, 0x5be0cd19 }; plBits[0] = iBytes >> 29; plBits[1] = iBytes << 3; while (1) { iMlen = ( iBytes < 64 )? iBytes : 64; memcpy( pcM, pcData, iMlen ); iBytes -= iMlen; pcData += iMlen; if( iMlen < 64 ) break; _MkgConvertEndian( pcM, 64 ); _MkgShaTransform( plH, pcM ); } pcM[iMlen] = 128; if ( ++iMlen < 56 ) { memset( pcM + iMlen, 0, 56 - iMlen ); _MkgConvertEndian( pcM, 56 ); } else { memset( pcM + iMlen, 0, 64 - iMlen ); _MkgConvertEndian( pcM, 64 ); _MkgShaTransform( plH, pcM ); memset( pcM, 0, 56 ); } memcpy( pcM + 56, (void*)plBits, 8 ); _MkgShaTransform( plH, pcM ); memcpy( pcResult, plH, 32 ); _MkgConvertEndian( pcResult, 32 ); } /* Mkg_Round2Func implements the math functions round2, floor2 and ceil2. (int)pC is 2 for ceil2, 1 for floor2, 0 for round2. if both parameters are integers, the result will be an integer, otherwise a double. */ int Mkg_Round2Func( ClientData pC, Tcl_Interp *pI, Tcl_Value *psArgs, Tcl_Value *psResult ) { double f1, f2, fResult; f1 = (psArgs[0].type==TCL_DOUBLE)? psArgs[0].doubleValue:psArgs[0].intValue; f2 = (psArgs[1].type==TCL_DOUBLE)? psArgs[1].doubleValue:psArgs[1].intValue; switch ( (int)pC ) { case 0: fResult = floor((f1+f2/2)/f2)*f2; break; case 1: fResult = floor(f1/f2)*f2; break; case 2: fResult = ceil(f1/f2)*f2; break; } if( psArgs[0].type == TCL_DOUBLE || psArgs[1].type == TCL_DOUBLE ) { psResult->type = TCL_DOUBLE; psResult->doubleValue = fResult; } else { psResult->type = TCL_INT; psResult->intValue = (int)fResult; } return TCL_OK; } /* Mkg_MinMaxFunc implements the math functions min and max. if max has been called, (int)pC is 1, otherwise 0. if both parameters are integers, the result will be an integer, otherwise a double. */ int Mkg_MinMaxFunc( ClientData pC, Tcl_Interp *pI, Tcl_Value *psArgs, Tcl_Value *psResult ) { double f1, f2, fResult; f1 = (psArgs[0].type==TCL_DOUBLE)? psArgs[0].doubleValue:psArgs[0].intValue; f2 = (psArgs[1].type==TCL_DOUBLE)? psArgs[1].doubleValue:psArgs[1].intValue; if( (int)pC ) fResult = (f1>f2)? f1:f2; else fResult = (f1type = TCL_DOUBLE; psResult->doubleValue = fResult; } else { psResult->type = TCL_INT; psResult->intValue = (int)fResult; } return TCL_OK; } /* Mkg_IsTypeFunc implements the math functions isint and isdouble. if isint has been called, (int)pC is 1, otherwise 0. returns 1, if the value is of the given type, otherwise 0. */ int Mkg_IsTypeFunc( ClientData pC, Tcl_Interp *pI, Tcl_Value *psArgs, Tcl_Value *psResult ) { psResult->type = TCL_INT; if( (int)pC ) psResult->intValue = (psArgs[0].type==TCL_DOUBLE)? 0:1; else psResult->intValue = (psArgs[0].type==TCL_DOUBLE)? 1:0; return TCL_OK; } /* Mkg_IsEvenFunc implements the math functions iseven and isodd. if iseven has been called, (int)pC is 1, otherwise 0. returns 1, if the value is even resp. odd, otherwise 0. */ int Mkg_IsEvenFunc( ClientData pC, Tcl_Interp *pI, Tcl_Value *psArgs, Tcl_Value *psResult ) { if( psArgs[0].type != TCL_INT ) throw eError; psResult->type = TCL_INT; psResult->intValue = ( psArgs[0].intValue + (int)pC ) % 2; return TCL_OK; catch eError: _SSO( _GOR, "Operand must be an integer" ); return TCL_ERROR; } /* Mkg_ConstFunc implements the pi and euler constants. */ int Mkg_ConstFunc( ClientData pC, Tcl_Interp *pI, Tcl_Value *psArgs, Tcl_Value *psResult ) { static int bInit; static double fPi, fE; if( ! bInit ) { fPi = 2*acos(0); fE = exp(1); bInit = TRUE; } psResult->type = TCL_DOUBLE; if( (int)pC ) psResult->doubleValue = fE; else psResult->doubleValue = fPi; return TCL_OK; } /* Mkg_ThrowCmd implements the throw command, which is intented to be used in conjunction with the try command. throw always returns TCL_ERROR. this is similar to the standard "error" command, except that the error code is specified first and then an optional message string. also, if throw is called without any arguments, it tries to recover the information about the last error and throws this error again. note that the order of setting the 3 error information parts must not be changed: first the code, then the info, then the result. */ int Mkg_ThrowCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { char *pcInfo; Tcl_Obj *poMsg; if( objc > 4 ) return _WNA( 1, "?code? ?message? ?info?" ); switch( objc ) { case 1: /* first, copy any existing errorCode */ _SEC( _OGVG2( "errorCode", NULL ) ); /* now get the first line of the stack trace and append it again */ pcInfo = _GSO( _OGVG2( "errorInfo", NULL ) ); _AEI( pcInfo, strchr( pcInfo, '\n' ) - pcInfo ); /* finally, if errorMsg was set by a previous try-catch, make it the new result */ if( ( poMsg = _OGVG2( "errorMsg", NULL ) ) != NULL ) _SOR( poMsg ); break; case 2: _SEC( objv[1] ); _ASO( _GOR, "Exception '", _GSO( objv[1] ), "' thrown.", NULL ); break; case 3: _SEC( objv[1] ); _SOR( objv[2] ); break; case 4: _SEC( objv[1] ); _AEI( _GSO( objv[3] ), -1 ); _SOR( objv[2] ); break; } return TCL_ERROR; } /* Mkg_TryCmd implements the try command. it first figures out if the syntax is correct. then evaluates the try-script. if it succeeds (i.e., returns with TCL_OK, TCL_RETURN, TCL_CONTINUE or TCL_BREAK), then it evals the finally-script and goes. if it fails with TCL_ERROR, then it sets the "artificial" variable "errorMsg" so that a catch-script can get the result that the try-script *would* have returned. then looks for the first element of the errorCode and tries to find a matching catch-exception. if it finds one, it evals the associated catch-script. if not, it evals the default catch-script, if any. then it evals the finally-script, if defined. if the catch-script failes, the finally-script is still executed, and then the error caused by the catch-script is propagated. if the finally-script fails, the error is propagated, too. it should all behave like in java. */ int Mkg_TryCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int i, iLast, iObjc, iRes, iResF, bNoFinally; char *pcLastKey, *pcInfo; Tcl_Obj **ppoObjv, *poFinally, *poDefault, *poCode, *poInfo, *poRes; if( objc == 1 || objc == 3 ) return _WNA( 1, "script ?catch pattern script ...? ?catch script? ?finally script?" ); /* assume no default-script and no finally-script */ poFinally = poDefault = NULL; pcLastKey = _GSO( objv[objc-2] ); if( ! ( objc % 3 ) ) /* default-catch and finally must be there */ { if( strcmp( pcLastKey, "finally" ) ) throw eFinally; poFinally = objv[objc-1]; poDefault = objv[objc-3]; } else if( ! ( ( objc - 1 ) % 3 ) ) /* either default or finally is given */ { bNoFinally = strcmp( pcLastKey, "finally" ); if( bNoFinally && strcmp( pcLastKey, "catch" ) ) throw eFinally; if( bNoFinally ) poDefault = objv[objc-1]; else poFinally = objv[objc-1]; } for( i = 2; i <= objc - 3; i += 3 ) /* now check for all catch keywords */ if( strcmp( _GSO( objv[i] ), "catch" ) ) throw eCatch; iRes = Tcl_EvalObj( pI, objv[1] ); /* eval the try script */ if( iRes == TCL_ERROR ) /* error? try to find a catch-handler! */ { /* store result in a var, so that a catch-script can get to it */ Tcl_SetVar2Ex( pI, "errorMsg", NULL, _GOR, TCL_GLOBAL_ONLY ); _LOGE( Tcl_GetVar2Ex( pI, "errorCode", NULL, TCL_GLOBAL_ONLY ), &iObjc, &ppoObjv ); iLast = objc - ( poDefault? 4 : poFinally? 3 : 2 ); /* compare the catch patterns with first element of errorCode */ for( i = 3; i <= iLast; i += 3 ) if( Tcl_StringMatch( _GSO( ppoObjv[0] ), _GSO( objv[i] ) ) ) break; if( i <= iLast ) /* matching pattern found, eval script */ iRes = Tcl_EvalObj( pI, objv[i+1] ); else if( poDefault ) /* no pattern found, eval default catch, if any */ iRes = Tcl_EvalObj( pI, poDefault ); } if( poFinally ) /* eval a given finally script now */ { if( iRes == TCL_ERROR ) /* save error infos from try or catch script */ { poCode = _OGVG2( "errorCode", NULL ); _IRC( poCode ); poInfo = _OGVG2( "errorInfo", NULL ); _IRC( poInfo ); pcInfo = _GSO( poInfo ); poRes = _GOR; _IRC( poRes ); } if( ( iResF = Tcl_EvalObj( pI, poFinally ) ) != TCL_OK ) { /* eval finally script */ _DRC( poCode ); _DRC( poInfo ); _DRC( poRes ); return iResF; /* propagate TCL_ERROR, TCL_BREAK, TCL_CONTINUE */ } if( iRes == TCL_ERROR ) /* restore the saved error information */ { _SEC( poCode ); _DRC( poCode ); _AEI( pcInfo, strchr( pcInfo, '\n' ) - pcInfo ); _DRC( poInfo ); _SOR( poRes ); _DRC( poRes ); } } return iRes; /* propagate the result of the try or the catch script */ catch eFinally: _SSO( _GOR, "Keyword 'finally' not found where expected." ); return TCL_ERROR; catch eCatch: _SSO( _GOR, "Keyword 'catch' not found where expected." ); return TCL_ERROR; } /* Mkg_DecodeCmd implements the decode command. each odd element in list is compared against expr. if it matches the next even element, i.e. the next element, is returned. if there is no match and a default value has been defined, it is returned, otherwise nothing. */ int Mkg_DecodeCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int i, iObjc; char *pcExpr; Tcl_Obj **ppoObjv; if( objc < 3 ) return _WNA( 1, "expr list ?defaultValue?" ); pcExpr = _GSO( objv[1] ); try( _LOGE( objv[2], &iObjc, &ppoObjv ), eError ); if( iObjc % 2 ) throw eOddNumber; for( i = 0; i < iObjc; i+=2 ) { if( ! strcmp( pcExpr, _GSO( ppoObjv[i] ) ) ) { _SOR( ppoObjv[i+1] ); break; } } if( i == iObjc && objc == 4 ) _SOR( objv[3] ); return TCL_OK; catch eError: return TCL_ERROR; catch eOddNumber: _SSO( _GOR, "List must have an even number of elements" ); return TCL_ERROR; } /* Mkg_CompleteCmd implements the complete command. builds the required char** array for Tcl_GetIndexFromObj() and calls the latter. in case of a match, lets the result point to the matching element. */ int Mkg_CompleteCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int i, iObjc, iMatch; char **ppcValues; Tcl_Obj **ppoObjv; if( objc != 3 ) return _WNA( 1, "expr list" ); try( _LOGE( objv[2], &iObjc, &ppoObjv ), eError ); ppcValues = (char**)ckalloc( ( iObjc + 1 ) * sizeof(char*) ); for( i = 0; i < iObjc; i++ ) ppcValues[i] = _GSO( ppoObjv[i] ); ppcValues[iObjc] = NULL; try( _GIFO( objv[1], ppcValues, "value", &iMatch ), eNotFound ); ckfree( (char*)ppcValues ); _SOR( ppoObjv[iMatch] ); return TCL_OK; catch eError: return TCL_ERROR; catch eNotFound: ckfree( (char*)ppcValues ); return TCL_ERROR; } /* Mkg_LinlistCmd implements the linlist command. loops thru the given list in search of a match. */ int Mkg_LinlistCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int iObjc; Tcl_Obj **ppoObjv; if( objc != 3 ) return _WNA( 1, "list element" ); try( _LOGE( objv[1], &iObjc, &ppoObjv ), eError ); while( iObjc-- ) if( ! strcmp( _GSO( ppoObjv[iObjc] ), _GSO( objv[2] ) ) ) break; _SIO( _GOR, ( iObjc == -1 )? 0:1 ); return TCL_OK; catch eError: return TCL_ERROR; } /* Mkg_LdeleteCmd implements the ldelete command. */ int Mkg_LdeleteCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int *pIndexes, iLen, i; Tcl_Obj *poList; if( objc < 2 ) return _WNA( 1, "list ?index ...?" ); pIndexes = (int*)ckalloc( (objc-2) * sizeof(int) ); poList = _SOB( objv[1] ); try( _LOGL( poList, &iLen ), eError ); for( i = 2; i < objc; i++ ) try( _MkgGetIndex( pI, objv[i], iLen, pIndexes+i-2 ), eError ); qsort( pIndexes, objc-2, sizeof(int), _MkgCompareInt ); for( i = objc-3; i >= 0; i-- ) { if( pIndexes[i] == pIndexes[i-1] && i > 0 ) continue; if( pIndexes[i] >= 0 && pIndexes[i] < iLen ) _LODE( poList, pIndexes[i] ); } ckfree( (char*)pIndexes ); _SOR( poList ); return TCL_OK; catch eError: ckfree( (char*)pIndexes ); return TCL_ERROR; } /* Mkg_LextendCmd implements the lextend command. searches each element in the given list for a string match with the given value. the list is copied into the result string, and, if no match was found, the value is appended. */ int Mkg_LextendCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int i, j, iObjc; Tcl_Obj *poList, **ppoObjv; if( objc < 2 ) return _WNA( 1, "list ?value ...?" ); poList = _SOB( objv[1] ); for( i = 2; i < objc; i++ ) { try( _LOGE( poList, &iObjc, &ppoObjv ), eError ); for( j= 0; j < iObjc; j++ ) if( ! strcmp( _GSO( ppoObjv[j] ) , _GSO( objv[i] ) ) ) break; if( j == iObjc ) _LOAE( poList, _SOB( objv[i] ) ); } _SOR( poList ); return TCL_OK; catch eError: return TCL_ERROR; } /* Mkg_LshrinkCmd implements the lshrink command. searches each element in the given list for a string match with the given value. any match is appended to a temporary list poHits. the second loop deletes all elements in poList whose positions are in the temporary list. */ int Mkg_LshrinkCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int i, j, iHit, iObjc; Tcl_Obj *poList, *poHits, **ppoObjv; if( objc < 2 ) return _WNA( 1, "list ?value ...?" ); poHits = _NOB; poList = _SOB( objv[1] ); try( _LOGE( poList, &iObjc, &ppoObjv ), eError ); for( i = 0; i < iObjc; i++ ) for( j = 2; j < objc; j++ ) if( ! strcmp( _GSO( ppoObjv[i] ) , _GSO( objv[j] ) ) ) { try( _LOAE( poHits, _NIO( i ) ), eError ); break; } try( _LOGE( poHits, &iObjc, &ppoObjv ), eError ); for( i = iObjc-1; i >= 0; i-- ) { try( _GIO( ppoObjv[i], &iHit ), eError ); _LODE( poList, iHit ); } _DRC( poHits ); _SOR( poList ); return TCL_OK; catch eError: return TCL_ERROR; } /* Mkg_LchangeCmd implements the lchange command. expects pairs of values. each value1 is searched in list and replaced with value2, for all given value pairs. */ int Mkg_LchangeCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int i, j, iObjc; Tcl_Obj *poList, **ppoObjv; if( objc < 2 || objc % 2 ) return _WNA( 1, "list value1 value2 ?value1 value2 ...?" ); poList = _SOB( objv[1] ); try( _LOGE( poList, &iObjc, &ppoObjv ), eError ); for( i = 0; i < iObjc; i++ ) for( j = 2; j < objc; j += 2 ) if( ! strcmp( _GSO( ppoObjv[i] ) , _GSO( objv[j] ) ) ) { try( _LORE( poList, i, &(objv[j+1]) ), eError ); break; } _SOR( poList ); return TCL_OK; catch eError: return TCL_ERROR; } /* Mkg_LnextCmd implememts the lnext and lprev commands. */ int Mkg_LnextCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int i, iObjc, bNext; Tcl_Obj **ppoObjv; bNext = (int)pC; if( objc != 3 ) return _WNA( 1, "list element" ); _LOGE( objv[1], &iObjc, &ppoObjv ); for( i = 0; i < iObjc; i++ ) if( ! strcmp( _GSO( ppoObjv[i] ), _GSO( objv[2] ) ) ) break; if( i == iObjc ) throw eNotFound; if( bNext ) { if( i < iObjc-1 ) _SOR( ppoObjv[i+1] ); } else { if( i > 0 ) _SOR( ppoObjv[i-1] ); } return TCL_OK; catch eNotFound: _ASO( _GOR, "element ", _GSO( objv[2] ), " not found in list", NULL ); return TCL_ERROR; } /* Mkg_LassignCmd implememts the lassign command. splits up the given list and assigns each element to one of the given variables. if there are more elements than variables, puts the remaining elements into the result. */ int Mkg_LassignCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int i, iObjc; Tcl_Obj **ppoObjv; if( objc < 2 ) return _WNA( 1, "list ?varName ...?" ); _LOGE( objv[1], &iObjc, &ppoObjv ); for( i = 0; i < iObjc; i++ ) { if( i+2 >= objc ) break; _OSV( objv[i+2], NULL, ppoObjv[i] ); } for( ; i < iObjc; i++ ) _LOAE( _GOR, ppoObjv[i] ); return TCL_OK; } /* Mkg_LevalCmd implements the leval command. splits up the given list and evaluates the given command for each element of the list. the result of each evaluation is appended to the result. */ int Mkg_LevalCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int i, iObjc; char *pcCmd; Tcl_Obj *poResult, **ppoObjv; if( objc != 3 ) return _WNA( 1, "list command" ); pcCmd = _GSO( objv[2] ); poResult = _NSO( "" ); _LOGE( objv[1], &iObjc, &ppoObjv ); for( i = 0; i < iObjc; i++ ) { try( Tcl_VarEval( pI, pcCmd, " ", _GSO( ppoObjv[i] ), NULL ), eError ); try( _LOAE( poResult, _GOR ), eError ); } _SOR( poResult ); return TCL_OK; catch eError: _DRC( poResult ); return TCL_ERROR; } /* Mkg_LstatCmd implements the lstat command. checks if the specified option is valid and detects the -force option. sets start values depending on the operation. loops thru the list and calculates either minimum, maximum or sum, hereby detecting non-numeric arguments and keeping track of their count. if option count was specified, the number of numberic elements is returned, for min, max, sum and avg the result is returned, or nothing, if none of the elements was numeric. for option count the number of numeric elements is returned. */ int Mkg_LstatCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int i, bForce, iValues, iMatch, iObjc; double fRes, fValue; Tcl_Obj *poList, **ppoObjv; char *ppcOptions[] = { "count", "min", "max", "sum", "avg", NULL }; if( objc < 3 || objc > 4 || ( objc == 4 && strcmp( _GSO( objv[2] ), "-force" ) ) ) return _WNA( 1, "option ?-force? list" ); try( _GIFO( objv[1], ppcOptions, "option", &iMatch ), eError ); bForce = (objc == 4); poList = (objc == 3)? objv[2]:objv[3]; _LOGE( poList, &iObjc, &ppoObjv ); iValues = iObjc; switch( iMatch ) { case 1 : fRes = 1.7E308; break; case 2 : fRes = -1.7E308; break; default: fRes = 0; } for( i = 0; i < iObjc; i++ ) { if( _GDO( ppoObjv[i], &fValue ) == TCL_ERROR ) { if( bForce ) { iValues--; continue; } else throw eError; } switch( iMatch ) { case 0 : break; case 1 : fRes = (fValue < fRes)? fValue:fRes; break; case 2 : fRes = (fValue > fRes)? fValue:fRes; break; default: fRes += fValue; } } if( iMatch == 0 ) _SOR( _NIO( iValues ) ); else if( iValues == 0 ) _ROR; else if( iMatch == 4 ) _SOR( _NDO( fRes/iValues ) ); else _SOR( _NDO( fRes ) ); return TCL_OK; catch eError: return TCL_ERROR; } /* Mkg_LunionCmd implements the lunion command. all given lists are concatenated to a single list, which is sorted by means of qsort. the sorted list elements are then appended to the result in the following way: if an element is not of the same value as its predecessor, it is appended to the result. */ int Mkg_LunionCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int i, iObjc; Tcl_Obj **ppoObjv, *poList; if( objc < 2 ) return _WNA( 1, "list ?list ...?" ); poList = Tcl_ConcatObj( objc-1, objv+1 ); try( _LOGE( poList, &iObjc, &ppoObjv ), eError ); if( iObjc ) { qsort( ppoObjv, iObjc, sizeof(Tcl_Obj*), _MkgCompareObj ); _LOAE( _GOR, ppoObjv[0] ); for( i = 1; i < iObjc; i++ ) if( strcmp( _GSO( ppoObjv[i-1] ), _GSO( ppoObjv[i] ) ) ) _LOAE( _GOR, ppoObjv[i] ); } _DRC( poList ); return TCL_OK; catch eError: return TCL_ERROR; } /* Mkg_LinterCmd implements the linter and lminus commands. (int)pC is 1 for linter, and 0 for lminus. all given lists are sorted and processed pairwise: two counters run through the two lists, each trying to catch up with the counter of the other list. in case of linter, each value contained in both lists is added to the result. in case of lminus, values only contained in list1 are added to the result, and at the end all remainders of list1 are added, too. the result list is processed in the same manner with the next list, if any, or returned. */ int Mkg_LinterCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int bInter, i, iCmp, iOc1, iOc2, iL1, iL2; Tcl_Obj **ppoOv1, **ppoOv2, *poL1, *poL2; if( objc < 2 ) return _WNA( 1, "list ?list ...?" ); bInter = (int)pC; poL1 = _DOB( objv[1] ); _IRC( poL1 ); try( _LOGE( poL1, &iOc1, &ppoOv1 ), eError ); qsort( ppoOv1, iOc1, sizeof(Tcl_Obj*), _MkgCompareObj ); if( iOc1 ) { _LOAE( _GOR, ppoOv1[0] ); for( i = 1; i < iOc1; i++ ) if( strcmp( _GSO( ppoOv1[i-1] ), _GSO( ppoOv1[i] ) ) ) _LOAE( _GOR, ppoOv1[i] ); } _DRC( poL1 ); for( i = 2; i < objc; i++ ) { poL1 = _GOR; _IRC( poL1 ); _LOGE( poL1, &iOc1, &ppoOv1 ); poL2 = _DOB( objv[i] ); _IRC( poL2 ); try( _LOGE( poL2, &iOc2, &ppoOv2 ), eError ); qsort( ppoOv2, iOc2, sizeof(Tcl_Obj*), _MkgCompareObj ); Tcl_ResetResult( pI ); for( iL1 = 0, iL2 = 0; iL1 < iOc1 && iL2 < iOc2; ) { iCmp = strcmp( _GSO( ppoOv1[iL1] ), _GSO( ppoOv2[iL2] ) ); if( ! iCmp ) { if( bInter ) _LOAE( _GOR, ppoOv1[iL1] ); iL1++; iL2++; } else if( iCmp < 0 ) { if( ! bInter ) _LOAE( _GOR, ppoOv1[iL1] ); while( ++iL1 < iOc1 && strcmp( _GSO( ppoOv1[iL1] ), _GSO( ppoOv2[iL2] ) ) < 0 ) if( ! bInter ) _LOAE( _GOR, ppoOv1[iL1] ); } else while( ++iL2 < iOc2 && strcmp( _GSO( ppoOv1[iL1] ), _GSO( ppoOv2[iL2] ) ) > 0 ); } if( ! bInter ) for( ; iL1 < iOc1; iL1++ ) _LOAE( _GOR, ppoOv1[iL1] ); _DRC( poL1 ); _DRC( poL2 ); } return TCL_OK; catch eError: return TCL_ERROR; } /* Mkg_LmirrorCmd implements the lmirror command. the given list is split into elements. the elements are appended to a new list, starting with the last element. */ int Mkg_LmirrorCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int i, iObjc; Tcl_Obj *poList, **ppoObjv; if( objc != 2 ) return _WNA( 1, "list" ); poList = _NOB; _LOGE( objv[1], &iObjc, &ppoObjv ); for( i = iObjc-1; i>= 0; i-- ) _LOAE( poList, ppoObjv[i] ); _SOR( poList ); return TCL_OK; } /* Mkg_LoopCmd implements the loop command. if an increment is given and its first character is '?' then later the increment is automatically adjusted. otherwise, the increment is set to 1 resp. copied from objv[4]. if lower or upper bound or the increment are not of type integer, the loop variable will later be set as a double, otherwise as integer. if the increment is zero, an infinite loop is indicated. otherwise, if the increment has the wrong sign, it is either adjusted or the function returns, depending on the '?' in objv[4] earlier. then, the number of iterations is calculated and a loop is processed. inside the loop, the loop variable is set, either as int or as double (see above), and the body is evaluated. if an evaluation returns an exception, then it is handled accordingly. */ int Mkg_LoopCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int i, iTest, iRes, iCount, bAuto, bDouble; double f, fFirst, fLast, fIncr; Tcl_Obj *poBody, *poIncr; if( objc < 5 || objc > 6 ) return _WNA( 1, "varName first last ?step? body" ); bAuto = ( objc == 6 && *_GSO( objv[4] ) == '?' ); if( bAuto ) poIncr = _NSO( _GSO( objv[4] ) + 1 ); else if( objc == 6 ) poIncr = _DOB( objv[4] ); else poIncr = _NIO( 1 ); bDouble = ( _GIO( objv[2], &iTest ) == TCL_ERROR || _GIO( objv[3], &iTest ) == TCL_ERROR || _GIO( poIncr , &iTest ) == TCL_ERROR ); try( _GDO( objv[2], &fFirst ), eError ); try( _GDO( objv[3], &fLast ), eError ); try( _GDO( poIncr , &fIncr ), eError ); _DRC( poIncr ); _ROR; if( fIncr == 0 ) throw eInfiniteLoop; else if( ( fLast < fFirst && fIncr > 0 ) || ( fLast > fFirst && fIncr < 0 ) ) { if( bAuto ) fIncr = -fIncr; else return TCL_OK; } poBody = objv[objc-1]; iCount = (int)(fabs((fLast-fFirst)/fIncr)+1); for( f = fFirst, i = 0; i < iCount; i++ ) { _OSV( objv[1], NULL, (bDouble)? _NDO( f ): _NIO( (int)f ) ); iRes = Tcl_EvalObj( pI, poBody ); f += fIncr; if ( iRes == TCL_CONTINUE ) continue; else if( iRes == TCL_BREAK ) break; else if( iRes != TCL_OK ) throw eOthers; } return TCL_OK; catch eError: return TCL_ERROR; catch eOthers: return iRes; catch eInfiniteLoop: _SSO( _GOR, "Infinite loop" ); return TCL_ERROR; } /* Mkg_DoCmd implements the do-while command. identical to the C/C++ do-while. body is evaluated at least once, then expr. if expr is false, the loop is exited. */ int Mkg_DoCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int iRes, bExpr; if( objc != 4 || strcmp( _GSO( objv[2] ), "while" ) ) return _WNA( 1, "body while expr" ); do { iRes = Tcl_EvalObj( pI, objv[1] ); if ( iRes == TCL_CONTINUE ) continue; else if( iRes == TCL_BREAK ) break; else if( iRes != TCL_OK ) throw eOthers; try( Tcl_ExprBooleanObj( pI, objv[3], &bExpr ), eError ); } while( bExpr ); return TCL_OK; catch eError: return TCL_ERROR; catch eOthers: return iRes; } /* Mkg_FincrCmd implements the fincr command. works exactly like the incr commmand, just for floating point values. */ int Mkg_FincrCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { double fValue, fIncr; Tcl_Obj *poValue; if( objc < 2 || objc > 3 ) return _WNA( 1, "varName ?value?" ); if( objc == 2 ) fIncr = 1.; else try( _GDO( objv[2], &fIncr ), eError ); poValue = _OGV( objv[1], NULL ); if( poValue == NULL ) throw eError; try( _GDO( poValue, &fValue ), eError ); poValue = _SOB( poValue ); _SDO( poValue, fValue+fIncr ); poValue = _OSV( objv[1], NULL, poValue ); if( poValue == NULL ) throw eError; _SOR( poValue ); return TCL_OK; catch eError: return TCL_ERROR; } /* Mkg_OptionsCmd implements the options command. splits up the given list into its elements and unsets the array given by varName. allocates space for a char* array to hold pointers to the string representations of all given options. in the first loop this array is initialized and any default values are set. in the second loop each element is tested if it starts with an '-' and is not "--". If false, then there are no more options. the rest might be arguments, which are only allowed if -nocomplain or -allowargs was set. In that case, these arguments are appended to the result. If true, it must be an option, which is checked against the allowed options by means of the char* array. if the option is not found and -nocomplain was not specified, an error is returned, otherwise the unknown option is appended to the result. if the option is found, the option data is analyzed: if there is no extra data to the option, it is assumed to be an option without argument, and the corresponding value in the array is set to "1". if there is extra data to the option, it is assumed to be an option with an argument. if the 2nd element of the spec is "*" the corresponding array value is set accordingly. otherwise the 2nd element is treated as a list. another char* array is created and the value is searched in there, prior to setting the array value. if not found, an error message is produced. */ int Mkg_OptionsCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int i, j, iLc, iOc, iVc, iFirst, iCount, bNocom, bAllow; char **ppcOpts, **ppcArgs; Tcl_Obj *poList, *poRest, **ppoVv, **ppoLv, **ppoOv, *poAvar; if( objc < 4 ) return _WNA( 1, "?-nocomplain|-allowargs? varName list optionSpec ?optionSpec ...?" ); bNocom = ( strcmp( "-nocomplain", _GSO( objv[1] ) ) == 0 ); bAllow = ( strcmp( "-allowargs", _GSO( objv[1] ) ) == 0 ); iFirst = ( bNocom || bAllow )? 4:3; iCount = objc-iFirst; poList = objv[iFirst-1]; poAvar = objv[iFirst-2]; poRest = _NOB; _LOGE( poList, &iLc, &ppoLv ); _OUV( poAvar, NULL ); _ROR; ppcOpts = (char**)ckalloc( ( iCount + 1 ) * sizeof(char*) ); ppcOpts[iCount] = NULL; for( i = 0; i < iCount; i++ ) { _LOGE( objv[iFirst+i], &iOc, &ppoOv ); if( iOc < 1 || iOc > 3 ) throw eBadSpec; ppcOpts[i] = _GSO( ppoOv[0] ); if( iOc == 3 ) _OSV( poAvar, ppoOv[0], ppoOv[2] ); } for( i = 0; i < iLc; i++ ) { if( *( _GSO( ppoLv[i] ) ) != '-' && bAllow ) { for( j = i; j < iLc; _LOAE( poRest, ppoLv[j++] ) ); break; } else if( ! strcmp( _GSO( ppoLv[i] ), "--" ) && ( bAllow || bNocom ) ) { for( j = i+1; j < iLc; _LOAE( poRest, ppoLv[j++] ) ); break; } else if( _GIFO( ppoLv[i], ppcOpts, "option", &j ) != TCL_OK ) { if( ! bNocom ) throw eError; _LOAE( poRest, ppoLv[i] ); continue; } _LOGE( objv[iFirst+j], &iOc, &ppoOv ); if( iOc == 1 ) _OSV( poAvar, ppoOv[0], _NSO( "1" ) ); else if( ++i == iLc ) throw eMissingArg; else if( ! strcmp( _GSO( ppoOv[1] ), "*" ) ) _OSV( poAvar, ppoOv[0], ppoLv[i] ); else { _LOGE( ppoOv[1], &iVc, &ppoVv ); ppcArgs = (char**)ckalloc( (iVc+1) * sizeof(char*) ); ppcArgs[iVc] = NULL; for( j = 0; j < iVc; j++ ) ppcArgs[j] = _GSO( ppoVv[j] ); _ROR; try( _GIFO( ppoLv[i], ppcArgs, "value", &j ), eBadValue ); _OSV( poAvar, ppoOv[0], ppoVv[j] ); ckfree( (char*)ppcArgs ); } } ckfree( (char*)ppcOpts ); _SOR( poRest ); return TCL_OK; catch eBadSpec: _SSO( _GOR, "At least one option spec is malformed" ); ckfree( (char*)ppcOpts ); return TCL_ERROR; catch eBadValue: ckfree( (char*)ppcArgs ); throw eError; catch eMissingArg: _SSO( _GOR, "Missing argument for last option" ); throw eError; catch eError: ckfree( (char*)ppcOpts ); _DRC( poRest ); return TCL_ERROR; } /* Mkg_HexdumpCmd implements the hexdump command. A string is read in chunks of 16 bytes and formatted as a typical hex dump. Each such formatted line is an element of the returned list. */ int Mkg_HexdumpCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int i, iLen; char *pcData, pcLine[200], pcBuf[50]; Tcl_Obj *poList; if( objc != 2 ) return _WNA( 1, "string" ); pcData = _GAO( objv[1], &iLen ); poList = _NOB; if( iLen ) { for( i = 0; i < iLen; i++ ) { if( ! (i%16) ) { if( i ) _LOAE( poList, _NSO( pcLine ) ); sprintf( pcLine, "%06x %65s", i, "" ); } sprintf( pcBuf, "%02x", (unsigned char)pcData[i] ); memcpy( pcLine+8+(i%16)*3, pcBuf, 2 ); sprintf( pcBuf, "%c", (pcData[i] >= ' ' && pcData[i] <= '~' )? pcData[i]:'.' ); memcpy( pcLine+57+(i%16), pcBuf, 1 ); } _LOAE( poList, _NSO( pcLine ) ); } _SOR( poList ); return TCL_OK; } /* Mkg_EncryptCmd implements the encrypt command. the algorithm used is TEA, which encodes 64 bits (2 longs) with a 128 bit key (4 longs). hence, the boundary for data to be encoded is 8 bytes. memory is allocated and the data is copied into it, then run through TEA in blocks of 8 bytes. the allocated memory is directly encrypted, so that in the end it holds the entiry encrypted data string. because of the 8 byte blocks, the length of the original data string is also coded into the encrypted string, so that it can be restored after decryption. */ int Mkg_EncryptCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int i, iLen, iLen8; char *pcData, *pcOut, pcKey[16]; if( objc != 3 ) return _WNA( 1, "key data" ); pcData = _GAO( objv[1], &iLen ); /* key can be a binary string */ if( iLen < 1 || iLen > 16 ) throw eBadKey; memset( pcKey, 0xAA, 16 ); /* set some bit pattern */ memcpy( pcKey, pcData, iLen ); /* ...then copy the key into it */ _MkgConvertEndian( pcKey, 16 ); pcData = _GAO( objv[2], &iLen ); /* data can be a binary string */ iLen8 = ((sizeof(int)+iLen-1)/8+1)*8; /* get 8 byte boundary, but... */ pcOut = ckalloc( iLen8 ); /* ...add space to store length */ memset( pcOut, 0, iLen8 ); *((int*)pcOut) = iLen; /* first store data length */ memcpy( pcOut+sizeof(int), pcData, iLen ); /* ...then copy data */ _MkgConvertEndian( pcOut+sizeof(int), iLen8-sizeof(int) ); for( i = 0; i < iLen8; i+= 8 ) /* now run TEA for each 64 bit block */ _MkgTEAencrypt( (unsigned long*)(pcOut+i), (unsigned long*)pcKey ); _SOR( _NAO( pcOut, iLen8 ) ); /* set result and free up memory */ ckfree( (char*)pcOut ); return TCL_OK; catch eBadKey: _SSO( _GOR, "Key length must be between 1 and 16 bytes" ); return TCL_ERROR; } /* Mkg_DecryptCmd implements the decrypt command. basically the same as its counterpart. the data length must be a multiple of 8 bytes as generated by Mkg_EncryptCmd. */ int Mkg_DecryptCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int i, iLen, iLen8; char *pcData, *pcOut, pcKey[16]; if( objc != 3 ) return _WNA( 1, "key data" ); pcData = _GAO( objv[1], &iLen ); if( iLen < 1 || iLen > 16 ) throw eBadKey; memset( pcKey, 0xAA, 16 ); memcpy( pcKey, pcData, iLen ); _MkgConvertEndian( pcKey, 16 ); pcData = _GAO( objv[2], &iLen8 ); if( iLen8 == 0 || iLen8 % 8 ) throw eBadData; pcOut = ckalloc( iLen8 ); memcpy( pcOut, pcData, iLen8 ); for( i = 0; i < iLen8; i+= 8 ) _MkgTEAdecrypt( (unsigned long*)(pcOut+i), (unsigned long*)pcKey ); _MkgConvertEndian( pcOut+sizeof(int), iLen8-sizeof(int) ); _SOR( _NAO( pcOut+sizeof(int), *((int*)pcOut) ) ); ckfree( (char*)pcOut ); return TCL_OK; catch eBadKey: _SSO( _GOR, "Key length must be between 1 and 16 bytes" ); return TCL_ERROR; catch eBadData: _SSO( _GOR, "Data length must be a non-zero integer multiple of 8" ); return TCL_ERROR; } /* Mkg_ChecksumCmd implements the checksum command. CRC (cyclic redundancy check) schemes are among the most reliable means of error detection in use. this particular implementation is table based and therefore very fast. the code is taken from the Internet and public domain. */ int Mkg_ChecksumCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { static unsigned short piTab16[256] = { 0x0000, 0x1021, 0x2042, 0x3063, 0x4084, 0x50a5, 0x60c6, 0x70e7, 0x8108, 0x9129, 0xa14a, 0xb16b, 0xc18c, 0xd1ad, 0xe1ce, 0xf1ef, 0x1231, 0x0210, 0x3273, 0x2252, 0x52b5, 0x4294, 0x72f7, 0x62d6, 0x9339, 0x8318, 0xb37b, 0xa35a, 0xd3bd, 0xc39c, 0xf3ff, 0xe3de, 0x2462, 0x3443, 0x0420, 0x1401, 0x64e6, 0x74c7, 0x44a4, 0x5485, 0xa56a, 0xb54b, 0x8528, 0x9509, 0xe5ee, 0xf5cf, 0xc5ac, 0xd58d, 0x3653, 0x2672, 0x1611, 0x0630, 0x76d7, 0x66f6, 0x5695, 0x46b4, 0xb75b, 0xa77a, 0x9719, 0x8738, 0xf7df, 0xe7fe, 0xd79d, 0xc7bc, 0x48c4, 0x58e5, 0x6886, 0x78a7, 0x0840, 0x1861, 0x2802, 0x3823, 0xc9cc, 0xd9ed, 0xe98e, 0xf9af, 0x8948, 0x9969, 0xa90a, 0xb92b, 0x5af5, 0x4ad4, 0x7ab7, 0x6a96, 0x1a71, 0x0a50, 0x3a33, 0x2a12, 0xdbfd, 0xcbdc, 0xfbbf, 0xeb9e, 0x9b79, 0x8b58, 0xbb3b, 0xab1a, 0x6ca6, 0x7c87, 0x4ce4, 0x5cc5, 0x2c22, 0x3c03, 0x0c60, 0x1c41, 0xedae, 0xfd8f, 0xcdec, 0xddcd, 0xad2a, 0xbd0b, 0x8d68, 0x9d49, 0x7e97, 0x6eb6, 0x5ed5, 0x4ef4, 0x3e13, 0x2e32, 0x1e51, 0x0e70, 0xff9f, 0xefbe, 0xdfdd, 0xcffc, 0xbf1b, 0xaf3a, 0x9f59, 0x8f78, 0x9188, 0x81a9, 0xb1ca, 0xa1eb, 0xd10c, 0xc12d, 0xf14e, 0xe16f, 0x1080, 0x00a1, 0x30c2, 0x20e3, 0x5004, 0x4025, 0x7046, 0x6067, 0x83b9, 0x9398, 0xa3fb, 0xb3da, 0xc33d, 0xd31c, 0xe37f, 0xf35e, 0x02b1, 0x1290, 0x22f3, 0x32d2, 0x4235, 0x5214, 0x6277, 0x7256, 0xb5ea, 0xa5cb, 0x95a8, 0x8589, 0xf56e, 0xe54f, 0xd52c, 0xc50d, 0x34e2, 0x24c3, 0x14a0, 0x0481, 0x7466, 0x6447, 0x5424, 0x4405, 0xa7db, 0xb7fa, 0x8799, 0x97b8, 0xe75f, 0xf77e, 0xc71d, 0xd73c, 0x26d3, 0x36f2, 0x0691, 0x16b0, 0x6657, 0x7676, 0x4615, 0x5634, 0xd94c, 0xc96d, 0xf90e, 0xe92f, 0x99c8, 0x89e9, 0xb98a, 0xa9ab, 0x5844, 0x4865, 0x7806, 0x6827, 0x18c0, 0x08e1, 0x3882, 0x28a3, 0xcb7d, 0xdb5c, 0xeb3f, 0xfb1e, 0x8bf9, 0x9bd8, 0xabbb, 0xbb9a, 0x4a75, 0x5a54, 0x6a37, 0x7a16, 0x0af1, 0x1ad0, 0x2ab3, 0x3a92, 0xfd2e, 0xed0f, 0xdd6c, 0xcd4d, 0xbdaa, 0xad8b, 0x9de8, 0x8dc9, 0x7c26, 0x6c07, 0x5c64, 0x4c45, 0x3ca2, 0x2c83, 0x1ce0, 0x0cc1, 0xef1f, 0xff3e, 0xcf5d, 0xdf7c, 0xaf9b, 0xbfba, 0x8fd9, 0x9ff8, 0x6e17, 0x7e36, 0x4e55, 0x5e74, 0x2e93, 0x3eb2, 0x0ed1, 0x1ef0 }; static unsigned long plTab32[256] = { 0x00000000L, 0x77073096L, 0xee0e612cL, 0x990951baL, 0x076dc419L, 0x706af48fL, 0xe963a535L, 0x9e6495a3L, 0x0edb8832L, 0x79dcb8a4L, 0xe0d5e91eL, 0x97d2d988L, 0x09b64c2bL, 0x7eb17cbdL, 0xe7b82d07L, 0x90bf1d91L, 0x1db71064L, 0x6ab020f2L, 0xf3b97148L, 0x84be41deL, 0x1adad47dL, 0x6ddde4ebL, 0xf4d4b551L, 0x83d385c7L, 0x136c9856L, 0x646ba8c0L, 0xfd62f97aL, 0x8a65c9ecL, 0x14015c4fL, 0x63066cd9L, 0xfa0f3d63L, 0x8d080df5L, 0x3b6e20c8L, 0x4c69105eL, 0xd56041e4L, 0xa2677172L, 0x3c03e4d1L, 0x4b04d447L, 0xd20d85fdL, 0xa50ab56bL, 0x35b5a8faL, 0x42b2986cL, 0xdbbbc9d6L, 0xacbcf940L, 0x32d86ce3L, 0x45df5c75L, 0xdcd60dcfL, 0xabd13d59L, 0x26d930acL, 0x51de003aL, 0xc8d75180L, 0xbfd06116L, 0x21b4f4b5L, 0x56b3c423L, 0xcfba9599L, 0xb8bda50fL, 0x2802b89eL, 0x5f058808L, 0xc60cd9b2L, 0xb10be924L, 0x2f6f7c87L, 0x58684c11L, 0xc1611dabL, 0xb6662d3dL, 0x76dc4190L, 0x01db7106L, 0x98d220bcL, 0xefd5102aL, 0x71b18589L, 0x06b6b51fL, 0x9fbfe4a5L, 0xe8b8d433L, 0x7807c9a2L, 0x0f00f934L, 0x9609a88eL, 0xe10e9818L, 0x7f6a0dbbL, 0x086d3d2dL, 0x91646c97L, 0xe6635c01L, 0x6b6b51f4L, 0x1c6c6162L, 0x856530d8L, 0xf262004eL, 0x6c0695edL, 0x1b01a57bL, 0x8208f4c1L, 0xf50fc457L, 0x65b0d9c6L, 0x12b7e950L, 0x8bbeb8eaL, 0xfcb9887cL, 0x62dd1ddfL, 0x15da2d49L, 0x8cd37cf3L, 0xfbd44c65L, 0x4db26158L, 0x3ab551ceL, 0xa3bc0074L, 0xd4bb30e2L, 0x4adfa541L, 0x3dd895d7L, 0xa4d1c46dL, 0xd3d6f4fbL, 0x4369e96aL, 0x346ed9fcL, 0xad678846L, 0xda60b8d0L, 0x44042d73L, 0x33031de5L, 0xaa0a4c5fL, 0xdd0d7cc9L, 0x5005713cL, 0x270241aaL, 0xbe0b1010L, 0xc90c2086L, 0x5768b525L, 0x206f85b3L, 0xb966d409L, 0xce61e49fL, 0x5edef90eL, 0x29d9c998L, 0xb0d09822L, 0xc7d7a8b4L, 0x59b33d17L, 0x2eb40d81L, 0xb7bd5c3bL, 0xc0ba6cadL, 0xedb88320L, 0x9abfb3b6L, 0x03b6e20cL, 0x74b1d29aL, 0xead54739L, 0x9dd277afL, 0x04db2615L, 0x73dc1683L, 0xe3630b12L, 0x94643b84L, 0x0d6d6a3eL, 0x7a6a5aa8L, 0xe40ecf0bL, 0x9309ff9dL, 0x0a00ae27L, 0x7d079eb1L, 0xf00f9344L, 0x8708a3d2L, 0x1e01f268L, 0x6906c2feL, 0xf762575dL, 0x806567cbL, 0x196c3671L, 0x6e6b06e7L, 0xfed41b76L, 0x89d32be0L, 0x10da7a5aL, 0x67dd4accL, 0xf9b9df6fL, 0x8ebeeff9L, 0x17b7be43L, 0x60b08ed5L, 0xd6d6a3e8L, 0xa1d1937eL, 0x38d8c2c4L, 0x4fdff252L, 0xd1bb67f1L, 0xa6bc5767L, 0x3fb506ddL, 0x48b2364bL, 0xd80d2bdaL, 0xaf0a1b4cL, 0x36034af6L, 0x41047a60L, 0xdf60efc3L, 0xa867df55L, 0x316e8eefL, 0x4669be79L, 0xcb61b38cL, 0xbc66831aL, 0x256fd2a0L, 0x5268e236L, 0xcc0c7795L, 0xbb0b4703L, 0x220216b9L, 0x5505262fL, 0xc5ba3bbeL, 0xb2bd0b28L, 0x2bb45a92L, 0x5cb36a04L, 0xc2d7ffa7L, 0xb5d0cf31L, 0x2cd99e8bL, 0x5bdeae1dL, 0x9b64c2b0L, 0xec63f226L, 0x756aa39cL, 0x026d930aL, 0x9c0906a9L, 0xeb0e363fL, 0x72076785L, 0x05005713L, 0x95bf4a82L, 0xe2b87a14L, 0x7bb12baeL, 0x0cb61b38L, 0x92d28e9bL, 0xe5d5be0dL, 0x7cdcefb7L, 0x0bdbdf21L, 0x86d3d2d4L, 0xf1d4e242L, 0x68ddb3f8L, 0x1fda836eL, 0x81be16cdL, 0xf6b9265bL, 0x6fb077e1L, 0x18b74777L, 0x88085ae6L, 0xff0f6a70L, 0x66063bcaL, 0x11010b5cL, 0x8f659effL, 0xf862ae69L, 0x616bffd3L, 0x166ccf45L, 0xa00ae278L, 0xd70dd2eeL, 0x4e048354L, 0x3903b3c2L, 0xa7672661L, 0xd06016f7L, 0x4969474dL, 0x3e6e77dbL, 0xaed16a4aL, 0xd9d65adcL, 0x40df0b66L, 0x37d83bf0L, 0xa9bcae53L, 0xdebb9ec5L, 0x47b2cf7fL, 0x30b5ffe9L, 0xbdbdf21cL, 0xcabac28aL, 0x53b39330L, 0x24b4a3a6L, 0xbad03605L, 0xcdd70693L, 0x54de5729L, 0x23d967bfL, 0xb3667a2eL, 0xc4614ab8L, 0x5d681b02L, 0x2a6f2b94L, 0xb40bbe37L, 0xc30c8ea1L, 0x5a05df1bL, 0x2d02ef8dL }; int i, iLen, iSize; char *pcData; unsigned short iCRC16; unsigned long lCRC32; if( objc != 2 && objc != 4 ) return _WNA( 1, "?-size 16|32? data" ); if( objc == 4 ) /* get the size, if given */ { if( strcmp( _GSO( objv[1] ), "-size" ) ) throw eBadOption; try( _GIO( objv[2], &iSize ), eError ); if( iSize != 16 && iSize != 32 ) /* must be 16 or 32 */ throw eBadSize; } else iSize = 16; /* default is 16 */ pcData = _GAO( objv[objc-1], &iLen ); if( iSize == 16 ) { iCRC16 = 0; for( i = 1; i < iLen; i++ ) iCRC16 = piTab16[(((iCRC16)>> 8) & 255)] ^ (iCRC16 << 8) ^ pcData[i]; _SOR( _NIO( iCRC16 ) ); } else { lCRC32 = 0xffffffffL; for( ; iLen >= 8; iLen -= 8 ) for( i = 8; i; i-- ) lCRC32 = plTab32[( (int)lCRC32 ^ (*pcData++) ) & 0xff] ^ ( lCRC32 >> 8 ); while( iLen-- ) lCRC32 = plTab32[( (int)lCRC32 ^ (*pcData++) ) & 0xff] ^ ( lCRC32 >> 8 ); _SOR( _NIO( lCRC32 ^ 0xffffffffL ) ); } return TCL_OK; catch eError: return TCL_ERROR; catch eBadOption: _SSO( _GOR, "Unknown option: Must be -size." ); return TCL_ERROR; catch eBadSize: _SSO( _GOR, "Bad size value: Must be 16 or 32" ); return TCL_ERROR; } /* Mkg_HashCmd implements the hash command. this here is SHA-256, a one-way hash algorithm (see http://csrc.nist.gov/cryptval/shs.html) that produces a 256-bit (32 bytes) key upon any given input data. the security against collision attacks is 128 bits. such algorithms are used for authentication, but not to create secrecy. there is lots of information about SHA-256 in the Internet, including example code. the code is tested on Win, Linux (both on intel platform, little endian) and HP-UX (big endian). to test, do a "binary scan [hash abc] h* key; puts $key". it should return ab8761fbf810fcae141404edd5ea22320b30163a6971a7c94b01ff162f0051da. */ int Mkg_HashCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { int iLen; char *pcData, pcResult[32]; if( objc != 2 ) return _WNA( 1, "data" ); pcData = _GAO( objv[1], &iLen ); _MkgSha256( pcData, iLen, pcResult ); _SOR( _NAO( pcResult, 32 ) ); return TCL_OK; } /* Mkg_IgnoreCmd implements the /# command. does nothing. */ int Mkg_IgnoreCmd( ClientData pC, Tcl_Interp *pI, int objc, Tcl_Obj *CONST objv[] ) { return TCL_OK; } /* Mkgeneric_Init package initialization. creates all new commands and math functions and registers the package. */ int Mkgeneric_Init( Tcl_Interp *pI ) { Tcl_ValueType piT[] = { TCL_EITHER, TCL_EITHER }; if( TCL_MAJOR_VERSION < 8 ) throw eWrongVersion; #ifdef USE_TCL_STUBS if( Tcl_InitStubs( pI, "8.3", 0) == NULL ) throw eError; #endif Tcl_CreateMathFunc( pI, "round2" , 2, piT, Mkg_Round2Func, (ClientData)0 ); Tcl_CreateMathFunc( pI, "floor2" , 2, piT, Mkg_Round2Func, (ClientData)1 ); Tcl_CreateMathFunc( pI, "ceil2" , 2, piT, Mkg_Round2Func, (ClientData)2 ); Tcl_CreateMathFunc( pI, "min" , 2, piT, Mkg_MinMaxFunc, (ClientData)0 ); Tcl_CreateMathFunc( pI, "max" , 2, piT, Mkg_MinMaxFunc, (ClientData)1 ); Tcl_CreateMathFunc( pI, "isdouble", 1, piT, Mkg_IsTypeFunc, (ClientData)0 ); Tcl_CreateMathFunc( pI, "isint" , 1, piT, Mkg_IsTypeFunc, (ClientData)1 ); Tcl_CreateMathFunc( pI, "isodd" , 1, piT, Mkg_IsEvenFunc, (ClientData)0 ); Tcl_CreateMathFunc( pI, "iseven" , 1, piT, Mkg_IsEvenFunc, (ClientData)1 ); Tcl_CreateMathFunc( pI, "pi" , 0, piT, Mkg_ConstFunc, (ClientData)0 ); Tcl_CreateMathFunc( pI, "e" , 0, piT, Mkg_ConstFunc, (ClientData)1 ); Tcl_CreateObjCommand( pI, "throw" , Mkg_ThrowCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "try" , Mkg_TryCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "complete", Mkg_CompleteCmd, NULL, NULL ); Tcl_CreateObjCommand( pI, "decode" , Mkg_DecodeCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "linlist" , Mkg_LinlistCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "ldelete" , Mkg_LdeleteCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "lextend" , Mkg_LextendCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "lshrink" , Mkg_LshrinkCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "lchange" , Mkg_LchangeCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "lnext" , Mkg_LnextCmd , (ClientData)1, NULL ); Tcl_CreateObjCommand( pI, "lprev" , Mkg_LnextCmd , (ClientData)0, NULL ); Tcl_CreateObjCommand( pI, "lassign" , Mkg_LassignCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "leval" , Mkg_LevalCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "lstat" , Mkg_LstatCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "lunion" , Mkg_LunionCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "linter" , Mkg_LinterCmd , (ClientData)1, NULL ); Tcl_CreateObjCommand( pI, "lminus" , Mkg_LinterCmd , (ClientData)0, NULL ); Tcl_CreateObjCommand( pI, "lmirror" , Mkg_LmirrorCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "loop" , Mkg_LoopCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "do" , Mkg_DoCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "fincr" , Mkg_FincrCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "options" , Mkg_OptionsCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "hexdump" , Mkg_HexdumpCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "encrypt" , Mkg_EncryptCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "decrypt" , Mkg_DecryptCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "checksum", Mkg_ChecksumCmd, NULL, NULL ); Tcl_CreateObjCommand( pI, "hash" , Mkg_HashCmd , NULL, NULL ); Tcl_CreateObjCommand( pI, "/#" , Mkg_IgnoreCmd , NULL, NULL ); try( Tcl_PkgProvide( pI, "mkGeneric", _VERSION ), eError ); return TCL_OK; catch eWrongVersion: _SSO( _GOR, "Package mkGeneric requires Tcl Version 8" ); return TCL_ERROR; catch eError: return TCL_ERROR; } int Mkgeneric_SafeInit( Tcl_Interp *pI ) { return Mkgeneric_SafeInit( pI ); } /* static linking. uncomment the following two functions if you want to create a stand-alone shell instead of a dynamic library. */ #ifndef USE_TCL_STUBS int main( int argc, char *argv[] ) { Tcl_Main( argc, argv, Tcl_AppInit ); return 0; } int Tcl_AppInit( Tcl_Interp *pI ) { try( Tcl_Init( pI ), eError ); try( Mkgeneric_Init( pI ), eError ); return TCL_OK; catch eError: return TCL_ERROR; } #endif /* * mkGeneric 1.3 * ------------- */