Attachment "mkGeneric13.c" to
ticket [3084489fff]
added by
anonymous
2010-10-11 22:34:16.
/*
* mkGeneric 1.3
* -------------
*
* Please see the web pages for releases and documentation.
*
* Author: Michael Kraus
* mailto:[email protected]
* 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 <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <math.h>
#include <tcl.h>
#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 <windows.h>
# 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 = (f1<f2)? f1:f2;
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_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
* -------------
*/
