ADDED CRITCL3_CONVERSION Index: CRITCL3_CONVERSION ================================================================== --- /dev/null +++ CRITCL3_CONVERSION @@ -0,0 +1,31 @@ +base64 requires separation of C and Tcl parts + +C pieces all around + +File Module Status +==== ====== ====== +base32_c base32 [done] +base32hex_c base32 [done] +base64c base64 [done] +crcc crc [done] +ipMoreC dns [done] +md4c md4 [done] +md5c md5 [done] +md5cryptc md5crypt [done] +pt_parse_peg_c pt [done] +pt_rdengine_c pt [done] +rc4c rc4 [done] +sha1c sha1 [done] +sha256c sha1 [done] +==== ====== ====== +crc32 crc +graph_c struct +jsonc json +queue_c struct +sets_c struct +stack_c struct +sum crc +tree_c struct +uuid uuid +yencode yencode +==== ====== ====== Index: modules/base32/base32_c.tcl ================================================================== --- modules/base32/base32_c.tcl +++ modules/base32/base32_c.tcl @@ -4,250 +4,274 @@ # # Public domain # # RCS: @(#) $Id: base32_c.tcl,v 1.3 2008/01/28 22:58:18 andreas_kupries Exp $ -package require critcl +package require critcl 3.1 package require Tcl 8.4 -namespace eval ::base32 { - # Supporting code for the main command. - catch { - #critcl::cheaders -g - #critcl::debug memory symbols - } - - # Main commands, encoder & decoder - - critcl::ccommand critcl_encode {dummy interp objc objv} { - /* Syntax -*- c -*- - * critcl_encode string - */ - - unsigned char* buf; - int nbuf; - - unsigned char* out; - unsigned char* at; - int nout; - - /* - * The array used for encoding - */ /* 123456789 123456789 123456789 12 */ - static const char map[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"; - -#define USAGEE "bitstring" - - if (objc != 2) { +if {![critcl::compiling]} { + error "Unable to build base32_cc, no proper compiler found." +} + +# # ## ### ##### ######## ############# ##################### +## Administrivia + +critcl::license {Andreas Kupries} {CC-0 public domain} +critcl::summary { + C implementation of the standard Base32 de- and encoder. +} +critcl::description { + This package provides a C implementation of a base32 de- + and encoder, as per RFC 3548. +} +critcl::subject \ + base32 {rfc 3548} + +critcl::meta location http://core.tcl.tk/tcllib + +# # ## ### ##### ######## ############# ##################### +## Implementation + +critcl::tcl 8.4 + +namespace eval ::base32 {} + +# Main commands, encoder & decoder + +critcl::ccommand ::base32::critcl_encode {dummy interp objc objv} { + /* Syntax -*- c -*- + * critcl_encode string + */ + + unsigned char* buf; + int nbuf; + + unsigned char* out; + unsigned char* at; + int nout; + + /* + * The array used for encoding + */ /* 123456789 123456789 123456789 12 */ + static const char map[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"; + + #define USAGEE "bitstring" + + if (objc != 2) { Tcl_WrongNumArgs (interp, 1, objv, USAGEE); return TCL_ERROR; - } + } - buf = Tcl_GetByteArrayFromObj (objv[1], &nbuf); - nout = ((nbuf+4)/5)*8; - out = (unsigned char*) Tcl_Alloc (nout*sizeof(char)); + buf = Tcl_GetByteArrayFromObj (objv[1], &nbuf); + nout = ((nbuf+4)/5)*8; + out = (unsigned char*) Tcl_Alloc (nout*sizeof(char)); - for (at = out; nbuf >= 5; nbuf -= 5, buf += 5) { + for (at = out; nbuf >= 5; nbuf -= 5, buf += 5) { *(at++) = map [ (buf[0]>>3) ]; *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; *(at++) = map [ 0x1f & (buf[1]>>1) ]; *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ]; *(at++) = map [ 0x1f & (buf[3]>>2) ]; *(at++) = map [ 0x1f & ((buf[3]<<3) | (buf[4]>>5)) ]; *(at++) = map [ 0x1f & (buf[4]) ]; - } - if (nbuf > 0) { - /* Process partials at end. */ - switch (nbuf) { - case 1: - /* |01234567| 2, padding 6 - * xxxxx - * xxx 00 - */ - - *(at++) = map [ (buf[0]>>3) ]; - *(at++) = map [ 0x1f & (buf[0]<<2) ]; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - break; - case 2: /* x3/=4 */ - /* |01234567|01234567| 4, padding 4 - * xxxxx - * xxx xx - * xxxxx - * x 0000 - */ - - *(at++) = map [ (buf[0]>>3) ]; - *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; - *(at++) = map [ 0x1f & (buf[1]>>1) ]; - *(at++) = map [ 0x1f & (buf[1]<<4) ]; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - break; - case 3: - /* |01234567|01234567|01234567| 5, padding 3 - * xxxxx - * xxx xx - * xxxxx - * x xxxx - * xxxx 0 - */ - - *(at++) = map [ (buf[0]>>3) ]; - *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; - *(at++) = map [ 0x1f & (buf[1]>>1) ]; - *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; - *(at++) = map [ 0x1f & (buf[2]<<1) ]; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - break; - case 4: - /* |01234567|01234567|01234567|012334567| 7, padding 1 - * xxxxx - * xxx xx - * xxxxx - * x xxxx - * xxxx - * xxxxx - * xxxx 0 - */ - - *(at++) = map [ (buf[0]>>3) ]; - *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; - *(at++) = map [ 0x1f & (buf[1]>>1) ]; - *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; - *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ]; - *(at++) = map [ 0x1f & (buf[3]>>2) ]; - *(at++) = map [ 0x1f & (buf[3]<<3) ]; - *(at++) = '='; - break; - } - } - - Tcl_SetObjResult (interp, Tcl_NewStringObj ((char*)out, nout)); - Tcl_Free ((char*) out); - return TCL_OK; - } - - - critcl::ccommand critcl_decode {dummy interp objc objv} { - /* Syntax -*- c -*- - * critcl_decode estring - */ - - unsigned char* buf; - int nbuf; - - unsigned char* out; - unsigned char* at; - unsigned char x [8]; - int nout; - - int i, j, a, pad, nx; - - /* - * An array for translating single base-32 characters into a value. - * Disallowed input characters have a value of 64. Upper and lower - * case is the same. Only 128 chars, as everything above char(127) - * is 64. - */ - static const char map [] = { + } + if (nbuf > 0) { + /* Process partials at end. */ + switch (nbuf) { + case 1: + /* |01234567| 2, padding 6 + * xxxxx + * xxx 00 + */ + + *(at++) = map [ (buf[0]>>3) ]; + *(at++) = map [ 0x1f & (buf[0]<<2) ]; + *(at++) = '='; + *(at++) = '='; + *(at++) = '='; + *(at++) = '='; + *(at++) = '='; + *(at++) = '='; + break; + case 2: /* x3/=4 */ + /* |01234567|01234567| 4, padding 4 + * xxxxx + * xxx xx + * xxxxx + * x 0000 + */ + + *(at++) = map [ (buf[0]>>3) ]; + *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; + *(at++) = map [ 0x1f & (buf[1]>>1) ]; + *(at++) = map [ 0x1f & (buf[1]<<4) ]; + *(at++) = '='; + *(at++) = '='; + *(at++) = '='; + *(at++) = '='; + break; + case 3: + /* |01234567|01234567|01234567| 5, padding 3 + * xxxxx + * xxx xx + * xxxxx + * x xxxx + * xxxx 0 + */ + + *(at++) = map [ (buf[0]>>3) ]; + *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; + *(at++) = map [ 0x1f & (buf[1]>>1) ]; + *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; + *(at++) = map [ 0x1f & (buf[2]<<1) ]; + *(at++) = '='; + *(at++) = '='; + *(at++) = '='; + break; + case 4: + /* |01234567|01234567|01234567|012334567| 7, padding 1 + * xxxxx + * xxx xx + * xxxxx + * x xxxx + * xxxx + * xxxxx + * xxxx 0 + */ + + *(at++) = map [ (buf[0]>>3) ]; + *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; + *(at++) = map [ 0x1f & (buf[1]>>1) ]; + *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; + *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ]; + *(at++) = map [ 0x1f & (buf[3]>>2) ]; + *(at++) = map [ 0x1f & (buf[3]<<3) ]; + *(at++) = '='; + break; + } + } + + Tcl_SetObjResult (interp, Tcl_NewStringObj ((char*)out, nout)); + Tcl_Free ((char*) out); + return TCL_OK; +} + + +critcl::ccommand ::base32::critcl_decode {dummy interp objc objv} { + /* Syntax -*- c -*- + * critcl_decode estring + */ + + unsigned char* buf; + int nbuf; + + unsigned char* out; + unsigned char* at; + unsigned char x [8]; + int nout; + + int i, j, a, pad, nx; + + /* + * An array for translating single base-32 characters into a value. + * Disallowed input characters have a value of 64. Upper and lower + * case is the same. Only 128 chars, as everything above char(127) + * is 64. + */ + static const char map [] = { /* \00 */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, /* DLE */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, /* SPC */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, /* '0' */ 64, 64, 26, 27, 28, 29, 30, 31, 64, 64, 64, 64, 64, 64, 64, 64, /* '@' */ 64, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 'P' */ 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 64, 64, 64, 64, 64, /* '`' */ 64, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 'p' */ 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 64, 64, 64, 64, 64 - }; + }; -#define USAGED "estring" + #define USAGED "estring" - if (objc != 2) { + if (objc != 2) { Tcl_WrongNumArgs (interp, 1, objv, USAGED); return TCL_ERROR; - } + } - buf = (unsigned char*) Tcl_GetStringFromObj (objv[1], &nbuf); + buf = (unsigned char*) Tcl_GetStringFromObj (objv[1], &nbuf); - if (nbuf % 8) { + if (nbuf % 8) { Tcl_SetObjResult (interp, Tcl_NewStringObj ("Length is not a multiple of 8", -1)); return TCL_ERROR; - } - - nout = (nbuf/8)*5 *TCL_UTF_MAX; - out = (unsigned char*) Tcl_Alloc (nout*sizeof(char)); - -#define HIGH(x) (((x) & 0x80) != 0) -#define BADC(x) ((x) == 64) -#define BADCHAR(a,j) (HIGH ((a)) || BADC (x [(j)] = map [(a)])) - - for (pad = 0, i=0, at = out; i < nbuf; i += 8, buf += 8){ + } + + nout = (nbuf/8)*5 *TCL_UTF_MAX; + out = (unsigned char*) Tcl_Alloc (nout*sizeof(char)); + + #define HIGH(x) (((x) & 0x80) != 0) + #define BADC(x) ((x) == 64) + #define BADCHAR(a,j) (HIGH ((a)) || BADC (x [(j)] = map [(a)])) + + for (pad = 0, i=0, at = out; i < nbuf; i += 8, buf += 8){ for (j=0; j < 8; j++){ - a = buf [j]; - - if (a == '=') { - x[j] = 0; - pad++; - continue; - } else if (pad) { - char msg [120]; - sprintf (msg, - "Invalid character at index %d: \"=\" (padding found in the middle of the input)", - j-1); - Tcl_Free ((char*) out); - Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); - return TCL_ERROR; - } - - if (BADCHAR (a,j)) { - char msg [100]; - sprintf (msg,"Invalid character at index %d: \"%c\"",j,a); - Tcl_Free ((char*) out); - Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); - return TCL_ERROR; - } + a = buf [j]; + + if (a == '=') { + x[j] = 0; + pad++; + continue; + } else if (pad) { + char msg [120]; + sprintf (msg, + "Invalid character at index %d: \"=\" (padding found in the middle of the input)", + j-1); + Tcl_Free ((char*) out); + Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); + return TCL_ERROR; + } + + if (BADCHAR (a,j)) { + char msg [100]; + sprintf (msg,"Invalid character at index %d: \"%c\"",j,a); + Tcl_Free ((char*) out); + Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); + return TCL_ERROR; + } } *(at++) = (x[0]<<3) | (x[1]>>2) ; *(at++) = (x[1]<<6) | (x[2]<<1) | (x[3]>>4); *(at++) = (x[3]<<4) | (x[4]>>1) ; *(at++) = (x[4]<<7) | (x[5]<<2) | (x[6]>>3); *(at++) = (x[6]<<5) | x[7] ; - } + } - if (pad) { + if (pad) { if (pad == 1) { - at -= 1; + at -= 1; } else if (pad == 3) { - at -= 2; + at -= 2; } else if (pad == 4) { - at -= 3; + at -= 3; } else if (pad == 6) { - at -= 4; + at -= 4; } else { - char msg [100]; - sprintf (msg,"Invalid padding of length %d",pad); - Tcl_Free ((char*) out); - Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); - return TCL_ERROR; - } - } - - Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out)); - Tcl_Free ((char*) out); - return TCL_OK; - } + char msg [100]; + sprintf (msg,"Invalid padding of length %d",pad); + Tcl_Free ((char*) out); + Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); + return TCL_ERROR; + } + } + + Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out)); + Tcl_Free ((char*) out); + return TCL_OK; } # ### ### ### ######### ######### ######### ## Ready + +# # ## ### ##### ######## ############# ##################### +# @sak notprovided base32_c +package provide base32_c 0.1 +return Index: modules/base32/base32hex_c.tcl ================================================================== --- modules/base32/base32hex_c.tcl +++ modules/base32/base32hex_c.tcl @@ -4,61 +4,81 @@ # # Public domain # # RCS: @(#) $Id: base32hex_c.tcl,v 1.3 2008/01/28 22:58:18 andreas_kupries Exp $ -package require critcl +package require critcl 3.1 package require Tcl 8.4 -namespace eval ::base32::hex { - # Supporting code for the main command. - catch { - #critcl::cheaders -g - #critcl::debug memory symbols - } - - # Main commands, encoder & decoder - - critcl::ccommand critcl_encode {dummy interp objc objv} { - /* Syntax -*- c -*- - * critcl_encode string - */ - - unsigned char* buf; - int nbuf; - - unsigned char* out; - unsigned char* at; - int nout; - - /* - * The array used for encoding - */ /* 123456789 123456789 123456789 12 */ - static const char map[] = "0123456789ABCDEFGHIJKLMNOPQRSTUV"; +if {![critcl::compiling]} { + error "Unable to build base32hex_c, no proper compiler found." +} + +# # ## ### ##### ######## ############# ##################### +## Administrivia + +critcl::license {Andreas Kupries} {CC-0 public domain} +critcl::summary { + C implementation of the extended hex Base32 de- and encoder. +} +critcl::description { + This package provides a C implementation of an extended hex + base32 de- and encoder, as per RFC 3548. +} +critcl::subject \ + base32 {rfc 3548} + +critcl::meta location http://core.tcl.tk/tcllib + +# # ## ### ##### ######## ############# ##################### +## Implementation + +critcl::tcl 8.4 + +namespace eval ::base32::hex {} + +# Main commands, encoder & decoder + +critcl::ccommand ::base32::hex::critcl_encode {dummy interp objc objv} { + /* Syntax -*- c -*- + * critcl_encode string + */ + + unsigned char* buf; + int nbuf; + + unsigned char* out; + unsigned char* at; + int nout; + + /* + * The array used for encoding + */ /* 123456789 123456789 123456789 12 */ + static const char map[] = "0123456789ABCDEFGHIJKLMNOPQRSTUV"; #define USAGEE "bitstring" - if (objc != 2) { - Tcl_WrongNumArgs (interp, 1, objv, USAGEE); - return TCL_ERROR; - } - - buf = Tcl_GetByteArrayFromObj (objv[1], &nbuf); - nout = ((nbuf+4)/5)*8; - out = (unsigned char*) Tcl_Alloc (nout*sizeof(char)); - - for (at = out; nbuf >= 5; nbuf -= 5, buf += 5) { + if (objc != 2) { + Tcl_WrongNumArgs (interp, 1, objv, USAGEE); + return TCL_ERROR; + } + + buf = Tcl_GetByteArrayFromObj (objv[1], &nbuf); + nout = ((nbuf+4)/5)*8; + out = (unsigned char*) Tcl_Alloc (nout*sizeof(char)); + + for (at = out; nbuf >= 5; nbuf -= 5, buf += 5) { *(at++) = map [ (buf[0]>>3) ]; *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; *(at++) = map [ 0x1f & (buf[1]>>1) ]; *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ]; *(at++) = map [ 0x1f & (buf[3]>>2) ]; *(at++) = map [ 0x1f & ((buf[3]<<3) | (buf[4]>>5)) ]; *(at++) = map [ 0x1f & (buf[4]) ]; - } - if (nbuf > 0) { + } + if (nbuf > 0) { /* Process partials at end. */ switch (nbuf) { case 1: /* |01234567| 2, padding 6 * xxxxx @@ -128,72 +148,71 @@ *(at++) = map [ 0x1f & (buf[3]>>2) ]; *(at++) = map [ 0x1f & (buf[3]<<3) ]; *(at++) = '='; break; } - } - - Tcl_SetObjResult (interp, Tcl_NewStringObj ((char*)out, nout)); - Tcl_Free ((char*) out); - return TCL_OK; - } - - - critcl::ccommand critcl_decode {dummy interp objc objv} { - /* Syntax -*- c -*- - * critcl_decode estring - */ - - unsigned char* buf; - int nbuf; - - unsigned char* out; - unsigned char* at; - unsigned char x [8]; - int nout; - - int i, j, a, pad, nx; - - /* - * An array for translating single base-32 characters into a value. - * Disallowed input characters have a value of 64. Upper and lower - * case is the same. Only 128 chars, as everything above char(127) - * is 64. - */ - static const char map [] = { + } + + Tcl_SetObjResult (interp, Tcl_NewStringObj ((char*)out, nout)); + Tcl_Free ((char*) out); + return TCL_OK; +} + +critcl::ccommand ::base32::hex::critcl_decode {dummy interp objc objv} { + /* Syntax -*- c -*- + * critcl_decode estring + */ + + unsigned char* buf; + int nbuf; + + unsigned char* out; + unsigned char* at; + unsigned char x [8]; + int nout; + + int i, j, a, pad, nx; + + /* + * An array for translating single base-32 characters into a value. + * Disallowed input characters have a value of 64. Upper and lower + * case is the same. Only 128 chars, as everything above char(127) + * is 64. + */ + static const char map [] = { /* \00 */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, /* DLE */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, /* SPC */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, /* '0' */ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 64, 64, 64, 64, 64, 64, /* '@' */ 64, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 'P' */ 25, 26, 27, 28, 29, 30, 31, 64, 64, 64, 64, 64, 64, 64, 64, 64, /* '`' */ 64, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 'p' */ 25, 26, 27, 28, 29, 30, 31, 64, 64, 64, 64, 64, 64, 64, 64, 64 - }; + }; #define USAGED "estring" - if (objc != 2) { + if (objc != 2) { Tcl_WrongNumArgs (interp, 1, objv, USAGED); return TCL_ERROR; - } + } - buf = (unsigned char*) Tcl_GetStringFromObj (objv[1], &nbuf); + buf = (unsigned char*) Tcl_GetStringFromObj (objv[1], &nbuf); - if (nbuf % 8) { + if (nbuf % 8) { Tcl_SetObjResult (interp, Tcl_NewStringObj ("Length is not a multiple of 8", -1)); return TCL_ERROR; - } + } - nout = (nbuf/8)*5 *TCL_UTF_MAX; - out = (unsigned char*) Tcl_Alloc (nout*sizeof(char)); + nout = (nbuf/8)*5 *TCL_UTF_MAX; + out = (unsigned char*) Tcl_Alloc (nout*sizeof(char)); #define HIGH(x) (((x) & 0x80) != 0) #define BADC(x) ((x) == 64) #define BADCHAR(a,j) (HIGH ((a)) || BADC (x [(j)] = map [(a)])) - for (pad = 0, i=0, at = out; i < nbuf; i += 8, buf += 8){ + for (pad = 0, i=0, at = out; i < nbuf; i += 8, buf += 8){ for (j=0; j < 8; j++){ a = buf [j]; if (a == '=') { x[j] = 0; @@ -221,33 +240,37 @@ *(at++) = (x[0]<<3) | (x[1]>>2) ; *(at++) = (x[1]<<6) | (x[2]<<1) | (x[3]>>4); *(at++) = (x[3]<<4) | (x[4]>>1) ; *(at++) = (x[4]<<7) | (x[5]<<2) | (x[6]>>3); *(at++) = (x[6]<<5) | x[7] ; - } + } - if (pad) { + if (pad) { if (pad == 1) { - at -= 1; + at -= 1; } else if (pad == 3) { - at -= 2; + at -= 2; } else if (pad == 4) { - at -= 3; + at -= 3; } else if (pad == 6) { - at -= 4; + at -= 4; } else { - char msg [100]; - sprintf (msg,"Invalid padding of length %d",pad); - Tcl_Free ((char*) out); - Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); - return TCL_ERROR; - } - } - - Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out)); - Tcl_Free ((char*) out); - return TCL_OK; - } + char msg [100]; + sprintf (msg,"Invalid padding of length %d",pad); + Tcl_Free ((char*) out); + Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); + return TCL_ERROR; + } + } + + Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out)); + Tcl_Free ((char*) out); + return TCL_OK; } # ### ### ### ######### ######### ######### ## Ready + +# # ## ### ##### ######## ############# ##################### +# @sak notprovided base32hex_c +package provide base32hex_c 0.1 +return Index: modules/base64/base64c.tcl ================================================================== --- modules/base64/base64c.tcl +++ modules/base64/base64c.tcl @@ -10,10 +10,12 @@ package require critcl package provide base64c 0.1.0 namespace eval ::base64c { variable base64c_rcsid {$Id: base64c.tcl,v 1.5 2008/03/25 07:15:35 andreas_kupries Exp $} +} - critcl::ccode { - /* no code required in this file */ - } +critcl::ccode { + /* no code required in this file */ } + +# TODO: Take the C code out of base64.tcl Index: modules/crc/crcc.tcl ================================================================== --- modules/crc/crcc.tcl +++ modules/crc/crcc.tcl @@ -18,5 +18,7 @@ } } # @sak notprovided crcc package provide crcc 1.0.0 + +# TODO: Take the C code out of crc.tcl Index: modules/dns/ipMoreC.tcl ================================================================== --- modules/dns/ipMoreC.tcl +++ modules/dns/ipMoreC.tcl @@ -1,5 +1,13 @@ +# -*- tcl -*- + +package require critcl 3.1 + +if {![critcl::compiling]} { + error "Unable to build ipMorec, no proper compiler found." +} + # Skip this for window and a specific version of Solaris # # This could do with an explanation -- why are we avoiding these platforms # and perhaps using critcl's platform::platform command might be better? # @@ -12,231 +20,251 @@ /* nothing to do */ } return } -package require critcl; +# # ## ### ##### ######## ############# ##################### +## Administrivia + +critcl::license {Aamer Akhter} BSD +critcl::summary { + Fast, i.e. C implementations of various dns::ip functions. +} +critcl::description { + Fast, i.e. C implementations of various dns::ip functions. +} +critcl::subject {internet address} ip ipv4 ipv6 {rfc 3513} +critcl::meta location http://core.tcl.tk/tcllib + +# # ## ### ##### ######## ############# ##################### +## Implementation + +critcl::tcl 8.4 -namespace eval ::ip { +namespace eval ::ip {} critcl::ccode { -#include -#include -#include -#include -#include -#include -#include -} - -critcl::ccommand prefixToNativec {clientData interp objc objv} { - int elemLen, maskLen, ipLen, mask; - int rval,convertListc,i; - Tcl_Obj **convertListv; - Tcl_Obj *listPtr,*returnPtr, *addrList; - char *stringIP, *slashPos, *stringMask; - char v4HEX[11]; - - uint32_t inaddr; - listPtr = NULL; - - /* printf ("\n in prefixToNativeC"); */ - /* printf ("\n objc = %d",objc); */ - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "/"); - return TCL_ERROR; - } - - - if (Tcl_ListObjGetElements (interp, objv[1], - &convertListc, &convertListv) != TCL_OK) { - return TCL_ERROR; - } - returnPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - for (i = 0; i < convertListc; i++) { - /* need to create a duplicate here because when we modify */ - /* the stringIP it'll mess up the original in the calling */ - /* context */ - addrList = Tcl_DuplicateObj(convertListv[i]); - stringIP = Tcl_GetStringFromObj(addrList, &elemLen); - listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - /* printf ("\n ### %s ### string \n", stringIP); */ - /* split the ip address and mask */ - slashPos = strchr(stringIP, (int) '/'); - if (slashPos == NULL) { - /* straight ip address without mask */ - mask = 0xffffffff; - ipLen = strlen(stringIP); - } else { - /* ipaddress has the mask, handle the mask and seperate out the */ - /* ip address */ - /* printf ("\n ** %d ",(uintptr_t)slashPos); */ - stringMask = slashPos +1; - maskLen =strlen(stringMask); - /* put mask in hex form */ - if (maskLen < 3) { - mask = atoi(stringMask); - mask = (0xFFFFFFFF << (32 - mask)) & 0xFFFFFFFF; - } else { - /* mask is in dotted form */ - if ((rval = inet_pton(AF_INET,stringMask,&mask)) < 1 ) { - Tcl_AddErrorInfo(interp, "\n bad format encountered in mask conversion"); - return TCL_ERROR; - } - mask = htonl(mask); - } - ipLen = (uintptr_t)slashPos - (uintptr_t)stringIP; - /* divide the string into ip and mask portion */ - *slashPos = '\0'; - /* printf("\n %d %d %d %d", (uintptr_t)stringMask, maskLen, (uintptr_t)stringIP, ipLen); */ - } - if ( (rval = inet_pton(AF_INET,stringIP,&inaddr)) < 1) { - Tcl_AddErrorInfo(interp, - "\n bad format encountered in ip conversion"); - return TCL_ERROR; - }; - inaddr = htonl(inaddr); - /* apply the mask the to the ip portion, just to make sure */ - /* what we return is cleaned up */ - inaddr = inaddr & mask; - sprintf(v4HEX,"0x%08X",inaddr); - /* printf ("\n\n ### %s",v4HEX); */ - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(v4HEX,-1)); - sprintf(v4HEX,"0x%08X",mask); - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(v4HEX,-1)); - Tcl_ListObjAppendElement(interp, returnPtr, listPtr); - Tcl_DecrRefCount(addrList); - } - - if (convertListc==1) { - Tcl_SetObjResult(interp,listPtr); - } else { - Tcl_SetObjResult(interp,returnPtr); - } - - return TCL_OK; -} - -critcl::ccommand isOverlapNativec {clientData interp objc objv} { - int i; - unsigned int ipaddr,ipMask, mask1mask2; - unsigned int ipaddr2,ipMask2; - int compareListc,comparePrefixMaskc; - int allSet,inlineSet,index; - Tcl_Obj **compareListv,**comparePrefixMaskv, *listPtr; - Tcl_Obj *result; - static CONST char *options[] = { - "-all", "-inline", "-ipv4", NULL + #include + #include + #include + #include + #include + #include + #include +} + +# todo :: critcl :: Convert to cproc (single argument, fixed) +critcl::ccommand ::ip::prefixToNativec {clientData interp objc objv} { + + int elemLen, maskLen, ipLen, mask; + int rval,convertListc,i; + Tcl_Obj **convertListv; + Tcl_Obj *listPtr,*returnPtr, *addrList; + char *stringIP, *slashPos, *stringMask; + char v4HEX[11]; + + uint32_t inaddr; + listPtr = NULL; + + /* printf ("\n in prefixToNativeC"); */ + /* printf ("\n objc = %d",objc); */ + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "/"); + return TCL_ERROR; + } + + if (Tcl_ListObjGetElements (interp, objv[1], + &convertListc, &convertListv) != TCL_OK) { + return TCL_ERROR; + } + + returnPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + + for (i = 0; i < convertListc; i++) { + /* need to create a duplicate here because when we modify */ + /* the stringIP it'll mess up the original in the calling */ + /* context */ + + addrList = Tcl_DuplicateObj(convertListv[i]); + stringIP = Tcl_GetStringFromObj(addrList, &elemLen); + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + + /* printf ("\n ### %s ### string \n", stringIP); */ + /* split the ip address and mask */ + + slashPos = strchr(stringIP, (int) '/'); + if (slashPos == NULL) { + /* straight ip address without mask */ + mask = 0xffffffff; + ipLen = strlen(stringIP); + } else { + /* ipaddress has the mask, handle the mask and seperate out the */ + /* ip address */ + /* printf ("\n ** %d ",(uintptr_t)slashPos); */ + + stringMask = slashPos +1; + maskLen =strlen(stringMask); + /* put mask in hex form */ + if (maskLen < 3) { + mask = atoi(stringMask); + mask = (0xFFFFFFFF << (32 - mask)) & 0xFFFFFFFF; + } else { + /* mask is in dotted form */ + if ((rval = inet_pton(AF_INET,stringMask,&mask)) < 1 ) { + Tcl_AddErrorInfo(interp, "\n bad format encountered in mask conversion"); + return TCL_ERROR; + } + mask = htonl(mask); + } + ipLen = (uintptr_t)slashPos - (uintptr_t)stringIP; + /* divide the string into ip and mask portion */ + *slashPos = '\0'; + /* printf("\n %d %d %d %d", (uintptr_t)stringMask, maskLen, (uintptr_t)stringIP, ipLen); */ + } + if ( (rval = inet_pton(AF_INET,stringIP,&inaddr)) < 1) { + Tcl_AddErrorInfo(interp, + "\n bad format encountered in ip conversion"); + return TCL_ERROR; + }; + inaddr = htonl(inaddr); + /* apply the mask the to the ip portion, just to make sure */ + /* what we return is cleaned up */ + inaddr = inaddr & mask; + sprintf(v4HEX,"0x%08X",inaddr); + /* printf ("\n\n ### %s",v4HEX); */ + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(v4HEX,-1)); + sprintf(v4HEX,"0x%08X",mask); + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(v4HEX,-1)); + Tcl_ListObjAppendElement(interp, returnPtr, listPtr); + Tcl_DecrRefCount(addrList); + } + + if (convertListc==1) { + Tcl_SetObjResult(interp,listPtr); + } else { + Tcl_SetObjResult(interp,returnPtr); + } + + return TCL_OK; +} + +critcl::ccommand ::ip::isOverlapNativec {clientData interp objc objv} { + int i; + unsigned int ipaddr,ipMask, mask1mask2; + unsigned int ipaddr2,ipMask2; + int compareListc,comparePrefixMaskc; + int allSet,inlineSet,index; + Tcl_Obj **compareListv,**comparePrefixMaskv, *listPtr; + Tcl_Obj *result; + + static CONST char *options[] = { + "-all","-inline","-ipv4", + NULL }; enum options { - OVERLAP_ALL, OVERLAP_INLINE, OVERLAP_IPV4 - }; - - allSet = 0; - inlineSet = 0; - listPtr = NULL; - - /* printf ("\n objc = %d",objc); */ - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?options? "); - return TCL_ERROR; - } - for (i = 1; i < objc-3; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) - != TCL_OK) { - return TCL_ERROR; - } - switch (index) { - case OVERLAP_ALL: - allSet = 1; - /* printf ("\n all selected"); */ - break; - case OVERLAP_INLINE: - inlineSet = 1; - /* printf ("\n inline selected"); */ - break; - case OVERLAP_IPV4: - break; - } - } - /* options are parsed */ - - /* create return obj */ - result = Tcl_GetObjResult (interp); - - /* set ipaddr and ipmask */ - Tcl_GetIntFromObj(interp,objv[objc-3],(int*)&ipaddr); - Tcl_GetIntFromObj(interp,objv[objc-2],(int*)&ipMask); - - /* split the 3rd argument into pairs */ - if (Tcl_ListObjGetElements (interp, objv[objc-1], &compareListc, &compareListv) != TCL_OK) { - return TCL_ERROR; - } -/* printf("comparing %x/%x \n",ipaddr,ipMask); */ - - if (allSet || inlineSet) { - listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - } - - for (i = 0; i < compareListc; i++) { - /* split the ipaddr2 and ipmask2 */ - if (Tcl_ListObjGetElements (interp, - compareListv[i], - &comparePrefixMaskc, - &comparePrefixMaskv) != TCL_OK) { - return TCL_ERROR; - } - if (comparePrefixMaskc != 2) { - Tcl_AddErrorInfo(interp,"need format {{ } { "); + return TCL_ERROR; + } + + /* process options */ + for (i = 1; i < objc-3; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) + != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case OVERLAP_ALL: + allSet = 1; + /* printf ("\n all selected"); */ + break; + case OVERLAP_INLINE: + inlineSet = 1; + /* printf ("\n inline selected"); */ + break; + case OVERLAP_IPV4: + break; + } + } + /* options are parsed */ + + /* create return obj */ + result = Tcl_GetObjResult (interp); + + /* set ipaddr and ipmask */ + Tcl_GetIntFromObj(interp,objv[objc-3],(int*)&ipaddr); + Tcl_GetIntFromObj(interp,objv[objc-2],(int*)&ipMask); + + /* split the 3rd argument into pairs */ + if (Tcl_ListObjGetElements (interp, objv[objc-1], &compareListc, &compareListv) != TCL_OK) { + return TCL_ERROR; + } + /* printf("comparing %x/%x \n",ipaddr,ipMask); */ + + if (allSet || inlineSet) { + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + } + + for (i = 0; i < compareListc; i++) { + /* split the ipaddr2 and ipmask2 */ + if (Tcl_ListObjGetElements (interp, + compareListv[i], + &comparePrefixMaskc, + &comparePrefixMaskv) != TCL_OK) { + return TCL_ERROR; + } + if (comparePrefixMaskc != 2) { + Tcl_AddErrorInfo(interp,"need format {{ } { # Copyright (c) 2013 - C binding - mi+tcl.tk-2013@aldan.algebra.com -package require critcl -# @sak notprovided jsonc -package provide jsonc 1.1.1 +package require critcl 3.1 package require Tcl 8.4 -#critcl::cheaders -g -#critcl::debug memory symbols -critcl::cheaders -Ic c/*.h -critcl::csources c/*.c +if {![critcl::compiling]} { + error "Unable to build jsonc, no proper compiler found." +} + +# # ## ### ##### ######## ############# ##################### +## Administrivia + +critcl::license {Mikhail Teterin} BSD +critcl::summary { + C implementation of a JSON parser. +} +critcl::description { + This package provides a C implementation of a KJSON parser. +} +critcl::subject json +critcl::meta location http://core.tcl.tk/tcllib + +# # ## ### ##### ######## ############# ##################### +## Implementation + +critcl::tcl 8.4 # # ## ### Import base declarations, forwards ### ## # # +critcl::cheaders c/*.h +critcl::csources c/*.c + +# # ## ### Main Conversion ### ## # # + +namespace eval ::json {} critcl::ccode { #include } -# # ## ### Main Conversion ### ## # # - -namespace eval ::json { - critcl::ccommand json2dict_critcl {dummy I objc objv} { - struct context context = { NULL }; - - if (objc != 2) { - Tcl_WrongNumArgs(I, 1, objv, "json"); - return TCL_ERROR; - } - - context.text = Tcl_GetStringFromObj(objv[1], &context.remaining); - context.I = I; - context.has_error = 0; - context.result = TCL_ERROR; - - jsonparse (&context); - return context.result; - } - - # Issue with critcl 2 used here. Cannot use '-', incomplete distinction of C and Tcl names. - # The json.tcl file making use of this code has a wrapper fixing the issue. - critcl::ccommand many_json2dict_critcl {dummy I objc objv} { - struct context context = { NULL }; - - int max; - int found; - - Tcl_Obj* result = Tcl_NewListObj (0, NULL); - - if ((objc < 2) || (objc > 3)) { - Tcl_WrongNumArgs(I, 1, objv, "jsonText ?max?"); - return TCL_ERROR; - } - - if (objc == 3) { - if (Tcl_GetIntFromObj(I, objv[2], &max) != TCL_OK) { - return TCL_ERROR; - } - if (max <= 0) { - Tcl_AppendResult (I, "Bad limit ", - Tcl_GetString (objv[2]), - " of json entities to extract.", - NULL); - Tcl_SetErrorCode (I, "JSON", "BAD-LIMIT", NULL); - return TCL_ERROR; - } - - } else { - max = -1; - } - - context.text = Tcl_GetStringFromObj(objv[1], &context.remaining); - context.I = I; - context.has_error = 0; - found = 0; - - /* Iterate over the input until - * - we have gotten all requested values. - * - we have run out of input - * - we have run into an error - */ - - while ((max < 0) || max) { - context.result = TCL_ERROR; - jsonparse (&context); - - /* parse error, abort */ - if (context.result != TCL_OK) { - Tcl_DecrRefCount (result); - return TCL_ERROR; - } - - /* Proper value extracted, extend result */ - found ++; - Tcl_ListObjAppendElement(I, result, - Tcl_GetObjResult (I)); - - /* Count down on the number of still missing - * values, if not asking for all (-1) - */ - if (max > 0) max --; - - /* Jump over trailing whitespace for proper end-detection */ - jsonskip (&context); - - /* Abort if we have consumed all input */ - if (!context.remaining) break; - - /* Clear scratch pad before continuing */ - context.obj = NULL; - } - - /* While all parses were ok we reached end of - * input without getting all requested values, - * this is an error - */ - if (max > 0) { - char buf [30]; - sprintf (buf, "%d", found); - Tcl_ResetResult (I); - Tcl_AppendResult (I, "Bad limit ", - Tcl_GetString (objv[2]), - " of json entities to extract, found only ", - buf, - ".", - NULL); - Tcl_SetErrorCode (I, "JSON", "BAD-LIMIT", "TOO", "LARGE", NULL); - Tcl_DecrRefCount (result); - return TCL_ERROR; - } - - /* We are good and done */ - Tcl_SetObjResult(I, result); - return TCL_OK; - } - - if 0 {critcl::ccommand validate_critcl {dummy I objc objv} { - struct context context = { NULL }; - - if (objc != 2) { - Tcl_WrongNumArgs(I, 1, objv, "jsonText"); - return TCL_ERROR; - } - - context.text = Tcl_GetStringFromObj(objv[1], &context.remaining); - context.I = I; - context.result = TCL_ERROR; - - /* Iterate over the input until we have run - * out of text, or encountered an error. We - * use only the lexer here, and told it to not - * create superfluous token values. - */ - - while (context.remaining) { - if (jsonlex (&context) == -1) { - Tcl_SetObjResult(I, Tcl_NewBooleanObj (0)); - return TCL_OK; - } - } - - /* We are good and done */ - Tcl_SetObjResult(I, Tcl_NewBooleanObj (1)); - return TCL_OK; - }} -} +critcl::ccommand ::json::json2dict_critcl {dummy I objc objv} { + struct context context = { NULL }; + + if (objc != 2) { + Tcl_WrongNumArgs(I, 1, objv, "json"); + return TCL_ERROR; + } + + context.text = Tcl_GetStringFromObj(objv[1], &context.remaining); + context.I = I; + context.has_error = 0; + context.result = TCL_ERROR; + + jsonparse (&context); + return context.result; +} + +# Issue with critcl 2 used here. Cannot use '-', incomplete distinction of C and Tcl names. +# The json.tcl file making use of this code has a wrapper fixing the issue. +critcl::ccommand ::json::many_json2dict_critcl {dummy I objc objv} { + struct context context = { NULL }; + + int max; + int found; + + Tcl_Obj* result = Tcl_NewListObj (0, NULL); + + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(I, 1, objv, "jsonText ?max?"); + return TCL_ERROR; + } + + if (objc == 3) { + if (Tcl_GetIntFromObj(I, objv[2], &max) != TCL_OK) { + return TCL_ERROR; + } + if (max <= 0) { + Tcl_AppendResult (I, "Bad limit ", + Tcl_GetString (objv[2]), + " of json entities to extract.", + NULL); + Tcl_SetErrorCode (I, "JSON", "BAD-LIMIT", NULL); + return TCL_ERROR; + } + + } else { + max = -1; + } + + context.text = Tcl_GetStringFromObj(objv[1], &context.remaining); + context.I = I; + context.has_error = 0; + found = 0; + + /* Iterate over the input until + * - we have gotten all requested values. + * - we have run out of input + * - we have run into an error + */ + + while ((max < 0) || max) { + context.result = TCL_ERROR; + jsonparse (&context); + + /* parse error, abort */ + if (context.result != TCL_OK) { + Tcl_DecrRefCount (result); + return TCL_ERROR; + } + + /* Proper value extracted, extend result */ + found ++; + Tcl_ListObjAppendElement(I, result, + Tcl_GetObjResult (I)); + + /* Count down on the number of still missing + * values, if not asking for all (-1) + */ + if (max > 0) max --; + + /* Jump over trailing whitespace for proper end-detection */ + jsonskip (&context); + + /* Abort if we have consumed all input */ + if (!context.remaining) break; + + /* Clear scratch pad before continuing */ + context.obj = NULL; + } + + /* While all parses were ok we reached end of + * input without getting all requested values, + * this is an error + */ + if (max > 0) { + char buf [30]; + sprintf (buf, "%d", found); + Tcl_ResetResult (I); + Tcl_AppendResult (I, "Bad limit ", + Tcl_GetString (objv[2]), + " of json entities to extract, found only ", + buf, + ".", + NULL); + Tcl_SetErrorCode (I, "JSON", "BAD-LIMIT", "TOO", "LARGE", NULL); + Tcl_DecrRefCount (result); + return TCL_ERROR; + } + + /* We are good and done */ + Tcl_SetObjResult(I, result); + return TCL_OK; +} + +if 0 {critcl::ccommand ::json::validate_critcl {dummy I objc objv} { + struct context context = { NULL }; + + if (objc != 2) { + Tcl_WrongNumArgs(I, 1, objv, "jsonText"); + return TCL_ERROR; + } + + context.text = Tcl_GetStringFromObj(objv[1], &context.remaining); + context.I = I; + context.result = TCL_ERROR; + + /* Iterate over the input until we have run + * out of text, or encountered an error. We + * use only the lexer here, and told it to not + * create superfluous token values. + */ + + while (context.remaining) { + if (jsonlex (&context) == -1) { + Tcl_SetObjResult(I, Tcl_NewBooleanObj (0)); + return TCL_OK; + } + } + + /* We are good and done */ + Tcl_SetObjResult(I, Tcl_NewBooleanObj (1)); + return TCL_OK; +}} + + +# # ## ### ##### ######## ############# ##################### +# @sak notprovided jsonc +package provide jsonc 1.1.1 +return Index: modules/md4/md4c.tcl ================================================================== --- modules/md4/md4c.tcl +++ modules/md4/md4c.tcl @@ -1,120 +1,154 @@ # md4c.tcl - Copyright (C) 2003 Pat Thoyts -# -# This provides a C implementation of MD4 using the sample code from RFC1320 -# and wrapping this up in a Tcl package. -# -# The tcl interface code is based upon the md5c code from critcl by JCW. -# + +# This provides a C implementation of MD4 using the sample code from +# RFC1320 and wrapping this up in a Tcl package. + +# The tcl interface code is based upon the md5c code from critcl by +# JCW (Jean-Claude Wippler ). + # INSTALLATION # ------------ -# This package uses critcl (http://wiki.tcl.tk/critcl). To build do: -# critcl -libdir -pkg md4c md4c +# This package uses critcl v3 (http://wiki.tcl.tk/critcl). +# To build run: +# critcl3 -libdir -pkg md4c md4c # # $Id: md4c.tcl,v 1.6 2009/05/06 22:57:50 patthoyts Exp $ -package require critcl -# @sak notprovided md4c -package provide md4c 1.1.0 +package require critcl 3.1 + +if {![critcl::compiling]} { + error "Unable to build md4c, no proper compiler found." +} + +# # ## ### ##### ######## ############# ##################### +## Administrivia + +critcl::license {Pat Thoyts, Jean-Claude Wippler} BSD +critcl::summary { + C implementation of the MD4 message digest +} +critcl::description { + This package provides a C implementation of MD4 using the + sample code from RFC1320 and wrapping this up in a Tcl + package. The tcl interface code is based upon the md5c code + from critcl by JCW (Jean-Claude Wippler ). +} +critcl::subject \ + hashing md4 message-digest security \ + {rfc 1320} {rfc 1321} {rfc 2104} + +critcl::meta location http://core.tcl.tk/tcllib + +# # ## ### ##### ######## ############# ##################### +## Implementation + +## todo :: critcl :: possibly define an argument conversion for the +## context. handling of default is an issue. + +critcl::tcl 8.4 critcl::cheaders md4.h critcl::csources md4.c -namespace eval ::md4 { - - critcl::ccode { - #include - #include "md4.h" - - /* - * define a Tcl object type for the MD4 state - */ - static Tcl_ObjType md4_type; - - static void md4_free_rep(Tcl_Obj *obj) - { - MD4_CTX *ctx = (MD4_CTX *)obj->internalRep.otherValuePtr; - Tcl_Free((char *)ctx); - } - - static void md4_dup_rep(Tcl_Obj *obj, Tcl_Obj *dup) - { - MD4_CTX *ctx = (MD4_CTX *)obj->internalRep.otherValuePtr; - dup->internalRep.otherValuePtr = (MD4_CTX *)Tcl_Alloc(sizeof(MD4_CTX)); - memcpy(dup->internalRep.otherValuePtr, ctx, sizeof(MD4_CTX)); - dup->typePtr = &md4_type; - } - - static void md4_string_rep(Tcl_Obj* obj) - { - unsigned char buf[16]; - Tcl_Obj* temp; - char* str; - MD4_CTX *dup = (MD4_CTX *)obj->internalRep.otherValuePtr; - - MD4Final(buf, dup); - - /* convert via a byte array to properly handle null bytes */ - temp = Tcl_NewByteArrayObj(buf, sizeof buf); - Tcl_IncrRefCount(temp); - - str = Tcl_GetStringFromObj(temp, &obj->length); - obj->bytes = Tcl_Alloc(obj->length + 1); - memcpy(obj->bytes, str, obj->length + 1); - - Tcl_DecrRefCount(temp); - } - - static int md4_from_any(Tcl_Interp* interp, Tcl_Obj* obj) - { - /* assert(0); */ - return TCL_ERROR; - } - - static Tcl_ObjType md4_type = { - "md4c", md4_free_rep, md4_dup_rep, md4_string_rep, md4_from_any - }; - - } - - critcl::ccommand md4c {dummy interp objc objv} { - MD4_CTX *ctx; - unsigned char *data; - int size; - Tcl_Obj *obj; - - if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "data ?context?"); - return TCL_ERROR; - } - - if (objc == 3) { - if (objv[2]->typePtr != &md4_type - && md4_from_any(interp, objv[2]) != TCL_OK) { - return TCL_ERROR; - } - obj = objv[2]; - if (Tcl_IsShared(obj)) { - obj = Tcl_DuplicateObj(obj); - } - } else { - ctx = (MD4_CTX *)Tcl_Alloc(sizeof(MD4_CTX)); - MD4Init(ctx); - obj = Tcl_NewObj(); - Tcl_InvalidateStringRep(obj); - obj->internalRep.otherValuePtr = ctx; - obj->typePtr = &md4_type; - } - - ctx = (MD4_CTX *)obj->internalRep.otherValuePtr; - data = Tcl_GetByteArrayFromObj(objv[1], &size); - MD4Update(ctx, data, size); - Tcl_SetObjResult(interp, obj); - - return TCL_OK; - } -} +namespace eval ::md4 {} + +critcl::ccode { + #include + #include "md4.h" + + /* + * define a Tcl object type for the MD4 state + */ + static Tcl_ObjType md4_type; + + static void md4_free_rep(Tcl_Obj *obj) + { + MD4_CTX *ctx = (MD4_CTX *)obj->internalRep.otherValuePtr; + Tcl_Free((char *)ctx); + } + + static void md4_dup_rep(Tcl_Obj *obj, Tcl_Obj *dup) + { + MD4_CTX *ctx = (MD4_CTX *)obj->internalRep.otherValuePtr; + dup->internalRep.otherValuePtr = (MD4_CTX *)Tcl_Alloc(sizeof(MD4_CTX)); + memcpy(dup->internalRep.otherValuePtr, ctx, sizeof(MD4_CTX)); + dup->typePtr = &md4_type; + } + + static void md4_string_rep(Tcl_Obj* obj) + { + unsigned char buf[16]; + Tcl_Obj* temp; + char* str; + MD4_CTX *dup = (MD4_CTX *)obj->internalRep.otherValuePtr; + + MD4Final(buf, dup); + + /* convert via a byte array to properly handle null bytes */ + temp = Tcl_NewByteArrayObj(buf, sizeof buf); + Tcl_IncrRefCount(temp); + + str = Tcl_GetStringFromObj(temp, &obj->length); + obj->bytes = Tcl_Alloc(obj->length + 1); + memcpy(obj->bytes, str, obj->length + 1); + + Tcl_DecrRefCount(temp); + } + + static int md4_from_any(Tcl_Interp* interp, Tcl_Obj* obj) + { + /* assert(0); */ + return TCL_ERROR; + } + + static Tcl_ObjType md4_type = { + "md4c", md4_free_rep, md4_dup_rep, md4_string_rep, md4_from_any + }; +} + +critcl::ccommand ::md4::md4c {dummy interp objc objv} { + MD4_CTX *ctx; + unsigned char *data; + int size; + Tcl_Obj *obj; + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "data ?context?"); + return TCL_ERROR; + } + + if (objc == 3) { + if (objv[2]->typePtr != &md4_type + && md4_from_any(interp, objv[2]) != TCL_OK) { + return TCL_ERROR; + } + obj = objv[2]; + if (Tcl_IsShared(obj)) { + obj = Tcl_DuplicateObj(obj); + } + } else { + ctx = (MD4_CTX *)Tcl_Alloc(sizeof(MD4_CTX)); + MD4Init(ctx); + obj = Tcl_NewObj(); + Tcl_InvalidateStringRep(obj); + obj->internalRep.otherValuePtr = ctx; + obj->typePtr = &md4_type; + } + + ctx = (MD4_CTX *)obj->internalRep.otherValuePtr; + data = Tcl_GetByteArrayFromObj(objv[1], &size); + MD4Update(ctx, data, size); + Tcl_SetObjResult(interp, obj); + + return TCL_OK; +} + +# # ## ### ##### ######## ############# ##################### +# @sak notprovided md4c +package provide md4c 1.1.0 +return # Local variables: # mode: tcl # indent-tabs-mode: nil # End: Index: modules/md5/md5c.tcl ================================================================== --- modules/md5/md5c.tcl +++ modules/md5/md5c.tcl @@ -1,148 +1,186 @@ # md5c.tcl - # # Wrapper for RSA's Message Digest in C # -# Written by Jean-Claude Wippler +# Written by Jean-Claude Wippler # # $Id: md5c.tcl,v 1.5 2009/05/06 22:46:10 patthoyts Exp $ -package require critcl; # needs critcl -# @sak notprovided md5c -package provide md5c 0.12; # - -critcl::cheaders md5.h; # The RSA header file -critcl::csources md5.c; # The RSA MD5 implementation. - -namespace eval ::md5 { - - critcl::ccode { - #include - #include "md5.h" - #include - - static - Tcl_ObjType md5_type; /* fast internal access representation */ - - static void - md5_free_rep(Tcl_Obj *obj) - { - MD5_CTX *mp = (MD5_CTX *) obj->internalRep.otherValuePtr; - Tcl_Free((char*)mp); - } - - static void - md5_dup_rep(Tcl_Obj *obj, Tcl_Obj *dup) - { - MD5_CTX *mp = (MD5_CTX *) obj->internalRep.otherValuePtr; - dup->internalRep.otherValuePtr = Tcl_Alloc(sizeof *mp); - memcpy(dup->internalRep.otherValuePtr, mp, sizeof *mp); - dup->typePtr = &md5_type; - } - - static void - md5_string_rep(Tcl_Obj *obj) - { - unsigned char buf[16]; - Tcl_Obj *temp; - char *str; - MD5_CTX dup = *(MD5_CTX *) obj->internalRep.otherValuePtr; - - MD5Final(buf, &dup); - - /* convert via a byte array to properly handle null bytes */ - temp = Tcl_NewByteArrayObj(buf, sizeof buf); - Tcl_IncrRefCount(temp); - - str = Tcl_GetStringFromObj(temp, &obj->length); - obj->bytes = Tcl_Alloc(obj->length + 1); - memcpy(obj->bytes, str, obj->length + 1); - - Tcl_DecrRefCount(temp); - } - - static int - md5_from_any(Tcl_Interp* ip, Tcl_Obj* obj) - { - assert(0); - return TCL_ERROR; - } - - static - Tcl_ObjType md5_type = { - "md5c", md5_free_rep, md5_dup_rep, md5_string_rep, md5_from_any - }; - } - - critcl::ccommand md5c {dummy ip objc objv} { - MD5_CTX *mp; - unsigned char *data; - int size; - Tcl_Obj *obj; - - if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(ip, 1, objv, "data ?context?"); - return TCL_ERROR; - } - - if (objc == 3) { - if (objv[2]->typePtr != &md5_type && md5_from_any(ip, objv[2]) != TCL_OK) { - return TCL_ERROR; - } - obj = objv[2]; - if (Tcl_IsShared(obj)) { - obj = Tcl_DuplicateObj(obj); - } - } else { - mp = (MD5_CTX *)Tcl_Alloc(sizeof *mp); - MD5Init(mp); - obj = Tcl_NewObj(); - Tcl_InvalidateStringRep(obj); - obj->internalRep.otherValuePtr = mp; - obj->typePtr = &md5_type; - } - - mp = (MD5_CTX *) obj->internalRep.otherValuePtr; - data = Tcl_GetByteArrayFromObj(objv[1], &size); - MD5Update(mp, data, size); - Tcl_SetObjResult(ip, obj); - - return TCL_OK; - } -} +package require critcl 3.1 + +if {![critcl::compiling]} { + error "Unable to build md5c, no proper compiler found." +} + +# # ## ### ##### ######## ############# ##################### +## Administrivia + +critcl::license {Jean-Claude Wippler} BSD +critcl::summary { + C implementation of the MD5 message digest +} +critcl::description { + This package provides a C implementation of MD5 using the + RSA sample code and wrapping this up in a Tcl package. +} +critcl::subject \ + hashing md5 message-digest security \ + {rfc 1320} {rfc 1321} {rfc 2104} + +critcl::meta location http://core.tcl.tk/tcllib + +# # ## ### ##### ######## ############# ##################### +## Implementation + +## todo :: critcl :: possibly define an argument conversion for the +## context. handling of default is an issue. + +critcl::tcl 8.4 + +critcl::cheaders md5.h ; # The RSA header file +critcl::csources md5.c ; # The RSA MD5 implementation. + +namespace eval ::md5 {} + +critcl::ccode { + #include + #include "md5.h" + #include + + static + Tcl_ObjType md5_type; /* fast internal access representation */ + + static void + md5_free_rep(Tcl_Obj *obj) + { + MD5_CTX *mp = (MD5_CTX *) obj->internalRep.otherValuePtr; + Tcl_Free((char*)mp); + } + + static void + md5_dup_rep(Tcl_Obj *obj, Tcl_Obj *dup) + { + MD5_CTX *mp = (MD5_CTX *) obj->internalRep.otherValuePtr; + dup->internalRep.otherValuePtr = Tcl_Alloc(sizeof *mp); + memcpy(dup->internalRep.otherValuePtr, mp, sizeof *mp); + dup->typePtr = &md5_type; + } + + static void + md5_string_rep(Tcl_Obj *obj) + { + unsigned char buf[16]; + Tcl_Obj *temp; + char *str; + MD5_CTX dup = *(MD5_CTX *) obj->internalRep.otherValuePtr; + + MD5Final(buf, &dup); + + /* convert via a byte array to properly handle null bytes */ + temp = Tcl_NewByteArrayObj(buf, sizeof buf); + Tcl_IncrRefCount(temp); + + str = Tcl_GetStringFromObj(temp, &obj->length); + obj->bytes = Tcl_Alloc(obj->length + 1); + memcpy(obj->bytes, str, obj->length + 1); + + Tcl_DecrRefCount(temp); + } + + static int + md5_from_any(Tcl_Interp* ip, Tcl_Obj* obj) + { + assert(0); + return TCL_ERROR; + } + + static + Tcl_ObjType md5_type = { + "md5c", md5_free_rep, md5_dup_rep, md5_string_rep, md5_from_any + }; +} + +critcl::ccommand ::md5::md5c {dummy ip objc objv} { + MD5_CTX *mp; + unsigned char *data; + int size; + Tcl_Obj *obj; + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(ip, 1, objv, "data ?context?"); + return TCL_ERROR; + } + + if (objc == 3) { + if (objv[2]->typePtr != &md5_type && md5_from_any(ip, objv[2]) != TCL_OK) { + return TCL_ERROR; + } + obj = objv[2]; + if (Tcl_IsShared(obj)) { + obj = Tcl_DuplicateObj(obj); + } + } else { + mp = (MD5_CTX *)Tcl_Alloc(sizeof *mp); + MD5Init(mp); + obj = Tcl_NewObj(); + Tcl_InvalidateStringRep(obj); + obj->internalRep.otherValuePtr = mp; + obj->typePtr = &md5_type; + } + + mp = (MD5_CTX *) obj->internalRep.otherValuePtr; + data = Tcl_GetByteArrayFromObj(objv[1], &size); + MD5Update(mp, data, size); + Tcl_SetObjResult(ip, obj); + + return TCL_OK; +} + +# # ## ### ##### ######## ############# ##################### +## Integrated test cases. if {[info exists pkgtest] && $pkgtest} { - - proc md5c_try {} { - foreach {msg expected} { - "" - "d41d8cd98f00b204e9800998ecf8427e" - "a" - "0cc175b9c0f1b6a831c399e269772661" - "abc" - "900150983cd24fb0d6963f7d28e17f72" - "message digest" - "f96b697d7cb7938d525a2f31aaf161d0" - "abcdefghijklmnopqrstuvwxyz" - "c3fcd3d76192e4007dfb496cca67e13b" - "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" - "d174ab98d277d9f5a5611c2c9f419d9f" - "12345678901234567890123456789012345678901234567890123456789012345678901234567890" - "57edf4a22be3c955ac49da2e2107b67a" - } { - puts "testing: ::md5::md5c \"$msg\"" - binary scan [::md5::md5c $msg] H* computed - puts "computed: $computed" - if {0 != [string compare $computed $expected]} { - puts "expected: $expected" - puts "FAILED" - } - } - - foreach len {10 50 100 500 1000 5000 10000} { - set blanks [format %$len.0s ""] - puts "input length $len: [time {md5c $blanks} 1000]" - } - } - - md5c_try -} + proc md5_try {} { + foreach {msg expected} { + "" + "d41d8cd98f00b204e9800998ecf8427e" + "a" + "0cc175b9c0f1b6a831c399e269772661" + "abc" + "900150983cd24fb0d6963f7d28e17f72" + "message digest" + "f96b697d7cb7938d525a2f31aaf161d0" + "abcdefghijklmnopqrstuvwxyz" + "c3fcd3d76192e4007dfb496cca67e13b" + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" + "d174ab98d277d9f5a5611c2c9f419d9f" + "12345678901234567890123456789012345678901234567890123456789012345678901234567890" + "57edf4a22be3c955ac49da2e2107b67a" + } { + puts "testing: ::md5::md5c \"$msg\"" + binary scan [::md5::md5c $msg] H* computed + puts "computed: $computed" + if {0 != [string compare $computed $expected]} { + puts "expected: $expected" + puts "FAILED" + } + } + + foreach len {10 50 100 500 1000 5000 10000} { + set blanks [format %$len.0s ""] + puts "input length $len: [time {md5c $blanks} 1000]" + } + } + + md5c_try +} + +# # ## ### ##### ######## ############# ##################### +# @sak notprovided md5c +package provide md5c 0.12 +return + +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: Index: modules/md5crypt/md5cryptc.tcl ================================================================== --- modules/md5crypt/md5cryptc.tcl +++ modules/md5crypt/md5cryptc.tcl @@ -17,158 +17,189 @@ # ------------------------------------------------------------------------- # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- +package require critcl 3.1 + +if {![critcl::compiling]} { + error "Unable to build md5cryptc, no proper compiler found." +} + +# # ## ### ##### ######## ############# ##################### +## Administrivia + +critcl::license {Pat Thoyts} BSD +critcl::summary { + C implementation of the MD5crypt MAC +} +critcl::description { + This package provides a C implementation of MD5crypt based + on the OpenBSD sources, which is in turn derived from the + original implementation by Poul-Henning Kamp. +} +critcl::subject \ + hashing md5 md5crypt message-digest security \ + {rfc 1320} {rfc 1321} {rfc 2104} + +critcl::meta location http://core.tcl.tk/tcllib + +# # ## ### ##### ######## ############# ##################### +## Implementation -package require critcl -# @sak notprovided md5cryptc -package provide md5cryptc 1.0 +critcl::tcl 8.4 critcl::cheaders ../md5/md5.h #critcl::csources ../md5/md5.c -namespace eval ::md5crypt { - critcl::ccode { -#include -#include "md5.h" -#ifdef _MSC_VER -#define snprintf _snprintf -#endif - static unsigned char itoa64[] = - "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"; - - static void to64(char *s, unsigned int v, int n) - { - while (--n >= 0) { - *s++ = itoa64[v&0x3f]; - v >>= 6; - } - } - - static void dump(const char *s, unsigned int len) - { - unsigned int i; - for (i = 0; i < len; i++) - printf("%02X", s[i]&0xFF); - putchar('\n'); - } - - static char * md5crypt(const char *pw, - const char *salt, - const char *magic) - { - static char passwd[120], *p; - static const unsigned char *sp,*ep; - unsigned char final[16]; - int sl,pl,i; - MD5_CTX ctx,ctx1; - unsigned long l; - - /* Refine the Salt first */ - sp = (const unsigned char *)salt; - - /* If it starts with the magic string, then skip that */ - if(!strncmp((const char *)sp,(const char *)magic,strlen((const char *)magic))) - sp += strlen((const char *)magic); - - /* It stops at the first '$', max 8 chars */ - for(ep=sp;*ep && *ep != '$' && ep < (sp+8);ep++) - continue; - - /* get the length of the true salt */ - sl = ep - sp; - - MD5Init(&ctx); - - /* The password first, since that is what is most unknown */ - MD5Update(&ctx,(unsigned char *)pw,strlen(pw)); - - /* Then our magic string */ - MD5Update(&ctx,(unsigned char *)magic,strlen((const char *)magic)); - - /* Then the raw salt */ - MD5Update(&ctx,(unsigned char*)sp,sl); - - /* Then just as many characters of the MD5(pw,salt,pw) */ - MD5Init(&ctx1); - MD5Update(&ctx1,(unsigned char *)pw,strlen(pw)); - MD5Update(&ctx1,(unsigned char *)sp,sl); - MD5Update(&ctx1,(unsigned char *)pw,strlen(pw)); - MD5Final(final,&ctx1); - - for(pl = strlen(pw); pl > 0; pl -= 16) { - int tl = pl > 16 ? 16 : pl; - MD5Update(&ctx,final,pl>16 ? 16 : pl); - } - - /* Don't leave anything around in vm they could use. */ - memset(final,0,sizeof final); - - /* Then something really weird... */ - for (i = strlen(pw); i ; i >>= 1) { - if(i&1) - MD5Update(&ctx, final, 1); - else - MD5Update(&ctx, (unsigned char *)pw, 1); - } - - /* Now make the output string */ - snprintf(passwd, sizeof(passwd), "%s%.*s$", (char *)magic, - sl, (const char *)sp); - - MD5Final(final,&ctx); - - /* - * and now, just to make sure things don't run too fast - * On a 60 Mhz Pentium this takes 34 msec, so you would - * need 30 seconds to build a 1000 entry dictionary... - */ - for(i=0;i<1000;i++) { - MD5Init(&ctx1); - if(i & 1) - MD5Update(&ctx1,(unsigned char *)pw,strlen(pw)); - else - MD5Update(&ctx1,final,16); - - if(i % 3) - MD5Update(&ctx1,(unsigned char *)sp,sl); - - if(i % 7) - MD5Update(&ctx1,(unsigned char *)pw,strlen(pw)); - - if(i & 1) - MD5Update(&ctx1,final,16); - else - MD5Update(&ctx1,(unsigned char *)pw,strlen(pw)); - MD5Final(final,&ctx1); - } - - p = passwd + strlen(passwd); - - l = (final[ 0]<<16) | (final[ 6]<<8) | final[12]; to64(p,l,4); p += 4; - l = (final[ 1]<<16) | (final[ 7]<<8) | final[13]; to64(p,l,4); p += 4; - l = (final[ 2]<<16) | (final[ 8]<<8) | final[14]; to64(p,l,4); p += 4; - l = (final[ 3]<<16) | (final[ 9]<<8) | final[15]; to64(p,l,4); p += 4; - l = (final[ 4]<<16) | (final[10]<<8) | final[ 5]; to64(p,l,4); p += 4; - l = final[11] ; to64(p,l,2); p += 2; - *p = '\0'; - - /* Don't leave anything around in vm they could use. */ - memset(final,0,sizeof final); - - return passwd; - } - } - critcl::cproc to64_c {Tcl_Interp* interp int v int n} ok { - char s[5]; - to64(s, (unsigned int)v, n); - Tcl_SetObjResult(interp, Tcl_NewStringObj(s, n)); - return TCL_OK; - } - - critcl::cproc md5crypt_c {Tcl_Interp* interp char* magic char* pw char* salt} ok { - char* s = md5crypt(pw, salt, magic); - Tcl_SetObjResult(interp, Tcl_NewStringObj(s, strlen(s))); - return TCL_OK; - } -} +namespace eval ::md5crypt {} + +critcl::ccode { + #include + #include "md5.h" + #ifdef _MSC_VER + #define snprintf _snprintf + #endif + static unsigned char itoa64[] = + "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"; + + static void to64(char *s, unsigned int v, int n) + { + while (--n >= 0) { + *s++ = itoa64[v&0x3f]; + v >>= 6; + } + } + + static void dump(const char *s, unsigned int len) + { + unsigned int i; + for (i = 0; i < len; i++) + printf("%02X", s[i]&0xFF); + putchar('\n'); + } + + static char * md5crypt(const char *pw, + const char *salt, + const char *magic) + { + static char passwd[120], *p; + static const unsigned char *sp,*ep; + unsigned char final[16]; + int sl,pl,i; + MD5_CTX ctx,ctx1; + unsigned long l; + + /* Refine the Salt first */ + sp = (const unsigned char *)salt; + + /* If it starts with the magic string, then skip that */ + if(!strncmp((const char *)sp,(const char *)magic,strlen((const char *)magic))) + sp += strlen((const char *)magic); + + /* It stops at the first '$', max 8 chars */ + for(ep=sp;*ep && *ep != '$' && ep < (sp+8);ep++) + continue; + + /* get the length of the true salt */ + sl = ep - sp; + + MD5Init(&ctx); + + /* The password first, since that is what is most unknown */ + MD5Update(&ctx,(unsigned char *)pw,strlen(pw)); + + /* Then our magic string */ + MD5Update(&ctx,(unsigned char *)magic,strlen((const char *)magic)); + + /* Then the raw salt */ + MD5Update(&ctx,(unsigned char *)sp,sl); + + /* Then just as many characters of the MD5(pw,salt,pw) */ + MD5Init(&ctx1); + MD5Update(&ctx1,(unsigned char *)pw,strlen(pw)); + MD5Update(&ctx1,(unsigned char *)sp,sl); + MD5Update(&ctx1,(unsigned char *)pw,strlen(pw)); + MD5Final(final,&ctx1); + + for(pl = strlen(pw); pl > 0; pl -= 16) { + int tl = pl > 16 ? 16 : pl; + MD5Update(&ctx,final,pl>16 ? 16 : pl); + } + + /* Don't leave anything around in vm they could use. */ + memset(final,0,sizeof final); + + /* Then something really weird... */ + for (i = strlen(pw); i ; i >>= 1) { + if(i&1) + MD5Update(&ctx, final, 1); + else + MD5Update(&ctx, (unsigned char *)pw, 1); + } + + /* Now make the output string */ + snprintf(passwd, sizeof(passwd), "%s%.*s$", (char *)magic, + sl, (const char *)sp); + + MD5Final(final,&ctx); + + /* + * and now, just to make sure things don't run too fast + * On a 60 Mhz Pentium this takes 34 msec, so you would + * need 30 seconds to build a 1000 entry dictionary... + */ + for(i=0;i<1000;i++) { + MD5Init(&ctx1); + if(i & 1) + MD5Update(&ctx1,(unsigned char *)pw,strlen(pw)); + else + MD5Update(&ctx1,final,16); + + if(i % 3) + MD5Update(&ctx1,(unsigned char *)sp,sl); + + if(i % 7) + MD5Update(&ctx1,(unsigned char *)pw,strlen(pw)); + + if(i & 1) + MD5Update(&ctx1,final,16); + else + MD5Update(&ctx1,(unsigned char *)pw,strlen(pw)); + MD5Final(final,&ctx1); + } + + p = passwd + strlen(passwd); + + l = (final[ 0]<<16) | (final[ 6]<<8) | final[12]; to64(p,l,4); p += 4; + l = (final[ 1]<<16) | (final[ 7]<<8) | final[13]; to64(p,l,4); p += 4; + l = (final[ 2]<<16) | (final[ 8]<<8) | final[14]; to64(p,l,4); p += 4; + l = (final[ 3]<<16) | (final[ 9]<<8) | final[15]; to64(p,l,4); p += 4; + l = (final[ 4]<<16) | (final[10]<<8) | final[ 5]; to64(p,l,4); p += 4; + l = final[11] ; to64(p,l,2); p += 2; + *p = '\0'; + + /* Don't leave anything around in vm they could use. */ + memset(final,0,sizeof final); + + return passwd; + } +} + +critcl::cproc ::md5crypt::to64_c {Tcl_Interp* interp int v int n} ok { + char s[5]; + to64(s, (unsigned int)v, n); + Tcl_SetObjResult(interp, Tcl_NewStringObj(s, n)); + return TCL_OK; +} + +critcl::cproc ::md5crypt::md5crypt_c {Tcl_Interp* interp char* magic char* pw char* salt} ok { + char* s = md5crypt(pw, salt, magic); + Tcl_SetObjResult(interp, Tcl_NewStringObj(s, strlen(s))); + return TCL_OK; +} + + +# # ## ### ##### ######## ############# ##################### +# @sak notprovided md5cryptc +package provide md5cryptc 1.0 +return Index: modules/pt/pt_cparam_config_critcl.tcl ================================================================== --- modules/pt/pt_cparam_config_critcl.tcl +++ modules/pt/pt_cparam_config_critcl.tcl @@ -45,10 +45,12 @@ # class = The namespace/prefix for the generated commands. # pkg = The name of the generated package / parser. # version = The version of the generated package / parser. + set license {Edit to suit} ;# TODO: Configurable value. + if {[string first :: $class] < 0} { set cheader $class set ctrailer $class } else { set cheader [namespace qualifier $class] @@ -59,10 +61,11 @@ lappend map @@PKG@@ $pkg lappend map @@VERSION@@ $version lappend map @@CLASS@@ $class lappend map @@CHEAD@@ $cheader lappend map @@CTAIL@@ $ctrailer + lappend map @@LICENSE@@ $license lappend map \n\t \n ;# undent the template {*}$cmd -main MAIN {*}$cmd -indent 8 {*}$cmd -template [string trim \ @@ -79,332 +82,335 @@ ## # # ## ### ##### ######## ############# ##################### ## Requirements package require Tcl 8.4 - package require critcl + package require critcl 3.1 # @sak notprovided @@PKG@@ package provide @@PKG@@ @@VERSION@@ + critcl::tcl 8.4 + critcl::license {@user@} {@@LICENSE@@} + + critcl::summary { + Critcl-based PEG parser for grammar @name@. + } + critcl::description { + This package provides a critcl-based C/PARAM implementation + of the parsing expression grammar @name@. + } + critcl::subject {@name@} {parsing expression grammar} parser + critcl::meta location http://core.tcl.tk/tcllib + # Note: The implementation of the PARAM virtual machine # underlying the C/PARAM code used below is inlined # into the generated parser, allowing for direct access # and manipulation of the RDE state, instead of having # to dispatch through the Tcl interpreter. # # ## ### ##### ######## ############# ##################### ## - namespace eval ::@@CHEAD@@ { - # # ## ### ##### ######## ############# ##################### - ## Supporting code for the main command. - - catch { - #critcl::cflags -g - #critcl::debug memory symbols - } - - # # ## ### ###### ######## ############# - ## RDE runtime, inlined, and made static. - - # This is the C code for the RDE, i.e. the implementation - # of pt::rde. Only the low-level engine is imported, the - # Tcl interface layer is ignored. This generated parser - # provides its own layer for that. - - critcl::ccode { - /* -*- c -*- */ - - #include - #define SCOPE static - -@@RUNTIME@@ - } - - # # ## ### ###### ######## ############# - ## BEGIN of GENERATED CODE. DO NOT EDIT. - - critcl::ccode { - /* -*- c -*- */ - -@code@ - } - - ## END of GENERATED CODE. DO NOT EDIT. - # # ## ### ###### ######## ############# - - # # ## ### ###### ######## ############# - ## Global PARSER management, per interp - - critcl::ccode { - /* -*- c -*- */ - - typedef struct PARSERg { - long int counter; - char buf [50]; - } PARSERg; - - static void - PARSERgRelease (ClientData cd, Tcl_Interp* interp) - { - ckfree((char*) cd); - } - - static const char* - PARSERnewName (Tcl_Interp* interp) - { -#define KEY "tcllib/parser/@@PKG@@/critcl" - - Tcl_InterpDeleteProc* proc = PARSERgRelease; - PARSERg* parserg; - - parserg = Tcl_GetAssocData (interp, KEY, &proc); - if (parserg == NULL) { - parserg = (PARSERg*) ckalloc (sizeof (PARSERg)); - parserg->counter = 0; - - Tcl_SetAssocData (interp, KEY, proc, - (ClientData) parserg); - } - - parserg->counter ++; - sprintf (parserg->buf, "@@CTAIL@@%ld", parserg->counter); - return parserg->buf; -#undef KEY - } - - static void - PARSERdeleteCmd (ClientData clientData) - { - /* - * Release the whole PARSER - * (Low-level engine only actually). - */ - rde_param_del ((RDE_PARAM) clientData); - } - } - - # # ## ### ##### ######## ############# - ## Functions implementing the object methods, and helper. - - critcl::ccode { - static int COMPLETE (RDE_PARAM p, Tcl_Interp* interp); - - static int parser_PARSE (RDE_PARAM p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) - { - int mode; - Tcl_Channel chan; - - if (objc != 3) { - Tcl_WrongNumArgs (interp, 2, objv, "chan"); - return TCL_ERROR; - } - - chan = Tcl_GetChannel(interp, - Tcl_GetString (objv[2]), - &mode); - - if (!chan) { - return TCL_ERROR; - } - - rde_param_reset (p, chan); - MAIN (p) ; /* Entrypoint for the generated code. */ - return COMPLETE (p, interp); - } - - static int parser_PARSET (RDE_PARAM p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) - { - char* buf; - int len; - - if (objc != 3) { - Tcl_WrongNumArgs (interp, 2, objv, "text"); - return TCL_ERROR; - } - - buf = Tcl_GetStringFromObj (objv[2], &len); - - rde_param_reset (p, NULL); - rde_param_data (p, buf, len); - MAIN (p) ; /* Entrypoint for the generated code. */ - return COMPLETE (p, interp); - } - - /* See also rde_critcl/m.c, param_COMPLETE() */ - static int COMPLETE (RDE_PARAM p, Tcl_Interp* interp) - { - if (rde_param_query_st (p)) { - long int ac; - Tcl_Obj** av; - - rde_param_query_ast (p, &ac, &av); - - if (ac > 1) { - Tcl_Obj** lv = NALLOC (3+ac, Tcl_Obj*); - - memcpy(lv + 3, av, ac * sizeof (Tcl_Obj*)); - lv [0] = Tcl_NewObj (); - lv [1] = Tcl_NewIntObj (1 + rde_param_query_lstop (p)); - lv [2] = Tcl_NewIntObj (rde_param_query_cl (p)); - - Tcl_SetObjResult (interp, Tcl_NewListObj (3, lv)); - ckfree ((char*) lv); - - } else if (ac == 0) { - /* - * Match, but no AST. This is possible if the grammar - * consists of only the start expression. - */ - Tcl_SetObjResult (interp, Tcl_NewStringObj ("",-1)); - } else { - Tcl_SetObjResult (interp, av [0]); - } - - return TCL_OK; - } else { - Tcl_Obj* xv [1]; - const ERROR_STATE* er = rde_param_query_er (p); - Tcl_Obj* res = rde_param_query_er_tcl (p, er); - /* res = list (location, list(msg)) */ - - /* Stick the exception type-tag before the existing elements */ - xv [0] = Tcl_NewStringObj ("pt::rde",-1); - Tcl_ListObjReplace(interp, res, 0, 0, 1, xv); - - Tcl_SetErrorCode (interp, "PT", "RDE", "SYNTAX", NULL); - Tcl_SetObjResult (interp, res); - return TCL_ERROR; - } - } - } - - # # ## ### ##### ######## ############# - ## Object command, method dispatch. - - critcl::ccode { - static int parser_objcmd (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) - { - RDE_PARAM p = (RDE_PARAM) cd; - int m, res; - - static CONST char* methods [] = { - "destroy", "parse", "parset", NULL - }; - enum methods { - M_DESTROY, M_PARSE, M_PARSET - }; - - if (objc < 2) { - Tcl_WrongNumArgs (interp, objc, objv, "option ?arg arg ...?"); - return TCL_ERROR; - } else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", - 0, &m) != TCL_OK) { - return TCL_ERROR; - } - - /* Dispatch to methods. They check the #args in - * detail before performing the requested - * functionality - */ - - switch (m) { - case M_DESTROY: - if (objc != 2) { - Tcl_WrongNumArgs (interp, 2, objv, NULL); - return TCL_ERROR; - } - - Tcl_DeleteCommandFromToken(interp, (Tcl_Command) rde_param_query_clientdata (p)); - return TCL_OK; - - case M_PARSE: res = parser_PARSE (p, interp, objc, objv); break; - case M_PARSET: res = parser_PARSET (p, interp, objc, objv); break; - default: - /* Not coming to this place */ - ASSERT (0,"Reached unreachable location"); - } - - return res; - } - } - - # # ## ### ##### ######## ############# - # Class command, i.e. object construction. - - critcl::ccommand @@CTAIL@@_critcl {dummy interp objc objv} { - /* - * Syntax: No arguments beyond the name - */ - - RDE_PARAM parser; - CONST char* name; - Tcl_Obj* fqn; - Tcl_CmdInfo ci; - Tcl_Command c; - -#define USAGE "?name?" - - if ((objc != 2) && (objc != 1)) { - Tcl_WrongNumArgs (interp, 1, objv, USAGE); - return TCL_ERROR; - } - - if (objc < 2) { - name = PARSERnewName (interp); - } else { - name = Tcl_GetString (objv [1]); - } - - if (!Tcl_StringMatch (name, "::*")) { - /* Relative name. Prefix with current namespace */ - - Tcl_Eval (interp, "namespace current"); - fqn = Tcl_GetObjResult (interp); - fqn = Tcl_DuplicateObj (fqn); - Tcl_IncrRefCount (fqn); - - if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { - Tcl_AppendToObj (fqn, "::", -1); - } - Tcl_AppendToObj (fqn, name, -1); - } else { - fqn = Tcl_NewStringObj (name, -1); - Tcl_IncrRefCount (fqn); - } - Tcl_ResetResult (interp); - - if (Tcl_GetCommandInfo (interp, - Tcl_GetString (fqn), - &ci)) { - Tcl_Obj* err; - - err = Tcl_NewObj (); - Tcl_AppendToObj (err, "command \"", -1); - Tcl_AppendObjToObj (err, fqn); - Tcl_AppendToObj (err, "\" already exists", -1); - - Tcl_DecrRefCount (fqn); - Tcl_SetObjResult (interp, err); - return TCL_ERROR; - } - - parser = rde_param_new (sizeof(p_string)/sizeof(char*), (char**) p_string); - c = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn), - parser_objcmd, (ClientData) parser, - PARSERdeleteCmd); - rde_param_clientdata (parser, (ClientData) c); - Tcl_SetObjResult (interp, fqn); - Tcl_DecrRefCount (fqn); - return TCL_OK; - } - - ## - # # ## ### ##### ######## ############# - } - - # # ## ### ##### ######## ############# ##################### + namespace eval ::@@CHEAD@@ {} + + # # ## ### ##### ######## ############# ##################### + ## Supporting code for the main command. + + # # ## ### ###### ######## ############# + ## RDE runtime, inlined, and made static. + + # This is the C code for the RDE, i.e. the implementation + # of pt::rde. Only the low-level engine is imported, the + # Tcl interface layer is ignored. This generated parser + # provides its own layer for that. + + critcl::ccode { + /* -*- c -*- */ + #include + #define SCOPE static +@@RUNTIME@@ + } + + # # ## ### ###### ######## ############# + ## BEGIN of GENERATED CODE. DO NOT EDIT. + + critcl::ccode { + /* -*- c -*- */ +@code@ + } + + ## END of GENERATED CODE. DO NOT EDIT. + # # ## ### ###### ######## ############# + + # # ## ### ###### ######## ############# + ## Global PARSER management, per interp + + critcl::ccode { + /* -*- c -*- */ + + typedef struct PARSERg { + long int counter; + char buf [50]; + } PARSERg; + + static void + PARSERgRelease (ClientData cd, Tcl_Interp* interp) + { + ckfree((char*) cd); + } + + static const char* + PARSERnewName (Tcl_Interp* interp) + { + #define KEY "tcllib/parser/@@PKG@@/critcl" + + Tcl_InterpDeleteProc* proc = PARSERgRelease; + PARSERg* parserg; + + parserg = Tcl_GetAssocData (interp, KEY, &proc); + if (parserg == NULL) { + parserg = (PARSERg*) ckalloc (sizeof (PARSERg)); + parserg->counter = 0; + + Tcl_SetAssocData (interp, KEY, proc, + (ClientData) parserg); + } + + parserg->counter ++; + sprintf (parserg->buf, "@@CTAIL@@%ld", parserg->counter); + return parserg->buf; + #undef KEY + } + + static void + PARSERdeleteCmd (ClientData clientData) + { + /* + * Release the whole PARSER + * (Low-level engine only actually). + */ + rde_param_del ((RDE_PARAM) clientData); + } + } + + # # ## ### ##### ######## ############# + ## Functions implementing the object methods, and helper. + + critcl::ccode { + static int COMPLETE (RDE_PARAM p, Tcl_Interp* interp); + + static int parser_PARSE (RDE_PARAM p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) + { + int mode; + Tcl_Channel chan; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "chan"); + return TCL_ERROR; + } + + chan = Tcl_GetChannel(interp, + Tcl_GetString (objv[2]), + &mode); + + if (!chan) { + return TCL_ERROR; + } + + rde_param_reset (p, chan); + MAIN (p) ; /* Entrypoint for the generated code. */ + return COMPLETE (p, interp); + } + + static int parser_PARSET (RDE_PARAM p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) + { + char* buf; + int len; + + if (objc != 3) { + Tcl_WrongNumArgs (interp, 2, objv, "text"); + return TCL_ERROR; + } + + buf = Tcl_GetStringFromObj (objv[2], &len); + + rde_param_reset (p, NULL); + rde_param_data (p, buf, len); + MAIN (p) ; /* Entrypoint for the generated code. */ + return COMPLETE (p, interp); + } + + /* See also rde_critcl/m.c, param_COMPLETE() */ + static int COMPLETE (RDE_PARAM p, Tcl_Interp* interp) + { + if (rde_param_query_st (p)) { + long int ac; + Tcl_Obj** av; + + rde_param_query_ast (p, &ac, &av); + + if (ac > 1) { + Tcl_Obj** lv = NALLOC (3+ac, Tcl_Obj*); + + memcpy(lv + 3, av, ac * sizeof (Tcl_Obj*)); + lv [0] = Tcl_NewObj (); + lv [1] = Tcl_NewIntObj (1 + rde_param_query_lstop (p)); + lv [2] = Tcl_NewIntObj (rde_param_query_cl (p)); + + Tcl_SetObjResult (interp, Tcl_NewListObj (3, lv)); + ckfree ((char*) lv); + + } else if (ac == 0) { + /* + * Match, but no AST. This is possible if the grammar + * consists of only the start expression. + */ + Tcl_SetObjResult (interp, Tcl_NewStringObj ("",-1)); + } else { + Tcl_SetObjResult (interp, av [0]); + } + + return TCL_OK; + } else { + Tcl_Obj* xv [1]; + const ERROR_STATE* er = rde_param_query_er (p); + Tcl_Obj* res = rde_param_query_er_tcl (p, er); + /* res = list (location, list(msg)) */ + + /* Stick the exception type-tag before the existing elements */ + xv [0] = Tcl_NewStringObj ("pt::rde",-1); + Tcl_ListObjReplace(interp, res, 0, 0, 1, xv); + + Tcl_SetErrorCode (interp, "PT", "RDE", "SYNTAX", NULL); + Tcl_SetObjResult (interp, res); + return TCL_ERROR; + } + } + } + + # # ## ### ##### ######## ############# + ## Object command, method dispatch. + + critcl::ccode { + static int parser_objcmd (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) + { + RDE_PARAM p = (RDE_PARAM) cd; + int m, res; + + static CONST char* methods [] = { + "destroy", "parse", "parset", NULL + }; + enum methods { + M_DESTROY, M_PARSE, M_PARSET + }; + + if (objc < 2) { + Tcl_WrongNumArgs (interp, objc, objv, "option ?arg arg ...?"); + return TCL_ERROR; + } else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", + 0, &m) != TCL_OK) { + return TCL_ERROR; + } + + /* Dispatch to methods. They check the #args in + * detail before performing the requested + * functionality + */ + + switch (m) { + case M_DESTROY: + if (objc != 2) { + Tcl_WrongNumArgs (interp, 2, objv, NULL); + return TCL_ERROR; + } + + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) rde_param_query_clientdata (p)); + return TCL_OK; + + case M_PARSE: res = parser_PARSE (p, interp, objc, objv); break; + case M_PARSET: res = parser_PARSET (p, interp, objc, objv); break; + default: + /* Not coming to this place */ + ASSERT (0,"Reached unreachable location"); + } + + return res; + } + } + + # # ## ### ##### ######## ############# + # Class command, i.e. object construction. + + critcl::ccommand ::@@CHEAD@@::@@CTAIL@@_critcl {dummy interp objc objv} { + /* + * Syntax: No arguments beyond the name + */ + + RDE_PARAM parser; + CONST char* name; + Tcl_Obj* fqn; + Tcl_CmdInfo ci; + Tcl_Command c; + + #define USAGE "?name?" + + if ((objc != 2) && (objc != 1)) { + Tcl_WrongNumArgs (interp, 1, objv, USAGE); + return TCL_ERROR; + } + + if (objc < 2) { + name = PARSERnewName (interp); + } else { + name = Tcl_GetString (objv [1]); + } + + if (!Tcl_StringMatch (name, "::*")) { + /* Relative name. Prefix with current namespace */ + + Tcl_Eval (interp, "namespace current"); + fqn = Tcl_GetObjResult (interp); + fqn = Tcl_DuplicateObj (fqn); + Tcl_IncrRefCount (fqn); + + if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { + Tcl_AppendToObj (fqn, "::", -1); + } + Tcl_AppendToObj (fqn, name, -1); + } else { + fqn = Tcl_NewStringObj (name, -1); + Tcl_IncrRefCount (fqn); + } + Tcl_ResetResult (interp); + + if (Tcl_GetCommandInfo (interp, + Tcl_GetString (fqn), + &ci)) { + Tcl_Obj* err; + + err = Tcl_NewObj (); + Tcl_AppendToObj (err, "command \"", -1); + Tcl_AppendObjToObj (err, fqn); + Tcl_AppendToObj (err, "\" already exists", -1); + + Tcl_DecrRefCount (fqn); + Tcl_SetObjResult (interp, err); + return TCL_ERROR; + } + + parser = rde_param_new (sizeof(p_string)/sizeof(char*), (char**) p_string); + c = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn), + parser_objcmd, (ClientData) parser, + PARSERdeleteCmd); + rde_param_clientdata (parser, (ClientData) c); + Tcl_SetObjResult (interp, fqn); + Tcl_DecrRefCount (fqn); + return TCL_OK; + } + + ## + # # ## ### ##### ######## ############# ##################### ## Ready (Note: Our package provide is at the top). return }]] return Index: modules/pt/pt_rdengine_c.tcl ================================================================== --- modules/pt/pt_rdengine_c.tcl +++ modules/pt/pt_rdengine_c.tcl @@ -14,131 +14,147 @@ # # ## ### ##### ######## ############# ##################### ## Requisites package require Tcl 8.4 -package require critcl +package require critcl 3.1 + +if {![critcl::compiling]} { + error "Unable to build pt_rde_critcl, no proper compiler found." +} + # @sak notprovided pt_rde_critcl package provide pt_rde_critcl 1.3.3 + +# # ## ### ##### ######## ############# ##################### +## Administrivia + +critcl::license {Andreas Kupries} BSD + +critcl::summary { + Critcl implementation of the PARAM runtime. +} +critcl::description { + This package provides a critcl-based implementation of the + PARAM runtime. +} + +critcl::subject PARAM {runtime PARAM} {parsing expression grammar} {parser support} +critcl::meta location http://core.tcl.tk/tcllib # # ## ### ##### ######## ############# ##################### ## Implementation -namespace eval ::pt { - - # # ## ### ##### ######## ############# ##################### - ## Supporting code for the main command. - - catch { - #critcl::cheaders -g - #critcl::debug memory symbols - } - - critcl::cheaders rde_critcl/*.h - critcl::csources rde_critcl/*.c - - critcl::ccode { - /* -*- c -*- */ - - #include /* Allocation macros */ - #include /* Public state API */ - #include /* Instance command */ - - /* .................................................. */ - /* Global PARAM management, per interp - */ - - typedef struct PARAMg { - long int counter; - char buf [50]; - } PARAMg; - - static void - PARAMgRelease (ClientData cd, Tcl_Interp* interp) - { - ckfree((char*) cd); - } - - static CONST char* - PARAMnewName (Tcl_Interp* interp) - { -#define KEY "tcllib/pt::rde/critcl" - - Tcl_InterpDeleteProc* proc = PARAMgRelease; - PARAMg* paramg; - - paramg = Tcl_GetAssocData (interp, KEY, &proc); - if (paramg == NULL) { - paramg = (PARAMg*) ckalloc (sizeof (PARAMg)); - paramg->counter = 0; - - Tcl_SetAssocData (interp, KEY, proc, - (ClientData) paramg); - } - - paramg->counter ++; - sprintf (paramg->buf, "rde%ld", paramg->counter); - return paramg->buf; - -#undef KEY - } - - static void - PARAMdeleteCmd (ClientData clientData) - { - /* Release the whole PARAM. */ - param_delete ((RDE_STATE) clientData); - } - } - - # # ## ### ##### ######## ############# ##################### - ## Main command, PARAM creation. - - critcl::ccommand rde_critcl {dummy interp objc objv} { - /* Syntax: No arguments beyond the name - */ - - CONST char* name; - RDE_STATE param; - Tcl_Obj* fqn; - Tcl_CmdInfo ci; - Tcl_Command c; - -#define USAGE "?name?" - - if ((objc != 2) && (objc != 1)) { +namespace eval ::pt {} + +# # ## ### ##### ######## ############# ##################### +## Supporting code for the main command. + +critcl::cheaders rde_critcl/*.h +critcl::csources rde_critcl/*.c + +critcl::ccode { + /* -*- c -*- */ + + #include /* Allocation macros */ + #include /* Public state API */ + #include /* Instance command */ + + /* .................................................. */ + /* Global PARAM management, per interp + */ + + typedef struct PARAMg { + long int counter; + char buf [50]; + } PARAMg; + + static void + PARAMgRelease (ClientData cd, Tcl_Interp* interp) + { + ckfree((char*) cd); + } + + static CONST char* + PARAMnewName (Tcl_Interp* interp) + { + #define KEY "tcllib/pt::rde/critcl" + + Tcl_InterpDeleteProc* proc = PARAMgRelease; + PARAMg* paramg; + + paramg = Tcl_GetAssocData (interp, KEY, &proc); + if (paramg == NULL) { + paramg = (PARAMg*) ckalloc (sizeof (PARAMg)); + paramg->counter = 0; + + Tcl_SetAssocData (interp, KEY, proc, + (ClientData) paramg); + } + + paramg->counter ++; + sprintf (paramg->buf, "rde%ld", paramg->counter); + return paramg->buf; + + #undef KEY + } + + static void + PARAMdeleteCmd (ClientData clientData) + { + /* Release the whole PARAM. */ + param_delete ((RDE_STATE) clientData); + } +} + +# # ## ### ##### ######## ############# ##################### +## Main command, PARAM creation. + +critcl::ccommand ::pt::rde_critcl {dummy interp objc objv} { + /* Syntax: No arguments beyond the name + */ + + CONST char* name; + RDE_STATE param; + Tcl_Obj* fqn; + Tcl_CmdInfo ci; + Tcl_Command c; + + #define USAGE "?name?" + + if ((objc != 2) && (objc != 1)) { Tcl_WrongNumArgs (interp, 1, objv, USAGE); return TCL_ERROR; - } + } - if (objc < 2) { + if (objc < 2) { name = PARAMnewName (interp); - } else { + } else { name = Tcl_GetString (objv [1]); - } + } - if (!Tcl_StringMatch (name, "::*")) { + if (!Tcl_StringMatch (name, "::*")) { /* Relative name. Prefix with current namespace */ Tcl_Eval (interp, "namespace current"); fqn = Tcl_GetObjResult (interp); fqn = Tcl_DuplicateObj (fqn); Tcl_IncrRefCount (fqn); if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { - Tcl_AppendToObj (fqn, "::", -1); + Tcl_AppendToObj (fqn, "::", -1); } Tcl_AppendToObj (fqn, name, -1); - } else { + } else { fqn = Tcl_NewStringObj (name, -1); Tcl_IncrRefCount (fqn); - } - Tcl_ResetResult (interp); + } + Tcl_ResetResult (interp); - if (Tcl_GetCommandInfo (interp, - Tcl_GetString (fqn), - &ci)) { + if (Tcl_GetCommandInfo (interp, + Tcl_GetString (fqn), + &ci)) { Tcl_Obj* err; err = Tcl_NewObj (); Tcl_AppendToObj (err, "command \"", -1); Tcl_AppendObjToObj (err, fqn); @@ -145,24 +161,23 @@ Tcl_AppendToObj (err, "\" already exists", -1); Tcl_DecrRefCount (fqn); Tcl_SetObjResult (interp, err); return TCL_ERROR; - } - - param = param_new (); - c = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn), - paramms_objcmd, (ClientData) param, - PARAMdeleteCmd); - param_setcmd (param, c); - - Tcl_SetObjResult (interp, fqn); - Tcl_DecrRefCount (fqn); - return TCL_OK; - } + } + + param = param_new (); + c = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn), + paramms_objcmd, (ClientData) param, + PARAMdeleteCmd); + param_setcmd (param, c); + + Tcl_SetObjResult (interp, fqn); + Tcl_DecrRefCount (fqn); + return TCL_OK; } # # ## ### ##### ######## ############# ##################### ## Ready package provide pt::rde::critcl 1.0.3 return Index: modules/rc4/rc4c.tcl ================================================================== --- modules/rc4/rc4c.tcl +++ modules/rc4/rc4c.tcl @@ -2,167 +2,200 @@ # # This provides a critcl C implementation of RC4 # # INSTALLATION # ------------ -# This package uses critcl (http://wiki.tcl.tk/critcl). To build do: -# critcl -libdir -pkg rc4c rc4c +# This package uses critcl3 (http://wiki.tcl.tk/critcl). +# To build run: +# critcl3 -libdir -pkg rc4c rc4c # # To build this for tcllib use sak.tcl: # tclsh sak.tcl critcl # generates a tcllibc module. # # $Id: rc4c.tcl,v 1.4 2009/05/07 00:14:02 patthoyts Exp $ -package require critcl -# @sak notprovided rc4c -package provide rc4c 1.1.0 - -namespace eval ::rc4 { - - critcl::ccode { - #include - - typedef struct RC4_CTX { - unsigned char x; - unsigned char y; - unsigned char s[256]; - } RC4_CTX; - - /* #define TRACE trace */ - #define TRACE 1 ? ((void)0) : trace - - static void trace(const char *format, ...) - { - va_list args; - va_start(args, format); - vfprintf(stderr, format, args); - va_end(args); - } - static Tcl_ObjType rc4_type; - - static void rc4_free_rep(Tcl_Obj *obj) - { - RC4_CTX *ctx = (RC4_CTX *)obj->internalRep.otherValuePtr; - TRACE("rc4_free_rep(%08x)\n", (long)obj); - Tcl_Free((char *)ctx); - } - - static void rc4_dup_rep(Tcl_Obj *obj, Tcl_Obj *dup) - { - RC4_CTX *ctx = (RC4_CTX *)obj->internalRep.otherValuePtr; - TRACE("rc4_dup_rep(%08x,%08x)\n", (long)obj, (long)dup); - dup->internalRep.otherValuePtr = (RC4_CTX *)Tcl_Alloc(sizeof(RC4_CTX)); - memcpy(dup->internalRep.otherValuePtr, ctx, sizeof(RC4_CTX)); - dup->typePtr = &rc4_type; - } - - static void rc4_string_rep(Tcl_Obj* obj) - { - RC4_CTX *ctx = (RC4_CTX *)obj->internalRep.otherValuePtr; - Tcl_Obj* tmpObj; - char* str; - TRACE("rc4_string_rep(%08x)\n", (long)obj); - /* convert via a byte array to properly handle null bytes */ - tmpObj = Tcl_NewByteArrayObj((unsigned char *)ctx, sizeof(RC4_CTX)); - Tcl_IncrRefCount(tmpObj); - - str = Tcl_GetStringFromObj(tmpObj, &obj->length); - obj->bytes = Tcl_Alloc(obj->length + 1); - memcpy(obj->bytes, str, obj->length + 1); - - Tcl_DecrRefCount(tmpObj); - } - - static int rc4_from_any(Tcl_Interp* interp, Tcl_Obj* obj) - { - TRACE("rc4_from_any %08x\n", (long)obj); - return TCL_ERROR; - } - - static Tcl_ObjType rc4_type = { - "rc4c", rc4_free_rep, rc4_dup_rep, rc4_string_rep, rc4_from_any - }; -#ifdef __GNUC__ - inline -#elif defined(_MSC_VER) - __inline -#endif - void swap (unsigned char *lhs, unsigned char *rhs) { - unsigned char t = *lhs; - *lhs = *rhs; - *rhs = t; - } - } - - critcl::ccommand rc4c_init {dummy interp objc objv} { - RC4_CTX *ctx; - Tcl_Obj *obj; - const unsigned char *k; - int n = 0, i = 0, j = 0, keylen; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "keystring"); - return TCL_ERROR; - } - - k = Tcl_GetByteArrayFromObj(objv[1], &keylen); - - obj = Tcl_NewObj(); - ctx = (RC4_CTX *)Tcl_Alloc(sizeof(RC4_CTX)); - ctx->x = 0; - ctx->y = 0; - for (n = 0; n < 256; n++) - ctx->s[n] = n; - for (n = 0; n < 256; n++) { - j = (k[i] + ctx->s[n] + j) % 256; - swap(&ctx->s[n], &ctx->s[j]); - i = (i + 1) % keylen; - } - - if (obj->typePtr != NULL && obj->typePtr->freeIntRepProc != NULL) - obj->typePtr->freeIntRepProc(obj); - obj->internalRep.otherValuePtr = ctx; - obj->typePtr = &rc4_type; - Tcl_InvalidateStringRep(obj); - Tcl_SetObjResult(interp, obj); - return TCL_OK; - } - - critcl::ccommand rc4c {dummy interp objc objv} { - Tcl_Obj *resObj = NULL; - RC4_CTX *ctx = NULL; - unsigned char *data, *res, x, y; - int size, n, i; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "key data"); - return TCL_ERROR; - } - - if (objv[1]->typePtr != &rc4_type - && rc4_from_any(interp, objv[1]) != TCL_OK) { - return TCL_ERROR; - } - - ctx = objv[1]->internalRep.otherValuePtr; - data = Tcl_GetByteArrayFromObj(objv[2], &size); - res = (unsigned char *)Tcl_Alloc(size); - - x = ctx->x; - y = ctx->y; - for (n = 0; n < size; n++) { - x = (x + 1) % 256; - y = (ctx->s[x] + y) % 256; - swap(&ctx->s[x], &ctx->s[y]); - i = (ctx->s[x] + ctx->s[y]) % 256; - res[n] = data[n] ^ ctx->s[i]; - } - ctx->x = x; - ctx->y = y; - - resObj = Tcl_NewByteArrayObj(res, size); - Tcl_SetObjResult(interp, resObj); - Tcl_Free((char*)res); - return TCL_OK; - } -} +package require critcl 3.1 + +if {![critcl::compiling]} { + error "Unable to build rc4c, no proper compiler found." +} + +# # ## ### ##### ######## ############# ##################### +## Administrivia + +critcl::license {Pat Thoyts} BSD +critcl::summary { + C implementation of the RC4 cipher +} +critcl::description { + This package provides a C implementation of RC4. +} +critcl::subject \ + arcfour rc4 {data integrity} encryption security \ + {stream cipher} + +critcl::meta location http://core.tcl.tk/tcllib + +# # ## ### ##### ######## ############# ##################### +## Implementation + +## todo :: critcl :: possibly define an argument conversion for the +## context. handling of default is an issue. + +critcl::tcl 8.4 + +namespace eval ::rc4 {} + +critcl::ccode { + #include + + typedef struct RC4_CTX { + unsigned char x; + unsigned char y; + unsigned char s[256]; + } RC4_CTX; + + /* #define TRACE trace */ + #define TRACE 1 ? ((void)0) : trace + + static void trace(const char *format, ...) + { + va_list args; + va_start(args, format); + vfprintf(stderr, format, args); + va_end(args); + } + static Tcl_ObjType rc4_type; + + static void rc4_free_rep(Tcl_Obj *obj) + { + RC4_CTX *ctx = (RC4_CTX *)obj->internalRep.otherValuePtr; + TRACE("rc4_free_rep(%08x)\n", (long)obj); + Tcl_Free((char *)ctx); + } + + static void rc4_dup_rep(Tcl_Obj *obj, Tcl_Obj *dup) + { + RC4_CTX *ctx = (RC4_CTX *)obj->internalRep.otherValuePtr; + TRACE("rc4_dup_rep(%08x,%08x)\n", (long)obj, (long)dup); + dup->internalRep.otherValuePtr = (RC4_CTX *)Tcl_Alloc(sizeof(RC4_CTX)); + memcpy(dup->internalRep.otherValuePtr, ctx, sizeof(RC4_CTX)); + dup->typePtr = &rc4_type; + } + + static void rc4_string_rep(Tcl_Obj* obj) + { + RC4_CTX *ctx = (RC4_CTX *)obj->internalRep.otherValuePtr; + Tcl_Obj* tmpObj; + char* str; + TRACE("rc4_string_rep(%08x)\n", (long)obj); + /* convert via a byte array to properly handle null bytes */ + tmpObj = Tcl_NewByteArrayObj((unsigned char *)ctx, sizeof(RC4_CTX)); + Tcl_IncrRefCount(tmpObj); + + str = Tcl_GetStringFromObj(tmpObj, &obj->length); + obj->bytes = Tcl_Alloc(obj->length + 1); + memcpy(obj->bytes, str, obj->length + 1); + + Tcl_DecrRefCount(tmpObj); + } + + static int rc4_from_any(Tcl_Interp* interp, Tcl_Obj* obj) + { + TRACE("rc4_from_any %08x\n", (long)obj); + return TCL_ERROR; + } + + static Tcl_ObjType rc4_type = { + "rc4c", rc4_free_rep, rc4_dup_rep, rc4_string_rep, rc4_from_any + }; + #ifdef __GNUC__ + inline + #elif defined(_MSC_VER) + __inline + #endif + void swap (unsigned char *lhs, unsigned char *rhs) { + unsigned char t = *lhs; + *lhs = *rhs; + *rhs = t; + } +} + +# todo :: critcl :: convertible to cproc +critcl::ccommand ::rc4::rc4c_init {dummy interp objc objv} { + RC4_CTX *ctx; + Tcl_Obj *obj; + const unsigned char *k; + int n = 0, i = 0, j = 0, keylen; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "keystring"); + return TCL_ERROR; + } + + k = Tcl_GetByteArrayFromObj(objv[1], &keylen); + + obj = Tcl_NewObj(); + ctx = (RC4_CTX *)Tcl_Alloc(sizeof(RC4_CTX)); + ctx->x = 0; + ctx->y = 0; + for (n = 0; n < 256; n++) + ctx->s[n] = n; + for (n = 0; n < 256; n++) { + j = (k[i] + ctx->s[n] + j) % 256; + swap(&ctx->s[n], &ctx->s[j]); + i = (i + 1) % keylen; + } + + if (obj->typePtr != NULL && obj->typePtr->freeIntRepProc != NULL) + obj->typePtr->freeIntRepProc(obj); + obj->internalRep.otherValuePtr = ctx; + obj->typePtr = &rc4_type; + Tcl_InvalidateStringRep(obj); + Tcl_SetObjResult(interp, obj); + return TCL_OK; +} + +# todo :: critcl :: convertible to cproc +critcl::ccommand ::rc4::rc4c {dummy interp objc objv} { + Tcl_Obj *resObj = NULL; + RC4_CTX *ctx = NULL; + unsigned char *data, *res, x, y; + int size, n, i; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "key data"); + return TCL_ERROR; + } + + if (objv[1]->typePtr != &rc4_type + && rc4_from_any(interp, objv[1]) != TCL_OK) { + return TCL_ERROR; + } + + ctx = objv[1]->internalRep.otherValuePtr; + data = Tcl_GetByteArrayFromObj(objv[2], &size); + res = (unsigned char *)Tcl_Alloc(size); + + x = ctx->x; + y = ctx->y; + for (n = 0; n < size; n++) { + x = (x + 1) % 256; + y = (ctx->s[x] + y) % 256; + swap(&ctx->s[x], &ctx->s[y]); + i = (ctx->s[x] + ctx->s[y]) % 256; + res[n] = data[n] ^ ctx->s[i]; + } + ctx->x = x; + ctx->y = y; + + resObj = Tcl_NewByteArrayObj(res, size); + Tcl_SetObjResult(interp, resObj); + Tcl_Free((char*)res); + return TCL_OK; +} + +# # ## ### ##### ######## ############# ##################### +# @sak notprovided rc4c +package provide rc4c 1.1.0 +return Index: modules/sha1/sha1c.tcl ================================================================== --- modules/sha1/sha1c.tcl +++ modules/sha1/sha1c.tcl @@ -2,124 +2,155 @@ # # Wrapper for the Secure Hashing Algorithm (SHA1) # # $Id: sha1c.tcl,v 1.6 2009/05/07 00:35:10 patthoyts Exp $ -package require critcl; # needs critcl -# @sak notprovided sha1c -package provide sha1c 2.0.3 +package require critcl 3.1 + +if {![critcl::compiling]} { + error "Unable to build sha1c, no proper compiler found." +} + +# # ## ### ##### ######## ############# ##################### +## Administrivia + +critcl::license {Pat Thoyts} BSD +critcl::summary { + C implementation of the SHA1 message digest +} +critcl::description { + This package provides a C implementation of SHA1 based + on the NetBSD sources. +} +critcl::subject \ + hashing sha1 message-digest security \ + {rfc 2104} {FIPS 180-1} + +critcl::meta location http://core.tcl.tk/tcllib + +# # ## ### ##### ######## ############# ##################### +## Implementation + +## todo :: critcl :: possibly define an argument conversion for the +## context. handling of default is an issue. + +critcl::tcl 8.4 -critcl::cheaders sha1.h; # NetBSD SHA1 implementation -critcl::csources sha1.c; # NetBSD SHA1 implementation +critcl::cheaders sha1.h ; # NetBSD SHA1 implementation +critcl::csources sha1.c ; # NetBSD SHA1 implementation if {$tcl_platform(byteOrder) eq "littleEndian"} { set byteOrder 1234 } else { set byteOrder 4321 } critcl::cflags -DTCL_BYTE_ORDER=$byteOrder -namespace eval ::sha1 { - - critcl::ccode { - #include "sha1.h" - #include - #include - #include - - static - Tcl_ObjType sha1_type; /* fast internal access representation */ - - static void - sha1_free_rep(Tcl_Obj* obj) - { - SHA1_CTX* mp = (SHA1_CTX*) obj->internalRep.otherValuePtr; - Tcl_Free ((char*)mp); - } - - static void - sha1_dup_rep(Tcl_Obj* obj, Tcl_Obj* dup) - { - SHA1_CTX* mp = (SHA1_CTX*) obj->internalRep.otherValuePtr; - dup->internalRep.otherValuePtr = Tcl_Alloc(sizeof *mp); - memcpy(dup->internalRep.otherValuePtr, mp, sizeof *mp); - dup->typePtr = &sha1_type; - } - - static void - sha1_string_rep(Tcl_Obj* obj) - { - unsigned char buf[20]; - Tcl_Obj* temp; - char* str; - SHA1_CTX dup = *(SHA1_CTX*) obj->internalRep.otherValuePtr; - - SHA1Final(buf, &dup); - - /* convert via a byte array to properly handle null bytes */ - temp = Tcl_NewByteArrayObj(buf, sizeof buf); - Tcl_IncrRefCount(temp); - - str = Tcl_GetStringFromObj(temp, &obj->length); - obj->bytes = Tcl_Alloc(obj->length + 1); - memcpy(obj->bytes, str, obj->length + 1); - - Tcl_DecrRefCount(temp); - } - - static int - sha1_from_any(Tcl_Interp* ip, Tcl_Obj* obj) - { - assert(0); - return TCL_ERROR; - } - - static - Tcl_ObjType sha1_type = { - "sha1c", sha1_free_rep, sha1_dup_rep, sha1_string_rep, - sha1_from_any - }; - } - - critcl::ccommand sha1c {dummy ip objc objv} { - SHA1_CTX* mp; - unsigned char* data; - int size; - Tcl_Obj* obj; - - if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(ip, 1, objv, "data ?context?"); - return TCL_ERROR; - } - - if (objc == 3) { - if (objv[2]->typePtr != &sha1_type - && sha1_from_any(ip, objv[2]) != TCL_OK) { - return TCL_ERROR; - } - obj = objv[2]; - if (Tcl_IsShared(obj)) { - obj = Tcl_DuplicateObj(obj); - } - } else { - obj = Tcl_NewObj(); - mp = (SHA1_CTX*) Tcl_Alloc(sizeof *mp); - SHA1Init(mp); - - if (obj->typePtr != NULL && obj->typePtr->freeIntRepProc != NULL) { - obj->typePtr->freeIntRepProc(obj); - } - - obj->internalRep.otherValuePtr = mp; - obj->typePtr = &sha1_type; - } - - Tcl_InvalidateStringRep(obj); - - mp = (SHA1_CTX*) obj->internalRep.otherValuePtr; - data = Tcl_GetByteArrayFromObj(objv[1], &size); - SHA1Update(mp, data, size); - - Tcl_SetObjResult(ip, obj); - return TCL_OK; - } -} +namespace eval ::sha1 {} + +critcl::ccode { + #include "sha1.h" + #include + #include + #include + + static + Tcl_ObjType sha1_type; /* fast internal access representation */ + + static void + sha1_free_rep(Tcl_Obj* obj) + { + SHA1_CTX* mp = (SHA1_CTX*) obj->internalRep.otherValuePtr; + Tcl_Free((char*)mp); + } + + static void + sha1_dup_rep(Tcl_Obj* obj, Tcl_Obj* dup) + { + SHA1_CTX* mp = (SHA1_CTX*) obj->internalRep.otherValuePtr; + dup->internalRep.otherValuePtr = Tcl_Alloc(sizeof *mp); + memcpy(dup->internalRep.otherValuePtr, mp, sizeof *mp); + dup->typePtr = &sha1_type; + } + + static void + sha1_string_rep(Tcl_Obj* obj) + { + unsigned char buf[20]; + Tcl_Obj* temp; + char* str; + SHA1_CTX dup = *(SHA1_CTX*) obj->internalRep.otherValuePtr; + + SHA1Final(buf, &dup); + + /* convert via a byte array to properly handle null bytes */ + temp = Tcl_NewByteArrayObj(buf, sizeof buf); + Tcl_IncrRefCount(temp); + + str = Tcl_GetStringFromObj(temp, &obj->length); + obj->bytes = Tcl_Alloc(obj->length + 1); + memcpy(obj->bytes, str, obj->length + 1); + + Tcl_DecrRefCount(temp); + } + + static int + sha1_from_any(Tcl_Interp* ip, Tcl_Obj* obj) + { + assert(0); + return TCL_ERROR; + } + + static + Tcl_ObjType sha1_type = { + "sha1c", sha1_free_rep, sha1_dup_rep, sha1_string_rep, + sha1_from_any + }; +} + +critcl::ccommand ::sha1::sha1c {dummy ip objc objv} { + SHA1_CTX* mp; + unsigned char* data; + int size; + Tcl_Obj* obj; + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(ip, 1, objv, "data ?context?"); + return TCL_ERROR; + } + + if (objc == 3) { + if (objv[2]->typePtr != &sha1_type + && sha1_from_any(ip, objv[2]) != TCL_OK) { + return TCL_ERROR; + } + obj = objv[2]; + if (Tcl_IsShared(obj)) { + obj = Tcl_DuplicateObj(obj); + } + } else { + obj = Tcl_NewObj(); + mp = (SHA1_CTX*) Tcl_Alloc(sizeof *mp); + SHA1Init(mp); + + if (obj->typePtr != NULL && obj->typePtr->freeIntRepProc != NULL) { + obj->typePtr->freeIntRepProc(obj); + } + + obj->internalRep.otherValuePtr = mp; + obj->typePtr = &sha1_type; + } + + Tcl_InvalidateStringRep(obj); + + mp = (SHA1_CTX*) obj->internalRep.otherValuePtr; + data = Tcl_GetByteArrayFromObj(objv[1], &size); + SHA1Update(mp, data, size); + + Tcl_SetObjResult(ip, obj); + return TCL_OK; +} + +# # ## ### ##### ######## ############# ##################### +# @sak notprovided sha1c +package provide sha1c 2.0.3 +return Index: modules/sha1/sha256c.tcl ================================================================== --- modules/sha1/sha256c.tcl +++ modules/sha1/sha256c.tcl @@ -5,170 +5,197 @@ # # Wrapper for the Secure Hashing Algorithm (SHA256) # # $Id: sha256c.tcl,v 1.5 2009/05/07 00:35:10 patthoyts Exp $ -package require critcl; # needs critcl -# @sak notprovided sha256c -package provide sha256c 1.0.2 +package require critcl 3.1 + +if {![critcl::compiling]} { + error "Unable to build sha256c, no proper compiler found." +} + +# # ## ### ##### ######## ############# ##################### +## Administrivia + +critcl::license {Pat Thoyts, Andreas Kupries} BSD +critcl::summary { + C implementation of the SHA256 message digest +} +critcl::description { + This package provides a C implementation of SHA256 based + on the FreeBSD sources. +} +critcl::subject \ + hashing sha256 message-digest security \ + {rfc 2104} {FIPS 180-1} + +critcl::meta location http://core.tcl.tk/tcllib + +# # ## ### ##### ######## ############# ##################### +## Implementation + +## todo :: critcl :: possibly define an argument conversion for the +## context. handling of default is an issue. + +critcl::tcl 8.4 -critcl::cheaders sha256.h; # FreeBSD SHA256 implementation -critcl::csources sha256.c; # FreeBSD SHA256 implementation +critcl::cheaders sha256.h ; # FreeBSD SHA256 implementation +critcl::csources sha256.c ; # FreeBSD SHA256 implementation if {$tcl_platform(byteOrder) eq "littleEndian"} { set byteOrder 1234 } else { set byteOrder 4321 } critcl::cflags -DTCL_BYTE_ORDER=$byteOrder -namespace eval ::sha2 { - # Supporting code for the main command. - catch { - #critcl::debug memory symbols - } - - critcl::ccode { - #include "sha256.h" - #include - #include - #include - - static - Tcl_ObjType sha256_type; /* fast internal access representation */ - - static void - sha256_free_rep(Tcl_Obj* obj) - { - SHA256_CTX* mp = (SHA256_CTX*) obj->internalRep.otherValuePtr; - free(mp); - } - - static void - sha256_dup_rep(Tcl_Obj* obj, Tcl_Obj* dup) - { - SHA256_CTX* mp = (SHA256_CTX*) obj->internalRep.otherValuePtr; - dup->internalRep.otherValuePtr = malloc(sizeof *mp); - memcpy(dup->internalRep.otherValuePtr, mp, sizeof *mp); - dup->typePtr = &sha256_type; - } - - static void - sha256_string_rep(Tcl_Obj* obj) - { - unsigned char buf[SHA256_HASH_SIZE]; - Tcl_Obj* temp; - char* str; - SHA256_CTX dup = *(SHA256_CTX*) obj->internalRep.otherValuePtr; - - SHA256Final(&dup, buf); - - /* convert via a byte array to properly handle null bytes */ - temp = Tcl_NewByteArrayObj(buf, sizeof buf); - Tcl_IncrRefCount(temp); - - str = Tcl_GetStringFromObj(temp, &obj->length); - obj->bytes = Tcl_Alloc(obj->length + 1); - memcpy(obj->bytes, str, obj->length + 1); - - Tcl_DecrRefCount(temp); - } - - static int - sha256_from_any(Tcl_Interp* ip, Tcl_Obj* obj) - { - assert(0); - return TCL_ERROR; - } - - static - Tcl_ObjType sha256_type = { - "sha256c", sha256_free_rep, sha256_dup_rep, sha256_string_rep, - sha256_from_any - }; - } - - critcl::ccommand sha256c_init256 {dummy ip objc objv} { - SHA256_CTX* mp; - unsigned char* data; - int size; - Tcl_Obj* obj; - - if (objc > 1) { - Tcl_WrongNumArgs(ip, 1, objv, ""); - return TCL_ERROR; - } - - obj = Tcl_NewObj(); - mp = (SHA256_CTX*) malloc(sizeof *mp); - SHA256Init(mp); - - if (obj->typePtr != NULL && obj->typePtr->freeIntRepProc != NULL) { - obj->typePtr->freeIntRepProc(obj); - } - - obj->internalRep.otherValuePtr = mp; - obj->typePtr = &sha256_type; - - Tcl_InvalidateStringRep(obj); - Tcl_SetObjResult(ip, obj); - return TCL_OK; - } - - critcl::ccommand sha256c_init224 {dummy ip objc objv} { - SHA256_CTX* mp; - unsigned char* data; - int size; - Tcl_Obj* obj; - - if (objc > 1) { - Tcl_WrongNumArgs(ip, 1, objv, ""); - return TCL_ERROR; - } - - obj = Tcl_NewObj(); - mp = (SHA256_CTX*) malloc(sizeof *mp); - SHA224Init(mp); - - if (obj->typePtr != NULL && obj->typePtr->freeIntRepProc != NULL) { - obj->typePtr->freeIntRepProc(obj); - } - - obj->internalRep.otherValuePtr = mp; - obj->typePtr = &sha256_type; - - Tcl_InvalidateStringRep(obj); - Tcl_SetObjResult(ip, obj); - return TCL_OK; - } - - critcl::ccommand sha256c_update {dummy ip objc objv} { - SHA256_CTX* mp; - unsigned char* data; - int size; - Tcl_Obj* obj; - - if (objc != 3) { - Tcl_WrongNumArgs(ip, 1, objv, "data context"); - return TCL_ERROR; - } - - if (objv[2]->typePtr != &sha256_type - && sha256_from_any(ip, objv[2]) != TCL_OK) { - return TCL_ERROR; - } - - obj = objv[2]; - if (Tcl_IsShared(obj)) { - obj = Tcl_DuplicateObj(obj); - } - - Tcl_InvalidateStringRep(obj); - mp = (SHA256_CTX*) obj->internalRep.otherValuePtr; - - data = Tcl_GetByteArrayFromObj(objv[1], &size); - SHA256Update(mp, data, size); - - Tcl_SetObjResult(ip, obj); - return TCL_OK; - } -} +namespace eval ::sha2 {} + +critcl::ccode { + #include "sha256.h" + #include + #include + #include + + static + Tcl_ObjType sha256_type; /* fast internal access representation */ + + static void + sha256_free_rep(Tcl_Obj* obj) + { + SHA256_CTX* mp = (SHA256_CTX*) obj->internalRep.otherValuePtr; + free(mp); + } + + static void + sha256_dup_rep(Tcl_Obj* obj, Tcl_Obj* dup) + { + SHA256_CTX* mp = (SHA256_CTX*) obj->internalRep.otherValuePtr; + dup->internalRep.otherValuePtr = malloc(sizeof *mp); + memcpy(dup->internalRep.otherValuePtr, mp, sizeof *mp); + dup->typePtr = &sha256_type; + } + + static void + sha256_string_rep(Tcl_Obj* obj) + { + unsigned char buf[SHA256_HASH_SIZE]; + Tcl_Obj* temp; + char* str; + SHA256_CTX dup = *(SHA256_CTX*) obj->internalRep.otherValuePtr; + + SHA256Final(&dup, buf); + + /* convert via a byte array to properly handle null bytes */ + temp = Tcl_NewByteArrayObj(buf, sizeof buf); + Tcl_IncrRefCount(temp); + + str = Tcl_GetStringFromObj(temp, &obj->length); + obj->bytes = Tcl_Alloc(obj->length + 1); + memcpy(obj->bytes, str, obj->length + 1); + + Tcl_DecrRefCount(temp); + } + + static int + sha256_from_any(Tcl_Interp* ip, Tcl_Obj* obj) + { + assert(0); + return TCL_ERROR; + } + + static + Tcl_ObjType sha256_type = { + "sha256c", sha256_free_rep, sha256_dup_rep, sha256_string_rep, + sha256_from_any + }; +} + +critcl::ccommand ::sha2::sha256c_init256 {dummy ip objc objv} { + SHA256_CTX* mp; + unsigned char* data; + int size; + Tcl_Obj* obj; + + if (objc > 1) { + Tcl_WrongNumArgs(ip, 1, objv, ""); + return TCL_ERROR; + } + + obj = Tcl_NewObj(); + mp = (SHA256_CTX*) malloc(sizeof *mp); + SHA256Init(mp); + + if (obj->typePtr != NULL && obj->typePtr->freeIntRepProc != NULL) { + obj->typePtr->freeIntRepProc(obj); + } + + obj->internalRep.otherValuePtr = mp; + obj->typePtr = &sha256_type; + + Tcl_InvalidateStringRep(obj); + Tcl_SetObjResult(ip, obj); + return TCL_OK; +} + +critcl::ccommand ::sha2::sha256c_init224 {dummy ip objc objv} { + SHA256_CTX* mp; + unsigned char* data; + int size; + Tcl_Obj* obj; + + if (objc > 1) { + Tcl_WrongNumArgs(ip, 1, objv, ""); + return TCL_ERROR; + } + + obj = Tcl_NewObj(); + mp = (SHA256_CTX*) malloc(sizeof *mp); + SHA224Init(mp); + + if (obj->typePtr != NULL && obj->typePtr->freeIntRepProc != NULL) { + obj->typePtr->freeIntRepProc(obj); + } + + obj->internalRep.otherValuePtr = mp; + obj->typePtr = &sha256_type; + + Tcl_InvalidateStringRep(obj); + Tcl_SetObjResult(ip, obj); + return TCL_OK; +} + +critcl::ccommand ::sha2::sha256c_update {dummy ip objc objv} { + SHA256_CTX* mp; + unsigned char* data; + int size; + Tcl_Obj* obj; + + if (objc != 3) { + Tcl_WrongNumArgs(ip, 1, objv, "data context"); + return TCL_ERROR; + } + + if (objv[2]->typePtr != &sha256_type + && sha256_from_any(ip, objv[2]) != TCL_OK) { + return TCL_ERROR; + } + + obj = objv[2]; + if (Tcl_IsShared(obj)) { + obj = Tcl_DuplicateObj(obj); + } + + Tcl_InvalidateStringRep(obj); + mp = (SHA256_CTX*) obj->internalRep.otherValuePtr; + + data = Tcl_GetByteArrayFromObj(objv[1], &size); + SHA256Update(mp, data, size); + + Tcl_SetObjResult(ip, obj); + return TCL_OK; +} + +# # ## ### ##### ######## ############# ##################### +# @sak notprovided sha256c +package provide sha256c 1.0.2 +return Index: modules/tcllibc.tcl ================================================================== --- modules/tcllibc.tcl +++ modules/tcllibc.tcl @@ -1,10 +1,14 @@ # Umbrella, i.e. Bundle, to put all of the critcl modules which are # found in Tcllib in one shared library. -package require critcl +package require critcl 3.1 package provide tcllibc 0.3.13 + +if {![critcl::compiling]} { + error "Unable to build tcllibc, no proper compiler found." +} namespace eval ::tcllib { variable tcllibc_rcsid {$Id: tcllibc.tcl,v 1.13 2010/05/25 19:26:17 andreas_kupries Exp $} critcl::ccode { /* no code required in this file */