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 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 \
    base32 {rfc 3548}

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

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

critcl::tcl 8.4

namespace eval ::base32 {}

# Main commands, encoder & decoder

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

    unsigned char* buf;
    int           nbuf;

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

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

    #define USAGEE "bitstring"

    if (objc != 2) {
        Tcl_WrongNumArgs (interp, 1, objv, USAGEE);
        return TCL_ERROR;
    }

    buf  = Tcl_GetByteArrayFromObj (objv[1], &nbuf);
    nout = ((nbuf+4)/5)*8;
    out  = (unsigned char*) Tcl_Alloc (nout*sizeof(char));

    for (at = out; nbuf >= 5; nbuf -= 5, buf += 5) {
	*(at++) = map [         (buf[0]>>3)                ];
	*(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
	*(at++) = map [ 0x1f &  (buf[1]>>1)                ];
	*(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
	*(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ];
	*(at++) = map [ 0x1f &  (buf[3]>>2)                ];
	*(at++) = map [ 0x1f & ((buf[3]<<3) | (buf[4]>>5)) ];
	*(at++) = map [ 0x1f &  (buf[4])                   ];
    }
    if (nbuf > 0) {
	/* Process partials at end. */
	switch (nbuf) {
	    case 1:
	        /* |01234567|		 2, padding 6
	         *  xxxxx
	         *       xxx 00
	         */
	    	    
	        *(at++) = map [        (buf[0]>>3) ];
	        *(at++) = map [ 0x1f & (buf[0]<<2) ];
	        *(at++) = '=';
	        *(at++) = '=';
	        *(at++) = '=';
	        *(at++) = '=';
	        *(at++) = '=';
	        *(at++) = '=';
	        break;
	    case 2: /* x3/=4 */
	        /* |01234567|01234567|	 4, padding 4
	         *  xxxxx
	         *       xxx xx
	         *             xxxxx
	         *                  x 0000
	         */
		    
	        *(at++) = map [         (buf[0]>>3)                ];
	        *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
	        *(at++) = map [ 0x1f &  (buf[1]>>1)                ];
	        *(at++) = map [ 0x1f &  (buf[1]<<4)                ];
	        *(at++) = '=';
	        *(at++) = '=';
	        *(at++) = '=';
	        *(at++) = '=';
	        break;
	    case 3:
	        /* |01234567|01234567|01234567|	 5, padding 3
	         *  xxxxx
	         *       xxx xx
	         *             xxxxx
	         *                  x xxxx
	         *                        xxxx 0
	         */
		    
	        *(at++) = map [         (buf[0]>>3)                ];
	        *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
	        *(at++) = map [ 0x1f &  (buf[1]>>1)                ];
	        *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
	        *(at++) = map [ 0x1f &  (buf[2]<<1)                ];
	        *(at++) = '=';
	        *(at++) = '=';
	        *(at++) = '=';
	        break;
	    case 4:
	        /* |01234567|01234567|01234567|012334567|	 7, padding 1
	         *  xxxxx
	         *       xxx xx
	         *             xxxxx
	         *                  x xxxx
	         *                        xxxx
	         *                             xxxxx
	         *                                  xxxx 0
	         */
		    
	        *(at++) = map [         (buf[0]>>3)                ];
	        *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
	        *(at++) = map [ 0x1f &  (buf[1]>>1)                ];
	        *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
	        *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ];
	        *(at++) = map [ 0x1f &  (buf[3]>>2)                ];
	        *(at++) = map [ 0x1f &  (buf[3]<<3)                ];
	        *(at++) = '=';
	        break;
	}
    }

    Tcl_SetObjResult (interp, Tcl_NewStringObj ((char*)out, nout));
    Tcl_Free ((char*) out);
    return TCL_OK;
}


critcl::ccommand ::base32::critcl_decode {dummy interp objc objv} {
    /* Syntax -*- c -*-
     * critcl_decode estring
     */

    unsigned char* buf;
    int           nbuf;

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

    int i, j, a, pad, nx;

    /*
     * An array for translating single base-32 characters into a value.
     * Disallowed input characters have a value of 64.  Upper and lower
     * case is the same. Only 128 chars, as everything above char(127)
     * is 64.
     */
    static const char map [] = {
	/* \00 */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
	/* DLE */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
	/* SPC */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
	/* '0' */ 64, 64, 26, 27, 28, 29, 30, 31,  64, 64, 64, 64, 64, 64, 64, 64, 
	/* '@' */ 64,  0,  1,  2,  3,  4,  5,  6,   7,  8,  9, 10, 11, 12, 13, 14,
	/* 'P' */ 15, 16, 17, 18, 19, 20, 21, 22,  23, 24, 25, 64, 64, 64, 64, 64,
	/* '`' */ 64,  0,  1,  2,  3,  4,  5,  6,   7,  8,  9, 10, 11, 12, 13, 14,
	/* 'p' */ 15, 16, 17, 18, 19, 20, 21, 22,  23, 24, 25, 64, 64, 64, 64, 64
    };

    #define USAGED "estring"

    if (objc != 2) {
        Tcl_WrongNumArgs (interp, 1, objv, USAGED);
        return TCL_ERROR;
    }

    buf = (unsigned char*) Tcl_GetStringFromObj (objv[1], &nbuf);

    if (nbuf % 8) {
	Tcl_SetObjResult (interp, Tcl_NewStringObj ("Length is not a multiple of 8", -1));
        return TCL_ERROR;
    }

    nout = (nbuf/8)*5 *TCL_UTF_MAX;
    out  = (unsigned char*) Tcl_Alloc (nout*sizeof(char));

    #define HIGH(x) (((x) & 0x80) != 0)
    #define BADC(x) ((x) == 64)
    #define BADCHAR(a,j) (HIGH ((a)) || BADC (x [(j)] = map [(a)]))

    for (pad = 0, i=0, at = out; i < nbuf; i += 8, buf += 8){
	for (j=0; j < 8; j++){
	   a = buf [j];

	   if (a == '=') {
	       x[j] = 0;
	       pad++;
	       continue;
	   } else if (pad) {
	       char     msg [120];
	       sprintf (msg,
			"Invalid character at index %d: \"=\" (padding found in the middle of the input)",
			j-1);
	       Tcl_Free ((char*) out);
	       Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1));
	       return TCL_ERROR;
	   }

	   if (BADCHAR (a,j)) {
	       char     msg [100];
	       sprintf (msg,"Invalid character at index %d: \"%c\"",j,a);
	       Tcl_Free ((char*) out);
	       Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1));
	       return TCL_ERROR;
	   }
	}

	*(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 == 1) {
	    at -= 1;
	} else if (pad == 3) {
	    at -= 2;
	} else if (pad == 4) {
	    at -= 3;
	} else if (pad == 6) {
	    at -= 4;
	} else {
	    char     msg [100];
	    sprintf (msg,"Invalid padding of length %d",pad);
	    Tcl_Free ((char*) out);
	    Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1));
	    return TCL_ERROR;
	}
    }

    Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out));
    Tcl_Free ((char*) out);
    return TCL_OK;

}

# ### ### ### ######### ######### #########
## 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 3.1
package require Tcl 8.4

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

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

critcl::license {Andreas Kupries} {CC-0 public domain}
critcl::summary {
    C implementation of the extended hex Base32 de- and encoder.
}
critcl::description {
    This package provides a C implementation of an extended hex
    base32 de- and encoder, as per RFC 3548.
}
critcl::subject \
    base32 {rfc 3548}

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

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

critcl::tcl 8.4

namespace eval ::base32::hex {}

# Main commands, encoder & decoder

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

    unsigned char* buf;
    int           nbuf;

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

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

#define USAGEE "bitstring"

    if (objc != 2) {
	Tcl_WrongNumArgs (interp, 1, objv, USAGEE);
	return TCL_ERROR;
    }

    buf  = Tcl_GetByteArrayFromObj (objv[1], &nbuf);
    nout = ((nbuf+4)/5)*8;
    out  = (unsigned char*) Tcl_Alloc (nout*sizeof(char));

    for (at = out; nbuf >= 5; nbuf -= 5, buf += 5) {
	*(at++) = map [         (buf[0]>>3)                ];
	*(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
	*(at++) = map [ 0x1f &  (buf[1]>>1)                ];
	*(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
	*(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ];
	*(at++) = map [ 0x1f &  (buf[3]>>2)                ];
	*(at++) = map [ 0x1f & ((buf[3]<<3) | (buf[4]>>5)) ];
	*(at++) = map [ 0x1f &  (buf[4])                   ];
    }
    if (nbuf > 0) {
	/* Process partials at end. */
	switch (nbuf) {
	case 1:
	  /* |01234567|		 2, padding 6
	   *  xxxxx
	   *       xxx 00
	   */

	  *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
	  *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ];
	  *(at++) = map [ 0x1f &  (buf[3]>>2)                ];
	  *(at++) = map [ 0x1f &  (buf[3]<<3)                ];
	  *(at++) = '=';
	  break;
	}
    }

    Tcl_SetObjResult (interp, Tcl_NewStringObj ((char*)out, nout));
    Tcl_Free ((char*) out);
    return TCL_OK;
}


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

    unsigned char* buf;
    int           nbuf;

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

    int i, j, a, pad, nx;

    /*
     * An array for translating single base-32 characters into a value.
     * Disallowed input characters have a value of 64.  Upper and lower
     * case is the same. Only 128 chars, as everything above char(127)
     * is 64.
     */
    static const char map [] = {
	/* \00 */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
	/* DLE */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
	/* SPC */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
	/* '0' */  0,  1,  2,  3,  4,  5,  6,  7,   8,  9, 64, 64, 64, 64, 64, 64, 
	/* '@' */ 64, 10, 11, 12, 13, 14, 15, 16,  17, 18, 19, 20, 21, 22, 23, 24,
	/* 'P' */ 25, 26, 27, 28, 29, 30, 31, 64,  64, 64, 64, 64, 64, 64, 64, 64,
	/* '`' */ 64, 10, 11, 12, 13, 14, 15, 16,  17, 18, 19, 20, 21, 22, 23, 24,
	/* 'p' */ 25, 26, 27, 28, 29, 30, 31, 64,  64, 64, 64, 64, 64, 64, 64, 64
    };

#define USAGED "estring"

    if (objc != 2) {
        Tcl_WrongNumArgs (interp, 1, objv, USAGED);
        return TCL_ERROR;
    }

    buf = (unsigned char*) Tcl_GetStringFromObj (objv[1], &nbuf);

    if (nbuf % 8) {
	Tcl_SetObjResult (interp, Tcl_NewStringObj ("Length is not a multiple of 8", -1));
        return TCL_ERROR;
    }

    nout = (nbuf/8)*5 *TCL_UTF_MAX;
    out  = (unsigned char*) Tcl_Alloc (nout*sizeof(char));

#define HIGH(x) (((x) & 0x80) != 0)
#define BADC(x) ((x) == 64)
#define BADCHAR(a,j) (HIGH ((a)) || BADC (x [(j)] = map [(a)]))

    for (pad = 0, i=0, at = out; i < nbuf; i += 8, buf += 8){
	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 == 1) {
	    at -= 1;
	} else if (pad == 3) {
	    at -= 2;
	} else if (pad == 4) {
	    at -= 3;
	} else if (pad == 6) {
	    at -= 4;
	} else {
	    char     msg [100];
	    sprintf (msg,"Invalid padding of length %d",pad);
	    Tcl_Free ((char*) out);
	    Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1));
	    return TCL_ERROR;
	}
    }

    Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out));
    Tcl_Free ((char*) out);
    return TCL_OK;

}

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

# 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

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

# todo :: critcl :: Convert to cproc (single argument, fixed)
critcl::ccommand ::ip::prefixToNativec {clientData interp objc objv} { 

    int elemLen, maskLen, ipLen, mask;
    int rval,convertListc,i;
    Tcl_Obj **convertListv;
    Tcl_Obj *listPtr,*returnPtr, *addrList;
    char *stringIP, *slashPos, *stringMask;
    char v4HEX[11];
	
    uint32_t inaddr;
    listPtr = NULL;

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

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "<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 (convertListc==1) {
	Tcl_SetObjResult(interp,listPtr);
    } else {
	Tcl_SetObjResult(interp,returnPtr);
    }
	
    return TCL_OK;
}

critcl::ccommand ::ip::isOverlapNativec {clientData interp objc objv} {
    int i; 
    unsigned int ipaddr,ipMask, mask1mask2;
    unsigned int ipaddr2,ipMask2;
    int compareListc,comparePrefixMaskc;
    int allSet,inlineSet,index;
    Tcl_Obj **compareListv,**comparePrefixMaskv, *listPtr;
    Tcl_Obj *result;

    static CONST char *options[] = {
	"-all","-inline","-ipv4",
	NULL
    };
    enum options {
	OVERLAP_ALL, OVERLAP_INLINE, OVERLAP_IPV4
    };

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

    /* printf ("\n objc = %d",objc); */
    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "?options? <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);

    /* 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); */

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

    if (allSet || inlineSet) {
	Tcl_SetObjResult(interp, listPtr);

    } else {
	Tcl_SetIntObj (result, 0);

    }
    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 3.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::summary {
    C implementation of a JSON parser.
}
critcl::description {
    This package provides a C implementation of a KJSON parser.
}
critcl::subject json
critcl::meta location http://core.tcl.tk/tcllib

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

critcl::tcl 8.4

# # ## ### Import base declarations, forwards ### ## # #
critcl::cheaders c/*.h
critcl::csources c/*.c

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

namespace eval ::json {}

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




critcl::ccommand ::json::json2dict_critcl {dummy I objc objv} {
    struct context context = { NULL };

    if (objc != 2) {
	Tcl_WrongNumArgs(I, 1, objv, "json");
	return TCL_ERROR;
    }

    context.text   = Tcl_GetStringFromObj(objv[1], &context.remaining);
    context.I      = I;
    context.has_error = 0;
    context.result = TCL_ERROR;

    jsonparse (&context);
    return context.result;
}

# Issue with critcl 2 used here. Cannot use '-', incomplete distinction of C and Tcl names.
# The json.tcl file making use of this code has a wrapper fixing the issue.
critcl::ccommand ::json::many_json2dict_critcl {dummy I objc objv} {
    struct context context = { NULL };

    int                      max;
    int                      found;

    Tcl_Obj* result = Tcl_NewListObj (0, NULL);

    if ((objc < 2) || (objc > 3)) {
	Tcl_WrongNumArgs(I, 1, objv, "jsonText ?max?");
	return TCL_ERROR;
    }

    if (objc == 3) {
	if (Tcl_GetIntFromObj(I, objv[2], &max) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (max <= 0) {
	    Tcl_AppendResult (I, "Bad limit ",
			      Tcl_GetString (objv[2]),
			      " of json entities to extract.",
			      NULL);
	    Tcl_SetErrorCode (I, "JSON", "BAD-LIMIT", NULL);
	    return TCL_ERROR;
	}

    } else {
	max = -1;
    }

    context.text   = Tcl_GetStringFromObj(objv[1], &context.remaining);
    context.I      = I;
    context.has_error = 0;
    found  = 0;

    /* Iterate over the input until
    * - we have gotten all requested values.
    * - we have run out of input
    * - we have run into an error
    */

    while ((max < 0) || max) {
	context.result = TCL_ERROR;
	jsonparse (&context);

	/* parse error, abort */
	if (context.result != TCL_OK) {
	    Tcl_DecrRefCount (result);
	    return TCL_ERROR;
	}

	/* Proper value extracted, extend result */
	found ++;
	Tcl_ListObjAppendElement(I, result,
				 Tcl_GetObjResult (I));

	/* Count down on the number of still missing
	* values, if not asking for all (-1)
	*/
	if (max > 0) max --;

	/* Jump over trailing whitespace for proper end-detection */
	jsonskip (&context);

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

	/* Clear scratch pad before continuing */
	context.obj = NULL;
    }

    /* While all parses were ok we reached end of
    * input without getting all requested values,
    * this is an error
    */
    if (max > 0) {
	char buf [30];
	sprintf (buf, "%d", found);
	Tcl_ResetResult (I);
	Tcl_AppendResult (I, "Bad limit ",
			  Tcl_GetString (objv[2]),
			  " of json entities to extract, found only ",
			  buf,
			  ".",
			  NULL);
	Tcl_SetErrorCode (I, "JSON", "BAD-LIMIT", "TOO", "LARGE", NULL);
	Tcl_DecrRefCount (result);
	return TCL_ERROR;
    }

    /* We are good and done */
    Tcl_SetObjResult(I, result);
    return TCL_OK;
}

if 0 {critcl::ccommand ::json::validate_critcl {dummy I objc objv} {
    struct context context = { NULL };

    if (objc != 2) {
	Tcl_WrongNumArgs(I, 1, objv, "jsonText");
	return TCL_ERROR;
    }

    context.text   = Tcl_GetStringFromObj(objv[1], &context.remaining);
    context.I      = I;
    context.result = TCL_ERROR;

    /* Iterate over the input until we have run
    * out of text, or encountered an error. We
    * use only the lexer here, and told it to not
    * create superfluous token values.
    */

    while (context.remaining) {
	if (jsonlex (&context) == -1) {
	    Tcl_SetObjResult(I, Tcl_NewBooleanObj (0));
	    return TCL_OK;
	}
    }

    /* We are good and done */
    Tcl_SetObjResult(I, Tcl_NewBooleanObj (1));
    return TCL_OK;
}}


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

# 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 (Jean-Claude Wippler <[email protected]>).

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

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

    /*
     * define a Tcl object type for the MD4 state 
     */
    static Tcl_ObjType md4_type;
    
    static void md4_free_rep(Tcl_Obj *obj)
    {
        MD4_CTX *ctx = (MD4_CTX *)obj->internalRep.otherValuePtr;
        Tcl_Free((char *)ctx);
    }

    static void md4_dup_rep(Tcl_Obj *obj, Tcl_Obj *dup)
    {
        MD4_CTX *ctx = (MD4_CTX *)obj->internalRep.otherValuePtr;
        dup->internalRep.otherValuePtr = (MD4_CTX *)Tcl_Alloc(sizeof(MD4_CTX));
        memcpy(dup->internalRep.otherValuePtr, ctx, sizeof(MD4_CTX));
        dup->typePtr = &md4_type;
    }

    static void md4_string_rep(Tcl_Obj* obj)
    {
        unsigned char buf[16];
        Tcl_Obj* temp;
        char* str;
        MD4_CTX *dup = (MD4_CTX *)obj->internalRep.otherValuePtr;
        
        MD4Final(buf, dup);
        
        /* convert via a byte array to properly handle null bytes */
        temp = Tcl_NewByteArrayObj(buf, sizeof buf);
        Tcl_IncrRefCount(temp);
        
        str = Tcl_GetStringFromObj(temp, &obj->length);
        obj->bytes = Tcl_Alloc(obj->length + 1);
        memcpy(obj->bytes, str, obj->length + 1);
        
        Tcl_DecrRefCount(temp);
    }
    
    static int md4_from_any(Tcl_Interp* interp, Tcl_Obj* obj)
    {
        /* assert(0); */
        return TCL_ERROR;
    }
    
    static Tcl_ObjType md4_type = {
        "md4c", md4_free_rep, md4_dup_rep, md4_string_rep, md4_from_any
    };
}


critcl::ccommand ::md4::md4c {dummy interp objc objv} {
    MD4_CTX *ctx;
    unsigned char *data;
    int size;
    Tcl_Obj *obj;
    
    if (objc < 2 || objc > 3) {
        Tcl_WrongNumArgs(interp, 1, objv, "data ?context?");
        return TCL_ERROR;
    }
    
    if (objc == 3) {
        if (objv[2]->typePtr != &md4_type 
            && md4_from_any(interp, objv[2]) != TCL_OK) {
            return TCL_ERROR;
        }
        obj = objv[2];
        if (Tcl_IsShared(obj)) {
            obj = Tcl_DuplicateObj(obj);
        }
    } else {
        ctx = (MD4_CTX *)Tcl_Alloc(sizeof(MD4_CTX));
        MD4Init(ctx);
        obj = Tcl_NewObj();
        Tcl_InvalidateStringRep(obj);
        obj->internalRep.otherValuePtr = ctx;
        obj->typePtr = &md4_type;
    }
    
    ctx = (MD4_CTX *)obj->internalRep.otherValuePtr;
    data = Tcl_GetByteArrayFromObj(objv[1], &size);
    MD4Update(ctx, data, size);
    Tcl_SetObjResult(interp, obj);

    return TCL_OK;
}

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

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

# md5c.tcl - 
#
# Wrapper for RSA's Message Digest in C
#
# 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 3.1

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

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

critcl::license {Jean-Claude Wippler} BSD
critcl::summary {
    C implementation of the MD5 message digest
}
critcl::description {
    This package provides a C implementation of MD5 using the
    RSA sample code and wrapping this up in a Tcl package.
}
critcl::subject \
    hashing md5 message-digest security \
    {rfc 1320} {rfc 1321} {rfc 2104}

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

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

## todo :: critcl :: possibly define an argument conversion for the
##                   context. handling of default is an issue.

critcl::tcl 8.4

critcl::cheaders md5.h ; # The RSA header file
critcl::csources md5.c ; # The RSA MD5 implementation.

namespace eval ::md5 {}

critcl::ccode {
    #include <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 ::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 md5_try {} {
	foreach {msg expected} {
	    ""
	    "d41d8cd98f00b204e9800998ecf8427e"
	    "a"
	    "0cc175b9c0f1b6a831c399e269772661"
	    "abc"
	    "900150983cd24fb0d6963f7d28e17f72"
	    "message digest"
	    "f96b697d7cb7938d525a2f31aaf161d0"
	    "abcdefghijklmnopqrstuvwxyz"
	    "c3fcd3d76192e4007dfb496cca67e13b"
	    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
	    "d174ab98d277d9f5a5611c2c9f419d9f"
	    "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
	    "57edf4a22be3c955ac49da2e2107b67a"
	} {
	    puts "testing: ::md5::md5c \"$msg\""
	    binary scan [::md5::md5c $msg] H* computed
	    puts "computed: $computed"
	    if {0 != [string compare $computed $expected]} {
		puts "expected: $expected"
		puts "FAILED"
	    }
	}

	foreach len {10 50 100 500 1000 5000 10000} {
	    set blanks [format %$len.0s ""]
	    puts "input length $len: [time {md5c $blanks} 1000]"
	}
    }

    md5c_try
}

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

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

# */
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------

package require critcl 3.1

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

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

critcl::license {Pat Thoyts} BSD
critcl::summary {
    C implementation of the MD5crypt MAC
}
critcl::description {
    This package provides a C implementation of MD5crypt based
    on the OpenBSD sources, which is in turn derived from the
    original implementation by Poul-Henning Kamp.
}
critcl::subject \
    hashing md5 md5crypt message-digest security \
    {rfc 1320} {rfc 1321} {rfc 2104}

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

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

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);
	}

	p = passwd + strlen(passwd);
	
	l = (final[ 0]<<16) | (final[ 6]<<8) | final[12]; to64(p,l,4); p += 4;
	l = (final[ 1]<<16) | (final[ 7]<<8) | final[13]; to64(p,l,4); p += 4;
	l = (final[ 2]<<16) | (final[ 8]<<8) | final[14]; to64(p,l,4); p += 4;
	l = (final[ 3]<<16) | (final[ 9]<<8) | final[15]; to64(p,l,4); p += 4;
	l = (final[ 4]<<16) | (final[10]<<8) | final[ 5]; to64(p,l,4); p += 4;
	l =		       final[11]		; to64(p,l,2); p += 2;
	*p = '\0';
	
	/* Don't leave anything around in vm they could use. */
	memset(final,0,sizeof final);
	
	return passwd;
    }            
}

critcl::cproc ::md5crypt::to64_c {Tcl_Interp* interp int v int n} ok {
    char s[5];
    to64(s, (unsigned int)v, n); 
    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, n));
    return TCL_OK;
}

critcl::cproc ::md5crypt::md5crypt_c {Tcl_Interp* interp char* magic char* pw char* salt} ok {
    char* s = md5crypt(pw, salt, magic);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(s, strlen(s)));
    return TCL_OK;
}


# # ## ### ##### ######## ############# #####################
# @sak notprovided md5cryptc
package provide md5cryptc 1.0
return

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






	# # ## ### ###### ######## #############
	## RDE runtime, inlined, and made static.

	# This is the C code for the RDE, i.e. the implementation
	# of pt::rde. Only the low-level engine is imported, the
	# Tcl interface layer is ignored.  This generated parser
	# provides its own layer for that.

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

	    #include <string.h>
	    #define SCOPE static

@@RUNTIME@@
	}

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

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

@code@
	}

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

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

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

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

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

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

		Tcl_InterpDeleteProc* proc = PARSERgRelease;
		PARSERg*                  parserg;

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

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

		parserg->counter ++;
		sprintf (parserg->buf, "@@CTAIL@@%ld", parserg->counter);
		return parserg->buf;
		#undef  KEY
	    }

	    static void
	    PARSERdeleteCmd (ClientData clientData)
	    {
		/*
		* Release the whole PARSER
		* (Low-level engine only actually).
		*/
		rde_param_del ((RDE_PARAM) clientData);
	    }
	}

	# # ## ### ##### ######## #############
	## Functions implementing the object methods, and helper.

	critcl::ccode {
	    static int  COMPLETE (RDE_PARAM p, Tcl_Interp* interp);

	    static int parser_PARSE  (RDE_PARAM p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
	    {
		int mode;
		Tcl_Channel chan;

		if (objc != 3) {
		    Tcl_WrongNumArgs (interp, 2, objv, "chan");
		    return TCL_ERROR;
		}

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

		if (!chan) {
		    return TCL_ERROR;
		}

		rde_param_reset (p, chan);
		MAIN (p) ; /* Entrypoint for the generated code. */
		return COMPLETE (p, interp);
	    }

	    static int parser_PARSET (RDE_PARAM p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
	    {
		char* buf;
		int   len;

		if (objc != 3) {
		    Tcl_WrongNumArgs (interp, 2, objv, "text");
		    return TCL_ERROR;
		}

		buf = Tcl_GetStringFromObj (objv[2], &len);

		rde_param_reset (p, NULL);
		rde_param_data  (p, buf, len);
		MAIN (p) ; /* Entrypoint for the generated code. */
		return COMPLETE (p, interp);
	    }

	    /* See also rde_critcl/m.c, param_COMPLETE() */
	    static int COMPLETE (RDE_PARAM p, Tcl_Interp* interp)
	    {
		if (rde_param_query_st (p)) {
		    long int  ac;
		    Tcl_Obj** av;

		    rde_param_query_ast (p, &ac, &av);

		    if (ac > 1) {
			Tcl_Obj** lv = NALLOC (3+ac, Tcl_Obj*);

			memcpy(lv + 3, av, ac * sizeof (Tcl_Obj*));
			lv [0] = Tcl_NewObj ();
			lv [1] = Tcl_NewIntObj (1 + rde_param_query_lstop (p));
			lv [2] = Tcl_NewIntObj (rde_param_query_cl (p));

			Tcl_SetObjResult (interp, Tcl_NewListObj (3, lv));
			ckfree ((char*) lv);

		    } else if (ac == 0) {
			/*
			* Match, but no AST. This is possible if the grammar
			* consists of only the start expression.
			*/
			Tcl_SetObjResult (interp, Tcl_NewStringObj ("",-1));
		    } else {
			Tcl_SetObjResult (interp, av [0]);
		    }

		    return TCL_OK;
		} else {
		    Tcl_Obj* xv [1];
		    const ERROR_STATE* er = rde_param_query_er (p);
		    Tcl_Obj* res = rde_param_query_er_tcl (p, er);
		    /* res = list (location, list(msg)) */

		    /* Stick the exception type-tag before the existing elements */
		    xv [0] = Tcl_NewStringObj ("pt::rde",-1);
		    Tcl_ListObjReplace(interp, res, 0, 0, 1, xv);

		    Tcl_SetErrorCode (interp, "PT", "RDE", "SYNTAX", NULL);
		    Tcl_SetObjResult (interp, res);
		    return TCL_ERROR;
		}
	    }
	}

	# # ## ### ##### ######## #############
	## Object command, method dispatch.

	critcl::ccode {
	    static int parser_objcmd (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
	    {
		RDE_PARAM p = (RDE_PARAM) cd;
		int m, res;

		static CONST char* methods [] = {
		    "destroy", "parse", "parset", NULL
		};
		enum methods {
		    M_DESTROY, M_PARSE, M_PARSET
		};

		if (objc < 2) {
		    Tcl_WrongNumArgs (interp, objc, objv, "option ?arg arg ...?");
		    return TCL_ERROR;
		} else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option",
						0, &m) != TCL_OK) {
		    return TCL_ERROR;
		}

		/* Dispatch to methods. They check the #args in
		* detail before performing the requested
		* functionality
		*/

		switch (m) {
		    case M_DESTROY:
		    if (objc != 2) {
			Tcl_WrongNumArgs (interp, 2, objv, NULL);
			return TCL_ERROR;
		    }

		    Tcl_DeleteCommandFromToken(interp, (Tcl_Command) rde_param_query_clientdata (p));
		    return TCL_OK;

		    case M_PARSE:	res = parser_PARSE  (p, interp, objc, objv); break;
		    case M_PARSET:	res = parser_PARSET (p, interp, objc, objv); break;
		    default:
		    /* Not coming to this place */
		    ASSERT (0,"Reached unreachable location");
		}

		return res;
	    }
	}

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

	critcl::ccommand ::@@CHEAD@@::@@CTAIL@@_critcl {dummy interp objc objv} {
	    /*
	    * Syntax: No arguments beyond the name
	    */

	    RDE_PARAM   parser;
	    CONST char* name;
	    Tcl_Obj*    fqn;
	    Tcl_CmdInfo ci;
	    Tcl_Command c;

	    #define USAGE "?name?"

	    if ((objc != 2) && (objc != 1)) {
		Tcl_WrongNumArgs (interp, 1, objv, USAGE);
		return TCL_ERROR;
	    }

	    if (objc < 2) {
		name = PARSERnewName (interp);
	    } else {
		name = Tcl_GetString (objv [1]);
	    }

	    if (!Tcl_StringMatch (name, "::*")) {
		/* Relative name. Prefix with current namespace */

		Tcl_Eval (interp, "namespace current");
		fqn = Tcl_GetObjResult (interp);
		fqn = Tcl_DuplicateObj (fqn);
		Tcl_IncrRefCount (fqn);

		if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) {
		    Tcl_AppendToObj (fqn, "::", -1);
		}
		Tcl_AppendToObj (fqn, name, -1);
	    } else {
		fqn = Tcl_NewStringObj (name, -1);
		Tcl_IncrRefCount (fqn);
	    }
	    Tcl_ResetResult (interp);

	    if (Tcl_GetCommandInfo (interp,
				    Tcl_GetString (fqn),
				    &ci)) {
		Tcl_Obj* err;

		err = Tcl_NewObj ();
		Tcl_AppendToObj    (err, "command \"", -1);
		Tcl_AppendObjToObj (err, fqn);
		Tcl_AppendToObj    (err, "\" already exists", -1);

		Tcl_DecrRefCount (fqn);
		Tcl_SetObjResult (interp, err);
		return TCL_ERROR;
	    }

	    parser = rde_param_new (sizeof(p_string)/sizeof(char*), (char**) p_string);
	    c = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn),
				      parser_objcmd, (ClientData) parser,
				      PARSERdeleteCmd);
	    rde_param_clientdata (parser, (ClientData) c);
	    Tcl_SetObjResult (interp, fqn);
	    Tcl_DecrRefCount (fqn);
	    return TCL_OK;
	}

	##



        # # ## ### ##### ######## ############# #####################
	## Ready (Note: Our package provide is at the top).
	return
    }]]

    return
}

#
## RD stands for Recursive Descent.

# # ## ### ##### ######## ############# #####################
## Requisites

package require Tcl 8.4
package require critcl 3.1

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

# @sak notprovided pt_rde_critcl
package provide pt_rde_critcl 1.3.3

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

critcl::license {Andreas Kupries} BSD

critcl::summary {
    Critcl implementation of the PARAM runtime.
}
critcl::description {
    This package provides a critcl-based implementation of the
    PARAM runtime.
}

critcl::subject PARAM {runtime PARAM} {parsing expression grammar} {parser support}
critcl::meta location http://core.tcl.tk/tcllib

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

namespace eval ::pt {}

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






critcl::cheaders rde_critcl/*.h
critcl::csources rde_critcl/*.c

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

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

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

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

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

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

	Tcl_InterpDeleteProc* proc = PARAMgRelease;
	PARAMg*                  paramg;

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

	    Tcl_SetAssocData (interp, KEY, proc,
			      (ClientData) paramg);
	}
	
	paramg->counter ++;
	sprintf (paramg->buf, "rde%ld", paramg->counter);
	return paramg->buf;

	#undef  KEY
    }

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

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

critcl::ccommand ::pt::rde_critcl {dummy interp objc objv} {
    /* Syntax: No arguments beyond the name
    */

    CONST char* name;
    RDE_STATE   param;
    Tcl_Obj*    fqn;
    Tcl_CmdInfo ci;
    Tcl_Command c;

    #define USAGE "?name?"

    if ((objc != 2) && (objc != 1)) {
        Tcl_WrongNumArgs (interp, 1, objv, USAGE);
        return TCL_ERROR;
    }

    if (objc < 2) {
        name = PARAMnewName (interp);
    } else {
        name = Tcl_GetString (objv [1]);
    }

    if (!Tcl_StringMatch (name, "::*")) {
        /* Relative name. Prefix with current namespace */

        Tcl_Eval (interp, "namespace current");
        fqn = Tcl_GetObjResult (interp);
        fqn = Tcl_DuplicateObj (fqn);
        Tcl_IncrRefCount (fqn);

        if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) {
	    Tcl_AppendToObj (fqn, "::", -1);
        }
        Tcl_AppendToObj (fqn, name, -1);
    } else {
        fqn = Tcl_NewStringObj (name, -1);
        Tcl_IncrRefCount (fqn);
    }
    Tcl_ResetResult (interp);

    if (Tcl_GetCommandInfo (interp,
			    Tcl_GetString (fqn),
			    &ci)) {
        Tcl_Obj* err;

        err = Tcl_NewObj ();
        Tcl_AppendToObj    (err, "command \"", -1);
        Tcl_AppendObjToObj (err, fqn);
        Tcl_AppendToObj    (err, "\" already exists", -1);

        Tcl_DecrRefCount (fqn);
        Tcl_SetObjResult (interp, err);
        return TCL_ERROR;
    }

    param = param_new ();
    c = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn),
			      paramms_objcmd, (ClientData) param,
			      PARAMdeleteCmd);
    param_setcmd (param, c);

    Tcl_SetObjResult (interp, fqn);
    Tcl_DecrRefCount (fqn);
    return TCL_OK;

}

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

package provide pt::rde::critcl 1.0.3
return

# rc4c.tcl - Copyright (C) 2004 Pat Thoyts <[email protected]>
#
# This provides a critcl C implementation of RC4 
#
# INSTALLATION
# ------------
# 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 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>

    typedef struct RC4_CTX {
	unsigned char x;
	unsigned char y;
	unsigned char s[256];
    } RC4_CTX;

    /* #define TRACE trace */
    #define TRACE 1 ? ((void)0) : trace

    static void trace(const char *format, ...)
    {
	va_list args;
	va_start(args, format);
	vfprintf(stderr, format, args);
	va_end(args);
    }
    static Tcl_ObjType rc4_type;
    
    static void rc4_free_rep(Tcl_Obj *obj)
    {
	RC4_CTX *ctx = (RC4_CTX *)obj->internalRep.otherValuePtr;
	TRACE("rc4_free_rep(%08x)\n", (long)obj);
	Tcl_Free((char *)ctx);
    }

    static void rc4_dup_rep(Tcl_Obj *obj, Tcl_Obj *dup)
    {
	RC4_CTX *ctx = (RC4_CTX *)obj->internalRep.otherValuePtr;
	TRACE("rc4_dup_rep(%08x,%08x)\n", (long)obj, (long)dup);
	dup->internalRep.otherValuePtr = (RC4_CTX *)Tcl_Alloc(sizeof(RC4_CTX));
	memcpy(dup->internalRep.otherValuePtr, ctx, sizeof(RC4_CTX));
	dup->typePtr = &rc4_type;
    }

    static void rc4_string_rep(Tcl_Obj* obj)
    {
	RC4_CTX *ctx = (RC4_CTX *)obj->internalRep.otherValuePtr;
	Tcl_Obj* tmpObj;
	char* str;
	TRACE("rc4_string_rep(%08x)\n", (long)obj);
	/* convert via a byte array to properly handle null bytes */
	tmpObj = Tcl_NewByteArrayObj((unsigned char *)ctx, sizeof(RC4_CTX));
	Tcl_IncrRefCount(tmpObj);
	
	str = Tcl_GetStringFromObj(tmpObj, &obj->length);
	obj->bytes = Tcl_Alloc(obj->length + 1);
	memcpy(obj->bytes, str, obj->length + 1);
	
	Tcl_DecrRefCount(tmpObj);
    }

    static int rc4_from_any(Tcl_Interp* interp, Tcl_Obj* obj)
    {
	TRACE("rc4_from_any %08x\n", (long)obj);
	return TCL_ERROR;
    }

    static Tcl_ObjType rc4_type = {
	"rc4c", rc4_free_rep, rc4_dup_rep, rc4_string_rep, rc4_from_any
    };
    #ifdef __GNUC__
    inline
    #elif defined(_MSC_VER)
    __inline
    #endif
    void swap (unsigned char *lhs, unsigned char *rhs) {
	unsigned char t = *lhs;
	*lhs = *rhs;
	*rhs = t;
    }
}

# todo :: critcl :: convertible to cproc
critcl::ccommand ::rc4::rc4c_init {dummy interp objc objv} {
    RC4_CTX *ctx;
    Tcl_Obj *obj;
    const unsigned char *k;
    int n = 0, i = 0, j = 0, keylen;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "keystring");
	return TCL_ERROR;
    }
    
    k = Tcl_GetByteArrayFromObj(objv[1], &keylen);

    obj = Tcl_NewObj();
    ctx = (RC4_CTX *)Tcl_Alloc(sizeof(RC4_CTX));
    ctx->x = 0;
    ctx->y = 0;
    for (n = 0; n < 256; n++)
    ctx->s[n] = n;
    for (n = 0; n < 256; n++) {
			       j = (k[i] + ctx->s[n] + j) % 256;
			       swap(&ctx->s[n], &ctx->s[j]);
			       i = (i + 1) % keylen;
			   }
    
    if (obj->typePtr != NULL && obj->typePtr->freeIntRepProc != NULL)
    obj->typePtr->freeIntRepProc(obj);
    obj->internalRep.otherValuePtr = ctx;
    obj->typePtr = &rc4_type;
    Tcl_InvalidateStringRep(obj);
    Tcl_SetObjResult(interp, obj);
    return TCL_OK;
}

# todo :: critcl :: convertible to cproc
critcl::ccommand ::rc4::rc4c {dummy interp objc objv} {
    Tcl_Obj *resObj = NULL;
    RC4_CTX *ctx = NULL;
    unsigned char *data, *res, x, y;
    int size, n, i;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "key data");
	return TCL_ERROR;
    }

    if (objv[1]->typePtr != &rc4_type
	&& rc4_from_any(interp, objv[1]) != TCL_OK) {
	return TCL_ERROR;
    }

    ctx = objv[1]->internalRep.otherValuePtr;
    data = Tcl_GetByteArrayFromObj(objv[2], &size);
    res = (unsigned char *)Tcl_Alloc(size);

    x = ctx->x;
    y = ctx->y;
    for (n = 0; n < size; n++) {
				x = (x + 1) % 256;
				y = (ctx->s[x] + y) % 256;
				swap(&ctx->s[x], &ctx->s[y]);
				i = (ctx->s[x] + ctx->s[y]) % 256;
				res[n] = data[n] ^ ctx->s[i];
			    }
    ctx->x = x;
    ctx->y = y;

    resObj = Tcl_NewByteArrayObj(res, size);
    Tcl_SetObjResult(interp, resObj);
    Tcl_Free((char*)res);
    return TCL_OK;
}

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

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

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);

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





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 ::sha2::sha256c_init224 {dummy ip objc objv} {
    SHA256_CTX* mp;
    unsigned char* data;
    int size;
    Tcl_Obj* obj;
    
    if (objc > 1) {
	Tcl_WrongNumArgs(ip, 1, objv, "");
	return TCL_ERROR;
    }
    
    obj = Tcl_NewObj();
    mp = (SHA256_CTX*) malloc(sizeof *mp);
    SHA224Init(mp);
    
    if (obj->typePtr != NULL && obj->typePtr->freeIntRepProc != NULL) {
	obj->typePtr->freeIntRepProc(obj);
    }
    
    obj->internalRep.otherValuePtr = mp;
    obj->typePtr = &sha256_type;
    
    Tcl_InvalidateStringRep(obj);        
    Tcl_SetObjResult(ip, obj);
    return TCL_OK;
}

critcl::ccommand ::sha2::sha256c_update {dummy ip objc objv} {
    SHA256_CTX* mp;
    unsigned char* data;
    int size;
    Tcl_Obj* obj;
    
    if (objc != 3) {
	Tcl_WrongNumArgs(ip, 1, objv, "data context");
	return TCL_ERROR;
    }
    
    if (objv[2]->typePtr != &sha256_type 
	&& sha256_from_any(ip, objv[2]) != TCL_OK) {
	return TCL_ERROR;
    }

    obj = objv[2];
    if (Tcl_IsShared(obj)) {
	obj = Tcl_DuplicateObj(obj);
    }
    
    Tcl_InvalidateStringRep(obj);
    mp = (SHA256_CTX*) obj->internalRep.otherValuePtr;
    
    data = Tcl_GetByteArrayFromObj(objv[1], &size);
    SHA256Update(mp, data, size);
    
    Tcl_SetObjResult(ip, obj);
    return TCL_OK;
}

# # ## ### ##### ######## ############# #####################
# @sak notprovided sha256c
package provide sha256c 1.0.2
return

# Umbrella, i.e. Bundle, to put all of the critcl modules which are
# found in Tcllib in one shared library.

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