{ -----------------------------------------------------------------------
Tcl Scripting Language Components (Tslc)
Copyright (C) 1996-2002 William Byrne

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

WilliamB@ByrneLitho.com
------------------------------------------------------------------------}
unit TslcLock;

interface
uses Classes, SysUtils, TclTk, Tslc;


Type

    TTclCmdLockBox = class(TTclCommand)
    private
		FCypher: string;

    protected
		procedure DoCommand(var result: string; var success: boolean); override;
        procedure DoInterpDelete(AInterp: pTcl_Interp); override;
		procedure DoPrepare(var result: string; var success: boolean); override;
        procedure DoScriptDelete(AInterp: pTcl_Interp); override;

    public
		constructor Create(AOwner: TComponent; ACommand: string);
		destructor Destroy; override;
        procedure SetStr(data: string);
        procedure GetStr(key: pChar; var data: string); // Throws EDESError
		procedure SetData(data: pointer; dataLen: integer);
		procedure GetData(key: pChar; var data: pointer; var dataLen: integer); // Throws EDESError

    end;

	TLockBoxProc = function(src, dest: pChar; destSize: integer): integer; cdecl;

procedure LockBoxCommandEncode(AInterp: pTcl_Interp; command: string; EncodeProc: TLockBoxProc; cypherKey: string); // Throws ETclError
procedure LockBoxCommandDecode(AInterp: pTcl_Interp; command: string; DecodeProc: TLockBoxProc; cypherKey: string); // Throws ETclError
procedure LockBoxGetStr(AInterp: pTcl_Interp; command: string; var data: string; cypherKey: pChar); // Throws ETclError;
procedure LockBoxSetStr(AInterp: pTcl_Interp; command, data: string); // Throws ETclError;


implementation
uses Windows, TslcDes, TslcKey, TslcPlat;

type
	TLockBoxAccessProc = function(cmd: TTclCmdLockBox; Proc: TLockBoxProc; cypherKey: pChar): integer; cdecl;
	TLockBoxGetProc = function(cmd: TTclCmdLockBox; cypherKey, data: pChar; dataLen: integer): integer; cdecl;
    TLockBoxSetProc = function(cmd: TTclCmdLockBox; data: pChar): integer; cdecl;

function LockBoxEncode(cmd: TTclCmdLockBox; EncodeProc: TLockBoxProc; cypherKey: pChar): integer; cdecl;
var
	buf: array[0..cMaxKeyLen] of char;
    clear, cypher: string;
begin
	result := StaticDecrypt(cypherKey, buf, cMaxKeyLen + 1);
	if result <> 0 then
    	exit;
	with cmd do
    try
    	GetStr(buf, clear);
		result := EncodeProc(pChar(clear), nil, 0);
		if result >= 0 then
        begin
	        SetString(cypher, nil, result);
            result := EncodeProc(pChar(clear), pChar(cypher), result);
            if result = 0 then
		        SetStr(cypher);
        end;
	except
    	result := -1;
    end;
end;

procedure LockBoxCommandEncode(AInterp: pTcl_Interp; command: string; EncodeProc: TLockBoxProc; cypherKey: string);
var
	cmd: TTclCommand;
    modInfo: TModuleCmdInfo;
    proc: TLockBoxAccessProc;
begin
	cmd := TslcFindCommand(AInterp, command);
	if cmd is TTclCmdLockBox then
    begin
        if LockBoxEncode(cmd as TTclCmdLockBox, EncodeProc, pChar(cypherKey)) <> 0 then
        	TclError('Invalid Key');
        exit;
    end;
    // will look into other loaded modules.
	modInfo.size := sizeof(TModuleCmdInfo);
    if TslcFindCommandModule(AInterp, command, @modInfo) then
    begin
		proc := TLockBoxAccessProc(GetProcAddress(modInfo.handle, 'LockBoxEncode'));
		if @proc = nil then
        	TclError('Unable to access foreign LockBox');
		// The following cast to TTclCmdLockBox is only for preventing a compiler error. Since the cmd
        // originated from the module whose procedure we're calling, we know the data is good
		if proc(TTclCmdLockBox(modInfo.command), EncodeProc, pChar(cypherKey)) <> 0 then
        	TclError('Invalid Key');
        exit;
    end else
    	TclErrorFmt('%s is not a LockBox command', [command]);
end;

function LockBoxDecode(cmd: TTclCmdLockBox; DecodeProc: TLockBoxProc; cypherKey: pChar): integer; cdecl;
var
	buf: array[0..cMaxKeyLen] of char;
    clear, cypher: string;
begin
	result := StaticDecrypt(cypherKey, buf, cMaxKeyLen + 1);
	if result <> 0 then
    	exit;
	with cmd do
    try
    	GetStr(buf, cypher);
		result := DecodeProc(pChar(cypher), nil, 0);
		if result >= 0 then
        begin
	        SetString(clear, nil, result);
            result := DecodeProc(pChar(cypher), pChar(clear), result);
            if result = 0 then
		        SetStr(clear);
        end;
	except
    	result := -1;
    end;
end;

procedure LockBoxCommandDecode(AInterp: pTcl_Interp; command: string; DecodeProc: TLockBoxProc; cypherKey: string);
var
	cmd: TTclCommand;
    modInfo: TModuleCmdInfo;
    proc: TLockBoxAccessProc;
begin
	cmd := TslcFindCommand(AInterp, command);
	if cmd is TTclCmdLockBox then
    begin
        if LockBoxDecode(cmd as TTclCmdLockBox, DecodeProc, pChar(cypherKey)) <> 0 then
        	TclError('Invalid Key');
        exit;
    end;
    // will look into other loaded modules.
	modInfo.size := sizeof(TModuleCmdInfo);
    if TslcFindCommandModule(AInterp, command, @modInfo) then
    begin
		proc := TLockBoxAccessProc(GetProcAddress(modInfo.handle, 'LockBoxDecode'));
		if @proc = nil then
        	TclError('Unable to access foreign LockBox');
		// The following cast to TTclCmdLockBox is only for preventing a compiler error. Since the cmd
        // originated from the module whose procedure we're calling, we know the data is good
		if proc(TTclCmdLockBox(modInfo.command), DecodeProc, pChar(cypherKey)) <> 0 then
        	TclError('Invalid Key');
        exit;
    end else
    	TclErrorFmt('%s is not a LockBox command', [command]);
end;

function LockBoxGet(cmd: TTclCmdLockBox; cypherKey, data: pChar; dataLen: integer): integer; cdecl;
var
   	buf: array[0..cMaxKeyLen] of char;
	dataStr: string;
begin
	try
		if StaticDecrypt(cypherKey, buf, cMaxKeyLen + 1) <> 0 then
	    	TclError('Invalid Key');
        cmd.GetStr(buf, dataStr);
        result := Length(dataStr) + 1;
        if (data <> nil) and (dataLen >= result) then
        begin
        	strcopy(data, pChar(dataStr));
            result := 0;
        end;
    except
    	result := -1;
    end;
end;


procedure LockBoxGetStr(AInterp: pTcl_Interp; command: string; var data: string; cypherKey: pChar);
var
	buf: array[0..cMaxKeyLen] of char;
	cmd: TTclCommand;
    modInfo: TModuleCmdInfo;
    proc: TLockBoxGetProc;
    len: integer;
begin

	cmd := TslcFindCommand(AInterp, command);
	if cmd is TTclCmdLockBox then
    begin
		if StaticDecrypt(cypherKey, buf, cMaxKeyLen + 1) <> 0 then
	    	TclError('Invalid Key');
        TTclCmdLockBox(cmd).GetStr(buf, data);
        exit;
    end;
    // will look into other loaded modules.
	modInfo.size := sizeof(TModuleCmdInfo);
    if TslcFindCommandModule(AInterp, command, @modInfo) then
    begin
		proc := TLockBoxGetProc(GetProcAddress(modInfo.handle, 'LockBoxGet'));
		if @proc = nil then
        	TclError('Unable to access foreign LockBox');
		// The following cast to TTclCmdLockBox is only for preventing a compiler error. Since the cmd
        // originated from the module whose procedure we're calling, we know the data is good
		len := proc(TTclCmdLockBox(modInfo.command), pChar(cypherKey), nil, 0);
		if len >= 0 then
        begin
        	SetString(data, nil, len);
			if proc(TTclCmdLockBox(modInfo.command), pChar(cypherKey), pChar(data), len + 1) <> 0 then
	        	TclError('Unable to read LockBox');
        end;
        exit;
    end else
    	TclErrorFmt('%s is not a LockBox command', [command]);
end;

function LockBoxSet(cmd: TTclCmdLockBox; data: pChar): integer; cdecl;
begin
	try
		cmd.SetStr(data);
	    result := 0;
    except
    	result := -1;
    end;
end;

procedure LockBoxSetStr(AInterp: pTcl_Interp; command, data: string); // Throws EDESError;
var
	buf: array[0..cMaxKeyLen] of char;
	cmd: TTclCommand;
    modInfo: TModuleCmdInfo;
    proc: TLockBoxSetProc;
    len: integer;
begin
	cmd := TslcFindCommand(AInterp, command);
	if cmd is TTclCmdLockBox then
    begin
        TTclCmdLockBox(cmd).SetStr(data);
        exit;
    end;
    // will look into other loaded modules.
	modInfo.size := sizeof(TModuleCmdInfo);
    if TslcFindCommandModule(AInterp, command, @modInfo) then
    begin
		proc := TLockBoxSetProc(GetProcAddress(modInfo.handle, 'LockBoxSet'));
		if @proc = nil then
        	TclError('Unable to access foreign LockBox');
		// The following cast to TTclCmdLockBox is only for preventing a compiler error. Since the cmd
        // originated from the module whose procedure we're calling, we know the data is good
		if proc(TTclCmdLockBox(modInfo.command), pChar(data)) <> 0 then
        	TclError('Unable to write LockBox');
        exit;
    end else
    	TclErrorFmt('%s is not a LockBox command', [command]);
end;

exports
	LockBoxEncode, LockBoxDecode, LockBoxGet, LockBoxSet;

constructor TTclCmdLockBox.Create(AOwner: TComponent; ACommand: string);
begin
	inherited Create(AOwner);
    MinArgs := 2;
    MaxArgs := 2;
	Command := ACommand;
    ErrorMsg := 'Syntax: LockBox <SetData Clear|GetData Key>';
    Options := [coParse, coCatchAll, coObjectCommand, coAutoFree];
end;

destructor TTclCmdLockBox.Destroy;
begin
	inherited Destroy;
end;

procedure TTclCmdLockBox.SetStr(data: string);
begin
	TslcEnterCritical;
    try
		StaticHexEncode(TslcGetSecondaryKey, data, FCypher);
    finally
    	TslcLeaveCritical;
    end;
end;

procedure TTclCmdLockBox.GetStr(key: pChar; var data: string);
var
	buf: array[0..cCypherHexLen] of char;
begin
	TslcEnterCritical;
    try
    	if StaticEncrypt(key, buf, cCypherHexLen) <> 0 then
        	TclError('Decryption Error');
        if StrComp(buf, TslcGetSecondaryKey) <> 0 then
        	TclError('Invalid Key');
		StaticHexDecode(TslcGetSecondaryKey, FCypher, data);
    finally
    	TslcLeaveCritical;
    end;
end;

procedure TTclCmdLockBox.SetData(data: pointer; dataLen: integer);
begin
end;

procedure TTclCmdLockBox.GetData(key: pChar; var data: pointer; var dataLen: integer);
begin
end;

procedure TTclCmdLockBox.DoCommand(var result: string; var success: boolean);
begin
	if TslcTextEqual(ParamValues[0], 'SETDATA') then
    	SetStr(ParamValues[1])
    else if TslcTextEqual(ParamValues[0], 'GETDATA') then
    	GetStr(pChar(ParamValues[1]), result)
    else
    	TclError(ErrorMsg);
end;

procedure TTclCmdLockBox.DoInterpDelete(AInterp: pTcl_Interp);
begin
end;

procedure TTclCmdLockBox.DoPrepare(var result: string; var success: boolean);
begin
end;

procedure TTclCmdLockBox.DoScriptDelete(AInterp: pTcl_Interp);
begin
end;


initialization
	TslcPrepareCritical;
	SetStaticKey(TslcGetStaticKey, 0);

finalization
	TslcDoneCritical;

end.
