cryptkit.tcl

cryptlib是功能强大的安全工具集。允许开发人员快速在自己的软件中集成加密和认证服务。

#
#   Cryptkit - Tcl interface to Cryptlib Encryption Toolkit
#   (http://www.cs.auckland.ac.nz/~pgut001/cryptlib/)
#
#   Development by Steve Landers <[e-mail]>
#   
#   $Id: cryptkit.tcl,v 1.28 2004/12/07 02:15:07 steve Exp $

package provide cryptkit 1.0

if {[catch {package require critcl}]} {
    puts stderr "This extension requires Critcl to be compiled"
    exit 1
}

if {![critcl::compiling]} {
    puts stderr "Critcl can't compile on this platform"
    exit 1
}

namespace eval cryptkit {

    namespace export crypt*

    critcl::cheaders -I[pwd]

    critcl::clibraries -L[pwd] -lcl_[critcl::platform]

    # platform specific stuff
    switch [critcl::platform] {
        Linux-x86 {
            critcl::clibraries -lresolv
        }
    }

    # force this source file into the resulting package so that the
    # pure Tcl procedures are available at run time
    critcl::tsources [file tail [info script]]

    # map Cryptlib #defines and enums into the current namespace
    critcl::cdefines CRYPT_* [namespace current]

    # other defines
    critcl::cdefines {
        NULL
        TRUE
        FALSE
        TCL_OK
        TCL_ERROR
    } [namespace current]
        
    critcl::ccode {
        #include <string.h>
        #include "cryptlib.h"

        int
        GetIntOrConstArg(Tcl_Interp *ip, Tcl_Obj *obj, int *val) {
            Tcl_Obj *obj1;
            if (Tcl_GetIntFromObj(NULL, obj, val) != TCL_OK) {
                Tcl_Obj *constObj = Tcl_NewStringObj("::cryptkit::",-1);
                Tcl_AppendObjToObj(constObj, obj);
                Tcl_IncrRefCount(constObj);
                if ((obj1 = Tcl_ObjGetVar2(ip, constObj, NULL,
                         TCL_LEAVE_ERR_MSG)) == NULL) {
                    Tcl_DecrRefCount(constObj);
                    return TCL_ERROR;
                }
                Tcl_DecrRefCount(constObj);
                if (Tcl_GetIntFromObj(ip, obj1, val) != TCL_OK) {
                    Tcl_AddErrorInfo(ip, " in '");
                    Tcl_AddErrorInfo(ip, Tcl_GetString(obj));
                    return TCL_ERROR;
                }
            }
            return TCL_OK;
        }

        int
        GetIntArg(Tcl_Interp *ip, Tcl_Obj *obj, int *val) {
            if (Tcl_GetIntFromObj(ip, obj, val) != TCL_OK) {
                Tcl_AddErrorInfo(ip, " in '");
                Tcl_AddErrorInfo(ip, Tcl_GetString(obj));
                return TCL_ERROR;
            }
            return TCL_OK;
        }

        int
        GetStringArg(Tcl_Interp *ip, Tcl_Obj *obj, char **val) {
            if ((*val = Tcl_GetStringFromObj(obj, NULL)) == NULL) {
                Tcl_AddErrorInfo(ip, " in '");
                Tcl_AddErrorInfo(ip, Tcl_GetString(obj));
                return TCL_ERROR;
            }
            return TCL_OK;
        }

        int
        GetByteArrayArg(Tcl_Interp *ip, Tcl_Obj *obj, void **val, int *len) {
            if (strcmp(Tcl_GetString(obj), "NULL") == 0) {
                *val = NULL;
                *len = 0;
            } else if ((*val = Tcl_GetByteArrayFromObj(obj, len)) == NULL) {
                Tcl_AddErrorInfo(ip, " in '");
                Tcl_AddErrorInfo(ip, Tcl_GetString(obj));
                return TCL_ERROR;
            }
            return TCL_OK;
        }

        void
        cryptSetQueryInfo(Tcl_Interp *ip, Tcl_Obj *info, \
                                         CRYPT_QUERY_INFO qinfo) {
            Tcl_ObjSetVar2(ip, info, Tcl_NewStringObj("algoName", -1), \
                                     Tcl_NewStringObj(qinfo.algoName, -1),
                                     TCL_LEAVE_ERR_MSG);
            Tcl_ObjSetVar2(ip, info, Tcl_NewStringObj("blockSize", -1), \
                                     Tcl_NewIntObj(qinfo.blockSize),
                                     TCL_LEAVE_ERR_MSG);
            Tcl_ObjSetVar2(ip, info, Tcl_NewStringObj("minKeySize", -1), \
                                     Tcl_NewIntObj(qinfo.minKeySize),
                                     TCL_LEAVE_ERR_MSG);
            Tcl_ObjSetVar2(ip, info, Tcl_NewStringObj("keySize", -1), \
                                     Tcl_NewIntObj(qinfo.keySize),
                                     TCL_LEAVE_ERR_MSG);
            Tcl_ObjSetVar2(ip, info, Tcl_NewStringObj("maxKeySize", -1), \
                                     Tcl_NewIntObj(qinfo.maxKeySize),
                                     TCL_LEAVE_ERR_MSG);
        }

        int
        cryptReturn(Tcl_Interp *ip, int ret) {
            Tcl_Obj *resultObj, *objv[2];

            objv[0] = Tcl_NewStringObj("::cryptkit::ReturnMsg", -1);
            objv[1] = Tcl_NewIntObj(ret);
            if (Tcl_EvalObjv(ip, 2, objv, TCL_EVAL_GLOBAL) != TCL_OK) {
                Tcl_AppendResult(ip, "oops", (char *) NULL);
                return TCL_ERROR;
            }
            resultObj = Tcl_GetObjResult(ip);
            if (Tcl_SetVar2Ex(ip, "::cryptkit::errmsg", NULL, resultObj,
                      TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
                return TCL_ERROR;
            }
            if (ret < CRYPT_OK) {
                Tcl_SetObjErrorCode(ip, resultObj);
                return TCL_ERROR;
            }
            return TCL_OK;
        }

    }

    # Return message (either number or text, or generate error)
    proc ReturnMsg {num} {
        variable errtype
        variable status
        if {![info exists errtype]} {
            # probably means cryptInit not called
            cryptInit
        }
        if {$errtype ne "text"} {
            return $num
        }
        if {[info exists status($num)]} {
            if {$num < 0} {
                return $status($num)
            } else {
                return $status($num)
            }
        } else {
            return "unknown Cryptlib error $num"
        }
    }

    # append to variable holding generated C code - makes code more readable
    # and allows it to be split over multiple lines
    proc code {args} {
        variable code
        set tmp ""
        foreach arg $args {
            append tmp $arg
        }
        lappend code $tmp
    }

    # generate critcl::ccomands to call C cryptlib functions
    proc generate {cmds} {
        if {[critcl::done]} {
            # we don't want to generate C code when the cryptkit package
            # is loaded at runtime
            return
        }
        variable code ""
        foreach {name arglist} $cmds {
            generate_function crypt$name [parse_arguments $arglist]
        }
        # uncomment the following line to view generated code
        # puts \n[join $code \n]
        eval [join $code \n]
    }

    proc parse_arguments {arglist} {
        set args [list]
        set argnum 0
        foreach arg $arglist {
            set suffix [string index $arg end]
            if {[string is alnum $suffix]} {
                set suffix ""
            } else {
                set arg [string range $arg 0 end-1]
            }
            lappend args [incr argnum] $arg $suffix
        }
        return $args
    }

    proc generate_function {name arguments} {
        # generate the critcl::cccomand
        variable allocated ""   ;# any Tcl_Alloc'd variables
        variable carglist ""    ;# list of arguments to the Cryptlib function
        variable numargs 0      ;# number of arguments to the Cryptlib function
        variable skiparg 0      ;# number of arguments skipped in Tcl API
        code "critcl::ccommand $name {data ip objc objv} \{"
        code "  int ret;"
        set objects ""      ;# Tcl objects to create
        set vararg 0        ;# indicates we have an option argument
        set usage ""        ;# usage message
        # generate definitions for arguments to Cryptlib function
        foreach {n arg suffix} $arguments {
            switch $suffix {
                *       { code "  char *arg$n;" }
                %       -
                :       -
                =       { code "  void *arg$n; int len$n;" }
                default { code "  int arg$n;" }
            }
            if {$suffix ne "#" && $suffix ne "!"} {
                lappend usage $arg
                lappend objects "*obj$n"
                incr numargs 
            }
        }
        # create Tcl objects for each argument to Cryptkit Tcl procedure
        if {$objects ne {}} {
            code "  Tcl_Obj [join $objects {, }];"
        }
        # check number of arguments
        code "  if (objc != [expr {$numargs + 1}]) \{"
        code "    Tcl_WrongNumArgs(ip, 1, objv, \"$usage\");"
        code "    return TCL_ERROR;"
        code "  \}"
        # first get all args that can be extracted from the Tcl argument list
        foreach {n arg suffix} $arguments {
            get_argument_values $name $n $arg $suffix
            if {$suffix eq "&"} {
                lappend carglist "&arg$n"
            } else {
                lappend carglist "arg$n"
            }
        }
        # now get any that are derived from later arguments
        foreach {n arg suffix} $arguments {
            if {$suffix eq "%"} {
                # get length of buffer from the next argument
                code "  arg$n = (void *) Tcl_Alloc(arg[expr {$n + 1}]);"
                lappend allocated arg$n
            }
        }
        query_return_buffer_size $name $arguments
        code "  ret = $name\([join $carglist {, }]\);" ;# call cryptlib function
        set_return_values $arguments
        foreach alloc $allocated {
            code "  Tcl_Free($alloc);"
        }
        code "  return cryptReturn(ip, ret);"
        code "\}"
        code ""
    }

    proc code_check {n name func} {
        variable skiparg
        set argnum [expr {$n - $skiparg}]
        code "  if ($func == TCL_ERROR) \{"
        code "    Tcl_AddErrorInfo(ip, \"' (argument $argnum to $name)\");" 
        code "    return TCL_ERROR;"
        code "  \}"