base32_c.tcl

Go to the documentation of this file.

/*  base32c.tcl --*/
/* */
/*        Implementation of a base32 (std) de/encoder for Tcl.*/
/* */
/*  Public domain*/
/* */
/*  RCS: @(#) $Id: base32_c.tcl,v 1.2 2006/05/28 04:29:09 andreas_kupries Exp $*/

package require critcl
package require Tcl 8.4

namespace ::base32 {
    /*  Supporting code for the main command.*/
    catch {
    critcl::cheaders -g
    critcl::debug memory symbols
    }

    /*  Main commands, encoder & decoder*/

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

      unsigned char* buf;
      int           nbuf;

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

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

/* define USAGEE "bitstring"*/

      if (objc != 2) {
        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 (out, nout));
      Tcl_Free ((char*) out);
      return TCL_OK;
    }


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

      unsigned char* buf;
      int           nbuf;

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

      int i, j, a, pad, nx;

      /*
       * An array for translating single base-32 characters into a value.
       * Disallowed input characters have a value of 64.  Upper and lower
       * case is the same. Only 128 chars, as everything above char(127)
       * is 64.
       */
      static const char map [] = {
    /* \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 = 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*/