cryptkit.tcl

cryptlib安全工具包

    }

    proc get_argument_values {name n arg suffix} {
        variable allocated
        variable numargs
        variable skiparg
        set r [expr {$n - $skiparg}]
        switch $suffix {
            & { # return integer value
              }
            ? { # if not specified set optional argument to length of
                # previous argument
                code "  if (objc != $numargs)"
                code "    arg$n = len[expr {$n - 1}];"
                code "  else"
                code_check $n $name "GetIntArg(ip, objv\[$r\], &arg$n)"
              }
            "#" { # use length of previous void *
                code "  arg$n = len[expr {$n - 1}];"
                incr skiparg
              }
            ! { # arbitrary value for maximum length of a void * 
                code "  arg$n = 32000;"
                incr skiparg
              }
            ^ { # integer or Cryptlib constant
                code_check $n $name "GetIntOrConstArg(ip, objv\[$r\], &arg$n)"
              }
            * { # char *
                code_check $n $name  "GetStringArg(ip, objv\[$r\], &arg$n)"
              }
            = { # void *
                  code_check $n $name \
                        "GetByteArrayArg(ip, objv\[$r\], &arg$n, &len$n)"
              }
            % { # handle specially }
            : { # we handle these specially in query_return_buffer_size
              }
            default { # integer
                 code_check $n $name "GetIntArg(ip, objv\[$r\], &arg$n)"
              }
        } 
    }

    # a number of cryptlib functions can be called with a NULL argument
    # to get the length of the data buffer  that will be returned
    proc query_return_buffer_size {name arguments} {
        variable allocated
        variable carglist
        # now look for candidates
        foreach {n arg suffix} $arguments {
            if {$suffix eq ":"} {
                set idx [expr {$n - 1}]
                set args [join [lreplace $carglist $idx $idx NULL] ,]
                code "  if \(ret = \($name\($args\)\) != CRYPT_OK\)"
                code "    return cryptReturn(ip, ret);"
                # need to check if next suffix is ! and ignore it
                set next [expr {($n+1)*3+2}]
                set x [expr {$n + 1}]
                while {[lindex $arguments $next] eq "!"} {
                    incr next 3
                    incr x
                }
                # create a buffer big enough to hold returned value
                code "  arg$n = (void *) Tcl_Alloc(arg$x);"
                lappend allocated arg$n
            }
        }
    }

    proc set_return_values {arguments} {
        set skip 0
        foreach {n arg suffix} $arguments {
            set r [expr {$n - $skip}]
            switch $suffix {
                % -
                : { # void *
                    code "  if (Tcl_ObjSetVar2(ip, objv\[$r\], NULL, " \
                                "Tcl_NewByteArrayObj(arg$n, " \
                                "arg[expr {$n+1}]), " \
                                "TCL_LEAVE_ERR_MSG) == NULL)"
                    code "    return TCL_ERROR;"
                  }
                & { # integer
                    code "  if (Tcl_ObjSetVar2(ip, objv\[$r\], NULL, " \
                                "Tcl_NewIntObj(arg$n)," \
                                "TCL_LEAVE_ERR_MSG) == NULL)"
                    code "    return TCL_ERROR;"
                  }
                ! -
                "#" { incr skip }
            }
        } 
    }

    proc mapping {name pattern} {
        variable $name
        foreach tmp [info vars [namespace current]::$pattern] {
            variable $tmp
            set var [namespace tail $tmp]
            set val [set $tmp]
            array set $name [list $val $var]
        }
    }

    # handle cryptInit specially, because we need to do some other setup as well
    proc cryptInit {{type text}} {
        # create a mapping from the C #defined errors to the textual
        # equivalent (note we introspect using [namespace current] since
        # namespace variables aren't visible unless explicitly declared
        mapping status CRYPT_ERROR_*
        mapping status CRYPT_OK
        mapping status CRYPT_ENVELOPE_RESOURCE
        # create a mapping from enums/defines for use in cryptQueryObject
        mapping objects CRYPT_ALGO_*
        mapping objects CRYPT_OBJECT_*
        mapping objects CRYPT_MODE_*
        variable errtype
        switch -glob $type {
            num* -
            text {
                set errtype $type
            }
            default {
                error "cryptInit: unknown error handling type '$type'"
            }
        }
        return [ReturnMsg [_cryptInit]]
    }

    critcl::cproc _cryptInit {} int {
        return cryptInit();
    }

    # functions that return structures are handled specially and the
    # structures are mapped into Tcl arrays
    #  DeviceQueryCapability { cryptDevice cryptAlgo &cryptQueryInfo }
    #  QueryCapability       { cryptAlgo &cryptQueryInfo }
    #  QueryObject           { objectPtr= &algocryptObjectInfo }

    critcl::cproc cryptDeviceQueryCapability \
            {Tcl_Interp* ip Tcl_Obj* dev Tcl_Obj* algo Tcl_Obj* info} ok {
        int ret, device, algorithm;
        CRYPT_QUERY_INFO qinfo;

        if (GetIntOrConstArg(ip, algo, &algorithm) != CRYPT_OK)
            return TCL_ERROR;
        if (GetIntOrConstArg(ip, dev, &device) != CRYPT_OK)
            return TCL_ERROR;
        if (GetIntOrConstArg(ip, algo, &algorithm) != CRYPT_OK)
            return TCL_ERROR;
        ret = cryptDeviceQueryCapability(device, algorithm, &qinfo);
        cryptSetQueryInfo(ip, info, qinfo);
        cryptReturn(ip, ret);
        return TCL_OK;
    }

    critcl::cproc cryptQueryCapability \
                {Tcl_Interp* ip Tcl_Obj* algo Tcl_Obj* info} ok {
        int ret, algorithm;
        CRYPT_QUERY_INFO qinfo;

        if (GetIntOrConstArg(ip, algo, &algorithm) != CRYPT_OK)
            return TCL_ERROR;
        ret = cryptQueryCapability(algorithm, &qinfo);
        cryptSetQueryInfo(ip, info, qinfo);
        cryptReturn(ip, ret);
        return TCL_OK;
    }

    critcl::cproc cryptQueryObject \
                {Tcl_Interp* ip Tcl_Obj* obj Tcl_Obj* info} ok {
        void *objbuf;
        CRYPT_OBJECT_INFO oinfo;
        int ret, len;
        Tcl_Obj *objects, *name;
        objbuf = Tcl_GetByteArrayFromObj(obj,&len);
        ret = cryptQueryObject(objbuf, len, &oinfo);
        if ((objects = Tcl_NewStringObj("::cryptkit::objects", -1)) == NULL)
            return TCL_ERROR;
        Tcl_ObjSetVar2(ip, info, Tcl_NewStringObj("objectType", -1), \
                Tcl_ObjGetVar2(ip, objects, Tcl_NewIntObj(oinfo.objectType),
                        TCL_LEAVE_ERR_MSG), TCL_LEAVE_ERR_MSG);
        Tcl_ObjSetVar2(ip, info, Tcl_NewStringObj("cryptAlgo", -1), \
                Tcl_ObjGetVar2(ip, objects, Tcl_NewIntObj(oinfo.cryptAlgo),
                        TCL_LEAVE_ERR_MSG), TCL_LEAVE_ERR_MSG);
        Tcl_ObjSetVar2(ip, info, Tcl_NewStringObj("cryptMode", -1), \
                Tcl_ObjGetVar2(ip, objects, Tcl_NewIntObj(oinfo.cryptMode),
                        TCL_LEAVE_ERR_MSG), TCL_LEAVE_ERR_MSG);
        Tcl_ObjSetVar2(ip, info, Tcl_NewStringObj("hashAlgo", -1), \
                Tcl_ObjGetVar2(ip, objects, Tcl_NewIntObj(oinfo.hashAlgo),
                        TCL_LEAVE_ERR_MSG), TCL_LEAVE_ERR_MSG);
        Tcl_ObjSetVar2(ip, info, Tcl_NewStringObj("salt", CRYPT_MAX_HASHSIZE), \
                                     Tcl_NewStringObj(oinfo.salt, -1),
                                     TCL_LEAVE_ERR_MSG);
        Tcl_ObjSetVar2(ip, info, Tcl_NewStringObj("saltSize", -1), \
                                     Tcl_NewIntObj(oinfo.saltSize),
                                     TCL_LEAVE_ERR_MSG);
        cryptReturn(ip, ret);
        return TCL_OK;
    }

    # generate remaining functions
    # function arguments
    #   default is "const int"
    # suffix modifiers to alter this
    #   ^   arg is name of #define/enum in cryptkit namespace
    #   *   char *
    #   =   void *
    #   &   return int
    #   %   return void *, next arg is length
    #   :   return void *, call with NULL to get length of string
    #   #   use length of previous void * (C API only)
    #   !   pass $maxlength to Cryptlib (C API only) 

    # Notes 
    #   - even though the GetPrivateKey documentation specifies the keyID
    #     should be "void *" it needed to be "char *" to work

    generate {
      AddCertExtension    { certificate oid* criticalFlag extension= \
                                extensionLength# }
      AddPrivateKey       { keyset cryptKey password* }
      AddPublicKey        { keyset certificate }
      AddRandom           { randomData= randomDataLength^ }
      AsyncCancel         { cryptObject }
      AsyncQuery          { cryptObject }
      CAAddItem           { keyset certificate }
      CACertManagement    { cryptCert& action keyset caKey certRequest }
      CAGetItem           { keyset certificate& certType keyIDtype keyID= }
      CheckCert           { certificate sigCheckKey }
      CheckSignature      { signature= length# sigCheckKey hashContext }
      CheckSignatureEx    { signature= length# sigCheckKey hashContext \
                                extraData& }
      CreateCert          { cryptCert& cryptUser^ certType^ }
      CreateContext       { cryptContext& cryptUser^ cryptAlgo^ }
      CreateEnvelope      { cryptEnvelope& cryptUser^ formatType^ }
      CreateSession       { cryptSession& cryptUser^ sessionType^ }
      CreateSignature     { signature: maxlength! signatureLength& \
                                signContext hashContext }
      CreateSignatureEx   { signature: maxlength! signatureLength& formatType \
                                signContext hashContext extraData }
      Decrypt             { cryptContext buffer= length# }
      DeleteAttribute     { cryptObject attributeType }
      DeleteCertExtension { certificate oid* }
      DeleteKey           { cryptObject keyIDtype keyID= }
      DestroyCert         { cryptCert }
      DestroyContext      { cryptContext }
      DestroyEnvelope     { cryptEnvelope }
      DestroyObject       { cryptObject }
      DestroySession      { cryptSession }
      DeviceClose         { device }
      DeviceCreateContext { cryptDevice cryptContext& cryptAlgo }
      DeviceOpen          { device& cryptUser^ deviceType name* }
      Encrypt             { cryptContext buffer= length# }
      End                 { }
      ExportCert          { certObject% maxlength! certObjectLength& \
                                certFormatType^ certificate }
      ExportKey           { encryptedKey% maxlength! encryptedKeyLength& \
                                exportKey sessionKeyContext }
      ExportKeyEx         { encryptedKey: maxlength! encryptedKeyLength& \
                                formatType exportKey sessionKeyContext }
      FlushData           { cryptHandle }
      GenerateKey         { cryptContext }
      GenerateKeyAsync    { cryptContext }
      GetAttribute        { cryptObject attributeType^ value& }
      GetAttributeString  { cryptObject attributeType^ value: valueLength& }
      GetCertExtension    { certificate oid* criticalFlag& extension: \
                                maxlength! extensionLength& }
      GetPrivateKey       { cryptHandle cryptContext& keyIDtype^ keyID* \
                                password* }
      GetPublicKey        { cryptObject publicKey& keyIDtype keyID= }
      ImportCert          { certObject= certObjectLength cryptUser^ \
                                certificate& }
      ImportKey           { encryptedKey= maxlength# importContext \
                                sessionKeyContext }
      KeysetClose         { keyset }
      KeysetOpen          { keyset& cryptUser^ keysetType^ name* options^ }
      PopData             { envelope buffer% length bytesCopied& }
      PushData            { envelope buffer= length# bytesCopied& }
      SetAttribute        { cryptObject^ attributeType^ value^ }
      SetAttributeString  { cryptObject^ attributeType^ value= valueLength# }
      SignCert            { certificate signContext }
    }

}