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

///////////////////////////////////////////////////////////////////////////////
//
//  uTslcLib.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
  TResourceMod = class(TTclThreadServer)
    TclResource: TTcl;
    TclCmd_source: TTclCommand;
    TclCmd_file: TTclCommand;
    TclCmd_image: TTclCommand;
    TclCmd_image_file: TTclCmdSwitch;
    TclCmd_image_photo: TTclCmdParam;
    TclCmd_interp: TTclCommand;
    TclCmd_interp_create: TTclCmdParam;
    TclCmd_interp_safe: TTclCmdSwitch;
    TclCmd_interp_: TTclCmdSwitch;
    TclCmd_interp_default: TTclCmdSwitch;
    TclCmd_file_exists: TTclCmdParam;
    TclCmd_file_isdir: TTclCmdParam;
    TclCmd_load: TTclCommand;
    TclCmd_load_tk: TTclCmdParam;
    TclCmd_glob: TTclCommand;
    TclCmd_glob_: TTclCmdSwitch;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    procedure TclCmd_sourceCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclResourceAfterInitInterp(Sender: TObject; AInterp: pTcl_Interp);
    procedure TclResourceBeforeInitInterp(Sender: TObject; AInterp: pTcl_Interp);
    procedure TclCmd_fileCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_imageCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_image_fileSwitch(Sender: TTclCmdSwitch;
      ASwitch: string; var result: string; var success: Boolean);
    procedure TclCmd_imagePrepare(Sender: TTclCommand; var result: string; var success: boolean);
    procedure TclCmd_image_photoParam(Sender: TTclCmdParam; APos: Integer;
      AParam: string; var result: string; var success: Boolean);
    procedure TclCmd_interp_createParam(Sender: TTclCmdParam;
      APos: Integer; AParam: string; var result: string;
      var success: Boolean);
    procedure TclCmd_interpPrepare(Sender: TTclCommand; var result: string; var success: boolean);
    procedure TclCmd_interpCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_interp_safeSwitch(Sender: TTclCmdSwitch;
      ASwitch: string; var result: string; var success: Boolean);
    procedure TclCmd_interp_defaultSwitch(Sender: TTclCmdSwitch;
      ASwitch: string; var result: string; var success: Boolean);
    procedure TclCmd_file_existsParam(Sender: TTclCmdParam; APos: Integer;
      AParam: string; var result: string; var success: Boolean);
    procedure TclCmd_file_isdirParam(Sender: TTclCmdParam; APos: Integer;
      AParam: string; var result: string; var success: Boolean);
    procedure TclCmd_filePrepare(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_loadCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_load_tkParam(Sender: TTclCmdParam; APos: Integer;
      AParam: string; var result: string; var success: Boolean);
    procedure TclCmd_loadPrepare(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_globPrepare(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_globCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure CompressModCreate(Sender: TObject);
  private
    { Private declarations }
    FSourceInfo, FFileInfo, FImageInfo, FInterpInfo, FLoadInfo, FGlobInfo: Tcl_CmdInfo;
    FCanGetImageInfo: integer;
	FAutoDecrypt: boolean;
    procedure InstallResourceCommands(AInterp: pTcl_Interp);
  public
    { Public declarations }
    constructor Create(AOwner: TComponent; AThreadId: integer); override;
	class function GetThreadServer(AThreadId: integer): TResourceMod;
    procedure Serve(AClient: TTcl); override;
    procedure Unserve(AClient: TTcl);
    procedure ServeInterp(AInterp: pTcl_Interp); override;
    property AutoDecrypt: boolean read FAutoDecrypt write FAutoDecrypt;
  end;

const
    cTslcTclResLibPath	= '/tcl8.0'; // ??? what about version
    cTslcTkResLibPath	= '/tk8.0';
    cTslcTixResLibPath	= '/tix4.1/library'; // ??? what about version
	cTslcVTclResLibPath	= '/vtcl';

function ResourceServeThread(AThreadId: integer; AClient: TTcl): TResourceMod;
function ResourceServeThreadInterp(AThreadId: integer; AInterp: pTcl_Interp): TResourceMod;

{$DEFINE TIX_RESOURCE}
{$DEFINE VTCL_RESOURCE}

function AsTclFile(const filename: string): string;
function ExtractTclFilePath(const filename: string): string;
function ExtractTclFileExt(const filename: string): string;

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

{$R TslcLibs.res} 	// Contains scripts & images needed by Tcl, Tk, & possibly Tix.
					// Tslc_Libs.rc was generated using ./Tslc1.0/library/dev/TslcLibs.tcl
					// If needed, build Simple.dpr for a basic script processor.
					// See tslc_lic.rc for info on compiling resource

function ResourceServeThread(AThreadId: integer; AClient: TTcl): TResourceMod;
begin
	if AClient = nil then
    	result := nil
    else
	    result := TResourceMod.GetThreadServer(AThreadId);
	if result <> nil then
    	result.Serve(AClient);
end;

function ResourceServeThreadInterp(AThreadId: integer; AInterp: pTcl_Interp): TResourceMod;
begin
	if AInterp = nil then
    	result := nil
    else
    	result := TResourceMod.GetThreadServer(AThreadId);
    if result <> nil then
    	result.ServeInterp(AInterp);
end;

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

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

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

procedure TResourceMod.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 := TclResource;
        Client := AClient;
    end;
end;

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

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


procedure TResourceMod.ServeInterp(AInterp: pTcl_Interp);
begin
	TclResource.ServiceInterp(AInterp);
end;


// From SysUtils with modification ->  '/'
function ExtractFilePath(const FileName: string): string;
var
  I: Integer;
begin
  I := Length(FileName);
  while (I > 0) and not (FileName[I] in ['/', '\', ':']) do Dec(I);
  Result := Copy(FileName, 1, I);
end;

// From SysUtils with modification ->  '/'
function ExtractFileExt(const FileName: string): string;
var
  I: Integer;
begin
  I := Length(FileName);
  while (I > 0) and not (FileName[I] in ['/', '.', '\', ':']) do Dec(I);
  if (I > 0) and (FileName[I] = '.') then
    Result := Copy(FileName, I, 255) else
    Result := '';
end;

procedure InitFileList; forward;
function PrepareFileName(const filename: string): string; forward;
function PrepareDirName(const dirname: string): string; forward;
function IsFileExpr(filename: string): boolean; forward;
function IsDirExpr(dir: string): boolean; forward;
function NativeName(const filename: string): string; forward;
function FindFileResHash(const filename: string): integer; forward;

const
	cRsrcPrefix = 'TSLC_%d';


{$IFDEF TIX_RESOURCE}
{$IFDEF VTCL_RESOURCE}
const
	cFileExp = '[\\/]tcl8\.0[\\/].*|[\\/]tk8\.0[\\/].*|[\\/]tix4\.1[\\/]library[\\/].*|[\\/]vtcl[\\/].*|[\\/]tix4\.1[\\/].*';
	cDirExp = '[\\/]tcl8\.0|[\\/]tcl8\.0[\\/].*|[\\/]tk8\.0|[\\/]tk8\.0[\\/].*|[\\/]tix4\.1[\\/]library|[\\/]tix4\.1[\\/]library[\\/].*|[\\/]vtcl|[\\/]vtcl[\\/].*[\\/]tix4\.1|[\\/]tix4\.1[\\/].*';

{$ELSE}
const
	cFileExp = '[\\/]tcl8\.0[\\/].*|[\\/]tk8\.0[\\/].*|[\\/]tix4\.1[\\/]library[\\/].*';
	cDirExp = '[\\/]tcl8\.0|[\\/]tcl8\.0[\\/].*|[\\/]tk8\.0|[\\/]tk8\.0[\\/].*|[\\/]tix4\.1[\\/]library|[\\/]tix4\.1[\\/]library[\\/].*';

{$ENDIF}
{$ELSE}
{$IFDEF VTCL_RESOURCE}
const
	cFileExp = '[\\/]tcl8\.0[\\/].*|[\\/]tk8\.0[\\/].*|[\\/]vtcl[\\/].*';
	cDirExp = '[\\/]tcl8\.0|[\\/]tcl8\.0[\\/].*|[\\/]tk8\.0|[\\/]tk8\.0[\\/].*|[\\/]vtcl|[\\/]vtcl[\\/].*';

{$ELSE}
const
	cFileExp = '[\\/]tcl8\.0[\\/].*|[\\/]tk8\.0[\\/].*';
	cDirExp = '[\\/]tcl8\.0|[\\/]tcl8\.0[\\/].*|[\\/]tk8\.0|[\\/]tk8\.0[\\/].*';
{$ENDIF}
{$ENDIF}

procedure TResourceMod.TclCmd_sourceCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
const
	cZero: integer = 0;
var
	filename, pword: string;
	st: TTslcScriptType;
	strm, tStrm: TStream;
	dStrm: TFileStream;
    h, retval: integer;
    buf: array[0..cMaxKeyLen] of char;
begin
	if Sender.ParamValuesCount  > 0 then
	begin
		// determine if sourcing native Tcl/Tk lib scripts that have been resourced
		filename := Sender.ParamValues[0];
		if IsFileExpr(filename) then // qualify path
        	h := FindFileResHash(PrepareFileName(filename))
        else
        	h := 0;

		if h <> 0 then  // Yes, load from resource
        begin
			filename := format(cRsrcPrefix, [h]);
			try
				strm := TslcLoadBinaryResource(HInstance, '', filename);
				try
					tStrm := TMemoryStream.Create;
					try
					   	InflateStream(strm, tStrm);
						tStrm.Write(cZero, 1);
						success := Tcl_Eval(Sender.Interp, pChar(TMemoryStream(tStrm).Memory)) <> TCL_ERROR;
						result := Tcl_GetStringResult(Sender.Interp);
					finally
						tStrm.Free;
					end;
				finally
					strm.Free;
				end;
				exit;
			except
				// Unable to load/eval resource. Let's try normal program flow.
			end;
		end;

		// let's see if we're sourcing an encrypted/compressed file. Determined by file ext.
    	// ??? should account for resourced-encrypted files. Above resource bails out before getting here.
        filename := NativeName(Sender.ParamValues[0]);
		st := StrToScriptType(ExtractFileExt(filename));
		if (st <> stNormal)  and FileExists(filename) then
		begin
			if not (st in [stEncrypted, stCompressedEncrypted]) then
				pword := ''
			else if Sender.ParamValuesCount < 2 then
            begin
            	if FAutoDecrypt then
                begin
					retval := StaticDecrypt(TslcGetSecondaryKey, buf, cMaxKeyLen + 1);
				    if retval <> 0 then
				    	TclErrorFmt('Hard Error: %d', [retval]);
                    pword := buf;
                end else
					TclErrorFmt('Error sourcing %s', [filename]); //(Sender.ErrorMsg);
			end else
				pword := Sender.ParamValues[1];
			strm := TFileStream.Create(filename, fmOpenRead);
			tStrm := strm;
			try
				strm := UncrunchScriptStream(strm, st, pword);
                strm.Seek(0, soFromEnd);
				strm.Write(cZero, 1);
			finally
				tStrm.Free;
			end;
			try
				success := Tcl_GlobalEval(Sender.Interp, pChar(ConvertPEOL(TMemoryStream(strm).Memory))) <> TCL_ERROR;
				result := Tcl_GetStringResult(Sender.Interp);
			finally
				strm.Free;
			end;
			exit;
		end;
	end;
	success := Sender.InvokeCmd(@FSourceInfo) <> TCL_ERROR;
	result := Sender.InterpResult;
end;

const
	cFileExists = 0;
    cFileIsDir	= 1;

procedure TResourceMod.TclCmd_filePrepare(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	Sender.Flags := 0;
end;

procedure TResourceMod.TclCmd_file_existsParam(Sender: TTclCmdParam;
  APos: Integer; AParam: string; var result: string; var success: Boolean);
begin
	Sender.Command.Flag[cFileExists] := True;
end;

procedure TResourceMod.TclCmd_file_isdirParam(Sender: TTclCmdParam;
  APos: Integer; AParam: string; var result: string; var success: Boolean);
begin
	Sender.Command.Flag[cFileIsDir] := True;
end;

procedure TResourceMod.TclCmd_fileCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
    isDir, found: boolean;                 
begin
	// The intent of this native command override is to filter requests for the existance of
	// Tcl/Tk lib files that have been resourced in the module. If the file in question has been
	// resourced we return a value of 1; otherwise, pass off to native command via InvokeCmd(...)
	isDir := Sender.Flag[cFileIsDir];
	if (Sender.ParamValuesCount  > 1) and
		(isDir or Sender.Flag[cFileExists]) then
	begin
		// determine if sourcing native Tcl/Tk lib scripts that have been resourced
		if isDir then
			found := IsDirExpr(Sender.ParamValues[1]) and (FindFileResHash(PrepareDirName(Sender.ParamValues[1])) <> 0)
        else
			found := IsFileExpr(Sender.ParamValues[1]) and (FindFileResHash(PrepareFileName(Sender.ParamValues[1])) <> 0);

		if found then
        begin
			result := '1';
			exit;
		end;
	end;
	success := Sender.InvokeCmd(@FFileInfo) <> TCL_ERROR;
	result := Sender.InterpResult;
end;

procedure TResourceMod.TclCmd_imagePrepare(Sender: TTclCommand; var result: string; var success: boolean);
begin
	Sender.ClientData := nil;
	Sender.Tag := 0;
end;

procedure TResourceMod.TclCmd_image_fileSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	if Sender.RelativeParamCount > 0 then
		Sender.Command.ClientData := TObject(MakeLong(Sender.Command.Arg, Sender.RelativeParam)); //Current raw argv index & Rel Param
end;

procedure TResourceMod.TclCmd_image_photoParam(Sender: TTclCmdParam;
  APos: Integer; AParam: string; var result: string; var success: Boolean);
begin
	// APos references the param position in the command line where the first param is index 1
	if (Sender.Command.ParamValuesCount > APos) and TslcTextEqual(Sender.Command.ParamValues[APos], 'GIF') then
		Sender.Command.Tag := 1; // Indicate the next param contains the GIF photo type
end;

procedure TResourceMod.TclCmd_imageCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
const
	cData: pChar = '-data';
    cFile: pChar = '-file';
var
	argv, _argv: Tcl_Argv;
	argc, switch, param, h: integer;
	filename, ext, tmp: string;
	x: integer;
	objArgs: boolean;
	obj1, obj2: pChar; // pTcl_Obj; //
	strm: TMemoryStream;
    fstrm: TFileStream;
    e64, ppm: boolean;
    pLoc, pData: pChar;
begin
	if Sender.ClientData <> nil then
	begin
		switch := LoWord(integer(Sender.ClientData));
		param := HiWord(integer(Sender.ClientData));

		filename := Sender.ParamValues[param];
        if IsFileExpr(filename) then
        	h := FindFileResHash(PrepareFileName(filename))
        else
        	h := 0;

		if h <> 0 then // Yes, load from resource
		begin
			argc := Sender.Argc;
			argv := Sender.RawArgv;
			objArgs := Sender.ObjectArgs;
            ext := UpperCase(ExtractFileExt(filename));
            e64 := ext = '.GIF'; // Sender.Tag <> 0
            ppm := ext = '.PPM';
			filename := format('TSLC_%d', [h]);
			try
				strm := TslcLoadImageResource(HInstance, '', filename, e64);
				try
					GetMem(_argv, argc * sizeof(pointer));
					try
                    	if ppm then // ???
                        begin
							tmp := TempFile;
                            pLoc := cFile;
                            pData := pChar(tmp);
                        	fstrm := TFileStream.Create(tmp, fmOpenWrite);
                            try
                                fstrm.CopyFrom(strm, strm.Size);
                            finally
                            	fstrm.Free;
                            end;
                        end else
                        begin
                        	pLoc := cData;
                            pData := pChar(strm.Memory);
                        end;


					   	if objArgs then
						begin
							obj1 := pChar(Tcl_NewStringObj(pLoc, -1));
							Tcl_IncrRefCount(pTcl_Obj(obj1));
							obj2 := pChar(Tcl_NewStringObj(pData, -1));
							Tcl_IncrRefCount(pTcl_Obj(obj2));
						end else
						begin
							obj1 := pLoc;
							obj2 := pData;
						end;
						try
							for x := 0 to argc - 1 do
							   	if x = switch then
								   	AssignArgvItem(_argv, x, obj1)
								else if x = switch + 1 then
								   	AssignArgvItem(_argv, x, obj2)
								else
								   	AssignArgvItem(_argv, x, ArgvItem(argv, x));
								success := TslcInvokeCmd(Sender.Interp, @FImageInfo, argc, _argv, objArgs) <> TCL_ERROR;
								result := Sender.InterpResult;
						finally
							if objArgs then
							begin
								Tcl_DecrRefCount(pTcl_Obj(obj1));
								Tcl_DecrRefCount(pTcl_Obj(obj2));
							end;
						end;
					finally
						FreeMem(_argv);
                        if ppm then
                        	DeleteFile(tmp);
					end;
				finally
				   	strm.Free;
				end;
				exit;
			except
					// Unable to load image -file resource. Let's try normal program flow.
			end;
		end;
	end;
   	success := Sender.InvokeCmd(@FImageInfo) <> TCL_ERROR;
	result := Sender.InterpResult;
end;

procedure TResourceMod.InstallResourceCommands(AInterp: pTcl_Interp);
var
	info: Tcl_CmdInfo;
begin
	InitFileList;
	if Tcl_GetCommandInfo(AInterp, 'source', info) <> 0 then
	begin
		if IsTslcCmdInfo(TclCmd_source, @info, nil) then
			TclError('Potential infinite recursion in "source" command');
        FSourceInfo := info;
		TclCmd_source.Install(AInterp);
	end else if false then
		TclError('TslcCompress: unable to locate native *source* command');

	if Tcl_GetCommandInfo(AInterp, 'file', info) <> 0 then
	begin
		if IsTslcCmdInfo(TclCmd_file, @info, nil) then
			TclError('Potential infinite recursion in "file" command');
        FFileInfo := info;
		TclCmd_file.Install(AInterp);
	end else if false then
		TclError('TslcCompress: unable to locate native *file* command');

	if Tcl_GetCommandInfo(AInterp, 'interp', info) <> 0 then
	begin
		if IsTslcCmdInfo(TclCmd_interp, @info, nil) then
			TclError('Potential infinite recursion in "interp" command');
        FInterpInfo := info;
		TclCmd_interp.Install(AInterp);
	end else if false then
		TclError('TslcCompress: unable to locate native *interp* command');

	if Tcl_GetCommandInfo(AInterp, 'load', info) <> 0 then
	begin
		if IsTslcCmdInfo(TclCmd_load, @info, nil) then
			TclError('Potential infinite recursion in "load" command');
        FLoadInfo := info;
		TclCmd_load.Install(AInterp);
	end else if false then
		TclError('TslcCompress: unable to locate native *load* command');

	if Tcl_GetCommandInfo(AInterp, 'glob', info) <> 0 then
	begin
		if IsTslcCmdInfo(TclCmd_glob, @info, nil) then
			TclError('Potential infinite recursion in "glob" command');
        FGlobInfo := info;
		TclCmd_glob.Install(AInterp);
	end else if false then
		TclError('TslcCompress: unable to locate native *glob* command');

end;


procedure TResourceMod.TclResourceAfterInitInterp(Sender: TObject;
  AInterp: pTcl_Interp);
var
	str: string;
begin
	InstallResourceCommands(AInterp);
//	Tcl_PkgProvide(AInterp, 'Tcl', '8.0');

    // Tslc is dcu
    if not Tslc.GetVar(AInterp, 'errorCode', '', str, [tfGlobalOnly]) or // assume Tcl not initialized. Let's do it now.
		Tslc.GetVar(AInterp, 'tslc_compress_force_init', '', str, [tfGlobalOnly]) then
	begin
//		Tslc.SetVar(AInterp, 'tcl_library', '', cTslcTclResLibPath, [tfGlobalOnly]);
		str := Format(	'set tcl_library %s' 						+ #10 +
    				 	'lappend auto_path $tcl_library'			+ #10 +
    				 	'package forget Tcl'						+ #10 +
        	            'package ifneeded Tcl 8.0 { '				+ #10 +
            	        '    set dir $tcl_library'					+ #10 +
                	    '    source $dir/tclIndex'					+ #10 +
	                    '    package provide Tcl 8.0'				+ #10 +
    	                '}', [cTslcTclResLibPath]);
		Tcl_GlobalEval(AInterp, pChar(str));

        Tcl_Init(AInterp);
    end;

    str := Format(	'package ifneeded Tk 8.0 {	'		+ #10 +
    				'	load Tk80;				'		+ #10 +
                    '	set dir $tk_library		'		+ #10 +
                    '	source $dir/tclIndex	'		+ #10 +
                    '	package provide Tk 8.0	'		+ #10 +
                    '}', [0]);

    Tcl_GlobalEval(AInterp, pChar(str));


    // When terminating a statement by using an EOL instead of semicolon, use #$A instead of #$D.
    // The Tcl engine doesn't recognize #13 as an EOL; however, #10 works fine. Remember, Tcl
    // will use a linefeed character, #$A, as a statement terminator in the absence of semicolon.
    //
    // Tslc.ConvertPEOL(src: pChar): pChar - will convert #$D and (#$D #$A) pairs to $#A. Work
    // is performed on the src buffer; thereby, potentially shrinking its sz size. Returns src.
{$IFDEF TIX_RESOURCE}

	// the following prevents redirection of our resourced tix library from within tix.tcl.
    // tix.tcl has been modified to accept our resourced tix library path:

    str :=	'if ![info exists tslc_priv(tixResourced)] {'	+ #10 +
            '	set tslc_priv(tixResourced) 1'				+ #10 +
            '}';
	Tcl_GlobalEval(AInterp, pChar(str));
	// user apps can preset tslc_priv(tixResourced) to a preferred value
    // if tslc_priv does not appear in tix.tcl, then the tix.tcl script is out of version with this topology


	str := Format(	'set tix_library %s' 						                + #10 +
    			 	'lappend auto_path $tix_library'                            + #10 +
                    'package ifneeded tix 4.1 { '	                            + #10 +
                    '    set dir $tix_library'					                + #10 +
                    '    source $dir/tclIndex'					                + #10 +
                    '    if [catch {load $tslc_library/tix4.1/tix4180.dll}] {'	+ #10 +
                    '        if [catch {load $tix_library/tix4180.dll}] {'      + #10 +
                    '            error "could not load $tslc_library/tix4.1/tix4180.dll and $tix_library/tix4180.dll"' + #10 +
					'        }'                                                 + #10 +
                    '    }'                                                     + #10 +
                    '    package provide tix 4.1'				                + #10 +
                    '}', [cTslcTixResLibPath]);
	Tcl_GlobalEval(AInterp, pChar(str));
{$ENDIF}
{$IFDEF VTCL_RESOURCE}
	str := Format(	'set env(VTCL_HOME) %s', [cTslcVTclResLibPath]);
	Tcl_GlobalEval(AInterp, pChar(str));
{$ENDIF}
	Tcl_ResetResult(AInterp); // return empty string in interpeter result
end;

procedure TResourceMod.TclResourceBeforeInitInterp(Sender: TObject;
  AInterp: pTcl_Interp);
begin
	InitZLib('');
end;


// The following interp switches and command emulate internals of
// the Tcl engine. The purpose is to make slave interpreters that
// are created by virtue of the *interp create...* command aware
// of the scripts stored in resource.

const // for TTclCommand.Flags - up to 32 flags can be defined for each TTclCommand object
	cCreateSubCommand	= 0;
	cSafeSwitch			= 1;
    cDefaultUnknown		= 2;

procedure TResourceMod.TclCmd_interpPrepare(Sender: TTclCommand; var result: string; var success: boolean);
begin
	Sender.Flags := 0;
end;

procedure TResourceMod.TclCmd_interp_safeSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	Sender.Command.Flag[cSafeSwitch] := True;
end;

procedure TResourceMod.TclCmd_interp_defaultSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	// extra switches... pass off to native for error control
    Sender.Command.Flag[cDefaultUnknown] := True;
end;

procedure TResourceMod.TclCmd_interp_createParam(Sender: TTclCmdParam;
  APos: Integer; AParam: string; var result: string; var success: Boolean);
begin
	Sender.Command.Flag[cCreateSubCommand] := True;
end;

type
	pSlave = ^TSlave;
	TSlave = record
    	masterInterp:	pTcl_Interp;
        slaveEntry:     pTcl_HashEntry;
        slaveInterp:	pTcl_Interp;
        interpCmd:		pTcl_Command;
        aliasTable:		Tcl_HashTable;
    end;
    pMaster = ^TMaster;
    TMaster = record
    	slaveTable:		Tcl_HashTable;
        targetTable:	Tcl_HashTable;
    end;

// This following is hacked from the Tcl engine "C" code. There's no need figure it out.
procedure TResourceMod.TclCmd_interpCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
const
	cInterpCounter: integer = 0;
    objCmd: TTclObjCmdProc = nil;
    delProc: TTclCmdDeleteProc = nil;
    assocProc: TTcl_InterpDeleteProc = nil;
var
	masterPtr: pMaster;
    slavePtr: pSlave;
    interp, masterInterp, slaveInterp: pTcl_Interp;
    x: integer;
    slavePath: pChar;
    info: Tcl_CmdInfo;
    argc, cnt, new: integer;
    argv: Tcl_Argv;
    safe, lift: boolean;
    hPtr: pTcl_HashEntry;
    proc: TTcl_InterpDeleteProc;
    str: string;
    pHT: pHashTable;
begin
	interp := Sender.Interp;
    cnt := Sender.ParamValuesCount;
    lift := (cnt < 3) and Sender.Flag[cCreateSubCommand] and not Sender.Flag[cDefaultUnknown];
	if lift then // encountered create subcommand with or without safe flag
    begin
    	if @objCmd = nil then
        begin
			slaveInterp := Tcl_CreateSlave(interp, 'tslcdummyslave',  1);
			if (Tcl_GetCommandInfo(interp, 'tslcdummyslave', info) = 1) and
            	(info.isNativeObjectProc <> 0) then
            begin
				objCmd := info.objProc;
                delProc := info.deleteProc;
            end;
            Tcl_GetAssocData(slaveInterp, 'tclSlaveRecord', assocProc);
            Tcl_DeleteInterp(slaveInterp);
    		if (@objCmd = nil) or (@assocProc = nil) then
            	TclError('Cannot mount native slave interpreter handlers');
        end;

    	safe := Sender.Flag[cSafeSwitch];
	    masterPtr := Tcl_GetAssocData(interp, 'tclMasterRecord', proc);
    	if masterPtr = nil then
    		TclError('Could not find master record');
		if cnt > 1 then
        begin
        	str := Sender.ParamValues[1];
        	slavePath := pChar(str);
        end else while true do
        begin
			str := format('interp%d', [cInterpCounter]);
            slavePath := pChar(str);
            inc(cInterpCounter);
            if Tcl_GetCommandInfo(interp, pChar(slavePath), info) = 0 then
            	break;
        end;
        if Tcl_SplitList(interp, slavePath, argc, argv) <> TCL_OK then
        	TclError('Unable to create slave interpreter');
		try
			if argc < 2 then
	        begin
	        	masterInterp := interp;
	            if argc = 1 then
	            	slavePath := ArgvItem(argv, 0);
	        end else
	        begin
				masterInterp := interp;
                for x:= 0 to argc - 2 do
                begin
                	hPtr := Tcl_FindHashEntry(@masterPtr^.slaveTable, ArgvItem(argv, x));
                    if hPtr = nil then
                    	TclError('Unable to parse slave path');
                    slavePtr := Tcl_GetHashValue(hPtr);
                    masterInterp := slavePtr^.slaveInterp;
                    if masterInterp = nil then
                    	TclError('Unable to parse slave path');
                    masterPtr := Tcl_GetAssocData(masterInterp, 'tclMasterRecord', proc);
                    if masterPtr = nil then
                    	TclError('Unable to parse slave path');
                end;

           		slavePath := ArgvItem(argv, argc - 1);
				if not safe then
                   	safe := Tcl_IsSafe(masterInterp) <> 0;
        	end;
            pHT := @(masterPtr^.slaveTable);
			hPtr := Tcl_CreateHashEntry(pHT, slavePath, @new);
            if new = 0 then
            	TclErrorFmt('%s Interpreter already exists', [slavePath]);
            slaveInterp := Tcl_CreateInterp;
            if slaveInterp = nil then
            	TclError('Out of memory');
            slavePtr := Tcl_GetAssocData(slaveInterp, 'tclSlaveRecord', proc);
            slavePtr^.masterInterp := masterInterp;
            slavePtr^.slaveEntry := hPtr;
            slavePtr^.slaveInterp := slaveInterp;
			slavePtr^.interpCmd := Tcl_CreateObjCommand(masterInterp, slavePath,
            	@objCmd, slaveInterp, @delProc);
            pHT := @(slavePtr^.aliasTable);
			Tcl_InitHashTable(pHT, TCL_STRING_KEYS);
            Tcl_SetAssocData(slaveInterp, 'tclSlaveRecord', assocProc, slavePtr);
            Tcl_SetHashValue(hPtr, slavePtr);
            Tcl_SetVar(slaveInterp, 'tcl_interactive', '0', TCL_GLOBAL_ONLY);

            // add in
            InstallResourceCommands(slaveInterp);

            if safe then
            	success := Tcl_MakeSafe(slaveInterp) <> TCL_ERROR
            else
            	success := Tcl_Init(slaveInterp) <> TCL_ERROR;
            if not success then
            begin
	            result := Tcl_GetStringResult(slaveInterp);
            	Tcl_ResetResult(slaveInterp);
                Tcl_DeleteCommand(masterInterp, slavePath);
            end else
            	result := slavePath;
        finally
        	Tcl_Free(pChar(argv));
        end;
	end else
    begin
		success := Sender.InvokeCmd(@FInterpInfo) <> TCL_ERROR;
		result := Sender.InterpResult;
    end;
end;

procedure TResourceMod.TclCmd_loadPrepare(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	Sender.ClientData := nil;
end;

procedure TResourceMod.TclCmd_load_tkParam(Sender: TTclCmdParam;
  APos: Integer; AParam: string; var result: string; var success: Boolean);
begin
	Sender.Command.ClientData := TObject(FCanGetImageInfo);
end;

procedure TResourceMod.TclCmd_loadCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);

	function TempDLL(dll: string): string;
	var
		pathbuf: array[0..MAX_PATH] of char;
        attr, len: integer;
        path: String;
	begin
		if (GetTempPath(MAX_PATH, pathbuf) = 0) then
        	TclError('Unable to located temporary directory for resource load');
        len := strlen(pathbuf);
        if (len > 0) and (pathbuf[len - 1] = '\') then
        	pathbuf[len - 1] := #0;

        strlcat(pathbuf, '\tslc\', MAX_PATH);

        attr := FileGetAttr(pathbuf);
        if attr = -1 then
        begin
        	if not CreateDirectory(pathbuf, nil) then
            	TclErrorFmt('Unable to create temporary directory for resource load: 0x%x', [GetLastError()]);
		end else if (attr and faDirectory) = 0 then
        	TclErrorFmt('Unable to access temporary directory for resource load: %s', [pathbuf]);

        path := ExtractFileName(NativeName(dll));
        strlcat(pathbuf, pChar(path), MAX_PATH);
        if ExtractFileExt(pathbuf) = '' then
	        strlcat(pathbuf, '.dll', MAX_PATH);
    	result := pathbuf;
	end;


var
	info: Tcl_CmdInfo;

	filename, dllname, path: string;
	strm, tStrm: TStream;
    fStrm: TFileStream;
    h: integer;
    args: array[0..3] of pChar;
    arg0, arg1, arg2, arg3: string;
begin
	if Sender.ParamValuesCount > 0 then
    begin
		// determine if loading binaries that have been resourced
		filename := Sender.ParamValues[0];
		if IsFileExpr(filename) then // qualify path
        	h := FindFileResHash(PrepareFileName(filename))
        else
        	h := 0;

		if h <> 0 then  // Yes, load from resource
        begin
            dllname := TempDLL(filename);
			filename := format(cRsrcPrefix, [h]);
    		if not fileExists(dllname) then
            begin
				strm := TslcLoadBinaryResource(HInstance, '', filename);
				try
					tStrm := TMemoryStream.Create;
					try
					   	InflateStream(strm, tStrm);
                        tStrm.Position := 0;
                       	fStrm := TFileStream.Create(dllname, fmCreate);
                        try
							if fStrm.CopyFrom(tStrm, tStrm.size) <> tStrm.size then
                            	TclError('Unable to extract resource for load');
                        finally
                        	fStrm.Free;
                        end;
					finally
						tStrm.Free;
					end;
				finally
					strm.Free;
				end;
			end;
           	arg0 := Sender.Argv[0];
            AssignArgvItem(@args, 0, pChar(arg0));
            arg1 := dllname;
            AssignArgvItem(@args, 1, pChar(arg1));
            if Sender.Argc > 2 then
            begin
            	arg2 := Sender.Argv[2];
                AssignArgvItem(@args, 2, pChar(arg2));
            end;
            if Sender.Argc > 3 then
            begin
            	arg3 := Sender.Argv[3];
                AssignArgvItem(@args, 3, pChar(arg3));
            end;
            if Sender.Argc <= 4 then
            begin
            	success := TslcInvokeCmd(Sender.Interp, @FLoadInfo, Sender.Argc, @args, False) <> TCL_ERROR;
                result := Sender.InterpResult;
                exit; // since we're not loading the Tk library from resource (too big), exit. the
                	  // special handling for the image command below is for the Tk lib.
            end;
		end;
	end;


	success := Sender.InvokeCmd(@FLoadInfo) <> TCL_ERROR;
    result := Sender.InterpResult;

	if Sender.ClientData <> nil then
		if Tcl_GetCommandInfo(Sender.Interp, 'image', info) <> 0 then
		begin
			if IsTslcCmdInfo(TclCmd_image, @info, nil) then
				TclError('Potential infinite recursion in "image" command');
            FImageInfo := info;
            FCanGetImageInfo := 0; // Load may be called frequently so...
			TclCmd_image.Install(Sender.Interp);
		end else if false then
			TclError('TslcCompress: unable to locate native *image* command');

end;

var
	FFileList, FDirList: TStrings;
    FHashList: TList;
    FRegFileProg, FRegDirProg: pointer;


procedure InitFileList;
	function HashDirName(filename: string): integer;
    var
    	expr, h: string;
    begin
        expr := PrepareDirName(ExtractFilePath(filename));
        h := UpperCase(expr);
        result := Hash(pChar(h));
        if FDirList.IndexOfObject(TObject(result)) < 0 then
	        FDirList.AddObject(expr, TObject(result));
    end;
var
	strm, tStrm: TMemoryStream;
    x: integer;
    n: string;
begin
	TslcEnterCritical;
    try
	    if FFileList = nil then
        begin
		    FFileList := TStringList.Create;
		    FDirList := TStringList.Create;
            FHashList := TList.Create;
			InitZLib('');
			strm := TslcLoadBinaryResource(HInstance, '', 'TSLC_FILELIST');
			try
				tStrm := TMemoryStream.Create;
				try
				   	InflateStream(strm, tStrm);
					tStrm.Position := 0;
					FFileList.LoadFromStream(tStrm);
		            with FFileList do
		            	for x:= 0 to Count - 1 do
                        begin
                        	n := Names[x];
		                	Objects[x] := TObject(HashDirName(n));
                            FHashList.add(pointer(Hash(pChar(n))));
                        end;
//                    FFileList.SaveToFile('d:\temp\filelistharmony.txt');
				finally
					tStrm.Free;
				end;
			finally
				strm.Free;
			end;
        end;
    finally
    	TslcLeaveCritical;
    end;
end;

function FindFileResHash(const filename: string): integer;
var
    u: string;
    x: integer;
begin
	u := UpperCase(filename);
    result := Hash(pChar(u));
    with FHashList do
    for x:= 0 to Count - 1 do
    	if result = integer(items[x]) then
        	exit;
	result := 0;
end;

function NativeName(const filename: string): string;
var
	p: pChar;
begin
	result := filename;
    p := pChar(result);
	while p^ <> #0 do
    begin
    	if p^ = '/' then
        	p^ := '\';
        inc(p);
    end;
end;

function IsDirExpr(dir: string): boolean;
begin
	if FRegDirProg = nil then
    	result := False
    else
		result := TclRegExec(FRegDirProg, pChar(dir), pChar(dir)) = 1;
end;

function IsFileExpr(filename: string): boolean;
begin
	if FRegFileProg = nil then
    	result := False
    else
		result := TclRegExec(FRegFileProg, pChar(filename), pChar(filename)) = 1;
end;

procedure TResourceMod.CompressModCreate(Sender: TObject);
begin
	FCanGetImageInfo := 1;
end;

function ExtractTclFilePath(const filename: string): string;
var
	len: integer;
begin
	result := ExtractFilePath(filename);
    // Tcl convention for well known dir paths normally does not include trailing '/'
	len := length(result);
    if (len > 0) and (result[len] = '/') then
    	Delete(result, len, 1);
end;

function ExtractTclFileExt(const filename: string): string;
begin
	result := ExtractFileExt(filename);
end;

function AsTclFile(const filename: string): string;
begin
	result := PrepareFileName(filename);
end;

function PrepareFileName(const filename: string): string;
var
	p: pChar;
begin
	result := filename;
	p := pChar(result);
    while p^ <> #0 do
    begin
    	if p^ = '\' then
        	p^ := '/';
        inc(p);
    end;
end;

function PrepareDirName(const dirname: string): string;
var
	l: integer;
    p: pChar;
begin
	result := PrepareFileName(dirname);
	l := length(result);
	p := pChar(result);
    if l > 1 then
	begin
    	inc(p, l - 2);
        if (p^ = '/') and ((p + 1)^ = '.') then
        	exit;
        if (p^ = '/') or ((p + 1)^ <> '/') then
        	result := result + '/.'
        else
        	result := result + '.';
    end else if (l > 0) and (p^ <> '/') and (p^ <> '.') then
    	result := result + '/.';
end;

procedure TResourceMod.TclCmd_globPrepare(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
//
end;

procedure TResourceMod.TclCmd_globCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	dir, dir2, str, pattern, pattern2: string;
	x, cnt, y, h, z, p: integer;
    match, tryDir2, tryPat2: boolean;
    list: TStrings;
begin

    list := nil;
	with Sender do
    try
    	cnt := ParamValuesCount;
        for x:= 0 to cnt - 1 do
        begin
        	pattern := ParamValues[x];

            dir := PrepareDirName(ExtractFilePath(pattern));

            pattern := UpperCase(PrepareFileName(pattern));
            pattern2 := pattern;
			repeat
				p := Pos('/*/', pattern2);
	            if p > 0 then
	   	           	Delete(pattern2, p, 2);
	        until p = 0;
			tryPat2 := pattern <> pattern2;



            // determine if sourcing native Tcl/Tk lib scripts that have been resourced

			if IsDirExpr(dir) then
            begin
                dir := UpperCase(dir);
				dir2 := dir;
				repeat
					p := Pos('/*/', dir2);
	                if p > 0 then
	    	           	Delete(dir2, p, 2);
	            until p = 0;
				tryDir2 := dir <> dir2;

            	for y := 0 to FDirList.Count - 1 do
                begin
					str := UpperCase(FDirList.Strings[y]);
					match := Tcl_StringMatch(pChar(str), pChar(dir)) <> 0;
                    if not match and tryDir2 then
						match := Tcl_StringMatch(pChar(str), pChar(dir2)) <> 0;

                    if match then
                    begin
                    	h := integer(FDirList.Objects[y]);
	                    for z := 0 to FFileList.Count - 1 do
	                    begin
		                    if h <> integer(FFileList.Objects[z]) then
		                    	continue;

		                	str := UpperCase(FFileList.names[z]);

		                    match := Tcl_StringMatch(pChar(str), pChar(pattern)) <> 0;
                            if not match and tryPat2 then
                            	match := Tcl_StringMatch(pChar(str), pChar(pattern2)) <> 0;

                            if match then
		                    begin
		                    	if list = nil then
		                        	list := TStringList.Create;
		                        list.add(LowerCase(str));
		                    end;
                        end;
                    end;
                end;
			end;
        end;
       	if list <> nil then
			result := Tslc.MergeList(list);
    finally
    	list.Free;
    end;
	if list <> nil then
    	exit;

	success := Sender.InvokeCmd(@FGlobInfo) <> TCL_ERROR;
    result := Sender.InterpResult;

end;

// The following two are critically wrapped
procedure StartUp(clientData: pointer);
begin
	if FRegFileProg = nil then
		FRegFileProg := TclRegComp(cFileExp);

    if FRegDirProg = nil then
    	FRegDirProg := TclRegComp(cDirExp);

end;

procedure CleanUp(clientData: pointer);
begin
	if FRegFileProg <> nil then
    	Tcl_Free(FRegFileProg);
    if FRegDirProg <> nil then
    	Tcl_Free(FRegDirProg);
end;

initialization
	AddTslcLibHook(@StartUp, nil, thAfterTclLoad); // see TclTk for declaration
	AddTslcLibHook(@CleanUp, nil, thBeforeTclUnload); // see TclTk for declaration

    RegisterTclServer(TResourceMod);
    TslcPrepareCritical;

finalization
	TslcDoneCritical;
    FFileList.Free;
    FDirList.Free;
    FHashList.Free;
end.

 