{ -----------------------------------------------------------------------
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 uTslcCmp;

///////////////////////////////////////////////////////////////////////////////
//
//  uTslcCmp.pas
//	Copyright(c) 1996-1997 William Byrne
//		WilliamB@ByrneLitho.com
//		76262.13@CompuServe.com
//
//	All rights reserved.
//  	William Byrne makes no representations about the suitability of this
//		software for any purpose.  It is provided "as is" without express or
//    	implied warranty.
//
//	Usage
//      I hereby grant to the legal purchasors of the source code contained
//      herein a non-exclusive license for the use of said source code in
//      developing compiled, executable software, and for the distribution of
//      said source code as part of said developed, compiled, executable software.
//
//	Editor:
//		Tab stops = 4
//		Page width = 132 characters
//		Font = Courier New, 8pt
//
//  Misc:
//      ??? = Note to self

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  TclTk, Tslc, TslcServ, StdCtrls;

type
  TCompressMod = class(TTclThreadServer)
    TclCompress: TTcl;
    TclCmd_Compress: TTclCommand;
    TclCmd_Decompress: TTclCommand;
    TclCmd_Compress_w: TTclCmdSwitch;
    TclCmd_Decompress_w: TTclCmdSwitch;
    TclDES: TTcl;
    TclCmd_Encrypt: TTclCommand;
    TclCmd_Decrypt: TTclCommand;
    TclCmd_Encrypt_w: TTclCmdSwitch;
    TclCmd_Decrypt_w: TTclCmdSwitch;
    TclCmd_Decrypt_v: TTclCmdSwitch;
    TclCmd_StaticKey: TTclCommand;
    TclCmd_StaticKey_c: TTclCmdSwitch;
    TclCmd_StaticEncode: TTclCommand;
    TclCmd_StaticDecode: TTclCommand;
    TclCmd_StaticKey_h: TTclCmdSwitch;
    TclCmd_Deflate: TTclCommand;
    TclCmd_Inflate: TTclCommand;
    TclCmd_Deflate_c: TTclCmdSwitch;
    TclCmd_LockBoxEncode: TTclCommand;
    TclCmd_LockBoxDecode: TTclCommand;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    TclCmd_AboutDES: TTclCommand;
    TclCmd_VersionDES: TTclCommand;
    TclCmd_AboutZLib: TTclCommand;
    TclCmd_VersionZLib: TTclCommand;
    TclCmd_InflateStream: TTclCommand;
    TclCmd_DeflateStream: TTclCommand;
    procedure TclCompressBeforeInitInterp(Sender: TObject; AInterp: pTcl_Interp);
    procedure TclCmd_CompressCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_Compress_wSwitch(Sender: TTclCmdSwitch;
      ASwitch: string; var result: string; var success: Boolean);
    procedure TclCmd_CompressPrepare(Sender: TTclCommand; var result: string; var success: boolean);
    procedure TclCmd_DecompressCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_EncryptCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_EncryptPrepare(Sender: TTclCommand; var result: string; var success: boolean);
    procedure TclCmd_Encrypt_wSwitch(Sender: TTclCmdSwitch;
      ASwitch: string; var result: string; var success: Boolean);
    procedure TclCmd_DecryptCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_Encrypt_vSwitch(Sender: TTclCmdSwitch;
      ASwitch: string; var result: string; var success: Boolean);
    procedure TclCmd_DecryptPrepare(Sender: TTclCommand; var result: string; var success: boolean);
    procedure TclCmd_StaticKeyCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_StaticKey_cSwitch(Sender: TTclCmdSwitch;
      ASwitch: string; var result: string; var success: Boolean);
    procedure TclCmd_StaticKeyCreate(Sender: TTclCommand);
    procedure TclCmd_StaticKeyDestroy(Sender: TTclCommand);
    procedure TclCmd_StaticKeyPrepare(Sender: TTclCommand; var result: string; var success: boolean);
    procedure TclCmd_StaticEncodeCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_StaticDecodeCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_StaticKey_hSwitch(Sender: TTclCmdSwitch;
      ASwitch: string; var result: string; var success: Boolean);
    procedure TclCmd_DeflatePrepare(Sender: TTclCommand; var result: string; var success: boolean);
    procedure TclCmd_Deflate_cSwitch(Sender: TTclCmdSwitch;
      ASwitch: string; var result: string; var success: Boolean);
    procedure TclCmd_DeflateCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_InflateCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_LockBoxEncodeCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_LockBoxDecodeCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCompressAfterInitInterp(Sender: TObject;
      AInterp: pTcl_Interp);
    procedure TclDESAfterInitInterp(Sender: TObject; AInterp: pTcl_Interp);
    procedure TclCmd_AboutDESCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_VersionDESCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_AboutZLibCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_VersionZLibCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_InflateStreamCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_DeflateStreamPrepare(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_DeflateStreamCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
  private
    { Private declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent; AThreadId: integer); override;
	class function GetThreadServer(AThreadId: integer): TCompressMod;
    procedure Serve(AClient: TTcl); override;
    procedure ServeInterp(AInterp: pTcl_Interp); override;
    procedure Unserve(AClient: TTcl);
  end;


const
	TSLC_COMPRESS_VERSION_MAJOR = 1;
	TSLC_COMPRESS_VERSION_MINOR = 0;
	TSLC_COMPRESS_VERSION_ISSUE = 'a';
	TSLC_COMPRESS_NAME = 'TslcCompress';

	TSLC_DES_VERSION_MAJOR = 1;
	TSLC_DES_VERSION_MINOR = 0;
	TSLC_DES_VERSION_ISSUE = 'a';
	TSLC_DES_NAME = 'TslcDES';


procedure CompressServeThread(AThreadId: integer; AClient: TTcl);
procedure CompressServeThreadInterp(AThreadId: integer; AInterp: pTcl_Interp);

implementation
uses TslcUtil, TslcHash, TslcPlat, TslcZLib, TslcDes, TslcKey, TslcLock, uTslcUti;
{$R *.DFM}

procedure CompressServeThread(AThreadId: integer; AClient: TTcl);
begin
	if AClient = nil then
    	exit;
	with TCompressMod.GetThreadServer(AThreadId) do
    	Serve(AClient);
end;

procedure CompressServeThreadInterp(AThreadId: integer; AInterp: pTcl_Interp);
begin
	if AInterp = nil then
    	exit;
	with TCompressMod.GetThreadServer(AThreadId) do
    	ServeInterp(AInterp);
end;

constructor TCompressMod.Create(AOwner: TComponent; AThreadId: integer);
begin
	InitTcl('');
    inherited Create(AOwner, AThreadId);

	// prevents normal library initialization procedure, Tslc_Init, from acting on these TTcl instances.
    TclDES.AutoActivate := False;
    TclCompress.AutoActivate := False;
end;

class function TCompressMod.GetThreadServer(AThreadId: integer): TCompressMod;
begin
	result := TTclThreadServer.GetThreadServer(TCompressMod, AThreadId) as TCompressMod;
end;

procedure TCompressMod.Serve(AClient: TTcl);
var
	x: integer;
begin
	if AClient = nil then // ??? should also check for redundancy
    	exit;

	for x:= 0 to ComponentCount - 1 do
    	if (Components[x] is TTclBridge) and (TTclBridge(Components[x]).Client = AClient) then
			exit;


    with TTclBridge.Create(Self) do
    begin
        Options := Options + [boFreeOnClientFree];
    	Server := TclCompress;
        Client := AClient;
    end;
    with TTclBridge.Create(Self) do
    begin
        Options := Options + [boFreeOnClientFree];
    	Server := TclDES;
        Client := AClient;
    end;
end;

procedure TCompressMod.Unserve(AClient: TTcl);
var
    x: integer;
begin

	for x:= ComponentCount - 1 downto 0 do
    	if (Components[x] is TTclBridge) and (TTclBridge(Components[x]).Client = AClient) then
        begin
        	Components[x].Free;
//            break;
        end;
end;



procedure TCompressMod.ServeInterp(AInterp: pTcl_Interp);
begin
	TclCompress.ServiceInterp(AInterp);
	TclDES.ServiceInterp(AInterp);
end;

procedure TCompressMod.TclCompressBeforeInitInterp(Sender: TObject;
  AInterp: pTcl_Interp);
begin
	InitZLib('');
end;

procedure TCompressMod.TclCmd_CompressCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	CompressFile(Sender.ParamValues[0], Sender.ParamValues[1], Sender.ClientData <> nil);
end;

procedure TCompressMod.TclCmd_Compress_wSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	if TslcStrTruth(Sender.SplitDef(ASwitch, '+')) then
		Sender.Command.ClientData := TObject(1)
	else
		Sender.Command.ClientData := nil;
end;

procedure TCompressMod.TclCmd_CompressPrepare(Sender: TTclCommand; var result: string; var success: boolean);
begin
	Sender.ClientData := nil;
end;

procedure TCompressMod.TclCmd_DecompressCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	DecompressFile(Sender.ParamValues[0], Sender.ParamValues[1], Sender.ClientData <> nil);
end;

const
	cOverwrite = 1;
	cVerifyKey = 2;

procedure TCompressMod.TclCmd_Encrypt_wSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	with Sender.Command do
		if TslcStrTruth(Sender.SplitDef(ASwitch, '+')) then
			ClientData := TObject(integer(ClientData) or cOverwrite)
		else
			ClientData := TObject(integer(ClientData) and not cOverwrite);
end;

procedure TCompressMod.TclCmd_Encrypt_vSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	with Sender.Command do
		if TslcStrTruth(Sender.SplitDef(ASwitch, '+')) then
			ClientData := TObject(integer(ClientData) or cVerifyKey)
		else
			ClientData := TObject(integer(ClientData) and not cVerifyKey);
end;

procedure TCompressMod.TclCmd_EncryptPrepare(Sender: TTclCommand; var result: string; var success: boolean);
begin
	Sender.ClientData := nil;
end;

procedure TCompressMod.TclCmd_DecryptPrepare(Sender: TTclCommand; var result: string; var success: boolean);
begin
	Sender.ClientData := TObject(cVerifyKey);
end;

procedure TCompressMod.TclCmd_EncryptCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	with Sender do
		DESFile(ParamValues[0], ParamValues[1], ParamValues[2], true,
			integer(ClientData) and cOverwrite <> 0, False);
end;

procedure TCompressMod.TclCmd_DecryptCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	with Sender do
		DESFile(ParamValues[0], ParamValues[1], ParamValues[2], false,
			integer(ClientData) and cOverwrite <> 0, integer(ClientData) and cVerifyKey <> 0);
end;

var
	StaticScriptLocked: boolean = True; // Prevents unauthorized usage of StaticKey Decrypt and StaticDecode
	UnlockCypher: string; // = TslcKey.TslcGetSecondaryKey; // Centralizing for convenience. Set in Initialization

type
	TCypherHexList = class(TStringList)
    public
		LastAdd: pChar;
		Hex: boolean;
	end;

procedure TCompressMod.TclCmd_StaticKeyPrepare(Sender: TTclCommand; var result: string; var success: boolean);
begin
	with Sender.ClientData as TCypherHexList do
	begin
		LastAdd := nil;
		Hex := False;
	end;
end;

procedure TCompressMod.TclCmd_StaticKey_cSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	with Sender.Command.ClientData as TCypherHexList do
		LastAdd := pChar(Strings[Add(Sender.Split(ASwitch))])
end;

procedure TCompressMod.TclCmd_StaticKey_hSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	with Sender.Command.ClientData as TCypherHexList do
		Hex := TslcStrTruth(Sender.SplitDef(ASwitch, '+'));
end;

procedure TCompressMod.TclCmd_StaticKeyCreate(Sender: TTclCommand);
begin
	Sender.ClientData := TCypherHexList.Create;
end;

procedure TCompressMod.TclCmd_StaticKeyDestroy(Sender: TTclCommand);
begin
	Sender.ClientData.Free;
end;

procedure TCompressMod.TclCmd_StaticKeyCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	buf:array[0..cCypherHexLen] of char;
	key:array[0..cMaxKeyLen] of char;
    n: integer;

	procedure Needs2;
	begin
		if Sender.ParamValuesCount < 2 then
			TclError(Sender.ErrorMsg);
	end;

	function pKey(akey: string): pChar;
	var
		x: integer;
	begin
		result := key;
		for x:= 0 to cMaxKeyLen do
			key[x] := #0;
		if (Sender.ClientData as TCypherHexList).Hex then
		begin
			if Hex2Bytes(key, cMaxKeyLen + 1, pChar(akey), strlen(pChar(akey))) <> 0 then
				TclError('Invalid Hex string');
		end else if strlen(pChar(akey)) > cMaxKeyLen then
			TclError('Key too long')
		else
			strcopy(key, pChar(akey));
	end;
begin
	with Sender do
	begin
		if TslcTextEqual(ParamValues[0], 'GEN') or TslcTextEqual(ParamValues[0], 'GENERATE') then
		begin
			Needs2;
			success := GenStaticKey(pKey(ParamValues[1]), buf, cCypherHexLen) = 0;
			if success then
				result := buf
			else
				result := 'Unable to generate static key';
		end else if TslcTextEqual(ParamValues[0], 'SET') then
		begin
			if ParamValuesCount = 1 then
				n := SetStaticKey(nil, 0)
			else
				n := SetStaticKey(pChar(ParamValues[1]), 0);
            success := n = 0;
			if not success then
				result := 'Invalid cypher hex key'
			else
				StaticScriptLocked := True;
		end else if TslcTextEqual(ParamValues[0], 'ENCRYPT') then
		begin
			Needs2;
			success := StaticEncrypt(pChar(ParamValues[1]), buf, cCypherHexLen) = 0;
			if not success then
				result := 'Unable to encypher key'
			else
				result := buf;
		end else if TslcTextEqual(ParamValues[0], 'DECRYPT') then
		begin
			Needs2;
			if StaticScriptLocked then
				TclError('StaticKey operation locked out');
			success := StaticDecrypt(pChar(ParamValues[1]), buf, cCypherHexLen) = 0;
			if not success then
				result := 'Unable to decypher CypherHex'
			else
				result := buf;
		end else if TslcTextEqual(ParamValues[0], 'UNLOCK') then // script level
		begin
			Needs2;
			if not StaticScriptLocked then
				exit;
			if UnlockCypher = '' then
				TclError('Cannot unlock');
			Sleep(750); // this should slow down script level attackers a bit...
			if StaticEncrypt(pChar(ParamValues[1]), buf, cCypherHexLen) <> 0 then
				TclError('Error while unlocking');
			if buf = UnlockCypher then
				StaticScriptLocked := False
			else
				TclError('Invalid key');
		end else if TslcTextEqual(ParamValues[0], 'LOCK') then // script level
		begin
			StaticScriptLocked := True;
		end else if TslcTextEqual(ParamValues[0], '_UNLOCK') then // machine level - no effect when in default StaticKey.
		begin 													// _LOCK and _UNLOCK may be undesirable to use since
			Needs2;												// it will be necessary to pass the same clear key to
			success := StaticUnlock(pKey(ParamValues[1])) = 0;	// StaticUnlock that was used to generate the custom StaticKey.
			if not success then									// Opposed to a script level lock, a machine level lock would
				result := 'Cannot unlock';						// prevent usage of StaticDecrypt without the availability of
		end else if TslcTextEqual(ParamValues[0], '_LOCK') then // the clear key used to generate the custom StaticKey. The lock
		begin													// mechanism prevents unauthorized usage of StaticDecrypt and
			StaticLock;											// StaticDecode; thereby, preventing decyphering of encoded data.
		end else if TslcTextEqual(ParamValues[0], 'CALLBACK') then
		begin
			Needs2;
			if not TslcTextEqual(ParamValues[1], 'BDE') then
				TclError('Unsupported Callback. Must be BDE');
			if TCypherHexList(ClientData).LastAdd = nil then
				TclError('BDE Password Callback requires -c switch having CypherHex appendage; e.g., -c7FAC02...');
			result := format('{ %d %d }', [integer(@StaticHexDecode), integer(TCypherHexList(ClientData).LastAdd)]);
		end else
			TclError(ErrorMsg);
	end;
end;

procedure TCompressMod.TclCmd_StaticEncodeCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	StaticHexEncode(pChar(Sender.ParamValues[0]), Sender.ParamValues[1], result);
end;

procedure TCompressMod.TclCmd_StaticDecodeCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	if StaticScriptLocked then
		TclError('Static operation locked out');
	StaticHexDecode(pChar(Sender.ParamValues[0]), Sender.ParamValues[1], result);
end;

function LockBoxEncodeProc(clear, cypher: pChar; cypherLen: integer): integer; cdecl;
var
	buf: string;
begin
	try
    	StaticHexEncode(TslcGetSecondaryKey, clear, buf);
		result := Length(buf) + 1;
        if (cypher <> nil) and (cypherLen >= result) then
        begin
        	strcopy(cypher, pChar(buf));
            result := 0;
        end;
    except
    	result := -1;
    end;
end;

function LockBoxDecodeProc(cypher, clear: pChar; clearLen: integer): integer; cdecl;
var
	buf: string;
begin
	try
		StaticHexDecode(TslcGetSecondaryKey, cypher, buf);
        result := Length(buf) + 1;
        if (clear <> nil) and (clearLen >= result) then
        begin
        	strcopy(clear, pChar(buf));
            result := 0;
        end;
    except
    	result := -1;
    end;
end;

procedure TCompressMod.TclCmd_LockBoxEncodeCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	LockBoxCommandEncode(Sender.Interp, Sender.ParamValues[0], @LockBoxEncodeProc, TslcGetSecondaryKey);
end;

procedure TCompressMod.TclCmd_LockBoxDecodeCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	LockBoxCommandDecode(Sender.Interp, Sender.ParamValues[0], @LockBoxDecodeProc, TslcGetSecondaryKey);
end;

procedure TCompressMod.TclCmd_DeflatePrepare(Sender: TTclCommand; var result: string; var success: boolean);
begin
	Sender.ClientData := TObject(Z_DEFAULT_COMPRESSION);
end;

procedure TCompressMod.TclCmd_Deflate_cSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	Sender.Command.ClientData := TObject(TslcStrToInt(Sender.SplitDef(ASwitch, IntToStr(Z_DEFAULT_COMPRESSION))));
end;

procedure TCompressMod.TclCmd_DeflateCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	src, dest: TFileStream;
begin
	src := TFileStream.Create(Sender.ParamValues[0], fmOpenRead);
	try
		dest := TFileStream.Create(Sender.ParamValues[1], fmCreate);
	except
		src.Free;
		raise;
	end;
	try
		DeflateStream(src, dest, integer(Sender.ClientData));
	finally
		try
			src.Free;
		finally
			dest.Free;
		end;
	end;
end;

procedure TCompressMod.TclCmd_InflateCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	src, dest: TFileStream;
begin
	src := TFileStream.Create(Sender.ParamValues[0], fmOpenRead);
	try
		dest := TFileStream.Create(Sender.ParamValues[1], fmCreate);
	except
		src.Free;
		raise;
	end;
	try
		InflateStream(src, dest);
	finally
		try
			src.Free;
		finally
			dest.Free;
		end;
	end;
end;

// This following is hacked from the Tcl engine "C" code. There's no need figure it out.
procedure TCompressMod.TclCompressAfterInitInterp(Sender: TObject;
  AInterp: pTcl_Interp);
var
	ver: string;
begin
	ver := format('%d.%d', [TSLC_COMPRESS_VERSION_MAJOR, TSLC_COMPRESS_VERSION_MINOR]);
	Tcl_PkgProvide(AInterp, TSLC_COMPRESS_NAME, pChar(ver));
end;

procedure TCompressMod.TclDESAfterInitInterp(Sender: TObject;
  AInterp: pTcl_Interp);
var
	ver: string;
begin
	ver := format('%d.%d', [TSLC_DES_VERSION_MAJOR, TSLC_DES_VERSION_MINOR]);
	Tcl_PkgProvide(AInterp, TSLC_DES_NAME, pChar(ver));
end;

procedure TCompressMod.TclCmd_AboutDESCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	result := DES_About;
end;

procedure TCompressMod.TclCmd_VersionDESCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	result := DES_Version;
end;

procedure TCompressMod.TclCmd_AboutZLibCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	result :=
    'zlib 1.0.4 is a general purpose data compression library.' + #10 + #10 +
	'(C) 1995-1996 Jean-loup Gailly and Mark Adler' + #10 + #10 +
	'This software is provided ''as-is'', without any express or implied' + #10 +
	'warranty.  In no event will the authors be held liable for any damages' + #10 +
	'arising from the use of this software.' + #10 + #10 +
	'Permission is granted to anyone to use this software for any purpose,' + #10 +
  	'including commercial applications, and to alter it and redistribute it' + #10 +
  	'freely, subject to the following restrictions:' + #10 +
    '  1. The origin of this software must not be misrepresented; you must not' + #10 +
    '     claim that you wrote the original software. If you use this software' + #10 +
    '     in a product, an acknowledgment in the product documentation would be' + #10 +
    '     appreciated but is not required.' + #10 +
  	'  2. Altered source versions must be plainly marked as such, and must not be' + #10 +
    '     misrepresented as being the original software.' + #10 +
  	'  3. This notice may not be removed or altered from any source distribution.';
end;

procedure TCompressMod.TclCmd_VersionZLibCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	result := '1.0.4';
end;

procedure TCompressMod.TclCmd_InflateStreamCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	src, dest: TTclCommandStream;
begin
	src := TTclCommandStream(TslcFindCommand(Sender.Interp, Sender.ParamValues[0]));
	dest := TTclCommandStream(TslcFindCommand(Sender.Interp, Sender.ParamValues[1]));
    if not (src is TTclCommandStream) then
    	TclErrorFmt('%s is not a TslcUtility::Stream object',[Sender.ParamValues[0]]);
    if not (dest is TTclCommandStream) then
    	TclErrorFmt('%s is not a TslcUtility::Stream object',[Sender.ParamValues[1]]);

	InflateStream(src.Stream, dest.Stream);
end;

procedure TCompressMod.TclCmd_DeflateStreamPrepare(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	Sender.ClientData := TObject(Z_DEFAULT_COMPRESSION);
end;

procedure TCompressMod.TclCmd_DeflateStreamCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	src, dest: TTclCommandStream;
begin
	src := TTclCommandStream(TslcFindCommand(Sender.Interp, Sender.ParamValues[0]));
	dest := TTclCommandStream(TslcFindCommand(Sender.Interp, Sender.ParamValues[1]));
    if not (src is TTclCommandStream) then
    	TclErrorFmt('%s is not a TslcUtility::Stream object',[Sender.ParamValues[0]]);
    if not (dest is TTclCommandStream) then
    	TclErrorFmt('%s is not a TslcUtility::Stream object',[Sender.ParamValues[1]]);

	DeflateStream(src.Stream, dest.Stream, integer(Sender.ClientData));
end;

initialization
    RegisterTclServer(TCompressMod);

 	// Commenting out next line would result in the usage of the default StaticKey.
	SetStaticKey(TslcGetStaticKey, 0); // Created using script: StaticKey Gen <?secretkey?>
	UnlockCypher := TslcGetSecondaryKey;

finalization

end.

