1# sha1c.tcl - Copyright (C) 2005 Pat Thoyts <patthoyts@users.sourceforge.net>
2#
3# Wrapper for the Secure Hashing Algorithm (SHA1)
4#
5# $Id: sha1c.tcl,v 1.6 2009/05/07 00:35:10 patthoyts Exp $
6
7package require critcl;                 # needs critcl
8# @sak notprovided sha1c
9package provide sha1c 2.0.3
10
11critcl::cheaders sha1.h;                # NetBSD SHA1 implementation
12critcl::csources sha1.c;                # NetBSD SHA1 implementation
13
14if {$tcl_platform(byteOrder) eq "littleEndian"} {
15    set byteOrder 1234
16} else {
17    set byteOrder 4321
18}
19critcl::cflags -DTCL_BYTE_ORDER=$byteOrder
20
21namespace eval ::sha1 {
22
23    critcl::ccode {
24        #include "sha1.h"
25        #include <stdlib.h>
26        #include <string.h>
27        #include <assert.h>
28
29        static
30        Tcl_ObjType sha1_type; /* fast internal access representation */
31
32        static void
33        sha1_free_rep(Tcl_Obj* obj)
34        {
35            Tcl_Free(obj->internalRep.otherValuePtr);
36        }
37
38        static void
39        sha1_dup_rep(Tcl_Obj* obj, Tcl_Obj* dup)
40        {
41            SHA1_CTX* mp = (SHA1_CTX*) obj->internalRep.otherValuePtr;
42            dup->internalRep.otherValuePtr = Tcl_Alloc(sizeof *mp);
43            memcpy(dup->internalRep.otherValuePtr, mp, sizeof *mp);
44            dup->typePtr = &sha1_type;
45        }
46
47        static void
48        sha1_string_rep(Tcl_Obj* obj)
49        {
50            unsigned char buf[20];
51            Tcl_Obj* temp;
52            char* str;
53            SHA1_CTX dup = *(SHA1_CTX*) obj->internalRep.otherValuePtr;
54
55            SHA1Final(buf, &dup);
56
57            /* convert via a byte array to properly handle null bytes */
58            temp = Tcl_NewByteArrayObj(buf, sizeof buf);
59            Tcl_IncrRefCount(temp);
60
61            str = Tcl_GetStringFromObj(temp, &obj->length);
62            obj->bytes = Tcl_Alloc(obj->length + 1);
63            memcpy(obj->bytes, str, obj->length + 1);
64
65            Tcl_DecrRefCount(temp);
66        }
67
68        static int
69        sha1_from_any(Tcl_Interp* ip, Tcl_Obj* obj)
70        {
71            assert(0);
72            return TCL_ERROR;
73        }
74
75        static
76        Tcl_ObjType sha1_type = {
77            "sha1c", sha1_free_rep, sha1_dup_rep, sha1_string_rep,
78            sha1_from_any
79        };
80    }
81
82    critcl::ccommand sha1c {dummy ip objc objv} {
83        SHA1_CTX* mp;
84        unsigned char* data;
85        int size;
86        Tcl_Obj* obj;
87
88        if (objc < 2 || objc > 3) {
89            Tcl_WrongNumArgs(ip, 1, objv, "data ?context?");
90            return TCL_ERROR;
91        }
92
93        if (objc == 3) {
94            if (objv[2]->typePtr != &sha1_type
95                && sha1_from_any(ip, objv[2]) != TCL_OK) {
96                return TCL_ERROR;
97            }
98            obj = objv[2];
99            if (Tcl_IsShared(obj)) {
100                obj = Tcl_DuplicateObj(obj);
101            }
102        } else {
103            obj = Tcl_NewObj();
104            mp = (SHA1_CTX*) Tcl_Alloc(sizeof *mp);
105            SHA1Init(mp);
106
107            if (obj->typePtr != NULL && obj->typePtr->freeIntRepProc != NULL) {
108                obj->typePtr->freeIntRepProc(obj);
109            }
110
111            obj->internalRep.otherValuePtr = mp;
112            obj->typePtr = &sha1_type;
113        }
114
115        Tcl_InvalidateStringRep(obj);
116
117        mp = (SHA1_CTX*) obj->internalRep.otherValuePtr;
118        data = Tcl_GetByteArrayFromObj(objv[1], &size);
119        SHA1Update(mp, data, size);
120
121        Tcl_SetObjResult(ip, obj);
122        return TCL_OK;
123    }
124}
125