Tcl Library Source Code

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
====		======		======

# base32c.tcl --
#
#       Implementation of a base32 (std) de/encoder for Tcl.
#
# 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

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 \
namespace eval ::base32 {
    # Supporting code for the main command.
    catch {
	#critcl::cheaders -g
	#critcl::debug memory symbols
    }
    base32 {rfc 3548}

critcl::meta location http://core.tcl.tk/tcllib

# # ## ### ##### ######## ############# #####################
## Implementation

critcl::tcl 8.4

namespace eval ::base32 {}

    # Main commands, encoder & decoder
# Main commands, encoder & decoder

    critcl::ccommand critcl_encode {dummy interp objc objv} {
      /* Syntax -*- c -*-
       * critcl_encode string
       */
critcl::ccommand ::base32::critcl_encode {dummy interp objc objv} {
    /* Syntax -*- c -*-
     * critcl_encode string
     */

      unsigned char* buf;
      int           nbuf;
    unsigned char* buf;
    int           nbuf;

      unsigned char* out;
      unsigned char* at;
      int           nout;
    unsigned char* out;
    unsigned char* at;
    int           nout;

      /*
       * The array used for encoding
       */                     /* 123456789 123456789 123456789 12 */
      static const char map[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567";
    /*
     * The array used for encoding
     */                     /* 123456789 123456789 123456789 12 */
    static const char map[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567";

#define USAGEE "bitstring"
    #define USAGEE "bitstring"

      if (objc != 2) {
    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) {
    }
    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;
	    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;
    }
    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
       */
critcl::ccommand ::base32::critcl_decode {dummy interp objc objv} {
    /* Syntax -*- c -*-
     * critcl_decode estring
     */

      unsigned char* buf;
      int           nbuf;
    unsigned char* buf;
    int           nbuf;

      unsigned char* out;
      unsigned char* at;
      unsigned char  x [8];
      int           nout;
    unsigned char* out;
    unsigned char* at;
    unsigned char  x [8];
    int           nout;

      int i, j, a, pad, nx;
    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 [] = {
    /*
     * 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));
    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)]))
    #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];
	   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 (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;
	  }
	   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;
	    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;
    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

# base32hexc.tcl --
#
#       Implementation of a base32 (extended hex) de/encoder for Tcl.
#
# 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

if {![critcl::compiling]} {
    error "Unable to build base32hex_c, no proper compiler found."
}
namespace eval ::base32::hex {
    # Supporting code for the main command.
    catch {
	#critcl::cheaders -g
	#critcl::debug memory symbols
    }

# # ## ### ##### ######## ############# #####################
## 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
# Main commands, encoder & decoder

    critcl::ccommand critcl_encode {dummy interp objc objv} {
      /* Syntax -*- c -*-
       * critcl_encode string
       */
critcl::ccommand ::base32::hex::critcl_encode {dummy interp objc objv} {
    /* Syntax -*- c -*-
     * critcl_encode string
     */

      unsigned char* buf;
      int           nbuf;
    unsigned char* buf;
    int           nbuf;

      unsigned char* out;
      unsigned char* at;
      int           nout;
    unsigned char* out;
    unsigned char* at;
    int           nout;

      /*
       * The array used for encoding
       */                     /* 123456789 123456789 123456789 12 */
      static const char map[] = "0123456789ABCDEFGHIJKLMNOPQRSTUV";
    /*
     * 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;
      }
    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) {
    }
    if (nbuf > 0) {
	/* Process partials at end. */
	switch (nbuf) {
	case 1:
	  /* |01234567|		 2, padding 6
	   *  xxxxx
	   *       xxx 00
	   */

	  *(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;
    }
    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
       */
critcl::ccommand ::base32::hex::critcl_decode {dummy interp objc objv} {
    /* Syntax -*- c -*-
     * critcl_decode estring
     */

      unsigned char* buf;
      int           nbuf;
    unsigned char* buf;
    int           nbuf;

      unsigned char* out;
      unsigned char* at;
      unsigned char  x [8];
      int           nout;
    unsigned char* out;
    unsigned char* at;
    unsigned char  x [8];
    int           nout;

      int i, j, a, pad, nx;
    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 [] = {
    /*
     * 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;
	    pad++;
	    continue;

	}

	*(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;
	    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;
    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

# @sak notprovided base64c
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

    critcl::ccode {
        /* no code required in this file */
    }
}

# @sak notprovided crcc
package provide crcc 1.0.0

# TODO: Take the C code out of crc.tcl

# -*- 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?
#
if {[string equal $::tcl_platform(platform) windows] ||
    ([string equal $::tcl_platform(os)      SunOS] &&
     [string equal $::tcl_platform(osVersion) 5.6])
} {
    # avoid warnings about nothing to compile
    critcl::ccode {
        /* nothing to do */
    }
    return
}

# # ## ### ##### ######## ############# #####################
## Administrivia
package require critcl;

namespace eval ::ip {

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 {}

critcl::ccode {
#include <stdlib.h>
#include <stdio.h>
#include <tcl.h>
#include <inttypes.h>
#include <arpa/inet.h>
#include <string.h>
#include <sys/socket.h>
    #include <stdlib.h>
    #include <stdio.h>
    #include <tcl.h>
    #include <inttypes.h>
    #include <arpa/inet.h>
    #include <string.h>
    #include <sys/socket.h>
}

# todo :: critcl :: Convert to cproc (single argument, fixed)
critcl::ccommand prefixToNativec {clientData interp objc objv} { 
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];
    int rval,convertListc,i;
    Tcl_Obj **convertListv;
    Tcl_Obj *listPtr,*returnPtr, *addrList;
    char *stringIP, *slashPos, *stringMask;
    char v4HEX[11];
	
	uint32_t inaddr;
	listPtr = NULL;
    uint32_t inaddr;
    listPtr = NULL;

	/* printf ("\n in prefixToNativeC"); */
	/* printf ("\n objc = %d",objc); */
    /* printf ("\n in prefixToNativeC"); */
    /* printf ("\n objc = %d",objc); */

	if (objc != 2) {
		Tcl_WrongNumArgs(interp, 1, objv, "<ipaddress>/<mask>");
		return TCL_ERROR;
	}
    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "<ipaddress>/<mask>");
	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 (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);
	}
    if (convertListc==1) {
	Tcl_SetObjResult(interp,listPtr);
    } else {
	Tcl_SetObjResult(interp,returnPtr);
    }
	
	return TCL_OK;
    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;
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
	"-all","-inline","-ipv4",
	NULL
    };
    enum options {
		OVERLAP_ALL, OVERLAP_INLINE, OVERLAP_IPV4
	OVERLAP_ALL, OVERLAP_INLINE, OVERLAP_IPV4
    };

        allSet = 0;
        inlineSet = 0;
        listPtr = NULL;
    allSet = 0;
    inlineSet = 0;
    listPtr = NULL;

        /* printf ("\n objc = %d",objc); */
        if (objc < 3) {
                Tcl_WrongNumArgs(interp, 1, objv, "?options? <hexIP> <hexMask> <hexList>");
                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 */
    /* printf ("\n objc = %d",objc); */
    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "?options? <hexIP> <hexMask> <hexList>");
	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);
    /* 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);
    /* 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 <ipaddr> <mask> pairs */
        if (Tcl_ListObjGetElements (interp, objv[objc-1], &compareListc, &compareListv) != TCL_OK) {
                return TCL_ERROR;
        }
/*       printf("comparing %x/%x \n",ipaddr,ipMask); */
    /* split the 3rd argument into <ipaddr> <mask> 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);
        }
    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 {{<ipaddr> <mask>} {<ipad..}}");
                        return TCL_ERROR;
                }
                Tcl_GetIntFromObj(interp,comparePrefixMaskv[0],(int*)&ipaddr2);
                Tcl_GetIntFromObj(interp,comparePrefixMaskv[1],(int*)&ipMask2);
/*               printf(" with %x/%x \n",ipaddr2,ipMask2); */
                mask1mask2 = ipMask & ipMask2;
/*               printf("  mask1mask2 %x \n",mask1mask2); */
/*               printf("  ipaddr & mask1mask2  %x\n",ipaddr & mask1mask2); */
/*               printf("  ipaddr2 & mask1mask2 %x\n",ipaddr2 & mask1mask2); */
                if ((ipaddr & mask1mask2) == (ipaddr2 & mask1mask2)) {
		    if (allSet) {
			if (inlineSet) {
			    Tcl_ListObjAppendElement(interp, listPtr,
						     compareListv[i]);
			} else {
			    /* printf("\n appending %d",i+1); */
			    Tcl_ListObjAppendElement(interp, listPtr,
						     Tcl_NewIntObj(i+1));
			};
		    } else {
			if (inlineSet) {
			    Tcl_ListObjAppendElement(interp, listPtr,
						     compareListv[i]);
			    Tcl_SetObjResult(interp,listPtr);
			} else {
			    Tcl_SetIntObj (result, i+1);
			}
			return TCL_OK;
		    };
                };
					};
    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 {{<ipaddr> <mask>} {<ipad..}}");
	    return TCL_ERROR;
	}
	Tcl_GetIntFromObj(interp,comparePrefixMaskv[0],(int*)&ipaddr2);
	Tcl_GetIntFromObj(interp,comparePrefixMaskv[1],(int*)&ipMask2);
	/*               printf(" with %x/%x \n",ipaddr2,ipMask2); */
	mask1mask2 = ipMask & ipMask2;
	/*               printf("  mask1mask2 %x \n",mask1mask2); */
	/*               printf("  ipaddr & mask1mask2  %x\n",ipaddr & mask1mask2); */
	/*               printf("  ipaddr2 & mask1mask2 %x\n",ipaddr2 & mask1mask2); */
	if ((ipaddr & mask1mask2) == (ipaddr2 & mask1mask2)) {
	    if (allSet) {
		if (inlineSet) {
		    Tcl_ListObjAppendElement(interp, listPtr,
					     compareListv[i]);
		} else {
		    /* printf("\n appending %d",i+1); */
		    Tcl_ListObjAppendElement(interp, listPtr,
					     Tcl_NewIntObj(i+1));
		};
	    } else {
		if (inlineSet) {
		    Tcl_ListObjAppendElement(interp, listPtr,
					     compareListv[i]);
		    Tcl_SetObjResult(interp,listPtr);
		} else {
		    Tcl_SetIntObj (result, i+1);
		}
		return TCL_OK;
	    };
	};
    };

        if (allSet || inlineSet) {
                Tcl_SetObjResult(interp, listPtr);
    if (allSet || inlineSet) {
	Tcl_SetObjResult(interp, listPtr);
                return TCL_OK;
        } else {
                Tcl_SetIntObj (result, 0);
    } else {
	Tcl_SetIntObj (result, 0);
                return TCL_OK;
        }
        return TCL_OK;

    }
    return TCL_OK;
}


# # ## ### ##### ######## ############# #####################
}


}

# @sak notprovided ipMorec
package provide ipMorec 1.0

# jsonc.tcl --
#
#       Implementation of a JSON parser in C.
#	Binding to a yacc/bison parser by Mikhail.
#
# Copyright (c) 2013 - critcl wrapper - Andreas Kupries <[email protected]>
# Copyright (c) 2013 - C binding      - [email protected]

package require critcl
package require critcl 3.1
# @sak notprovided jsonc
package provide jsonc 1.1.1
package require Tcl 8.4

if {![critcl::compiling]} {
    error "Unable to build jsonc, no proper compiler found."
}

# # ## ### ##### ######## ############# #####################
## Administrivia

critcl::license {Mikhail Teterin} BSD
#critcl::cheaders -g
#critcl::debug memory symbols
critcl::cheaders -Ic c/*.h
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 ### ## # #
# # ## ### Import base declarations, forwards ### ## # #

namespace eval ::json {}

critcl::ccode {
    #include <json_y.h>
}

# # ## ### Main Conversion ### ## # #

namespace eval ::json {
    critcl::ccommand json2dict_critcl {dummy I objc objv} {
	struct context context = { NULL };
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;
	}
    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;
    context.text   = Tcl_GetStringFromObj(objv[1], &context.remaining);
    context.I      = I;
    context.has_error = 0;
    context.result = TCL_ERROR;

	jsonparse (&context);
	return context.result;
    }
    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 };
# 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;
    int                      max;
    int                      found;

	Tcl_Obj* result = Tcl_NewListObj (0, NULL);
    Tcl_Obj* result = Tcl_NewListObj (0, NULL);

	if ((objc < 2) || (objc > 3)) {
	    Tcl_WrongNumArgs(I, 1, objv, "jsonText ?max?");
	    return TCL_ERROR;
	}
    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;
	    }
    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;
	}
    } else {
	max = -1;
    }

	context.text   = Tcl_GetStringFromObj(objv[1], &context.remaining);
	context.I      = I;
	context.has_error = 0;
	found  = 0;
    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
	 */
    /* 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);
    while ((max < 0) || max) {
	context.result = TCL_ERROR;
	jsonparse (&context);

	    /* parse error, abort */
	    if (context.result != TCL_OK) {
		Tcl_DecrRefCount (result);
		return TCL_ERROR;
	    }
	/* 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));
	/* 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 --;
	/* 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);
	/* Jump over trailing whitespace for proper end-detection */
	jsonskip (&context);

	    /* Abort if we have consumed all input */
	    if (!context.remaining) break;
	/* Abort if we have consumed all input */
	if (!context.remaining) break;

	    /* Clear scratch pad before continuing */
	    context.obj = NULL;
	}
	/* 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;
	}
    /* 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;
    }
    /* 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 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;
	}
    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;
    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.
	 */
    /* 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;
	    }
	}
    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;
    }}
}
    /* We are good and done */
    Tcl_SetObjResult(I, Tcl_NewBooleanObj (1));
    return TCL_OK;
}}


# # ## ### ##### ######## ############# #####################
# @sak notprovided jsonc
package provide jsonc 1.1.1
return

# md4c.tcl - Copyright (C) 2003 Pat Thoyts <[email protected]>
#
# 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 <[email protected]>).

# INSTALLATION
# ------------
# This package uses critcl (http://wiki.tcl.tk/critcl). To build do:
#  critcl -libdir <your-tcl-lib-dir> -pkg md4c md4c
# This package uses critcl v3 (http://wiki.tcl.tk/critcl).
# To build run:
#    critcl3 -libdir <your-tcl-lib-dir> -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 <[email protected]>).
}
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 {
namespace eval ::md4 {}

    critcl::ccode {
        #include <string.h>
        #include "md4.h"
critcl::ccode {
    #include <string.h>
    #include "md4.h"

        /*
         * define a Tcl object type for the MD4 state 
         */
        static Tcl_ObjType md4_type;
    /*
     * 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_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_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 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
        };

    }
    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;
        }
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);
    ctx = (MD4_CTX *)obj->internalRep.otherValuePtr;
    data = Tcl_GetByteArrayFromObj(objv[1], &size);
    MD4Update(ctx, data, size);
    Tcl_SetObjResult(interp, obj);

        return TCL_OK;
    }
}
    return TCL_OK;
}

# # ## ### ##### ######## ############# #####################
# @sak notprovided md4c
package provide md4c 1.1.0
return

# Local variables:
#   mode: tcl
#   indent-tabs-mode: nil
# End:

# md5c.tcl - 
#
# Wrapper for RSA's Message Digest in C
#
# Written by Jean-Claude Wippler <jcw@equi4.com>
# Written by Jean-Claude Wippler <jc@wippler.nl>
#
# $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;              # 
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.
critcl::cheaders md5.h ; # The RSA header file
critcl::csources md5.c ; # The RSA MD5 implementation.

namespace eval ::md5 {
namespace eval ::md5 {}

    critcl::ccode {
        #include <string.h>
        #include "md5.h"
        #include <assert.h>
critcl::ccode {
    #include <string.h>
    #include "md5.h"
    #include <assert.h>

        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;
    }
}
    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"
      }
    }
    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]"
    }
  }
	foreach len {10 50 100 500 1000 5000 10000} {
	    set blanks [format %$len.0s ""]
	    puts "input length $len: [time {md5c $blanks} 1000]"
	}
    }

  md5c_try
    md5c_try
}

# # ## ### ##### ######## ############# #####################
# @sak notprovided md5c
package provide md5c 0.12
return

# Local variables:
#   mode: tcl
#   indent-tabs-mode: nil
# End:

# */
#
# -------------------------------------------------------------------------
# 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."
}
package require critcl
# @sak notprovided md5cryptc
package provide md5cryptc 1.0

# # ## ### ##### ######## ############# #####################
## 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

critcl::tcl 8.4

critcl::cheaders ../md5/md5.h
#critcl::csources ../md5/md5.c

namespace eval ::md5crypt {
    critcl::ccode {
#include <string.h>
#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);
            }
namespace eval ::md5crypt {}

critcl::ccode {
    #include <string.h>
    #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;
    }
	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_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;
    }
}
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

    # TODO :: Container may make exporter manager available through
    # TODO :: public method.

    # 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]
	set ctrailer [namespace tail      $class]
    }

    lappend map	@@RUNTIME@@ [GetRuntime]
    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 \
			    [string map $map {
	## -*- tcl -*-
	##
	## Critcl-based C/PARAM implementation of the parsing
	## expression grammar
	##
	##	@name@
	##
	## Generated from file	@file@
	##            for user  @user@
	##
	# # ## ### ##### ######## ############# #####################
	## 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.
	namespace eval ::@@CHEAD@@ {}

	# # ## ### ##### ######## ############# #####################
	## Supporting code for the main command.

	    catch {
		#critcl::cflags -g
		#critcl::debug memory symbols
	    }

	    # # ## ### ###### ######## #############
	    ## RDE runtime, inlined, and made static.
	# # ## ### ###### ######## #############
	## 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.
	# 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 -*- */
	critcl::ccode {
	    /* -*- c -*- */

		#include <string.h>
		#define SCOPE static
	    #include <string.h>
	    #define SCOPE static

@@RUNTIME@@
	    }
	}

	    # # ## ### ###### ######## #############
	    ## BEGIN of GENERATED CODE. DO NOT EDIT.
	# # ## ### ###### ######## #############
	## BEGIN of GENERATED CODE. DO NOT EDIT.

	    critcl::ccode {
		/* -*- c -*- */
	critcl::ccode {
	    /* -*- c -*- */

@code@
	    }
	}

	    ## END of GENERATED CODE. DO NOT EDIT.
	    # # ## ### ###### ######## #############
	## END of GENERATED CODE. DO NOT EDIT.
	# # ## ### ###### ######## #############

	    # # ## ### ###### ######## #############
	    ## Global PARSER management, per interp
	# # ## ### ###### ######## #############
	## Global PARSER management, per interp

	    critcl::ccode {
		/* -*- c -*- */
	critcl::ccode {
	    /* -*- c -*- */

		typedef struct PARSERg {
		    long int counter;
		    char     buf [50];
		} PARSERg;
	    typedef struct PARSERg {
		long int counter;
		char     buf [50];
	    } PARSERg;

		static void
		PARSERgRelease (ClientData cd, Tcl_Interp* interp)
		{
		    ckfree((char*) cd);
		}
	    static void
	    PARSERgRelease (ClientData cd, Tcl_Interp* interp)
	    {
		ckfree((char*) cd);
	    }

		static const char*
		PARSERnewName (Tcl_Interp* interp)
		{
#define KEY "tcllib/parser/@@PKG@@/critcl"
	    static const char*
	    PARSERnewName (Tcl_Interp* interp)
	    {
		#define KEY "tcllib/parser/@@PKG@@/critcl"

		    Tcl_InterpDeleteProc* proc = PARSERgRelease;
		    PARSERg*                  parserg;
		Tcl_InterpDeleteProc* proc = PARSERgRelease;
		PARSERg*                  parserg;

		    parserg = Tcl_GetAssocData (interp, KEY, &proc);
		    if (parserg  == NULL) {
			parserg = (PARSERg*) ckalloc (sizeof (PARSERg));
			parserg->counter = 0;
		parserg = Tcl_GetAssocData (interp, KEY, &proc);
		if (parserg  == NULL) {
		    parserg = (PARSERg*) ckalloc (sizeof (PARSERg));
		    parserg->counter = 0;

			Tcl_SetAssocData (interp, KEY, proc,
					  (ClientData) parserg);
		    }
		    Tcl_SetAssocData (interp, KEY, proc,
				      (ClientData) parserg);
		}

		    parserg->counter ++;
		    sprintf (parserg->buf, "@@CTAIL@@%ld", parserg->counter);
		    return parserg->buf;
#undef  KEY
		}
		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);
		}
	    }
	    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.
	# # ## ### ##### ######## #############
	## Functions implementing the object methods, and helper.

	    critcl::ccode {
		static int  COMPLETE (RDE_PARAM p, Tcl_Interp* interp);
	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;
	    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;
		    }
		if (objc != 3) {
		    Tcl_WrongNumArgs (interp, 2, objv, "chan");
		    return TCL_ERROR;
		}

		    chan = Tcl_GetChannel(interp,
					  Tcl_GetString (objv[2]),
					  &mode);
		chan = Tcl_GetChannel(interp,
				      Tcl_GetString (objv[2]),
				      &mode);

		    if (!chan) {
			return TCL_ERROR;
		    }
		if (!chan) {
		    return TCL_ERROR;
		}

		    rde_param_reset (p, chan);
		    MAIN (p) ; /* Entrypoint for the generated code. */
		    return COMPLETE (p, interp);
		}
		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;
	    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;
		    }
		if (objc != 3) {
		    Tcl_WrongNumArgs (interp, 2, objv, "text");
		    return TCL_ERROR;
		}

		    buf = Tcl_GetStringFromObj (objv[2], &len);
		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);
		}
		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;
	    /* 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);
		    rde_param_query_ast (p, &ac, &av);

			if (ac > 1) {
			    Tcl_Obj** lv = NALLOC (3+ac, Tcl_Obj*);
		    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));
			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);
			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]);
			}
		    } 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)) */
		    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);
		    /* 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;
		    }
		}
	    }
		    Tcl_SetErrorCode (interp, "PT", "RDE", "SYNTAX", NULL);
		    Tcl_SetObjResult (interp, res);
		    return TCL_ERROR;
		}
	    }
	}

	    # # ## ### ##### ######## #############
	    ## Object command, method dispatch.
	# # ## ### ##### ######## #############
	## 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;
	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
		    };
		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;
		    }
		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
		     */
		/* 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;
			    }
		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;
		    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");
		    }
		    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;
		}
	    }
		return res;
	    }
	}

	    # # ## ### ##### ######## #############
	    # Class command, i.e. object construction.
	# # ## ### ##### ######## #############
	# Class command, i.e. object construction.

	    critcl::ccommand @@CTAIL@@_critcl {dummy interp objc objv} {
		/*
		 * Syntax: No arguments beyond the name
		 */
	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;
	    RDE_PARAM   parser;
	    CONST char* name;
	    Tcl_Obj*    fqn;
	    Tcl_CmdInfo ci;
	    Tcl_Command c;

#define USAGE "?name?"
	    #define USAGE "?name?"

		if ((objc != 2) && (objc != 1)) {
		    Tcl_WrongNumArgs (interp, 1, objv, USAGE);
		    return TCL_ERROR;
		}
	    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 (objc < 2) {
		name = PARSERnewName (interp);
	    } else {
		name = Tcl_GetString (objv [1]);
	    }

		if (!Tcl_StringMatch (name, "::*")) {
		    /* Relative name. Prefix with current namespace */
	    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);
		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_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;
	    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);
		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;
		}
		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;
	    }
	    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
}

#
## RD stands for Recursive Descent.

# # ## ### ##### ######## ############# #####################
## 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 {
namespace eval ::pt {}

    # # ## ### ##### ######## ############# #####################
    ## Supporting code for the main command.
# # ## ### ##### ######## ############# #####################
## 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::cheaders rde_critcl/*.h
critcl::csources rde_critcl/*.c

    critcl::ccode {
	/* -*- c -*- */
critcl::ccode {
    /* -*- c -*- */

	#include <util.h>  /* Allocation macros */
	#include <p.h>     /* Public state API */
	#include <ms.h>    /* Instance command */
    #include <util.h>  /* Allocation macros */
    #include <p.h>     /* Public state API */
    #include <ms.h>    /* Instance command */

	/* .................................................. */
	/* Global PARAM management, per interp
	*/
    /* .................................................. */
    /* Global PARAM management, per interp
    */

	typedef struct PARAMg {
	    long int counter;
	    char     buf [50];
	} PARAMg;
    typedef struct PARAMg {
	long int counter;
	char     buf [50];
    } PARAMg;

	static void
	PARAMgRelease (ClientData cd, Tcl_Interp* interp)
	{
	    ckfree((char*) cd);
	}
    static void
    PARAMgRelease (ClientData cd, Tcl_Interp* interp)
    {
	ckfree((char*) cd);
    }

	static CONST char*
	PARAMnewName (Tcl_Interp* interp)
	{
#define KEY "tcllib/pt::rde/critcl"
    static CONST char*
    PARAMnewName (Tcl_Interp* interp)
    {
	#define KEY "tcllib/pt::rde/critcl"

	    Tcl_InterpDeleteProc* proc = PARAMgRelease;
	    PARAMg*                  paramg;
	Tcl_InterpDeleteProc* proc = PARAMgRelease;
	PARAMg*                  paramg;

	    paramg = Tcl_GetAssocData (interp, KEY, &proc);
	    if (paramg  == NULL) {
		paramg = (PARAMg*) ckalloc (sizeof (PARAMg));
		paramg->counter = 0;
	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;
	    Tcl_SetAssocData (interp, KEY, proc,
			      (ClientData) paramg);
	}
	
	paramg->counter ++;
	sprintf (paramg->buf, "rde%ld", paramg->counter);
	return paramg->buf;

#undef  KEY
	}
	#undef  KEY
    }

	static void
	PARAMdeleteCmd (ClientData clientData)
	{
	    /* Release the whole PARAM. */
	    param_delete ((RDE_STATE) clientData);
	}
    }
    static void
    PARAMdeleteCmd (ClientData clientData)
    {
	/* Release the whole PARAM. */
	param_delete ((RDE_STATE) clientData);
    }
}

    # # ## ### ##### ######## ############# #####################
    ## Main command, PARAM creation.
# # ## ### ##### ######## ############# #####################
## Main command, PARAM creation.

    critcl::ccommand rde_critcl {dummy interp objc objv} {
      /* Syntax: No arguments beyond the name
       */
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;
    CONST char* name;
    RDE_STATE   param;
    Tcl_Obj*    fqn;
    Tcl_CmdInfo ci;
    Tcl_Command c;

#define USAGE "?name?"
    #define USAGE "?name?"

      if ((objc != 2) && (objc != 1)) {
    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);
        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);
    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;
    Tcl_SetObjResult (interp, fqn);
    Tcl_DecrRefCount (fqn);
    return TCL_OK;
    }
}

# # ## ### ##### ######## ############# #####################
## Ready

package provide pt::rde::critcl 1.0.3
return

# rc4c.tcl - Copyright (C) 2004 Pat Thoyts <[email protected]>
#
# This provides a critcl C implementation of RC4 
#
# INSTALLATION
# ------------
# This package uses critcl (http://wiki.tcl.tk/critcl). To build do:
#  critcl -libdir <your-tcl-lib-dir> -pkg rc4c rc4c
# This package uses critcl3 (http://wiki.tcl.tk/critcl).
# To build run:
#  critcl3 -libdir <your-tcl-lib-dir> -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 {
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 <string.h>
critcl::ccode {
    #include <string.h>

        typedef struct RC4_CTX {
            unsigned char x;
            unsigned char y;
            unsigned char s[256];
        } RC4_CTX;
    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
    /* #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 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_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_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 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 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;
        }
    }
    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 rc4c_init {dummy interp objc objv} {
        RC4_CTX *ctx;
        Tcl_Obj *obj;
        const unsigned char *k;
        int n = 0, i = 0, j = 0, keylen;
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);
    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;
    }
    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 rc4c {dummy interp objc objv} {
        Tcl_Obj *resObj = NULL;
        RC4_CTX *ctx = NULL;
        unsigned char *data, *res, x, y;
        int size, n, i;
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 (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;
        }
    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);
    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;
    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;
    }
}
    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

# sha1c.tcl - Copyright (C) 2005 Pat Thoyts <[email protected]>
#
# 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

critcl::cheaders sha1.h;                # NetBSD SHA1 implementation
critcl::csources sha1.c;                # NetBSD SHA1 implementation
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

if {$tcl_platform(byteOrder) eq "littleEndian"} {
    set byteOrder 1234
} else {
    set byteOrder 4321
}
critcl::cflags -DTCL_BYTE_ORDER=$byteOrder

namespace eval ::sha1 {
namespace eval ::sha1 {}

    critcl::ccode {
        #include "sha1.h"
        #include <stdlib.h>
        #include <string.h>
        #include <assert.h>
        
        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);
critcl::ccode {
    #include "sha1.h"
    #include <stdlib.h>
    #include <string.h>
    #include <assert.h>
    
    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);
    mp = (SHA1_CTX*) obj->internalRep.otherValuePtr;
    data = Tcl_GetByteArrayFromObj(objv[1], &size);
    SHA1Update(mp, data, size);

        Tcl_SetObjResult(ip, obj);
        return TCL_OK;
    }
}
    Tcl_SetObjResult(ip, obj);
    return TCL_OK;
}

# # ## ### ##### ######## ############# #####################
# @sak notprovided sha1c
package provide sha1c 2.0.3
return

# sha256c.tcl
# - Copyright (C) 2005 Pat Thoyts <[email protected]>
# - Copyright (C) 2006 Andreas Kupries <[email protected]>
#   (Rewriting the sha1c wrapper to 256).
#
# 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
			       
critcl::cheaders sha256.h;     # FreeBSD SHA256 implementation
critcl::csources sha256.c;     # FreeBSD SHA256 implementation
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

if {$tcl_platform(byteOrder) eq "littleEndian"} {
    set byteOrder 1234
} else {
    set byteOrder 4321
}
critcl::cflags -DTCL_BYTE_ORDER=$byteOrder

namespace eval ::sha2 {
namespace eval ::sha2 {}
    # Supporting code for the main command.
    catch {
        #critcl::debug memory symbols
    }

    critcl::ccode {
        #include "sha256.h"
        #include <stdlib.h>
        #include <string.h>
        #include <assert.h>
        
        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::ccode {
    #include "sha256.h"
    #include <stdlib.h>
    #include <string.h>
    #include <assert.h>
    
    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 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_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;
	}
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;
    }
}
    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

# 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 */
    }
}