unit Tslc;
{ -----------------------------------------------------------------------
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
------------------------------------------------------------------------}


///////////////////////////////////////////////////////////////////////////////
//
//  TclDbTbl.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.
//
//  Purpose:
//		This file provides for Bde Table Manipulation using the
//		Tcl Scripting Language Components.
//
//	Editor:
//		Tab stops = 4
//		Page width = 132 characters
//		Font = Courier New, 8pt
//
//  Misc:
//      ??? = Note to self

{$Z+}
//{$D-,L-,Y-,R-,H+} // R=Range checking, H=Long Strings
{$O+}

interface

uses
 SysUtils, Classes, Controls, TclTk;

const
	MAX_TCL_IDENT_LEN 	= 32;
    WM_NAMECHANGE		= 2048;
    TSLC_VERSION_MAJOR	= 1; // v0.7
    TSLC_VERSION_MINOR	= 0; // v0.7
    TSLC_VERSION_ISSUE	= 'e'; //v0.7
    cTslcVersion		= 'TslcVersion'; // v0.7
    cTslcIssue			= 'TslcIssue'; //v1.0
	MAX_HASH_VALUES		= 8 * sizeof(integer); // v1.0

type

	ETclError = class(Exception);

	TTclIdent = string[MAX_TCL_IDENT_LEN];

	PTclNewName = ^TTclNewName;
    TTclNewName = record
    	Comp: TComponent;
        NewName: TComponentName;
    end;


    TTclState = set of (tsInterpDeleteProc);
    TTclComponent = class(TComponent)
    private
    	FTclState: TTclState;
        FClientData: TObject;
        FDeletionFlag: pInteger;
	protected
		procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    public
    	destructor Destroy; override;
	   	procedure ClientDataNotify; // adds notification for transparant ClientData deletion
		property ClientData: TObject read FClientData write FClientData;
    	property TclState: TTclState read FTclState;
    end;

	TTclEventSource = class;
	TTclEventSetupEvent = procedure(Sender: TTclEventSource; flags: integer) of object;
    TTclEventCheckEvent = TTclEventSetupEvent;
	TTclEventSource = class(TTclComponent)
    private
    	FActive: boolean;
		FStreamedActive: boolean; //v1.0
    	FOnSetup: TTclEventSetupEvent;
        FOnCheck: TTclEventCheckEvent;
        procedure SetActive(value: boolean);
    protected
    	procedure Loaded; override;
    public
    	constructor Create(AOwner: TComponent); override;
        destructor Destroy; override;
		procedure DoCheck(flags: integer);
        procedure DoSetup(flags: integer);
        procedure Install;
        procedure Uninstall;
    published
        property Active: boolean read FActive write SetActive default False; // v1.0
//    	property AutoActive: boolean read FAutoActive write FAutoActive default True;
    	property OnSetup: TTclEventSetupEvent read FOnSetup write FOnSetup;
        property OnCheck: TTclEventCheckEvent read FOnCheck write FOnCheck;
    end;

    TTclTimer = class;
    TTclTimerEvent = procedure(Sender: TTclTimer) of object;
    TTclTimerKind = (tkIdle, tkModal, tkNormal);
    TTclTimer = class(TTclComponent)   // v0.2
    private
    	FActive: boolean;
//        FAutoActive: boolean;
        FMilliseconds: longint;
        FStreamedActive: boolean;
        FTimerKind: TTclTimerKind;
        FTimerToken: Tcl_TimerToken;
        FOnTimer: TTclTimerEvent;
        procedure DoTimer(kind: TTclTimerKind);
        procedure SetActive(value: boolean);
        procedure SetMilliseconds(val: longint);
        procedure SetTimerKind(kind: TTclTimerKind);
    protected
    	procedure Loaded; override;
    public
    	constructor Create(AOwner: TComponent); override;
        destructor Destroy; override;
        procedure Install;
        procedure Uninstall;
    published
        property Active: boolean read FActive write SetActive default False; // v1.0 published
  //  	property AutoActive: boolean read FAutoActive write FAutoActive default True; //v1.0
		property Milliseconds: longint read FMilliseconds write SetMilliseconds default 1000;
        property TimerKind: TTclTimerKind read FTimerKind write SetTimerKind default tkNormal;
        property OnTimer: TTclTimerEvent read FOnTimer write FOnTimer;
    end;


	TTclChannel = class;
    TTclDriverBlockModeEvent	= procedure(Sender: TTclChannel; mode: integer; var result: integer) of object;
    TTclDriverCloseEvent		= procedure(Sender: TTclChannel; interp: pTcl_Interp; var result: integer) of object;
    TTclDriverInputEvent 		= procedure(Sender: TTclChannel; buf: pChar; toRead: integer; var errorCode: integer;
    								 var result: integer) of object;
    TTclDriverOutputEvent 		= procedure(Sender: TTclChannel; buf: pChar; toWrite: integer; var errorCode: integer;
    								 var result: integer) of object;
    TTclDriverSeekEvent 		= procedure(Sender: TTclChannel; offset: longint; mode: integer; var errorCode: integer;
    								 var result: integer) of object;
    TTclDriverSetOptionEvent	= procedure(Sender: TTclChannel; interp: pTcl_Interp; optionName: pChar; value: pChar;
    								 var result: integer) of object;
	TTclDriverGetOptionEvent	= procedure(Sender: TTclChannel; interp: pTcl_Interp; optionName: pChar; var value: string;
    								 var result: integer) of object;
    TTclDriverWatchEvent		= procedure(Sender: TTclChannel; mask: integer) of object;
    TTclDriverGetHandleEvent	= procedure(Sender: TTclChannel; direction: integer;	var handlePtr: Tcl_ClientData;
    								 var result: integer) of object;

// TTclChannel
	TTcl = class;
	TTclChannelMode = (cmRead, cmWrite, cmReadWrite);
    TTclChannelBuffering = (cbFull, cbLine, cbNone);
    TTclChannelBufferSize = 10..1024*1024;
    TTclChannelEofChar = -1..255;
    TTclChannelTranslation = (ctAuto, ctBinary, ctCr, ctCrLf, ctLf);
    TTclChannelType = (ctNormal, ctStdIn, ctStdOut, ctStdErr);
    TTclChannelOption = (coRegNullInterp, coPresetFullWrite);
    TTclChannelOptions = set of TTclChannelOption;

    TTclChannel = class(TTclComponent)
    private
    	FActive: boolean;
    	FChannel: pTcl_Channel;
        FChannelName: string;
        FMode: TTclChannelMode;
        FChannelData: pointer;
        FChannelType: TTclChannelType;
        FInterpList: TList;
		FOptions: TTclChannelOptions;
		FOldSelf: TObject;
        
        FBlocking: boolean;
        FBuffering: TTclChannelBuffering;
        FBufferSize: TTclChannelBufferSize;
        FEofCharIn: TTclChannelEofChar;
        FEofCharOut: TTclChannelEofChar;
        FStreamedActive: boolean;
        FTranslationIn: TTclChannelTranslation;
        FTranslationOut: TTclChannelTranslation;

        FUpdateDwell, FLastTranslationRead, FLastEofCharRead:  cardinal;

		FOnBlockMode: TTclDriverBlockModeEvent;
        FOnClose: TTclDriverCloseEvent;
        FOnCreate: TNotifyEvent;
        FOnDestroy: TNotifyEvent;
        FOnInput: TTclDriverInputEvent;
        FOnOutput: TTclDriverOutputEvent;
        FOnSeek: TTclDriverSeekEvent;
        FOnSetOption: TTclDriverSetOptionEvent;
        FOnGetOption: TTclDriverGetOptionEvent;
        FOnWatch: TTclDriverWatchEvent;
        FOnGetHandle: TTclDriverGetHandleEvent;
        procedure CallbackClose;
        function GetActive: boolean;
        function GetBlocking: boolean;
        function GetBuffering: TTclChannelBuffering;
        function GetBufferSize: TTclChannelBufferSize;
        function GetEofChar(index: integer): TTclChannelEofChar;
        function GetTranslation(index: integer): TTclChannelTranslation;
        procedure InterpDelete(interp: pTcl_Interp);
        procedure SetActive(value: boolean);
		procedure SetBlocking(value: boolean);
        procedure SetBuffering(value: TTclChannelBuffering);
        procedure SetBufferSize(value: TTclChannelBufferSize);
	    procedure SetChannelName(value: string);
        procedure SetChannelType(value: TTclChannelType);
        procedure SetEofChar(index: integer; value: TTclChannelEofChar);
        procedure SetEofChars(inValue, outValue: TTclChannelEofChar; AMode: TTclChannelMode);
        procedure SetMode(value: TTclChannelMode);
        procedure SetOptions(value: TTclChannelOptions);
    	procedure SetTranslation(index: integer; value: TTclChannelTranslation);
        procedure SetTranslations(inValue, outValue: TTclChannelTranslation; AMode: TTclChannelMode);
        procedure TrackInterp(interp: pTcl_Interp);
        procedure UntrackInterp(interp: pTcl_Interp);
    protected
        procedure CheckActive; // ??? how about public on these
	    procedure DoBlockMode(mode: integer; var result: integer); virtual;
	    procedure DoClose(interp: pTcl_Interp; var result: integer); virtual;
        procedure DoCreate; virtual;
        procedure DoDestroy; virtual;
	    procedure DoInput(buf: pChar; toRead: integer; var errorCode: integer; var result: integer); virtual;
	    procedure DoOutput(buf: pChar; toWrite: integer; var errorCode: integer; var result: integer); virtual;
	    procedure DoSeek(offset: longint; mode: integer; var errorCode: integer; var result: integer); virtual;
	    procedure DoSetOption(interp: pTcl_Interp; optionName: pChar; value: pChar; var result: integer); virtual;
	    procedure DoGetOption(interp: pTcl_Interp; optionName: pChar; var value: string; var result: integer); virtual;
	    procedure DoWatch(mask: integer); virtual;
	    procedure DoGetHandle(direction: integer; var handlePtr: Tcl_ClientData; var result: integer); virtual;
		procedure Loaded; override;
	    procedure SetName(const NewName: TComponentName); override;

    public
    	constructor Create(AOwner: TComponent); override;
        destructor Destroy; override;
        procedure Close;
        function Flush: boolean;
        function GetOption(optName: string; var optValue: string): boolean;
        procedure Open;
        procedure RegisterChannel(interp: pTcl_Interp);
//        procedure RegisterTcl(tcl: TTcl);
		procedure UnregisterChannel(interp: pTcl_Interp);
//        procedure UnregisterTcl(tcl: TTcl);

    	property Channel: pTcl_Channel read FChannel;
        property UpdateDwell: cardinal read FUpdateDwell write FUpdateDwell;
	published
		property Active: boolean read GetActive write SetActive;
        property Blocking: boolean read GetBlocking write SetBlocking;
        property Buffering: TTclChannelBuffering read GetBuffering write SetBuffering;
        property BufferSize: TTclChannelBufferSize read GetBufferSize write SetBufferSize;
        property EofCharIn: TTclChannelEofChar index 0 read GetEofChar write SetEofChar;
        property EofCharOut: TTclChannelEofChar index 1 read GetEofChar write SetEofChar;
		property TranslationIn: TTclChannelTranslation index 0 read GetTranslation write SetTranslation;
		property TranslationOut: TTclChannelTranslation index 1 read GetTranslation write SetTranslation;
    	property ChannelName: string read FChannelName write SetChannelName;
        property ChannelType: TTclChannelType read FChannelType write SetChannelType;
        property Mode: TTclChannelMode read FMode write SetMode;
        property Options: TTclChannelOptions read FOptions write SetOptions default [coPresetFullWrite];
        property OnBlockMode: TTclDriverBlockModeEvent read FOnBlockMode write FOnBlockMode;
        property OnClose: TTclDriverCloseEvent read FOnClose write FOnClose;
        property OnCreate: TNotifyEvent read FOnCreate write FOnCreate;
        property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
        property OnInput: TTclDriverInputEvent read FOnInput write FOnInput;
        property OnOutput: TTclDriverOutputEvent read FOnOutput write FOnOutput;
        property OnSeek: TTclDriverSeekEvent read FOnSeek write FOnSeek;
        property OnGetOption: TTclDriverGetOptionEvent read FOnGetOption write FOnGetOption;
        property OnSetOption: TTclDriverSetOptionEvent read FOnSetOption write FOnSetOption;
        property OnWatch: TTclDriverWatchEvent read FOnWatch write FOnWatch;
        property OnGetHandle: TTclDriverGetHandleEvent read FOnGetHandle write FOnGetHandle;
	end;

	TTclBridgeOption = (boFreeOnClientFree, boFreeOnServerFree);
    TTclBridgeOptions = set of TTclBridgeOption;
	TTclBridge = class(TTclComponent)
    private
    	FServer: TTcl;
        FClient: TTcl;
        FOptions: TTclBridgeOptions;
        procedure SetClient(ATcl: TTcl);
        procedure SetServer(ATcl: TTcl);
    protected
    	procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    public
		destructor Destroy; override;
    published
    	property Client: TTcl read FClient write SetClient;
        property Options: TTclBridgeOptions read FOptions write FOptions;
        property Server: TTcl read FServer write SetServer;
    end;

    TInterpEvent = procedure(Sender: TObject; AInterp: pTcl_Interp) of object;

	TTclCmdType = (ctLocal, ctInternal, ctAll);
	TTclFlag = (tfGlobalOnly, tfReads, tfWrites, tfUnsets, tfDestroyed, tfLeaveErrMsg, tfAppendValue, tfListElement, tfParsePart1);
   	TTclFlags = set of TTclFlag;
  	TTclTrace = class;
    TTclTraceClass = class of TTclTrace;
  	TTclCommand = class;
    TTclCommandClass = class of TTclCommand;
	TTclCommandEvent = procedure(Sender: TTclCommand; var result: string;
   							var success: boolean) of object;
  	TTclEvent = procedure(Sender: TTcl) of object;
    TTclOption = (toPerformInit, toConvertEOL, toTslcVersion, toImportOverwrite, toNoOpExistingNS, toBindExistingNS);
    TTclOptions = set of TTclOption;
    TTclEvalKind = (ekFile, ekResource, ekScript, ekGlobalScript, ekGlobalResource);
  	TTcl = class(TTclComponent)
  	private
    	FActive: boolean;
        FAutoActive: boolean;
//        FCatchAll: boolean; removed 3/19/97
		FAuxInterps: TList;
    	FError: integer;
        FChannels: TList;
    	FCommands: TList;
        FExportPattern: string;
        FImportPattern: string;
        FInterp: pTcl_Interp;
        FInterpList: TList; //v0.7
		FNamespace: string;
        FOldSelf: TObject;
		FOptions: TTclOptions; //v0.7
//        FPerformInit: boolean; //v0.7  - removed 3/19/97
        FSafe: boolean;
        FStreamedActive, FStreamedAutoActive: boolean;
    	FTraces: TList;
    	FBeforeOpen, FAfterOpen, FBeforeClose, FAfterClose: TTclEvent;
    	FBeforeEval, FAfterEval: TTclEvent;
        FDesigner: TObject;
        FOnInterpDelete: TInterpEvent;
		FAfterInitInterp, FBeforeInitInterp, FOnInitError: TInterpEvent;
        FOnNamespaceDelete: TTclEvent;
        FNsPtr: pTcl_Namespace;
        FBridgeList: TList;
    	procedure AddCommand(cmd: TTclCommand);
        procedure AddBridge(ABridge: TTclBridge);
    	procedure AddTrace(trace: TTclTrace);
    	procedure CheckInterp;
        procedure DestroyCommands;
        procedure DestroyTraces;
		function  DoEval(kind: TTclEvalKind; fileName, data: string): boolean;
        function  GetActive: boolean;
        function  GetAuxInterps(index: integer): pTcl_Interp;
        function  GetAuxInterpCount: integer;
        function  GetChannel(index: integer): TTclChannel;
        function  GetChannelCount: integer;
        function  GetCommand(index: integer): TTclCommand;
        function  GetCommandCount: integer;
        function  GetInterp: pTcl_Interp;
        function  GetInterpreterCount: integer;
        function  GetInterpreters(index: integer): pTcl_Interp;
    	function  GetResult: string;
        function  GetTrace(index: integer): TTclTrace;
        function  GetTraceCount: integer;
        procedure InitInterp(_interp: pTcl_Interp; _safe: boolean);
        procedure InstallChannel(channel: TTclChannel);
        procedure InterpDelete(AInterp: pTcl_Interp);
        procedure MakeSafe;
        procedure ReadChannels(Reader: TReader);
	   	procedure RemoveCommand(cmd: TTclCommand);
        procedure RemoveFromInitLists;
        procedure RemoveBridge(ABridge: TTclBridge);
    	procedure RemoveTrace(trace: TTclTrace);
        function  SafeCheckInterp: boolean;
    	procedure SetActive(value: boolean);
        procedure SetAutoActive(value: boolean);
        procedure SetExportPattern(value: string);
        procedure SetImportPattern(value: string);
        procedure SetNamespace(value: string);
        procedure SetSafe(value: boolean);
        procedure ShutDownAll;
        procedure ShutDownInterp(AInterp: pTcl_Interp);
		procedure TrackInterp(_interp: pTcl_Interp);
		procedure UninstallCommand(cmd: TTclCommand);
        procedure UninstallCommands;
        procedure UninstallInterpCommands(AInterp: pTcl_Interp);
    	procedure UninstallTrace(trace: TTclTrace);
        procedure UninstallTraces;
        procedure UninstallInterpTraces(AInterp: pTcl_Interp);
        procedure UnlinkBridges;
        procedure UntrackAll;
        procedure UntrackInterp(_interp: pTcl_Interp);
        procedure WriteChannels(Writer: TWriter);

  	protected
    	procedure AfterClose; virtual;
    	procedure AfterEval; virtual;
        procedure AfterInitInterp(AInterp: pTcl_Interp); virtual;
    	procedure AfterOpen; virtual;
    	procedure BeforeClose; virtual;
    	procedure BeforeEval; virtual;
        procedure BeforeInitInterp(AInterp: pTcl_Interp); virtual;
    	procedure BeforeOpen; virtual;
        procedure CheckActive;
{$IFNDEF VER90}
		procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
{$ELSE}
    	procedure GetChildren(Proc: TGetChildProc); override;
{$ENDIF}
		function  InstallCommand(cmd: TTclCommand; AInterp: pTcl_Interp): integer; virtual;
    	function  InstallTrace(trace: TTclTrace; AInterp: pTcl_Interp): integer; virtual;
		procedure Loaded; override;
        procedure DefineProperties(Filer: TFiler); override;
        procedure DoInterpDelete(AInterp: pTcl_Interp); virtual;
        procedure DoInitError(AInterp: pTcl_Interp); virtual;
		procedure DoNamespaceDelete; virtual;
        procedure Notification(AComponent: TComponent; Operation: TOperation); override; //v0.7
	    procedure SetChildOrder(Child: TComponent; Order: Integer); override;
  	public
    	constructor Create(AOwner: TComponent); override;
    	destructor Destroy; override;

        function  BuildCommand: TTclCommandClass; virtual;	// return derived class, i.e.: result := TMyTclCommand;
        function  BuildTrace: TTclTraceClass; virtual;		// return defived class, i.e.: result := TMyTclTrace;
    	procedure Close;
    	function  ConvertEOL(const script: string): string;
        function  CreateAuxInterp(AOptions: TTclOptions; ASafe: boolean): pTcl_Interp;
        procedure DeleteAuxInterp(index: integer);
//		function  CreateCommand(ACommand: string; AProc: TTclCommandEvent;
    	procedure DeleteTclCommand(cmdName: string);
    	function  Eval(script: string): boolean;
        function  EvalFile(filename: string): boolean;
        function  EvalResource(fileName, resourceId: string): boolean; //v0.7c - use #1234 for numerical resource identifiers.
    	function  GetLocalCommand(cmdName: string): TTclCommand;
    	function  GetCommands(list: TStrings; typ: TTclCmdType; pattern: string):integer;
        function  GetNsPtr: pTcl_Namespace;
        function  GetVar(varName, elemName: string; var value: string; flags: TTclFlags): boolean;
		function  GlobalEval(script: string): boolean;
        function  GlobalEvalResource(fileName, resourceId: string): boolean; //v0.7c - use #1234 for numerical resource identifiers.
        function  IndexOfAux(AInterp: pTcl_Interp): integer;
        function  IndexOfInterpreters(AInterp: pTcl_Interp): integer;
        procedure InsertChannel(channel: TTclChannel);
        function  IsLocalInterp(AInterp: pTcl_Interp): boolean; //v1.0 changes.txt
		function  LinkBoolean(varName: string; var b: longbool; readOnly: boolean): boolean; 	// "C" booleans are integers
        function  LinkDouble(varName: string; var d: double; readOnly: boolean): boolean;
        function  LinkInteger(varName: string; var i: integer; readOnly: boolean): boolean;
        function  LinkString(varName: string; var p: pChar; readOnly: boolean): boolean;       // p must be set to nil
        function  Merge(list: TStrings): string; // v0.7
        procedure MoveCommand(curIdx, newIdx: integer); //v1.0
        procedure MoveTrace(curIdx, newIdx: integer); //v1.0
    	procedure Open;
        procedure PkgProvide(package, version: string);
        procedure RemoveChannel(channel: TTclChannel);
        procedure RemoveChannels;
        function  ResultStrings(list: TStrings): integer; // v1.0
        procedure ServiceInterp(AInterp: pTcl_Interp); // knows how to handle safe & normal interps
        function  SetVar(varName, elemName, newValue: string; flags: TTclFlags): boolean;
        function  SplitList(literal: string; list: TStrings): boolean; // v0.7
        procedure UnlinkVar(varName: string);
        procedure UnserviceInterp(AInterp: pTcl_Interp);
    	function  UnsetVar(varName, elemName: string; flags: TTclFlags): boolean;

//	   	property  Active: boolean read GetActive write SetActive default False;   //v1.0 published
		property  AuxInterps[index: integer]: pTcl_Interp read GetAuxInterps;
        property  AuxInterpCount: integer read GetAuxInterpCount;
		property  Channels[index: integer]: TTclChannel read GetChannel;
        property  ChannelCount: integer read GetChannelCount;
        property  Commands[index: integer]: TTclCommand read GetCommand;
        property  CommandCount: integer read GetCommandCount;
        property  Designer: TObject read FDesigner write FDesigner;
    	property  Error: integer read FError;
    	property  Interp: pTcl_Interp read GetInterp;
        property  InterpreterCount: integer read GetInterpreterCount; //v0.7
        property  Interpreters[index: integer]: pTcl_Interp read GetInterpreters; //v0.7
    	property  Result: string read GetResult;
        property  Traces[index: integer]: TTclTrace read GetTrace;
        property  TraceCount: integer read GetTraceCount;
  	published
	   	property  Active: boolean read GetActive write SetActive default False; // v1.0 5/19/97
    	property AutoActivate: boolean read FAutoActive write SetAutoActive default True;
//		property CatchAll: boolean read FCatchAll write FCatchAll default True;  removed 3/19/97
//      property PerformInit: boolean read FPerformInit write FPerformInit default True; removed 3/19/97
		property ExportPattern: string read FExportPattern write SetExportPattern;
        property ImportPattern: string read FImportPattern write SetImportPattern;
		property Namespace: string read FNamespace write SetNamespace;
		property Options: TTclOptions read FOptions write FOptions default [toConvertEOL,toTslcVersion,toBindExistingNS];
        property Safe: boolean read FSafe write SetSafe default False;
    	property OnBeforeOpen: TTclEvent read FBeforeOpen write FBeforeOpen;
    	property OnAfterOpen: TTclEvent read FAfterOpen write FAfterOpen;
    	property OnBeforeClose: TTclEvent read FBeforeClose write FBeforeClose;
    	property OnAfterClose: TTclEvent read FAfterClose write FAfterClose;
    	property OnBeforeEval: TTclEvent read FBeforeEval write FBeforeEval;
    	property OnAfterEval: TTclEvent read FAfterEval write FAfterEval;
        property OnBeforeInitInterp: TInterpEvent read FBeforeInitInterp write FBeforeInitInterp;
        property OnAfterInitInterp: TInterpEvent read FAfterInitInterp write FAfterInitInterp;
        property OnInterpDelete: TInterpEvent read FOnInterpDelete write FOnInterpDelete;
        property OnInitError: TInterpEvent read FOnInitError write FOnInitError;
        property OnNamespaceDelete: TTclEvent read FOnNamespaceDelete write FOnNamespaceDelete;
  	end;



	TTclTraceEvent = procedure(Sender: TTclTrace; AVarName, AElemName: string; AFlags: TTclFlags; var result: string;
   						var success: boolean) of object;
	TTclTrace = class(TTclComponent)
   	private
   		FVarName, FElemName: TTclIdent;
      	FFlags: TTclFlags;
      	FTcl: TTcl;
        FInterp: pTcl_Interp;
        FInterpList: TList;
        FOldSelf: TObject;
        FOnInterpDelete: TInterpEvent;
      	FOnTrace: TTclTraceEvent;
      	procedure CheckActive;
      	function  ExecTrace(_interp: pTcl_Interp; AVarName: pChar; AElemName: pChar; flags: integer): pChar;
		function  GetInterp: pTcl_Interp;
        procedure InterpDelete(AInterp: pTcl_Interp);
		procedure SetTcl(ATcl: TTcl);
      	procedure SetVarName(AName: TTclIdent);
      	procedure SetElemName(AName: TTclIdent);
      	procedure SetFlags(AFlags: TTclFlags);
        procedure TrackInterp(AInterp: pTcl_Interp);
        procedure UntrackInterp(AInterp: pTcl_Interp);
	protected
    	procedure DefineProperties(Filer: TFiler); override;
        procedure DoInterpDelete(AInterp: pTcl_Interp); virtual;
        procedure DoTrace(AVarName, AElemName: string; flags: TTclFlags; var result: string; var success: boolean); virtual;
    	function  GetParentComponent: TComponent; override;
        function  HasParent: boolean; override;
		function  Install(AInterp: pTcl_Interp): integer;
	    procedure SetName(const NewName: TComponentName); override;
	   	procedure SetParentComponent(Value: TComponent); override;
        procedure Uninstall(AInterp: pTcl_Interp);
        procedure UninstallAll;
	public
   		constructor Create(AOwner: TComponent); override;
      	destructor Destroy; override;
        function  GetVar(var value: string; flags: TTclFlags): boolean;
        function  SetVar(newValue: string; flags: TTclFlags): boolean;
        function  Variable: string;
//      procedure Writing; virtual;
//      procedure Reading; virtual;
        property Interp: pTcl_Interp read GetInterp;
      	property Tcl : TTcl read FTcl write SetTcl;
	published
		property VarName: TTclIdent read FVarName write SetVarName;
      	property ElemName: TTclIdent read FElemName write SetElemName;
      	property Flags: TTclFlags read FFlags write SetFlags default [];
        property OnInterpDelete: TInterpEvent read FOnInterpDelete write FOnInterpDelete;
      	property OnTrace: TTclTraceEvent read FOnTrace write FOnTrace;
	end;


	pTcl_CmdMetaInfo = ^Tcl_CmdMetaInfo; //v1.0
	Tcl_CmdMetaInfo = packed record
    	fullName	: pChar;
    	HashEntry	: pTcl_Command;
        Interp		: pTcl_Interp;
        Command		: TTclCommand;
        Destroyed	: pInteger;
    end;

    TTclCommandMode = (cmBoth, cmNormal, cmSafe);
	TTclCmdSwitchPrefix = (spDash, spSlash, spDashSlash, spNone, spOther); //v0.7 spNone, spOther
	TTclCmdSwitch = class;
    TTclCmdSwitchClass = class of TTclCmdSwitch;
    TTclCmdParam = class;
    TTclCmdParamClass = class of TTclCmdParam;
    TTclCommandOption = (coCallParams, coCallSwitches, coCountSwitches, coParse, coRaiseInvalidSwitch,
    					coNoCreateExists, coCatchAll, coObjectCommand, coAutoInstall, coAutoFree);
    TTclCommandOptions = set of TTclCommandOption;
    TTclCommandHashMethod = (chNormal, chLowerCase, chUpperCase, chOnHash);
	TTclCmdEvent = procedure(Sender: TTclCommand) of object;
	TTclPrepareEvent = procedure(Sender: TTclCommand; var result: string; var success: boolean) of object;
    TTclScriptDeleteEvent = procedure(Sender: TTclCommand; AInterp: pTcl_Interp) of object; //v1.0
    TTclCmdHashEvent = procedure(Sender: TTclCommand; APos: integer; AParam: string; var hash: integer) of object; //v1.0
	TTclCmdExceptionEvent = procedure(Sender: TTclCommand; var message: string; var ignore: boolean; E: exception) of object; //v1.0
   	TTclCommand = class(TTclComponent)
   	private
        FArg: integer;
        FArgc: integer;
        FArgv: Tcl_Argv;
    	FBreak: boolean; //v0.7d breaks out of current Switch Evals or Param Evals
   		FCommand: TTclIdent;
        FCmdMetaInfo: TList; //v1.0
		FEmulation: boolean; // v0.7e
        FEmulResult: pstring;
      	FErrorMsg: string;
        FEvaluating: integer;
        FFlags: integer;
        FObjectArgs: boolean;
        FHashed: integer;
        FHashMethod: TTclCommandHashMethod;
		FHashValues: array[0..MAX_HASH_VALUES - 1] of integer;
        FInterp: pTcl_Interp; // transient, meaningful during DoCommand only.
      	FMinArgs, FMaxArgs: Byte;
        FMode: TTclCommandMode;
        FInterpList: TList;
        FOldSelf: TObject;
        FOnCreate: TTclCmdEvent;
      	FOnCommand: TTclCommandEvent;
      	FOnDestroy: TTclCmdEvent;
        FOnException: TTclCmdExceptionEvent;
        FOnHash: TTclCmdHashEvent;
        FOnInterpDelete: TInterpEvent;
        FOnPrepare: TTclPrepareEvent; // v0.7 ??? 2/10/97 Prepares ?ClientData? prior to switches & params
		FOnScriptDelete: TTclScriptDeleteEvent; //v1.0
        FOptions: TTclCommandOptions;
        FParams: TList;
        FParamValues: TStrings;
        FStop: boolean;
        FSwitches: TList;
        FSwitchPrefix: TTclCmdSwitchPrefix;
        FSwitchPrefixOther: char; //v0.7
        FSwitchValues: TStrings;
      	FTcl: TTcl;

		function  AddCmdMetaInfo(fullName: string; ATcl_Command: pTcl_Command; _interp: pTcl_Interp): pTcl_CmdMetaInfo; //v1.0
		procedure AddParam(AParam: TTclCmdParam);
        procedure AddSwitch(ASwitch: TTclCmdSwitch);
		procedure CheckActive;
        procedure DeleteCmdMetaInfo(AMetaInfo: pTcl_CmdMetaInfo); //v1.0
        procedure DestroyParams;
        procedure DestroySwitches;
        function  DoFindSwitch(ASwitch: string): TTclCmdSwitch;
        procedure DoSafeScriptDelete(AInterp: pTcl_Interp; ACmdMetaInfo: pTcl_CmdMetaInfo);
      	function  ExecCommand(_interp: pTcl_Interp; _argc: integer; _argv: Tcl_Argv): integer;
      	function  ExecObjCommand(_interp: pTcl_Interp; _objc: integer; _objv: ppTcl_Obj): integer;
        function  GetArgv(index: integer): string;
        function  GetCmdMetaInfo(index: integer): pTcl_CmdMetaInfo; //v1.0
        function  GetCmdMetaInfoCount: integer; //v1.0
        function  GetFlag(index: integer): boolean;
        function  GetInterp: pTcl_Interp;
        function  GetInterpResult: string;
        function  GetInterpreterCount: integer;
        function  GetInterpreters(index: integer): pTcl_Interp;
        function  GetHashValues(index: integer): integer;
        function  GetObject(index: integer): pTcl_Obj;
        function  GetObjectCount: integer;
        function  GetParam(index: integer): TTclCmdParam;
        function  GetParamCount: integer;
        function  GetParamValue(index: integer): string;
        function  GetParamValuesCount: integer;
        function  GetRawArgv: Tcl_Argv;
        function  GetSwitch(index: integer): TTclCmdSwitch;
        function  GetSwitchCount: integer;
        function  GetSwitchValue(index: integer): string;
        function  GetSwitchValuesCount: integer;
        function  GetSwitchValueSwitch(index: integer): TTclCmdSwitch;
        procedure InterpDelete(AInterp: pTcl_Interp);
        procedure RemoveParam(AParam: TTclCmdParam);
        procedure RemoveSwitch(ASwitch: TTclCmdSwitch);
      	procedure SetCommand(ACommand: TTclIdent);
        procedure SetInterpResult(AResult: string);
        procedure SetFlag(index: integer; value: boolean);
		procedure SetHashEvent(event: TTclCmdHashEvent);
        procedure SetHashMethod(value: TTclCommandHashMethod);
        procedure SetMode(m: TTclCommandMode);
        procedure SetOptions(o: TTclCommandOptions);
      	procedure SetTcl(ATcl: TTcl);
        procedure TrackInterp(AInterp: pTcl_Interp);
        procedure UntrackInterp(AInterp: pTcl_Interp);
    protected
    	procedure DefineProperties(Filer: TFiler); override;
    	procedure DoCommand(var result: string; var success: boolean); virtual;
        procedure DoCreate; virtual;
        procedure DoDestroy; virtual;
        procedure DoException(var message: string; var ignore: boolean; E: Exception); virtual;
      	function  DoExecCommand(_interp: pTcl_Interp; _argc: integer; _argv: Tcl_Argv; isObj: boolean): integer; virtual;
        procedure DoInterpDelete(AInterp: pTcl_Interp); virtual;
        procedure DoPrepare(var result: string; var success: boolean); virtual;
        procedure DoScriptDelete(AInterp: pTcl_Interp); virtual;
		procedure Loaded; override;
{$IFDEF VER90}
    	procedure GetChildren(Proc: TGetChildProc); override;
{$ELSE}
		procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
{$ENDIF}
    	function  GetParentComponent: TComponent; override;
        function  HasParent: boolean; override;
	    procedure SetChildOrder(Child: TComponent; Order: Integer); override;
        procedure SetMinArgs(value: Byte);
        procedure SetMaxArgs(value: Byte);
	    procedure SetName(const NewName: TComponentName); override;
	   	procedure SetParentComponent(Value: TComponent); override;
    public
   		constructor Create(AOwner: TComponent); override;
      	destructor Destroy; override;
        procedure BreakLoop; //v0.7d
    	function  BuildParam: TTclCmdParamClass; virtual; 	// return derived class, i.e.: result := TMyTclCmdParam;
		function  BuildSwitch: TTclCmdSwitchClass; virtual;	// return derived class, i.e.: result := TMyTclCmdSwitch;
		function  CommandLine: string;
		function  Emulate(var emulResult: string; argc: integer; argv: Tcl_Argv): boolean;
        function  EmulateArray(var emulResult: string; const args: array of pChar): boolean;
        function  EmulateList(var emulResult: string; argList: TStrings): boolean;
        function  FindSwitch(ASwitch: string): TTclCmdSwitch;
		function  Install(AInterp: pTcl_Interp): integer;
        function  InvokeCmd(pInfo: pTcl_CmdInfo): integer; //v1.0
        function  InvokeCommand(cmd: TTclCommand): integer;
    	function  IsSwitch(c: char): boolean;
        function  IsTslcCmdInfo(pInfo: pTcl_CmdInfo): boolean;
        function  GetArgument(arg, argc: integer; argv: Tcl_Argv; var value: string): boolean; // skips switches, counts parameters
		procedure MoveParam(curIdx, newIdx: integer); //v1.0
        procedure MoveSwitch(curIdx, newIdx: integer); //v1.0
		function  ParamValueDef(index: integer; default: string): string;
        procedure StopEvaluating;
        procedure Uninstall(AInterp: pTcl_Interp);
        procedure UninstallAll;
        property  Arg: integer read FArg; //v1.0 raw argv index, meainingful only during calls to OnParam or OnSwitch
		property  Argv[index: integer]: string read GetArgv;
        property  Argc: integer read FArgc;
        property  CmdMetaInfo[index: integer]: pTcl_CmdMetaInfo read GetCmdMetaInfo; //v1.0
        property  CmdMetaInfoCount: integer read GetCmdMetaInfoCount; //v1.0
		property  Emulation: boolean read FEmulation;
        property  Evaluating: integer read FEvaluating; // 1.0 changes.txt
		property  Flag[index: integer]: Boolean read GetFlag write SetFlag; // where ( 1 shl index ) set/resets
        property  Flags: integer read FFlags write FFlags;
        property  HashValues[index: integer]: integer read GetHashValues; // v1.0
		property  Interp: pTcl_Interp read GetInterp;
        property  InterpResult: string read GetInterpResult write SetInterpResult;
        property  InterpreterCount: integer read GetInterpreterCount; //v1.0
        property  Interpreters[index: integer]: pTcl_Interp read GetInterpreters; //v1.0
		property  ObjectArgs: boolean read FObjectArgs;
		property  Objects[index: integer]: pTcl_Obj read GetObject;
        property  ObjectCount: integer read GetObjectCount;
        property  Params[index: integer]: TTclCmdParam read GetParam;
        property  ParamCount: integer read GetParamCount;
        property  ParamValues[index: integer]: string read GetParamValue;
        property  ParamValuesCount: integer read GetParamValuesCount;
        property  RawArgv: Tcl_Argv read GetRawArgv; // Never write to this pointer !!!
        property  Switches[index: integer]: TTclCmdSwitch read GetSwitch;
        property  SwitchCount: integer read GetSwitchCount;
        property  SwitchPrefixOther: char read FSwitchPrefixOther write FSwitchPrefixOther default '-'; //v0.7
        property  SwitchValues[index: integer]: string read GetSwitchValue;
        property  SwitchValuesCount: integer read GetSwitchValuesCount;
        property  SwitchValueSwitch[index: integer]: TTclCmdSwitch read GetSwitchValueSwitch;
   		property  Tcl: TTcl read FTcl write SetTcl;

	published
   		property Command: TTclIdent read FCommand write SetCommand;
      	property ErrorMsg: string read FErrorMsg write FErrorMsg;
        property HashMethod: TTclCommandHashMethod read FHashMethod write SetHashMethod default chUpperCase; //v1.0
      	property MinArgs: Byte read FMinArgs write SetMinArgs default 0;
      	property MaxArgs: Byte read FMaxArgs write SetMaxArgs default 0;
        property Mode: TTclCommandMode read FMode write SetMode default cmBoth;
        property Options: TTclCommandOptions read FOptions write SetOptions
        			default [coCallParams, coCallSwitches, coParse, coRaiseInvalidSwitch, coCatchAll, coObjectCommand, coAutoInstall];
        property SwitchPrefix: TTclCmdSwitchPrefix read FSwitchPrefix write FSwitchPrefix;
        property OnCreate:  TTclCmdEvent read FOnCreate write FOnCreate;
      	property OnCommand: TTclCommandEvent read FOnCommand write FOnCommand;
      	property OnDestroy: TTclCmdEvent read FOnDestroy write FOnDestroy;
		property OnException: TTclCmdExceptionEvent read FOnException write FOnException;
        property OnHash: TTclCmdHashEvent read FOnHash write SetHashEvent; //v1.0
        property OnInterpDelete: TInterpEvent read FOnInterpDelete write FOnInterpDelete;
        property OnPrepare: TTclPrepareEvent read FOnPrepare write FOnPrepare;
        property OnScriptDelete: TTclScriptDeleteEvent read FOnScriptDelete write FOnScriptDelete; //v1.0
   	end;

    //(tsNone, tsA, tsB, tsC, tsD, tsE, tsF, tsG, tsH, tsI, tsJ, tsK, tsL, tsM, tsN, tsO, tsP,
    //				tsQ, tsR, tsS, tsT, tsU, tsV, tsW, tsX, tsY, tsZ);
	TCmdSwitch = procedure(Sender: TTclCmdSwitch);
	TTclCmdSwitchEvent = procedure(Sender: TTclCmdSwitch; ASwitch: string; var result: string; var success: boolean) of object;
	TTclCmdSwitchOption = (soHaltSwitchParsing, soIgnoreDuplicate, soRaiseDuplicate, soHijackRelative);
    TTclCmdSwitchOptions = set of TTclCmdSwitchOption;
	TTclCmdSwitch = class(TTclComponent)
    private
		FRelativeParam: integer;
        FRelativeParamCount: integer;
        FSwitchValue: string;
        FPValue: pChar;
        FHijacked: boolean;
        FRequireParams: integer;
        FSwitch: string;
        FCaseSensitive: boolean;
        FCanAppend: boolean;
		FCommand: TTclCommand;
        FHits: integer;
        FMinCompare: Cardinal;
        FOptions: TTclCmdSwitchOptions;
        FOnSwitch: TTclCmdSwitchEvent;
      	function  ExecSwitch(var newValue: string; ASwitch: string): integer;
        function  GetSwitchValue: string;
    	procedure SetCommand(ACommand: TTclCommand);
        procedure SetSwitch(ASwitch: string);
	protected
    	procedure DefineProperties(Filer: TFiler); override;
        procedure DoSwitch(ASwitch: string; var result: string; var success: boolean); virtual;
    	function  GetParentComponent: TComponent; override;
	    procedure SetName(const NewName: TComponentName); override;
	   	procedure SetParentComponent(Value: TComponent); override;
        function  HasParent: boolean; override;
	public
    	constructor Create(AOwner: TComponent); override;
        destructor  Destroy; override;
        function  Split(ASwitch: string): string; // returns appendage to switch, i.e.: -sValue  -> Value
        function  SplitDef(ASwitch, Default: string): string; //v1.0
    	property  Command: TTclCommand read FCommand write SetCommand;
		property  Hijacked: boolean read FHijacked;
        property  Hits: integer read FHits;
        property  RelativeParam: integer read FRelativeParam;
        property  RelativeParamCount: integer read FRelativeParamCount;
        property  SwitchValue: string read GetSwitchValue;
    published
    	property  CanAppend: boolean read FCanAppend write FCanAppend default True;
		property  CaseSensitive: boolean read FCaseSensitive write FCaseSensitive default false;
        property  Options: TTclCmdSwitchOptions read FOptions write FOptions default [];
        property  MinCompare: Cardinal read FMinCompare write FMinCompare default 0;
        property  RequireParams: integer read FRequireParams write FRequireParams default 0;
        property  Switch: string read FSwitch write SetSwitch;
        property  OnSwitch: TTclCmdSwitchEvent read FOnSwitch write FOnSwitch;
    end;

	TTclCmdParamPos = LongInt;
	TTclCmdParamEvent = procedure(Sender: TTclCmdParam; APos: integer; AParam: string; var result: string; var success: boolean) of object;
	TTclCmdParam = class(TTclComponent)
    private
		FCaseSensitive: boolean;
		FDefault: boolean;
        FParam: string;
        FLen: integer;
        FPosition: TTclCmdParamPos;
		FCommand: TTclCommand;
        FMinCompare: Cardinal;
        FOnParam: TTclCmdParamEvent;
      	function  ExecParam(APos: integer; var newValue: string; AParam: string): integer;
    	procedure SetCommand(ACommand: TTclCommand);
        procedure SetParam(AParam: string);
        procedure SetPosition(pos: TTclCmdParamPos);
	protected
    	procedure DefineProperties(Filer: TFiler); override;
        procedure DoParam(APos: integer; AParam: string; var result: string; var success: boolean); virtual;
    	function  GetParentComponent: TComponent; override;
	    procedure SetName(const NewName: TComponentName); override;
	   	procedure SetParentComponent(Value: TComponent); override;
        function  HasParent: boolean; override;
	public
    	constructor Create(AOwner: TComponent); override;
        destructor  Destroy; override;
        function  IsPosition(APos: TTclCmdParamPos): boolean;
    	property  Command: TTclCommand read FCommand write SetCommand;
    published
    	property  CaseSensitive: boolean read FCaseSensitive write FCaseSensitive default False;
        property  Default: boolean read FDefault write FDefault default False;
        property  MinCompare: Cardinal read FMinCompare write FMinCompare default 0;
        property  Param: string read FParam write SetParam;
        property  Position: TTclCmdParamPos read FPosition write SetPosition default -1;
        property  OnParam: TTclCmdParamEvent read FOnParam write FOnParam;
    end;

	pTModuleCmdInfo = ^TModuleCmdInfo;
    TModuleCmdInfo = record
    	size: integer;
    	handle: integer;
        command: pointer;
    end;


function  Tcl_MallocEvent(size: integer): pTcl_Event; // Provided for backward compatibility - calls Tcl_Alloc

procedure TclError(msg: string);
procedure TclErrorFmt(msg: string; const args: array of const);
function oemFlags(Flags: TTclFlags): integer;
function ConvertPEOL(source: pChar): pChar;
function flagsOEM(oem: integer): TTclFlags;
function ArgvItem(argv: ppChar; idx: integer): pChar; cdecl; far; external;
function AssignArgvItem(argv: ppChar; idx: integer; ptr: pChar): pChar; cdecl; far; external;
function IsTslcModProcs(p: pointer): integer; cdecl; export;
function IsTslcCmdInfo(cmd: TTclCommand; pInfo: pTcl_CmdInfo; pModuleInfo: pTModuleCmdInfo): boolean;
function IsTslcProc(proc: pointer): boolean;
function Tslc_Init(_interp: pTcl_Interp): integer; cdecl;  // Entry point for package loader
function Tslc_SafeInit(_interp: pTcl_Interp): integer; cdecl; // Entry point for safe package loader
procedure TslcPkgProvide(interp: pTcl_Interp; name, version: string); // Throws ETclError;
function TslcAddTextToStrings(const text: pChar; list: TStrings): integer; //v1.0
function TslcFindCommand(interp: pTcl_Interp; cmd: string): TTclCommand;
function TslcFindCommandModule(interp: pTcl_Interp; cmd: string; pModuleInfo: pTModuleCmdInfo): boolean;
function TslcInvokeCmd(interp: pTcl_Interp; pInfo: pTcl_CmdInfo; argc: integer; argv: Tcl_Argv; objectArgs: boolean): integer;
function TslcVersion: string;
function TslcIssue: string;
procedure TslcCriticalEvals(value: boolean); // default on - entry blocked by any thread evaluations

function GetVar(interp: pTcl_Interp; varName, elemName: string; var value: string; flags: TTclFlags): boolean;
function InterpResult(interp: pTcl_Interp): string;
function LinkBoolean(interp: pTcl_Interp; varName: string; var b: longbool; readOnly: boolean): boolean;
function LinkDouble(interp: pTcl_Interp; varName: string; var d: double; readOnly: boolean): boolean;
function LinkInteger(interp: pTcl_Interp; varName: string; var i: integer; readOnly: boolean): boolean;
function LinkString(interp: pTcl_Interp; varName: string; var p: pChar; readOnly: boolean): boolean;
function MergeList(list: TStrings): string;
function MergeArray(const args: array of string): string;
function SetVar(interp: pTcl_Interp; varName, elemName, newValue: string; flags: TTclFlags): boolean;
function SplitList(interp: pTcl_Interp; literal: string; list: TStrings): boolean;
procedure UnlinkVar(interp: pTcl_Interp; varName: string);
function  UnsetVar(interp: pTcl_Interp; varName, elemName: string; flags: TTclFlags): boolean;

type
	TTslcTraceKind = (tkEnter, tkXNest, tkExit);

// Works with or without Tslc.bug (Tslc.bg2, Tslc.bg3)
// Critically wrapped. Trace file specified by TslcMsg.pas or during initialization
procedure TslcClientTrace(msg: string; kind: TTslcTraceKind);
procedure TslcPrepareTrace;
procedure TslcDoneTrace;

type
	TOnLoadPackage = procedure(interp: pTcl_Interp; safe: boolean; var abort: boolean);

var
	OnLoadPackage: TOnLoadPackage = nil;
	TslcWrapTraceInfo: boolean = False; // if true, places extra info on second line


implementation
uses TslcMsg, TslcRsrc, TslcHash, TslcPlat;

{$R TslcErr.res}
{$I TslcErr.inc}

//{$DEFINE TSLC_DEBUG}
//{$DEFINE TSLC_DEBUG_EXCEPTIONS}

procedure TslcPrepareTrace;
begin
	TslcMsg.TslcPrepareTrace;
end;

procedure TslcDoneTrace;
begin
	TslcMsg.TslcDoneTrace;
end;

{$IFDEF TSLC_DEBUG}
const
	cTRACE_WRAP 	= -2;

type
	TSelfDestroyed = class(TComponent)
    public
    	_class: string;
    	constructor Create(aclass: string);
    end;

constructor TSelfDestroyed.Create(aclass: string);
begin
	inherited Create(nil);
    _class := aclass;
end;

function SD(aclass: string): TSelfDestroyed;
begin
	result := TSelfDestroyed.Create(aclass);
end;

procedure Trace(nest: integer; msg: string);
const
	firstTime: boolean = True;
	nestLevel: integer = 0;
    entry: array[-1..1] of string[8] = ('EXIT ','XNEST','ENTER');
begin
	TslcEnterCritical;
    try
		if firstTime then
        begin
        	firstTime := False;
            TslcMessage(format('Tslc Trace File - %s', [DateTimeToStr(Now)]), tmTrace);
			TslcMessage(       '================================================================================', tmTrace);
            TslcMessage(       '    ClockTick = Number of milliseconds since OS started', tmTrace);
			TslcMessage(       '    NestLevel = Nesting level of procedure calls.', tmTrace);
            TslcMessage(       '                XNEST = Basic trace info. Arbitrarily placed in procedure', tmTrace);
            TslcMessage(       '                ENTER = Trace info located at beginning of procedure.', tmTrace);
            TslcMessage(       '                EXIT  = Trace info located at exit point of procedure.', tmTrace);
            TslcMessage(       '    TraceInfo = Description of Class.Procedure, instance name, and optional info', tmTrace);
            TslcMessage('', tmTrace);
            TslcMessage(       '    *Note: Under normal conditions, each ENTER trace should have a corresponding', tmTrace);
            TslcMessage(       '           EXIT and the final nest level should be zero.', tmTrace);
			TslcMessage(       '           Procedures traced are limited to allocators, destructors, library,', tmTrace);
            TslcMessage(       '           interpreter bindery, & similar procedures that establish the dynamic', tmTrace);
            TslcMessage(       '           relationship of the compiled program. High usage procedures relating', tmTrace);
            TslcMessage(       '           to script evaluations, channel operations, & the Tcl event mechanism', tmTrace);
            TslcMessage(       '           are not traced (if necessary, client code can handle such trace', tmTrace);
            TslcMessage(       '           requirements by virtue of event procedures and/or method overrides.)', tmTrace);
            TslcMessage('', tmTrace);
			TslcMessage(format('%-9.9s %-10.10s %s', ['ClockTick', 'NestLevel', 'Trace Information']), tmTrace);
			TslcMessage(       '================================================================================', tmTrace);
		end;
        if nest = cTRACE_WRAP then
            TslcMessage(format('%30.30s%s', ['', msg]), tmTrace)
        else
        begin
			if nest > 0 then
				inc(nestLevel, nest);
			TslcMessage(format('%9.9d %2.2d %-5.5s %s', [TslcTickCount, nestLevel, entry[nest], msg]), tmTrace);
			if nest < 0 then
            	inc(nestLevel, nest);
        end;
    finally
    	TslcLeaveCritical;
    end;
end;

procedure TraceFmt(nest: integer; msg: string; const args: array of const);
begin
	Trace(nest, format(msg, args));
end;


procedure TraceCompProc(nest: integer; comp: TComponent; proc, msg: string; const args: array of const);
	function TON(comp: TComponent): string;
	begin
		if comp = nil then
        	result := '(NOT AVAILABLE)'
        else if comp.owner = nil then
        begin
			result := comp.name;
            if result = '' then
            	result := 'Self(NAMELESS)';
	    	result := 'Owner(NULL).' + result;
	    end else
        begin
        	result := comp.owner.name;
            if result = '' then
		    	result := 'Owner(NAMELESS)';
            if comp.name = '' then
            	result := result + '.Self(NAMELESS)'
            else
            	result := result + '.' + comp.name;
		end;
	end;
    function OC(obj: TObject): string;
    begin
    	if obj = nil then
        	result := '(NOT AVAIL)'
        else
        	result := obj.ClassName;
    end;
var
	str, info: string;
begin
    TslcEnterCritical;
    try
        if comp is TSelfDestroyed then
        begin
        	str := Format('%s.%s', [(comp as TSelfDestroyed)._class, proc]);
            comp.Free;
            comp := nil;
        end else
	    	str := Format('%s.%s', [OC(comp), proc]);

		info := trim(format(msg, args));

		if TslcWrapTraceInfo then
        begin
			Trace(nest, format('%-28.28s %-30.30s',[str, TON(comp)]));
		    if info <> '' then
    			Trace(cTRACE_WRAP, info);
        end else
			Trace(nest, format('%-28.28s %-26.26s %s',[str, TON(comp), info]));
    finally
    	TslcLeaveCritical;
    end;
end;
{$ENDIF}

procedure TslcClientTrace(msg: string; kind: TTslcTraceKind);
const
	cNest: array[tkEnter..tkExit] of integer = (1, 0, -1);
{$IFNDEF TSLC_DEBUG}
    entry: array[-1..1] of string[8] = ('ENTER','XNEST','EXIT ');
    nestLevel: integer = 0;
    firstTime: boolean = True;
{$ENDIF}
begin
{$IFDEF TSLC_DEBUG}
	Trace(cNest[kind], msg);
{$ELSE}
	TslcEnterCritical;
    try
		if firstTime then
        begin
        	firstTime := False;
            TslcMessage(format('Tslc Trace File - %s', [DateTimeToStr(Now)]), tmTrace);
            TslcMessage('', tmTrace);
			TslcMessage(format('%-9.9s %-10.10s %s', ['ClockTick', ' NestLevel', 'Trace Information']), tmTrace);
			TslcMessage('================================================================================', tmTrace);
		end;
		if kind = tkEnter then
        	inc(nestLevel, cNest[kind]);
    	TslcMessage(format('%9.9d %2d %-5.5s %s', [TslcTickCount, nestLevel, entry[cNest[kind]], msg]), tmTrace);
		if kind = tkExit then
			inc(nestLevel, cNest[kind]);
    finally
    	TslcLeaveCritical;
    end;
{$ENDIF}
end;

procedure TclError(msg: string);
begin
{$IFDEF TSLC_DEBUG_EXCEPTIONS}
{$IFDEF TSLC_DEBUG}
	TslcEnterCritical;
    try
		TslcMessage(format('%-9.9s %s', ['EXCEPTION', msg]), tmTrace);
	finally
    	TslcLeaveCritical;
    end;
{$ENDIF}
{$ENDIF}

	Raise ETclError.Create(msg);
end;

procedure TclErrorFmt(msg: string; const args: array of const);
begin
	TclError(format(msg, args));
end;

function TslcVersion: string;
begin
	result := format('%d.%d',[TSLC_VERSION_MAJOR,TSLC_VERSION_MINOR]);
end;

function TslcIssue: string;
begin
	result := format('%d.%d.%s',[TSLC_VERSION_MAJOR,TSLC_VERSION_MINOR,TSLC_VERSION_ISSUE]);
end;

// Borrowed from Classes.pas TslcUtil
function TslcAddTextToStrings(const text: pChar; list: TStrings): integer;
var
	p, q: pChar;
    s: string;
begin
	result := 0;
    if text = nil then
    	exit;
	p := text;
	list.BeginUpdate;
	try
		while p^ <> #0 do
    	begin
        	q := p;
        	while not (p^ in [#0, #10, #13]) do inc(p);
	        SetString(s, q, p - q);
	        list.Add(s);
            inc(result);
	        if p^ = #13 then inc(p);
            if p^ = #10 then inc(p);
		end;
	finally
    	list.EndUpdate;
  	end;
end;

function TslcFindCommand(interp: pTcl_Interp; cmd: string): TTclCommand;
var
	info: Tcl_CmdInfo;
begin
	result := nil;
	if (Tcl_GetCommandInfo(interp, pChar(cmd), info) <> 0) and IsTslcCmdInfo(nil, @info, nil) then
    	if info.isNativeObjectProc <> 0 then
        	result := TTclCommand(info.ObjClientData)
        else
        	result := TTclCommand(info.ClientData);
end;

function TslcFindCommandModule(interp: pTcl_Interp; cmd: string; pModuleInfo: pTModuleCmdInfo): boolean;
var
	info: Tcl_CmdInfo;
begin
    result :=  (Tcl_GetCommandInfo(interp, pChar(cmd), info) <> 0) and IsTslcCmdInfo(nil, @info, pModuleInfo);
    if result and (pModuleInfo <> nil) then
    	if info.isNativeObjectProc <> 0 then
        	pModuleInfo.command := TTclCommand(info.ObjClientData)
        else
        	pModuleInfo.command := TTclCommand(info.ClientData);
end;


var
	TslcRenameInfo: Tcl_CmdInfo;

type
	TTclRenameCommand = class(TTclCommand)
    protected
      	function  DoExecCommand(_interp: pTcl_Interp; _argc: integer; _argv: Tcl_Argv; isObj: boolean): integer; override;
	end;


function  TTclRenameCommand.DoExecCommand(_interp: pTcl_Interp; _argc: integer; _argv: Tcl_Argv; isObj: boolean): integer;
var
	cmd: TTclCommand;
    x, c: integer;

begin

    result := TslcInvokeCmd(_interp, @TslcRenameInfo, _argc, _argv, isObj);

	if result = TCL_OK then
    begin
		cmd := TslcFindCommand(_interp, Tcl_GetStringFromObj(pTcl_Obj(ArgvItem(_argv, 2)), nil));
        if cmd <> nil then
        begin
	        cmd.FCommand := Tcl_GetStringFromObj(pTcl_Obj(ArgvItem(_argv, 2)), nil);
			c := cmd.GetCmdMetaInfoCount - 1;
            for x := 0 to c do
            with cmd.GetCmdMetaInfo(x)^ do
			begin
            	FreeMem(FullName);
                GetMem(FullName, length(cmd.FCommand) + 1);
                strpcopy(FullName, cmd.FCommand);
            end;
        end;
    end;
end;


{$L argv.obj}
var
    TslcInitList: TList;
    TslcRenameCommand: TTclCommand;


procedure PanicProc(fmt, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8: pChar); cdecl;
var
	msg: string;
begin
	try
		msg := Format(strpas(fmt), [arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8]);
    except
    	on E:Exception do
        begin
        	TslcMessage(E.message + ' (' + strpas(fmt) + ')', tmPanic);
            exit;
        end;
    end;
   	TslcMessage(msg, tmPanic);
end;

{$IFDEF TSLC_DEBUG}
procedure TclLibHook(clientData: pointer);
const
	Kind: array[thBeforeTclLoad..thAfterTkUnload] of pChar =
    	('thBeforeTclLoad', 'thAfterTclLoad', 'thBeforeTkLoad', 'thAfterTkLoad',
    	 'thBeforeTclUnload', 'thAfterTclUnload', 'thBeforeTkUnload', 'thAfterTkUnload');
begin
	TraceFmt(0, 'Lib Hook: %s', [kind[TTslcLibHookKind(clientData)]]);
end;
{$ENDIF}

procedure InitTcl;//(LibPath: string; comp: TComponent);
begin
	if InitializedTcl then
    	exit;
	TslcEnterCritical;
    try
{$IFDEF TSLC_DEBUG}
        TslcMessage('Compiled with trace debug', tmWarning);
		TraceCompProc(0, SD('(STATIC)'),'InitTcl', '', [0]);
	    AddTslcLibHook(TclLibHook, pointer(thBeforeTclLoad), thBeforeTclLoad);
	    AddTslcLibHook(TclLibHook, pointer(thAfterTclLoad), thAfterTclLoad);
{$ENDIF}
		TclTk.InitTcl('');
	    Tcl_SetPanicProc(PanicProc);
	    Tcl_FindExecutable(pChar(TslcApplicationPath)); //v0.7c
	finally
    	TslcLeaveCritical;
    end;
end;

function  GetVar(interp: pTcl_Interp; varName, elemName: string; var value: string; flags: TTclFlags): boolean;
var
	p: pChar;
begin
	if elemName = '' then
		p := Tcl_GetVar(interp, pChar(varName), oemFlags(flags))
    else
    	p := Tcl_GetVar2(interp, pChar(varName), pChar(elemName), oemFlags(flags));

	result := p <> nil;
	if result then
    	value := strpas(p)
    else
	    value := '';
end;

function InterpResult(interp: pTcl_Interp): string;
begin
	if interp <> nil then
		result := strpas(Tcl_GetStringResult(interp))
    else
    	result := '';
end;

function LinkBoolean(interp: pTcl_Interp; varName: string; var b: longbool; readOnly: boolean): boolean; 	// "C" booleans are integers
begin
	if readOnly then
		result := Tcl_LinkVar(interp, pChar(varName), b, TCL_LINK_BOOLEAN or TCL_LINK_READ_ONLY) = TCL_OK
    else
		result := Tcl_LinkVar(interp, pChar(varName), b, TCL_LINK_BOOLEAN) = TCL_OK;
end;

function LinkDouble(interp: pTcl_Interp; varName: string; var d: double; readOnly: boolean): boolean;
begin
	if readOnly then
		result := Tcl_LinkVar(interp, pChar(varName), d, TCL_LINK_DOUBLE or TCL_LINK_READ_ONLY) = TCL_OK
    else
    	result := Tcl_LinkVar(interp, pChar(varName), d, TCL_LINK_DOUBLE) = TCL_OK;
end;

function LinkInteger(interp: pTcl_Interp; varName: string; var i: integer; readOnly: boolean): boolean;
begin
    if readOnly then
    	result := Tcl_LinkVar(interp, pChar(varName), i, TCL_LINK_INT or TCL_LINK_READ_ONLY) = TCL_OK
    else
    	result := Tcl_LinkVar(interp, pChar(varName), i, TCL_LINK_INT) = TCL_OK;
end;

function LinkString(interp: pTcl_Interp; varName: string; var p: pChar; readOnly: boolean): boolean;
begin
    if readOnly then
    	result := Tcl_LinkVar(interp, pChar(varName), p, TCL_LINK_STRING or TCL_LINK_READ_ONLY) = TCL_OK
    else
    	result := Tcl_LinkVar(interp, pChar(varName), p, TCL_LINK_STRING) = TCL_OK;
end;

function MergeList(list: TStrings): string;
var
    argv: Tcl_Argv;
    merged, p: pChar;
    x, count: integer;
begin
	count := list.count;
    GetMem(argv, count * sizeof(pChar));
    for x := 0 to count - 1 do
    begin
        GetMem(p, length(list.strings[x]) + 1);
        strpcopy(p, list.strings[x]);
        AssignArgvItem(argv, x, p);
    end;

    merged := Tcl_Merge(count, argv);
    for x := 0 to count - 1 do
        FreeMem(ArgvItem(argv, x));
    FreeMem(argv);
    result := strpas(merged);
    Tcl_Free(merged);
end;

function MergeArray(const args: array of string): string;
var
    argv: Tcl_Argv;
    merged, p: pChar;
    x, count: integer;
begin
	count := High(args) + 1;
    GetMem(argv, count * sizeof(pChar));
    for x := 0 to High(args) do
    begin
        GetMem(p, length(args[x]) + 1);
        strpcopy(p, args[x]);
        AssignArgvItem(argv, x, p);
    end;

    merged := Tcl_Merge(count, argv);
    for x := 0 to count - 1 do
        FreeMem(ArgvItem(argv, x));
    FreeMem(argv);
    result := strpas(merged);
    Tcl_Free(merged);
end;


function SplitList(interp: pTcl_Interp; literal: string; list: TStrings): boolean;
var
    argc, x: integer;
    argv: Tcl_Argv;
begin
	try
	    result :=  Tcl_SplitList(interp, pChar(literal), argc, argv) = TCL_OK;
    	if not result then exit;
		list.BeginUpdate;
    	try
		    for x := 0 to argc - 1 do
    		    list.add(strpas(ArgvItem(argv, x)));
	    finally
    		list.EndUpdate;
	    end;
    	Tcl_Free(pChar(argv));
    except
    	TslcMessage(Exception(ExceptObject).Message, tmError);
    end;
end;

function SetVar(interp: pTcl_Interp; varName, elemName, newValue: string; flags: TTclFlags): boolean;
begin
	if elemName = '' then
		result := Tcl_SetVar(interp, pChar(varName), pChar(newValue), oemFlags(flags)) <> nil
    else
    	result :=  Tcl_SetVar2(interp, pChar(varName), pChar(elemName), pChar(newValue), oemFlags(flags)) <> nil;
end;

procedure UnlinkVar(interp: pTcl_Interp; varName: string);
begin
    Tcl_UnlinkVar(interp, pChar(varName));
end;

function UnsetVar(interp: pTcl_Interp; varName, elemName: string; flags: TTclFlags): boolean;
begin
	if elemName = '' then
    	result := Tcl_UnsetVar(interp, pChar(varName), oemFlags(flags)) = TCL_OK
    else
    	result := Tcl_UnsetVar2(interp, pChar(varName), pChar(elemName), oemFlags(flags)) = TCL_OK;
end;

function  Tcl_MallocEvent(size: integer): pTcl_Event;
begin
	if size < sizeof(Tcl_Event) then size := sizeof(Tcl_Event);
    result := pTcl_Event(Tcl_Alloc(size));
end;

procedure TslcEventSetup(clientData: Tcl_ClientData; flags: integer); cdecl;
begin
	if InitializedTcl then
    with TTclEventSource(clientData) do
    	DoSetup(flags);
end;

procedure TslcEventCheck(clientData: Tcl_ClientData; flags: integer); cdecl;
begin
	if InitializedTcl then
	with TTclEventSource(clientData) do
    	DoCheck(flags);
end;

procedure TslcIdleTimer(clientData: Tcl_ClientData); cdecl;
begin
	if InitializedTcl then
	with TTclTimer(clientData) do
    	DoTimer(tkIdle);
end;

procedure TslcModalTimer(clientData: Tcl_ClientData); cdecl;
begin
	if InitializedTcl then
	with TTclTimer(clientData) do
    	DoTimer(tkModal);
end;

procedure TslcNormalTimer(clientData: Tcl_ClientData); cdecl;
begin
	if InitializedTcl then
	with TTclTimer(clientData) do
    	DoTimer(tkNormal);
end;

procedure TslcNamespaceDeleteProc(clientData: Tcl_ClientData); cdecl;
begin
	if InitializedTcl then
	if clientData <> nil then
    with TTcl(clientData) do
    	DoNamespaceDelete;
end;

function TslcCommandProc(clientData: Tcl_ClientData; _interp: pTcl_Interp; _argc: integer; _argv: Tcl_Argv): integer; cdecl;
begin
    result := TTclCommand(clientData).ExecCommand(_interp, _argc, _argv);
    if result = TCL_DESTROYED then
    	result := TCL_OK;
end;

function TslcObjCommandProc(clientData: Tcl_ClientData; _interp: pTcl_Interp; _objc: integer; _objv: ppTcl_Obj): integer; cdecl;
begin
   	result := TTclCommand(clientData).ExecObjCommand(_interp, _objc, _objv);
    if result = TCL_DESTROYED then
    	result := TCL_OK;
end;

procedure TslcIDP_TTclChannel(clientData: Tcl_ClientData; _interp: pTcl_Interp); cdecl;
begin
	if clientData = nil then
    	exit;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, SD('(STATIC)'),'TslcIDP_TTclChannel', 'AInterp: %p, TTclChannel: %s', [_interp, TTclChannel(ClientData).Name]);
{$ENDIF}
	if InitializedTcl then
    with TTclChannel(ClientData) do
    begin
    	include(FTclState, tsInterpDeleteProc);
    	InterpDelete(_interp);
    end;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, SD('(STATIC)'),'TslcIDP_TTclChannel', 'AInterp: %p, TTclChannel: %s', [_interp, '(NOT AVAILABLE)'])
{$ENDIF}
end;

procedure TslcIDP_TTcl(clientData: Tcl_ClientData; _interp: pTcl_Interp); cdecl;
begin
	if clientData = nil then
    	exit;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, SD('(STATIC)'),'TslcIDP_TTcl', 'AInterp %p, TTcl: %s', [_interp, TTcl(ClientData).Name]);
{$ENDIF}
	if InitializedTcl then
	with TTcl(clientData) do
    begin
    	include(FTclState, tsInterpDeleteProc);
    	InterpDelete(_interp);
    end;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, SD('(STATIC)'),'TslcIDP_TTcl', 'AInterp %p, TTcl: %s', [_interp, '(NOT AVAILABLE)'])
{$ENDIF}
end;

procedure TslcIDP_TTclTrace(clientData: Tcl_ClientData; _interp: pTcl_Interp); cdecl;
begin
	if clientData = nil then
    	exit;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, SD('(STATIC)'),'TslcIDP_TTclTrace', 'AInterp %p, TTclTrace: %s', [_interp, TTclTrace(ClientData).Name]);
{$ENDIF}
	if InitializedTcl then
    with TTclTrace(clientData) do
    begin
    	include(FTclState, tsInterpDeleteProc);
    	InterpDelete(_interp);
    end;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, SD('(STATIC)'),'TslcIDP_TTclTrace', 'AInterp %p, TTclTrace: %s', [_interp, '(NOT AVAILABLE)']);
{$ENDIF}
end;

procedure TslcIDP_TTclCommand(clientData: Tcl_ClientData; _interp: pTcl_Interp); cdecl;
begin
	if clientData = nil then
    	exit;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, SD('(STATIC)'), 'TslcIDP_TTclCommand', 'AInterp %p, TTclCommand: %s', [_interp, TTclCommand(ClientData).Name]);
{$ENDIF}
	if InitializedTcl then
	if clientData <> nil then
    with TTclCommand(clientData) do
    begin
    	include(FTclState, tsInterpDeleteProc);
    	InterpDelete(_interp);
    end;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, SD('(STATIC)'), 'TslcIDP_TTclCommand', 'AInterp %p, TTclCommand: %s', [_interp, '(NOT AVAILABLE)'])
{$ENDIF}
end;

procedure TslcCmdDeleteProc(deleteData: Tcl_ClientData); cdecl;
begin
	if deleteData = nil then
    	exit;
	if InitializedTcl then
	with pTcl_CmdMetaInfo(deleteData)^ do
    begin
{$IFDEF TSLC_DEBUG}
		TraceCompProc(1, SD('(STATIC)'),'TslcCmdDeleteProc', 'AInterp: %p, Command: %s', [Interp, Command.Name]);
{$ENDIF}
		if not (csDestroying in Command.ComponentState) then
	        Command.DoSafeScriptDelete(Interp, pTcl_CmdMetaInfo(deleteData));
{$IFDEF TSLC_DEBUG}
		TraceCompProc(-1, SD('(STATIC)'),'TslcCmdDeleteProc', 'AInterp: %p, Command: %s', [Interp, '(NOT AVAILABLE)']);
{$ENDIF}
   end;
end;

function TslcTraceProc(clientData: Tcl_ClientData; _interp: pTcl_Interp; varName: pChar; elemName: pChar;
	flags: integer): pChar; cdecl;
begin
	if InitializedTcl then
		result := TTclTrace(clientData).ExecTrace(_interp, varName, elemName, flags);
end;

function IsTslcModProcs(p: pointer): integer; cdecl;
begin
 	if p = @TslcCmdDeleteProc then
    	result := 1
    else
    	result := 0;
end;

function IsTslcCmdInfo(cmd: TTclCommand; pInfo: pTcl_CmdInfo; pModuleInfo: pTModuleCmdInfo): boolean;
begin
	with pInfo^ do
    begin
		if pModuleInfo <> nil then
        	pModuleInfo^.handle := 0;
    	result := @DeleteProc = @TslcCmdDeleteProc;
        if not result and (pModuleInfo <> nil) then
        	result := TslcWalkForCommand(@DeleteProc, pModuleInfo);
        if cmd <> nil then
        	result := result and ((ClientData = cmd) or (ObjClientData = cmd));
    end;
end;

function IsTslcProc(proc: pointer): boolean;
begin
	result := (proc = @TslcCommandProc) or (proc = @TslcObjCommandProc); // ??? finish comparisons
end;

function DoTslc_Init(_interp: pTcl_Interp; _safe: boolean): integer;
var
	x: integer;
    abort: boolean;
begin
	result := TCL_ERROR;
	if not InitializedTcl then
    	exit;
    abort := False;
	if not Assigned(_interp) then exit; //or not TslcIsLibrary then exit;
    try
		TslcEnterCritical;
        try
	    	if Assigned(OnLoadPackage) then
    	    	OnLoadPackage(_interp, _safe, abort);
        finally
        	TslcLeaveCritical;
        end;
        if abort then
        	exit;


		TslcEnterCritical;
        try
			with TslcInitList do
	    		for x:= 0 to count - 1 do
	        		with TObject(items[x]) as TTcl do
	                	if AutoActivate then
	                    	InitInterp(_interp, _safe);
		finally
        	TslcLeaveCritical;
        end;
        result := TCL_OK;

	except
       	TslcMessage(Exception(ExceptObject).Message, tmError);
    end;
end;

function Tslc_Init(_interp: pTcl_Interp): integer;
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, SD('(STATIC)'), 'Tslc_Init', 'DLL Export, AInterp: %p', [_interp]);
{$ENDIF}
	InitTcl;
	result := DoTslc_Init(_interp, False);
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, SD('(STATIC)'), 'Tslc_Init', 'DLL Export, AInterp: %p', [_interp]);
{$ENDIF}
end;

function Tslc_SafeInit(_interp: pTcl_Interp): integer;
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, SD('(STATIC)'), 'Tslc_SafeInit', 'DLL Export, AInterp: %p', [_interp]);
{$ENDIF}
	InitTcl;
	result := DoTslc_Init(_interp, True);
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, SD('(STATIC)'), 'Tslc_SafeInit', 'DLL Export, AInterp: %p', [_interp]);
{$ENDIF}
end;

procedure TslcPkgProvide(interp: pTcl_Interp; name, version: string);
begin
	if Tcl_PkgProvide(interp, pChar(name), pChar(version)) <> TCL_OK then
		TclError(Tcl_GetStringResult(interp));
end;

procedure CheckInterp(_interp: pTcl_Interp);
begin
	if not Assigned(_interp) then
   		TclError(LoadStr(sTslcAccessInvalidInterp));
end;

function oemFlags(Flags: TTclFlags): integer;
begin
	if tfGlobalOnly in Flags then result := TCL_GLOBAL_ONLY
	else result := 0;
	if tfReads in Flags then result := result or TCL_TRACE_READS;
	if tfWrites in Flags then result := result or TCL_TRACE_WRITES;
	if tfUnsets in Flags then result := result or TCL_TRACE_UNSETS;
	if tfDestroyed in Flags then result := result or TCL_TRACE_DESTROYED;
	if tfLeaveErrMsg in Flags then result := result or TCL_LEAVE_ERR_MSG;
	if tfAppendValue in Flags then result := result or TCL_APPEND_VALUE;
	if tfListElement in Flags then result := result or TCL_LIST_ELEMENT;
    if tfParsePart1 in Flags then result := result or TCL_PARSE_PART1;
end;

function flagsOEM(oem: integer): TTclFlags;
begin
	if (TCL_GLOBAL_ONLY and oem) <> 0 then
    	result := [tfGlobalOnly]
    else
    	result := [];
    if (TCL_TRACE_READS and oem) <> 0 then include(result, tfReads);
    if (TCL_TRACE_WRITES and oem) <> 0 then include(result, tfWrites);
    if (TCL_TRACE_UNSETS and oem) <> 0 then include(result, tfUnsets);
    if (TCL_TRACE_DESTROYED and oem) <> 0 then include(result, tfDestroyed);
    if (TCL_LEAVE_ERR_MSG and oem) <> 0 then include(result, tfLeaveErrMsg);
    if (TCL_APPEND_VALUE and oem) <> 0 then include(result, tfAppendValue);
    if (TCL_LIST_ELEMENT and oem) <> 0 then include(result, tfListElement);
    if (TCL_PARSE_PART1 and oem) <> 0 then include(result, tfParsePart1);
end;


{~~~ TTclComponent ~~~}

destructor TTclComponent.Destroy;
begin
	if FDeletionFlag <> nil then
    	FDeletionFlag^ := 1;
    inherited Destroy;
end;

procedure TTclComponent.Notification(AComponent: TComponent; Operation: TOperation);
begin
	inherited Notification(AComponent, Operation);
    if (Operation = opRemove) and (AComponent = FClientData) then
    	FClientData := nil;
end;

procedure TTclComponent.ClientDataNotify;
begin
	if FClientData is TComponent then
		TComponent(FClientData).FreeNotification(Self)
    else if FClientData <> nil then
   		TclError(LoadStr(sTslcInvalidClientDataNotify));
end;

{~~~ TTclChannel ~~~}
type
	pTclChannelData = ^TTclChannelData;
    TTclChannelData = record
		nextPtr: pTclChannelData;
        channel: TTclChannel;
    end;

var
	TslcChannelType: Tcl_ChannelType;
    TslcChannelSTDIN: Tcl_Channel;
    TslcChannelSTDOUT: Tcl_Channel;
    TslcChannelSTDERR: Tcl_Channel;
    TslcChannelSTDPRN: Tcl_Channel;
    FirstChannelPtr: pTclChannelData = nil;
    ChannelsClosed: boolean; // PosixCheckChannel was hanging on app termination

procedure FreeChannelData;
const                          // Threads...
	deleting: boolean = False; // ??? this will happen when Tcl lib unloads - but CriticalSect may be dead - so using constant ???
var
	cp: pTclChannelData;
begin
	if deleting then
    	exit;
    deleting := true;
    try
		while firstChannelPtr <> nil do
	    begin
	    	cp := firstChannelPtr^.nextPtr;
			TslcFree(firstChannelPtr);
	        firstChannelPtr := cp;
	    end;
    finally
    	deleting := False;
    end;
end;

function GetChannel(instanceData: Tcl_ClientData): TTclChannel;
var
	cp: pTclChannelData;
begin
    cp := pTclChannelData(instanceData);
	if cp <> nil then
    	result := cp^.channel
    else
    	result := nil;
end;

function PosixCheckChannel(instanceData: Tcl_ClientData; var channel: TTclChannel; errorCode:pInteger): integer;
begin
    channel := GetChannel(instanceData);

   	if (channel = nil) or (csDestroying in channel.componentState) then
    begin
		if InitializedTcl then
	    	Tcl_SetErrno(ENODEV);
        if errorCode <> nil then
        	errorCode^ := ENODEV;
        result := TCL_ERROR;
    end else
    	result := TCL_OK;
end;

procedure ShutdownChannels(clientData: pointer); // Called by thread safe hook handler
var
	chan: TTclChannel;
    data: pTclChannelData;
begin
	ChannelsClosed := True;
	data := FirstChannelPtr;
    while data <> nil do
    begin
    	chan := GetChannel(data);
        if (chan <> nil) and not (csDestroying in chan.ComponentState) then
        	chan.Close;
        data := data^.nextPtr;
	end;
end;

procedure TslcFreeChannelData(clientData: pointer); cdecl; // Called only once upon exit
begin
	FreeChannelData;
    TslcDoneCritical;
end;

function AddChannelData(channel: TTclChannel): pTclChannelData;
const
	cCloseCallbackAdded: boolean = False;
begin
//	if firstChannelPtr = nil then
//    	TslcAfterTclObjectFree(TChannelDataKiller.Create);
	TslcEnterCritical;
    try
		if not cCloseCallbackAdded then
	    begin
	        cCloseCallbackAdded := True;
	    	AddTslcLibHook(ShutdownChannels, nil, thBeforeTclUnload);
            TslcPrepareCritical; // TslcDoneCritical called in TslcFreeChannelData
	        Tcl_CreateExitHandler(TslcFreeChannelData, FirstChannelPtr);
	    end;

	//	GetMem(Result, sizeof(TTclChannelData));
		Result := pTclChannelData(TslcAlloc(sizeof(TTclChannelData)));
	    result^.nextPtr := firstChannelPtr;
	    result^.channel := channel;
	    firstChannelPtr := result;
    finally
    	TslcLeaveCritical;
    end;
end;

function TslcChannelBlockMode(instanceData: Tcl_ClientData; mode: integer): integer; cdecl;
var
	channel: TTclChannel;
begin
	if ChannelsClosed then
		result := TCL_ERROR
    else
	    result := PosixCheckChannel(instanceData, channel, nil);
    if result = TCL_OK then
    try
		channel.DoBlockMode(mode, result);
    except
    	result := TCL_ERROR;
    end;
end;

function TslcChannelClose(instanceData: Tcl_ClientData; interp: pTcl_Interp): integer; cdecl;
var
	channel: TTclChannel;
begin
	if ChannelsClosed then
		result := TCL_ERROR
    else
	    result := PosixCheckChannel(instanceData, channel, nil);
    if result = TCL_OK then
    try
		channel.DoClose(interp, result);
    except
    	result := TCL_ERROR;
    end;
end;

function TslcChannelInput(instanceData: Tcl_ClientData; buf: pChar; toRead: integer; errorCodePtr: pInteger): integer; cdecl;
var
	channel: TTclChannel;
	i: integer;
begin
    result := PosixCheckChannel(instanceData, channel, errorCodePtr);
    if result = TCL_OK then
    try
	    i := 0;
    	channel.DoInput(buf, toRead, i, result);
		if errorCodePtr <> nil then
    		errorCodePtr^ := i;
    except
		if errorCodePtr <> nil then
    		errorCodePtr^ := EINVAL;
    end;
end;

function TslcChannelOutput(instanceData: Tcl_ClientData; buf: pChar; toWrite: integer; errorCodePtr: pInteger): integer; cdecl;
var
	channel: TTclChannel;
	i: integer;
begin
	result := PosixCheckChannel(instanceData, channel, errorCodePtr);
    if result = TCL_OK then
    try
	    i := 0;
        if coPresetFullWrite in channel.Options then
        	result := toWrite;
		channel.DoOutput(buf, toWrite, i, result);
		if errorCodePtr <> nil then
    		errorCodePtr^ := i;
    except
		if errorCodePtr <> nil then
    		errorCodePtr^ := EINVAL;
    end;
end;

function TslcChannelSeek(instanceData: Tcl_ClientData; offset: longint; mode: integer; errorCodePtr: pInteger): integer; cdecl;
var
	channel: TTclChannel;
	i: integer;
begin
	result := PosixCheckChannel(instanceData, channel, errorCodePtr);
    if result = TCL_OK then
    try
	    i := 0;
    	channel.DoSeek(offset, mode, i, result);
	   	if errorCodePtr <> nil then
    		errorCodePtr^ := i;
    except
		if errorCodePtr <> nil then
    		errorCodePtr^ := EINVAL;
    end;
end;

function TslcChannelSetOption(instanceData: Tcl_ClientData; interp: pTcl_Interp; optionName: pChar;	value: pChar): integer; cdecl;
var
	channel: TTclChannel;
begin
    result := PosixCheckChannel(instanceData, channel, nil);
    if result = TCL_OK then
	try
		channel.DoSetOption(interp, optionName, value, result);
    except
    	result := TCL_ERROR;
    end;
end;

function TslcChannelGetOption(instanceData: Tcl_ClientData; interp: pTcl_Interp; optionName: pChar; dsPtr: pTcl_DString): integer; cdecl;
var
	channel: TTclChannel;
	value: string;
begin
    result := PosixCheckChannel(instanceData, channel, nil);
    if result = TCL_OK then
    try
	   	value := '';
		channel.DoGetOption(interp, optionName, value, result);
		if dsPtr <> nil then
	    	Tcl_DStringAppend(dsPtr, pChar(value), length(value));
    except
    	result := TCL_ERROR;
    end;
end;

procedure TslcChannelWatch(instanceData: Tcl_ClientData; mask: integer); cdecl;
var
	channel: TTclChannel;
begin
    if PosixCheckChannel(instanceData, channel, nil) = TCL_OK then
    try
		channel.DoWatch(mask);
    except
    end;
end;

function TslcChannelGetHandle(instanceData: Tcl_ClientData; direction: integer;	var handlePtr: Tcl_ClientData): integer; cdecl;
var
	channel: TTclChannel;
begin
    result := PosixCheckChannel(instanceData, channel, nil);
    if result = TCL_OK then
    try
		result := TCL_ERROR;
		channel.DoGetHandle(direction, handlePtr, result);
    except
    end;
end;

procedure TslcChannelCloseProc(clientData: Tcl_ClientData); cdecl;
var
	chan: TTclChannel;
begin
	chan := GetChannel(clientData);
    if chan <> nil then
    try
    	chan.CallbackClose;
    except
    end;
end;

function TTclChannel.Flush: boolean;
begin
	if FChannel <> nil then
        result := Tcl_Flush(FChannel) = TCL_OK
    else
    	result := True;
end;

function TTclChannel.GetOption(optName: string; var optValue: string): boolean;
var
	dStr: Tcl_DString;
begin
	if FChannel <> nil then
    begin
    	Tcl_DStringInit(@dStr);
    	result := Tcl_GetChannelOption(nil, FChannel, pChar(optName), @dStr) = TCL_OK;
        optValue := dStr.str;
        Tcl_DStringFree(@dStr);
    end else
    	result := False;
end;

function TTclChannel.GetBlocking: boolean;
var
	value: string;
    i,c: integer;
begin
	if GetOption('-blocking', value) then
    begin
    	val(value, i, c);
        if c <> 0 then
	    	FBlocking := boolean(i);
    end;
    result := FBlocking;
end;

function TTclChannel.GetBuffering: TTclChannelBuffering;
var
	val: string;
begin
	if GetOption('-buffering', val) then
    begin
    	if val = 'full' then
        	FBuffering := cbFull
        else if val = 'none' then
        	FBuffering := cbNone
        else if val = 'line' then
        	FBuffering := cbLine;
    end;
    result := FBuffering;
end;

function TTclChannel.GetBufferSize: TTclChannelBufferSize;
var
	value: string;
    i, c: integer;
begin
	if GetOption('-buffersize', value) then
    begin
    	val(value, i, c);
        if c <> 0 then
	    	FBufferSize := i;
    end;
	result := FBufferSize;
end;

function TTclChannel.GetEofChar(index: integer): TTclChannelEofChar;
var
	val: string;
    argc, x: integer;
    argv: Tcl_Argv;
    chars: array[0..1] of TTclChannelEofChar;
begin
	if ((TslcTickCount - FLastEofCharRead) > FUpdateDwell) and
    	GetOption('-eofchar', val) and (Tcl_SplitList(nil, pChar(val), argc, argv) = TCL_OK) then
    begin
    	if argc > 2 then argc := 2;
        for x:= 0 to argc - 1 do
        begin
        	val := ArgvItem(argv, x);
			if val = '{}' then
            	chars[x] := -1
            else
            	chars[x] := ord(pChar(val)^);
        end;
		if argc > 0 then
        	FEofCharIn := chars[0];
        if argc > 1 then
        	FEofCharOut := chars[1];
        FLastEofCharRead := TslcTickCount;
    end;
    if index = 0 then
    	result := FEofCharIn
    else
    	result := FEofCharOut;
end;

function TTclChannel.GetTranslation(index: integer): TTclChannelTranslation;
var
	val: string;
    argc, x: integer;
    argv: Tcl_Argv;
    trans: array[0..1] of TTclChannelTranslation;
begin
	if ((TslcTickCount - FLastTranslationRead) > FUpdateDwell) and
		GetOption('-translation', val) and (Tcl_SplitList(nil, pChar(val), argc, argv) = TCL_OK) then
    begin
    	if argc > 2 then argc := 2;
        for x:= 0 to argc - 1 do
        begin
			val := ArgvItem(argv, x);
            if val = 'auto' then
				trans[x] := ctAuto
            else if val = 'binary' then
            	trans[x] := ctBinary
            else if val = 'cr' then
            	trans[x] := ctCr
            else if val = 'crlf' then
            	trans[x] := ctCrLf
            else if val = 'lf' then
            	trans[x] := ctLf;
		end;
        Tcl_Free(pChar(argv));
        if argc > 0 then
			FTranslationIn := trans[0];
        if argc > 1 then
        	FTranslationOut := trans[1];
        FLastTranslationRead := TslcTickCount;
    end;
    if index = 0 then
        result := FTranslationIn
    else
    	result := FTranslationOut;
end;

procedure TTclChannel.SetBlocking(value: boolean);
const
	cBool: array[False..True] of pChar = ('0', '1');
begin
	if value = FBlocking then
    	exit;
	if FChannel <> nil then
    begin
    	if Tcl_SetChannelOption(nil, FChannel, '-blocking', cBool[value]) = TCL_OK then
        	FBlocking := value;
    end else
    	FBlocking := value;
end;

procedure TTclChannel.SetBuffering(value: TTclChannelBuffering);
const
	cBuffering: array[cbFull..cbNone] of pChar = ('full', 'line', 'none');
begin
	if value = FBuffering then
    	exit;
	if FChannel <> nil then
    begin
    	if Tcl_SetChannelOption(nil, FChannel, '-buffering', cBuffering[value]) = TCL_OK then
        	FBuffering := value;
    end else
    	FBuffering := value;
end;

procedure TTclChannel.SetBufferSize(value: TTclChannelBufferSize);
begin
	if value = FBufferSize then
    	exit;
	if FChannel <> nil then
    begin
    	if Tcl_SetChannelOption(nil, FChannel, '-buffersize', pChar(inttostr(value))) = TCL_OK then
        	FBufferSize := value;
    end else
    	FBufferSize := value;
end;

procedure TTclChannel.SetEofChars(inValue, outValue: TTclChannelEofChar; AMode: TTclChannelMode);
var
    argv: Tcl_Argv;
    p: pChar;
    inBuf, outBuf: array[0..1] of char;
    pp: array[0..1] of pointer;
begin
	if FChannel <> nil then
    begin
		inBuf[1] := #0;
        outBuf[1] := #0;
		argv := @pp;
        if AMode = cmRead then
            outValue := EofCharOut
        else if AMode = cmWrite then
        	inValue := EofCharIn;
		if inValue < 0 then
	        AssignArgvItem(argv, 0, '{}')
        else
        begin
        	inBuf[0] := Chr(inValue);
        	AssignArgvItem(argv, 0, inBuf);
        end;
		if outValue < 0 then
	        AssignArgvItem(argv, 1, '{}')
        else
        begin
        	outBuf[0] := Chr(outValue);
        	AssignArgvItem(argv, 1, outBuf);
        end;
		p := Tcl_Merge(2, argv);
    	if Tcl_SetChannelOption(nil, FChannel, '-eofchar', p) = TCL_OK then
        begin
        	FEofCharIn := inValue;
            FEofCharOut := outValue;
        end;
        Tcl_Free(p);
    end else
    begin
    	if AMode <> cmWrite then
        	FEofCharIn := inValue;
        if AMode <> cmRead then
        	FEofCharOut := outValue;
    end;
end;

procedure TTclChannel.SetEofChar(index: integer; value: TTclChannelEofChar);
begin
	if index = 0 then
    begin
    	if value <> FEofCharIn then
	    	SetEofChars(value, FEofCharOut, cmRead)
    end else
    	if value <> FEofCharOut then
	    	SetEofChars(FEofCharIn, value, cmWrite);
end;

procedure TTclChannel.SetTranslations(inValue, outValue: TTclChannelTranslation; AMode: TTclChannelMode);
const
	cTrans: array[ctAuto..ctLf] of pChar = ('auto', 'binary', 'cr', 'crlf', 'lf');
var
    argv: Tcl_Argv;
    p: pChar;
    pp: array[0..1] of pointer;
begin
	if FChannel <> nil then
    begin
        argv := @pp;
		if AMode = cmRead then
            outValue := TranslationOut;
        if AMode = cmWrite then
        	inValue := TranslationIn;
        AssignArgvItem(argv, 0, cTrans[inValue]);
        AssignArgvItem(argv, 1, cTrans[outValue]);
		p := Tcl_Merge(2, argv);
    	if Tcl_SetChannelOption(nil, FChannel, '-translation', p) = TCL_OK then
        begin
        	FTranslationIn := inValue;
            FTranslationOut := outValue;
        end;
        Tcl_Free(p);
    end else
    begin
    	if AMode <> cmWrite then
        	FTranslationIn := inValue;
        if AMode <> cmRead then
        	FTranslationOut := outValue;
    end;
end;

procedure TTclChannel.SetTranslation(index: integer; value: TTclChannelTranslation);
begin
	if index = 0 then
    begin
    	if value <> FTranslationIn then
	    	SetTranslations(value, FTranslationOut, cmRead)
    end else
    	if value <> FTranslationOut then
	    	SetTranslations(FTranslationIn, value, cmWrite);
end;

procedure TTclChannel.CheckActive;
begin
	if Active then
    	TclError(FmtLoadStr(sTslcOpFailActiveChannel_S,[name]));
end;

function TTclChannel.GetActive: boolean;
begin
   	result := FActive
end;

type
	TNameMsg = record
	  Msg: Word;
	  case Integer of
    	0: (
	      WParam: Word;
    	  LParam: Longint;
	      Result: Longint);
	    1: (
	      WParamLo: Byte;
	      WParamHi: Byte;
	      LParamLo: Word;
	      LParamHi: Word;
	      ResultLo: Word;
	      ResultHi: Word);
      end;

procedure TTclChannel.SetName(const NewName: TComponentName);
var
	_NewName: TTclNewName;
    msg: TNameMsg;
begin
	inherited SetName(NewName);
{	if (csDesigning in ComponentState) and Assigned(Tcl) and Assigned(Tcl.Designer) then
    begin
		_NewName.Comp := Self;
        _NewName.NewName := NewName;
        msg.msg := WM_NAMECHANGE;
        msg.wParam := 0;
        msg.lParam := LongInt(@_NewName);
        Tcl.Designer.Dispatch(msg);
//		SendMessage(Tcl.Designer.Handle, WM_NAMECHANGE, 0, LongInt(@_NewName));
    end;
}
end;

procedure TTclChannel.RegisterChannel(interp: pTcl_Interp);
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(0, self, 'RegisterChannel', 'Interp: %p', [interp]);
{$ENDIF}
	if (FChannel = nil) or not Active then // inheritants may try to implement this during design mode
    	exit;
	Active := True; // ??? Automatic ???
    TrackInterp(interp);
	Tcl_RegisterChannel(interp, FChannel);
end;

procedure TTclChannel.SetActive(value: boolean);
begin
	if value = FActive then
    	exit;
    if csReading in ComponentState then
    	FStreamedActive := value
    else if value then
    	Open
    else
    	Close;
end;

procedure TTclChannel.SetChannelName(value: string);
begin
	FChannelName := Trim(FChannelName);
	if value = FChannelName then
    	exit;
    CheckActive;
    FChannelName := value;
end;

procedure TTclChannel.SetChannelType(value: TTclChannelType);
begin
	if FChannelType = value then
    	exit;
    CheckActive;
    case value of
		ctNormal: FMode := cmReadWrite;
    	ctStdIn: FMode := cmRead;
        ctStdErr,
        ctStdOut: FMode := cmWrite;
    end;
    FChannelType := value;
end;

procedure TTclChannel.SetMode(value: TTclChannelMode);
begin
	if value = FMode then
    	exit;
    CheckActive;
    if FChannelType <> ctNormal then
    	TclError('Cannot change mode on Standard Channels');
    FMode := value;
end;

procedure TTclChannel.SetOptions(value: TTclChannelOptions);
begin
	if FOptions = value then
    	exit;
	CheckActive;
    FOptions := value;
end;

procedure TTclChannel.UnregisterChannel(interp: pTcl_Interp);
begin
	if FChannel = nil then
    	exit;
	Tcl_UnregisterChannel(interp, FChannel);
    UntrackInterp(interp);
end;

procedure TTclChannel.DoBlockMode(mode: integer; var result: integer);
begin
	if Assigned(FOnBlockMode) then
    	FOnBlockMode(Self, mode, result);
end;

procedure TTclChannel.DoClose(interp: pTcl_Interp; var result: integer);
begin
	if Assigned(FOnClose) then
    	FOnClose(Self, interp, result);
end;

procedure TTclChannel.DoInput(buf: pChar; toRead: integer; var errorCode: integer; var result: integer);
begin
	if Assigned(FOnInput) then
    	FOnInput(Self, buf, toRead, errorCode, result);
end;

procedure TTclChannel.DoOutput(buf: pChar; toWrite: integer; var errorCode: integer; var result: integer);
begin
	if Assigned(FOnOutput) then
    	FOnOutput(Self, buf, toWrite, errorCode, result);
end;

procedure TTclChannel.DoSeek(offset: longint; mode: integer; var errorCode: integer; var result: integer);
begin
	if Assigned(FOnSeek) then
    	FOnSeek(Self, offset, mode, errorCode, result);
end;

procedure TTclChannel.DoSetOption(interp: pTcl_Interp; optionName: pChar; value: pChar; var result: integer);
begin
	if Assigned(FOnSetOption) then
    	FOnSetOption(Self, interp, optionName, value, result);
end;

procedure TTclChannel.DoGetOption(interp: pTcl_Interp; optionName: pChar; var value: string; var result: integer);
begin
	if Assigned(FOnGetOption) then
		FOnGetOption(Self, interp, optionName, value, result);
end;

procedure TTclChannel.DoWatch(mask: integer);
begin
	if Assigned(FOnWatch) then
    	FOnWatch(Self, mask);
end;

procedure TTclChannel.DoGetHandle(direction: integer; var handlePtr: Tcl_ClientData; var result: integer);
begin
	if Assigned(FOnGetHandle) then
    	FOnGetHandle(Self, direction, handlePtr, result);
end;

constructor TTclChannel.Create(AOwner: TComponent);
begin
	inherited Create(AOwner);
    FOldSelf := Self;
    FInterpList := TList.Create;
    FUpdateDwell := 1000;
    FOptions := [coPresetFullWrite];
{$IFDEF TSLC_DEBUG}
	TraceCompProc(0, self, 'Create', 'Self: %p', [pointer(Self)]);
{$ENDIF}
end;

destructor TTclChannel.Destroy;
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'Destroy', 'Self: %p', [pointer(FOldSelf)]);
{$ENDIF}
	if FChannelData <> nil then
	    pTclChannelData(FChannelData)^.Channel := nil;
	Close;
    DoDestroy;
    FInterpList.Free;
	inherited Destroy;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, SD('(TTclChannel)'), 'Destroy', 'Self: %p', [pointer(FOldSelf)]);
{$ENDIF}
end;

procedure TTclChannel.DoCreate;
begin
	if Assigned(FOnCreate) then
    	FOnCreate(Self);
end;

procedure TTclChannel.DoDestroy;
begin
	if Assigned(FOnDestroy) then
    	FOnDestroy(Self);
end;

procedure TTclChannel.Open;
const
	chanMode: array[cmRead..cmReadWrite] of integer = (TCL_READABLE, TCL_WRITABLE,  TCL_READABLE or TCL_WRITABLE);
	chanType: array[ctNormal..ctStdErr] of integer = (-1, TCL_STDIN, TCL_STDOUT, TCL_STDERR);
var
    prevBlocking: boolean;
	prevBuffering: TTclChannelBuffering;
    prevBufferSize: TTclChannelBufferSize;
begin
	if Active then
    	exit;
    if csDesigning in ComponentState then
    begin
    	FActive := True;
        exit;
    end;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'Open', '', [0]);
{$ENDIF}
    InitTcl;
	if FChannelName = '' then
    	TclError('Bad Channel Name');// ??? raise invalid name
	if FChannelData <> nil then
    	pTclChannelData(FChannelData)^.Channel := nil;
	FChannelData := pointer(AddChannelData(self));
    TslcEnterCritical;
    try
		FChannel := Tcl_CreateChannel(@TslcChannelType, pChar(FChannelName), FChannelData, chanMode[FMode]);
	finally
    	TslcLeaveCritical;
    end;
    if FChannel = nil then
	   	TclError('Unable to create channel...'); //???
//	Tcl_Preserve(FChannel);
    Tcl_CreateCloseHandler(FChannel, TslcChannelCloseProc, FChannelData);
	FActive := True;
	prevBuffering := FBuffering;
    if FBuffering = cbFull then
    	FBuffering := cbNone
    else
    	FBuffering := cbFull;
    prevBufferSize := FBufferSize;
    if FBufferSize = 10 then
    	FBufferSize := 11
    else
    	FBufferSize := 10;
    prevBlocking := FBlocking;
    FBlocking := not FBlocking;

    Blocking := prevBlocking;
    Buffering := prevBuffering;
    BufferSize := prevBufferSize;
	SetEofChars(FEofCharIn, FEofCharOut, cmReadWrite);
    SetTranslations(FTranslationIn, FTranslationOut, cmReadWrite);
	if ChannelType <> ctNormal then
    	Tcl_SetStdChannel(FChannel, chanType[ChannelType]);

    if coRegNullInterp in FOptions then
    	Tcl_RegisterChannel(nil, FChannel);
	// Install Tracked Interps ???         
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, self, 'Open', '', [0]);
{$ENDIF}
end;

procedure TTclChannel.Loaded; //???
begin
	inherited Loaded;
    DoCreate;
    if FStreamedActive then
    	Open;
end;

procedure TTclChannel.CallbackClose;
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'CallbackClose', '', [0]);
{$ENDIF}
    FChannel := nil;
    FActive := False;
	FInterpList.Clear;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, self, 'CallbackClose', '', [0]);
{$ENDIF}
end;

procedure TTclChannel.Close;
const
	chanType: array[ctNormal..ctStdErr] of integer = (-1, TCL_STDIN, TCL_STDOUT, TCL_STDERR);
var
	x: integer;
begin
	if FChannel <> nil then
    begin
{$IFDEF TSLC_DEBUG}
		TraceCompProc(1, self, 'Close', '', [0]);
{$ENDIF}
		Flush;
	    with FInterpList do
	    for x:= 0 to Count - 1 do
	    	Tcl_UnregisterChannel(pTcl_Interp(items[x]), FChannel);
	    FInterpList.Clear;
	    if (FChannel <> nil) and (coRegNullInterp in FOptions) then
	    	Tcl_UnregisterChannel(nil, FChannel);
//		if ChannelType <> ctNormal then // ??? quickie...
//    		Tcl_SetStdChannel(nil, chanType[ChannelType]);
	//	if FChannel <> nil then
	//		Tcl_Release(FChannel);
{$IFDEF TSLC_DEBUG}
		TraceCompProc(-1, self, 'Close', '', [0]);
{$ENDIF}
	end;
	if FChannelData <> nil then
    	pTclChannelData(FChannelData)^.Channel := nil;
    FActive := False;
end;

procedure TTclChannel.InterpDelete(interp: pTcl_Interp);
begin
	UntrackInterp(interp);
end;

procedure TTclChannel.TrackInterp(interp: pTcl_Interp);
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'TrackInterp', 'AInterp: %p', [interp]);
{$ENDIF}
    Tcl_CallWhenDeleted(interp, TslcIDP_TTclChannel, self);
	FInterpList.Add(interp);
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, self, 'TrackInterp', 'AInterp: %p', [interp]);
{$ENDIF}
end;

procedure TTclChannel.UntrackInterp(interp: pTcl_Interp);
var
	i: integer;
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'UntrackInterp', 'AInterp: %p', [interp]);
{$ENDIF}
	i := FInterpList.indexOf(interp);
    if i >= 0 then
    	FInterpList.Delete(i);
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, self, 'UntrackInterp', 'AInterp: %p', [interp]);
{$ENDIF}
end;

{~~~ TTclEventSource ~~~}
const
	cMagic: array[False..True] of integer = ($452AD9F2,$2987A8C1);
	cAlpha = #$B0+#$0B+#$08+#$5D+#$04+#$06+#$18+#$85+#$A1+#$21+#$CE+#$53+#$00;

procedure AlphaMagic(p: pChar);
var
	q: pChar;
begin
	q := cAlpha;
    while (q^ <> #0) and (p^ <> #0) and (p^ = q^) do
    begin
    	inc(q);
        inc(p);
    end;
    if (q^ <> #0) or (p^ <> #0) then
    	TclError('');
end;

constructor TTclEventSource.Create(AOwner: TComponent);
begin
    inherited Create(AOwner);
end;

destructor TTclEventSource.Destroy;
begin
	Uninstall;
	inherited Destroy;
end;

procedure TTclEventSource.Loaded;
begin
	inherited Loaded;
	try
    	if FStreamedActive then
        	SetActive(True);
  	except
    	on E:Exception do
    	if csDesigning in ComponentState then
       		TslcMessage(E.Message, tmError)
    	else
      		raise;
  	end;
end;

procedure TTclEventSource.DoSetup(flags: integer);
begin
	if Assigned(FOnSetup) then
    	FOnSetup(self, flags);
end;

procedure TTclEventSource.DoCheck(flags: integer);
begin
	if Assigned(FOnCheck) then
    	FOnCheck(self, flags);
end;

procedure TTclEventSource.Install;
begin
	if FActive then exit;
    if not Assigned(FOnSetup) and not Assigned(FOnCheck) then exit;
    Tcl_CreateEventSource(TslcEventSetup, TslcEventCheck, self);
    FActive := true;
end;

procedure TTclEventSource.SetActive(value: boolean);
begin
	if csReading in ComponentState then
    	FStreamedActive := value
    else if value then
    	Install
    else
    	Uninstall;
end;

procedure TTclEventSource.Uninstall;
begin
	if not FActive then exit;
    Tcl_DeleteEventSource(TslcEventSetup, TslcEventCheck, self);
    FActive := false;
end;

{~~~ TTclTimer ~~~}
constructor TTclTimer.Create(AOwner: TComponent);
begin
	FActive := False;
    FMilliseconds := 1000;
    FTimerKind := tkNormal;
    FOnTimer := nil;
    inherited Create(AOwner);
end;

destructor TTclTimer.Destroy;
begin
	Uninstall;
    inherited Destroy;
end;

procedure TTclTimer.Loaded;
begin
	inherited Loaded;
    try
		if FStreamedActive then
        	SetActive(True);
    except
    	on E:Exception do
        if csDesigning in ComponentState then
        	TslcMessage(E.Message, tmError)
        else
        	raise;
    end;
end;

procedure TTclTimer.DoTimer(kind: TTclTimerKind);
begin
	if kind <> FTimerKind then exit; // ???
	if FTimerKind in [tkNormal] then FActive := False; // Prevents user unloading of timer that is already unloaded.
	if Assigned(FOnTimer) then
    	FOnTimer(self);
end;

procedure TTclTimer.Install;
begin
	if FActive then exit;
    if not Assigned(FOnTimer) then exit;
    case FTimerKind of
    	tkIdle:		Tcl_DoWhenIdle(TslcIdleTimer, self);
//			        Tcl_CreateModalTimeout(FMilliseconds, TslcModalTimer, self);
        tkModal:	TclError(FmtLoadStr(sTslcOpNoLongerSupported_S, ['Tcl_CreateModalTimeout']));
        tkNormal:	FTimerToken := Tcl_CreateTimerHandler(FMilliseconds, TslcNormalTimer, self);
    end;
    FActive := true;
end;

procedure TTclTimer.SetActive(value: boolean);
begin
	if csReading in ComponentState then
    	FStreamedActive := value
    else if value then
    	Install
    else
    	Uninstall;
end;

procedure TTclTimer.SetMilliseconds(val: longint);
begin
	if val = FMilliseconds then exit;
    if val < 0 then
    	TclError(LoadStr(sTslcNoValuesLessThanZero));
    FMilliseconds := val;
end;

procedure TTclTimer.SetTimerKind(kind: TTclTimerKind);
begin
	if kind = FTimerKind then exit;
	if FActive then
    	TclError(LoadStr(sTslcOpFailActiveTimer));
	FTimerKind := kind;
end;


procedure TTclTimer.Uninstall;
begin
	if not FActive then exit;
    case FTimerKind of
    	tkIdle:		Tcl_CancelIdleCall(TslcIdleTimer, self);
//					Tcl_DeleteModalTimeout(TslcModalTimer, self);
        tkModal:	TclError(FmtLoadStr(sTslcOpNoLongerSupported_S, ['Tcl_DeleteModalTimeout']));
        tkNormal:	Tcl_DeleteTimerHandler(FTimerToken);
    end;
    FActive := false;
end;

{~~~ TTclBridge ~~~}
destructor TTclBridge.Destroy;
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(0, self, 'Destroy', '', [0]);
{$ENDIF}
	if FClient <> nil then
    	FClient.RemoveBridge(Self);
	inherited Destroy;
end;

procedure TTclBridge.Notification(AComponent: TComponent; Operation: TOperation);
begin
	inherited Notification(AComponent, Operation);
	if Operation = opRemove then
    	if AComponent = Client then
        begin
        	Client := nil;
            if boFreeOnClientFree in FOptions then
            	Free;
        end else if AComponent = Server then
        begin
        	Server := nil;
            if boFreeOnServerFree in FOptions then
            	Free;
        end;
end;

procedure TTclBridge.SetClient(ATcl: TTcl);
begin
	if ATcl = FClient then
    	exit;
    if (ATcl = FServer) and (ATcl <> nil) then
    	TclError(LoadStr(sTslcOpFailClientEqServer));
    if FClient <> nil then
    	FClient.RemoveBridge(Self);
    FClient := ATcl;
	if FClient <> nil then
    	FClient.AddBridge(Self);
end;

procedure TTclBridge.SetServer(ATcl: TTcl);
var
   prevClient: TTcl;
begin
	if ATcl = FServer then
    	exit;
    if (ATcl = FClient) and (ATcl <> nil) then
    	TclError(LoadStr(sTslcOpFailClientEqServer));
	prevClient := FClient;
	Client := nil;
    FServer := ATcl;
    Client := prevClient;
end;

{~~~ TTcl ~~~}
procedure TTcl.AddCommand(cmd: TTclCommand);
begin
	if cmd = nil then exit;
    if FCommands.IndexOf(cmd) <> -1 then // 3/20/97
    	TclError(LoadStr(sTslcMultCommandInsertion));
//	RemoveCommand(cmd);
//   	if Assigned(FInterp) then 3/25/97
    InstallCommand(cmd, nil);
   	FCommands.add(cmd);
    cmd.FTcl := self;
end;

procedure TTcl.AddBridge(ABridge: TTclBridge);
var
	x: integer;
begin
	if (FBridgeList.indexOf(ABridge) >= 0) or (ABridge = nil) then
    	exit;
	FreeNotification(ABridge);
   	FBridgeList.Add(ABridge);
    if Assigned(ABridge.Server) then
    for x:= 0 to InterpreterCount - 1 do
   		ABridge.Server.ServiceInterp(Interpreters[x]);
end;

procedure TTcl.AddTrace(trace: TTclTrace);
begin
	if trace = nil then exit;
    if FTraces.IndexOf(trace) <> -1 then // 3/20/97
    	TclError(LoadStr(sTslcMultTraceInsertion));
//	RemoveTrace(trace);
//if Assigned(FInterp) then 3/25/97
    InstallTrace(trace, nil);
	FTraces.add(trace);
    trace.FTcl := self;
end;

procedure TTcl.AfterClose;
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'AfterClose', '', [0]);
{$ENDIF}
	if Assigned(FAfterClose) then FAfterClose(self);
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, self, 'AfterClose', '', [0]);
{$ENDIF}
end;

procedure TTcl.AfterEval;
begin
	if Assigned(FAfterEval) then FAfterEval(self);
end;

procedure TTcl.AfterInitInterp(AInterp: pTcl_Interp);
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'AfterInitInterp', 'AInterp: %p', [AInterp]);
{$ENDIF}
	if Assigned(FAfterInitInterp) then
    	FAfterInitInterp(Self, AInterp);
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, self, 'AfterInitInterp', 'AInterp: %p', [AInterp]);
{$ENDIF}
end;

procedure TTcl.AfterOpen;
begin
	if Assigned(FAfterOpen) then FAfterOpen(self);
end;

procedure TTcl.BeforeClose;
begin
	if Assigned(FBeforeClose) then FBeforeClose(self);
end;

procedure TTcl.BeforeEval;
begin
	if Assigned(FBeforeEval) then FBeforeEval(self);
end;

procedure TTcl.BeforeInitInterp(AInterp: pTcl_Interp);
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'BeforeInitInterp', 'AInterp: %p', [AInterp]);
{$ENDIF}
    if Assigned(FBeforeInitInterp) then
    	FBeforeInitInterp(self, AInterp);
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, self, 'BeforeInitInterp', 'AInterp: %p', [AInterp]);
{$ENDIF}
end;

procedure TTcl.BeforeOpen;
begin
	if Assigned(FBeforeOpen) then FBeforeOpen(self);
end;

function TTcl.BuildCommand: TTclCommandClass;
begin
	result := TTclCommand;
end;

function TTcl.BuildTrace: TTclTraceClass;
begin
	result := TTclTrace;
end;

procedure TTcl.CheckInterp;
begin
	if not Assigned(FInterp) then
   		TclError(LoadStr(sTslcAccessInvalidInterp));
end;

procedure TTcl.Close;
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'Close', '', [0]);
{$ENDIF}
	if Active and Assigned(FInterp) then // and not TslcIsLibrary then
	begin
   		BeforeClose;
		try
        	ShutDownInterp(FInterp);
      		AfterClose;
	   	finally
	   	   	FInterp := nil;
	   	end;
   	end;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, self, 'Close', '', [0]);
{$ENDIF}
end;

function TTcl.ConvertEOL(const script: string): string;
var
	Source, SourceEnd, Dest: PChar;
	Extra, len: Integer;
begin
	Source := Pointer(Script);
	Dest := Source;
	len := Length(Script);
	SourceEnd := Source + Len;
	Extra := 0;
	SetString(Result, nil, Len);
	Dest := Pointer(Result);
	while Source < SourceEnd do
	begin
		if (Source^ = #$D) and (Source[1] = #$A) then inc(Extra)
    	else
    	begin
    		Dest^ := Source^;
      		inc(Dest);
    	end;
    	inc(Source);
	end;
  	SetLength(Result, len - extra);
end;

function ConvertPEOL(source: pChar): pChar;
var
  Dest: PChar;
begin
	Result := Source;
	Dest := Source;
	while Source^ <> #0 do
	begin
		while Source^ = #$D do
        begin
            inc(Source);
            if Source^ = #$A then
            	inc(Source);
            Dest^ := #$A;
            inc(Dest);
        end;
        Dest^ := Source^;
        inc(Source);
        inc(Dest);
    end;
	Dest^ := #0;
end;

constructor TTcl.Create(AOwner: TComponent);
begin
   	FError := TCL_OK;
   	FCommands := TList.Create;
    FChannels := TList.Create;
   	FTraces := TList.Create;
    FBridgeList := TList.Create;
    FAutoActive := True;
	FOptions := [toConvertEOL,toTslcVersion, toBindExistingNS];
    FInterpList := TList.Create;
    FAuxInterps := TList.Create;
   	inherited Create(AOwner);
    FOldSelf := Self;
	if Assigned(AOwner) then
    	AOwner.FreeNotification(self);
    TslcEnterCritical;
    try
	    TslcInitList.add(self);
    finally
    	TslcLeaveCritical;
    end;
end;

procedure TTcl.CheckActive;
begin
	if FActive then
    	TclError(LoadStr(sTslcOpFailActiveInterp));
end;


function TTcl.CreateAuxInterp(AOptions: TTclOptions; ASafe: boolean): pTcl_Interp;
var
	prevOpts: TTclOptions;
    i: pTcl_Interp;
    idx: integer;
begin
	prevOpts := FOptions;
	FOptions := AOptions;
    try
    	i := Tcl_CreateInterp;
        try
        	FAuxInterps.Add(i);
        	InitInterp(i, ASafe);
        except
			idx := IndexOfAux(i);
            if idx >= 0 then
            	FAuxInterps.Delete(idx);
            Tcl_DeleteInterp(i);
            raise;
        end;
    finally
    	FOptions := prevOpts;
    end;
end;

procedure TTcl.DeleteTclCommand(cmdName: string);
var
	x: integer;
    _interp: pTcl_Interp;
begin
    if Assigned(FInterpList) then
    with FInterpList do
    	for x:= 0 to Count - 1 do
        begin
        	_interp := items[x];
            if Assigned(_interp) then
            	Tcl_DeleteCommand(_interp, pChar(cmdName));
        end;
end;

destructor TTcl.Destroy;
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'Destroy', 'FInterp: %p, Self: %p', [FInterp, pointer(Self)]);
{$ENDIF}
	Destroying;
	RemoveFromInitLists;
	FDesigner.Free;

	ShutDownAll;
//	if Assigned(FClient) then
//    	FClient.RemoveServer(Self);

    UnlinkBridges;
    FBridgeList.Free;
    FBridgeList := nil;
    UninstallCommands;
    UninstallTraces;

	FAuxInterps.free;
    FInterpList.free;
    DestroyCommands;
    FCommands.Free;
    DestroyTraces;
    FTraces.Free;
	RemoveChannels;
	FChannels.Free;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(0, self, 'Destroy', 'Calling Inherited', [0]);
{$ENDIF}
	inherited Destroy;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, SD('(TTcl)'), 'Destroy', 'Self: %p', [pointer(FOldSelf)]);
{$ENDIF}
end;

procedure TTcl.DestroyCommands;
var
	cmd: TTclCommand;
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'DestroyCommands', '', [0]);
{$ENDIF}
	while FCommands.Count > 0 do
    begin
    	cmd := FCommands.Last;
        RemoveCommand(cmd);
        cmd.free;
    end;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, self, 'DestroyCommands', '', [0]);
{$ENDIF}
end;

procedure TTcl.DestroyTraces;
var
	trace: TTclTrace;
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'DestroyTraces', '', [0]);
{$ENDIF}
	while FTraces.Count > 0 do
    begin
    	trace := FTraces.Last;
        RemoveTrace(trace);
        trace.free;
	end;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, self, 'DestroyTraces', '', [0]);
{$ENDIF}
end;

var
	FPerformCriticalEvals: boolean = True;
    FCriticalEvaluations: integer = 0;

procedure TslcCriticalEvals(value: boolean);
begin
	TslcEnterCritical;
    try
		if FPerformCriticalEvals <> value then
        begin
		    while FCriticalEvaluations > 0 do
	    		TslcSleep(1000);
	        FPerformCriticalEvals := value;
        end;
    finally
    	TslcLeaveCritical;
    end;
end;

procedure TslcCriticalEvaluation(value: boolean);
begin
	if value then
    begin
		TslcEnterCritical;
    	inc(FCriticalEvaluations);
	    if not FPerformCriticalEvals then
        	TslcLeaveCritical;
    end else
    begin
		TslcEnterCritical;
        if FPerformCriticalEvals then
        	TslcLeaveCritical;
        dec(FCriticalEvaluations);
        TslcLeaveCritical;
    end;
end;


function TTcl.DoEval(kind: TTclEvalKind; fileName, data: string): boolean;
var
	s: string;
begin
{	if TslcIsLibrary then
    begin
    	TslcMessage(LoadStr(sTslcEvalInLibrary), tmError);
		FError := TCL_OK;
        result := False;
		exit;
    end;
}
	if (not Active) and FAutoActive then Active := True;
	FError := TCL_OK;


   	if (fileName <> '')  or (data <> '') then
   	begin
		CheckInterp;
	   	BeforeEval;
		TslcCriticalEvaluation(True);
        try
		case kind of
        	ekFile:
            	begin
		        	FError := Tcl_EvalFile(FInterp, pChar(fileName));
                end;
            ekResource:
            	begin
                	s := TslcLoadScriptResource(0, fileName, data);
                    if toConvertEOL in FOptions then
						FError := Tcl_Eval(FInterp, ConvertPEOL(pChar(s)))
			        else
			        	FError := Tcl_Eval(FInterp, pChar(s));
                end;
            ekGlobalResource:
            	begin
                	s := TslcLoadScriptResource(0, fileName, data);
                    if toConvertEOL in FOptions then
						FError := Tcl_GlobalEval(FInterp, ConvertPEOL(pChar(s)))
			        else
			        	FError := Tcl_GlobalEval(FInterp, pChar(s));
                end;
            ekScript:
            	begin
        			if toConvertEOL in FOptions then
						FError := Tcl_Eval(FInterp, pChar(ConvertEOL(data)))
			        else
			        	FError := Tcl_Eval(FInterp, pChar(data));
                end;
            ekGlobalScript:
            	begin
        			if toConvertEOL in FOptions then
						FError := Tcl_GlobalEval(FInterp, pChar(ConvertEOL(data)))
			        else
			        	FError := Tcl_GlobalEval(FInterp, pChar(data));
                end;
        end;
        finally
        	TslcCriticalEvaluation(False);
        end;
   		AfterEval;
   	end;
   	Result := FError <> TCL_ERROR;
end;

procedure TTcl.DefineProperties(Filer: TFiler);
begin
	inherited DefineProperties(Filer);
    Filer.DefineProperty('Channels', ReadChannels, WriteChannels, (FChannels <> nil) and (FChannels.Count > 0));
end;

procedure TTcl.DeleteAuxInterp(index: integer);
var
	i: pTcl_Interp;
begin
	i := AuxInterps[index];
    ShutdownInterp(i);
end;

procedure TTcl.DoInterpDelete(AInterp: pTcl_Interp);
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'DoInterpDelete', 'AInterp: %p', [AInterp]);
{$ENDIF}
	if Assigned(FOnInterpDelete) then
    	FOnInterpDelete(self, AInterp);
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, self, 'DoInterpDelete', 'AInterp: %p', [AInterp]);
{$ENDIF}
end;

procedure TTcl.DoInitError(AInterp: pTcl_Interp);
begin
	if Assigned(FOnInitError) then
    	FOnInitError(self, AInterp);
end;

procedure TTcl.DoNamespaceDelete;
begin
	if Assigned(FOnNamespaceDelete) then
    	FOnNamespaceDelete(self);
end;

function TTcl.Eval(script: string): boolean;
begin
	result := DoEval(ekScript, '', script);
end;

function TTcl.EvalFile(filename: string): boolean;
begin
	result := DoEval(ekFile, filename, '');
end;

function  TTcl.EvalResource(fileName, resourceId: string): boolean;
begin
	result := DoEval(ekResource, fileName, resourceId);
end;

function TTcl.GetAuxInterps(index: integer): pTcl_Interp;
begin
	result := pTcl_Interp(FAuxInterps.items[index]);
end;

function TTcl.GetAuxInterpCount: integer;
begin
	result := FAuxInterps.Count;
end;

function TTcl.GetActive: boolean;
begin
	result := FActive; // FInterp <> nil;
end;

{$IFDEF VER90}
procedure TTcl.GetChildren(Proc: TGetChildProc);
{$ELSE}
procedure TTcl.GetChildren(Proc: TGetChildProc; Root: TComponent);
{$ENDIF}
var
	x: integer;
begin
	for x := 0 to FCommands.Count - 1 do
		Proc(FCommands[x]);
	for x := 0 to FTraces.Count - 1 do
    	Proc(FTraces[x]);
end;

function TTcl.GetChannel(index: integer): TTclChannel;
begin
	result := TTclChannel(FChannels.items[index]);
end;

function TTcl.GetChannelCount: integer;
begin
	result := FChannels.Count;
end;

function TTcl.GetCommand(index: integer): TTclCommand;
begin
	result := TTclCommand(FCommands.items[index]);
end;

function TTcl.GetCommandCount: integer;
begin
	result := FCommands.count;
end;

function TTcl.GetCommands(list: TStrings; typ: TTclCmdType; pattern: string):integer;
// Modified intensively in v0.7
// This function depends too heavily on Tcl version stability
type
    pLongInt = ^LongInt;
var
	hashEntry : pTcl_HashEntry;
   	search	: Tcl_HashSearch;
   	cmdTable : pHashTable;
   	cmdPtr : pChar;
//   	local, ObjPush : boolean;
    version: string;
begin
//	cmdTable := @(pTcl_InterpEx(FInterp).commandTable); 1/15/97 dropped - can no longer assume
//	cmdTable := pHashTable(longint(FInterp) + sizeof(Tcl_Interp));
//   	if  strtofloat(version) >= 8.0 then // pretty sure it happened in this version
//		cmdTable := pHashTable(longint(cmdTable) + sizeof(pointer));

   	Result := 0;
	cmdTable := Tcl_GetCommandTable(FInterp);
	hashEntry := Tcl_FirstHashEntry(cmdTable, search);

	if list <> nil then
		list.BeginUpdate;
    try
	while hashEntry <> nil do
   	begin
    	cmdPtr := Tcl_GetHashKey(cmdTable, hashEntry); //v1.0 firm
{		if @Tcl_GetHashKey <> nil then // Hopeful that an export (not a macro) will exist one day
	   		cmdPtr := Tcl_GetHashKey(cmdTable, hashEntry)
		else if cmdTable^.keyType = 1 then
            cmdPtr :=  pChar(pLongInt(@(hashEntry^.key[0]))^)
        else
        	cmdPtr := hashEntry^.key;
 }
{

#define TCL_STRING_KEYS		0
#define TCL_ONE_WORD_KEYS	1

#define Tcl_GetHashKey(tablePtr, h) \
    ((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS) ? (h)->key.oneWordValue \
						: (h)->key.string))

}
      	if (pattern = '') or (Tcl_StringMatch(cmdPtr, pChar(pattern)) = 1) then
      	begin
       		if (typ = ctAll) then
         	begin
         		if Assigned(list) then list.add(strpas(cmdPtr));
            	inc(result);
         	end else if (GetLocalCommand(strpas(cmdPtr)) <> nil) = (typ = ctLocal) then
         	begin
         		if Assigned(list) then list.add(strpas(cmdPtr));
            	inc(result);
         	end;
      	end;
		hashEntry := Tcl_NextHashEntry(search);
   	end;
    finally
    	if list <> nil then
	    	list.EndUpdate;
    end;
end;

function TTcl.GetInterp: pTcl_Interp;
begin
	CheckInterp;
    result := FInterp;
end;

function TTcl.GetInterpreterCount: integer;
begin
	if Assigned(FInterpList) then
    	result := FInterpList.Count
    else
    	result := 0;
end;

function TTcl.GetInterpreters(index: integer): pTcl_Interp;
begin
	if (index < 0) or (not Assigned(FInterpList)) or (index > FInterpList.Count - 1) then
		TclError(LoadStr(sTslcInterpIndexOutOfRange));
    result := FInterpList.items[index];
end;

function TTcl.GetLocalCommand(cmdName: string): TTclCommand;
var
	x, c: integer;
begin
	Result := nil;
	with FCommands do
   	begin
	  	c := count - 1;
      	for x := 0 to c do with TTclCommand(items[x]) do
			if Command = cmdName then
        	begin
           		result := TTclCommand(items[x]);
            	exit;
          	end;
   	end;
end;

function TTcl.GetNsPtr: pTcl_Namespace;
begin
    if Active then
    	result := FNsPtr
    else
    	result := nil;
end;

function TTcl.GetResult: string;
begin
	result := InterpResult(FInterp);
end;

function TTcl.GetTrace(index: integer): TTclTrace;
begin
	result := TTclTrace(FTraces.items[index]);
end;

function TTcl.GetTraceCount: integer;
begin
	result := FTraces.count;
end;

function  TTcl.GetVar(varName, elemName: string; var value: string; flags: TTclFlags): boolean;
begin
	result := SafeCheckInterp;
    if not result then exit;
    result := Tslc.GetVar(FInterp, varName, elemName, value, flags);
	if result then
    	FError := TCL_OK
    else
    	FError := TCL_ERROR;
end;

function TTcl.GlobalEval(script: string): boolean;
begin
	result := DoEval(ekGlobalScript, '', script);
end;

function  TTcl.GlobalEvalResource(fileName, resourceId: string): boolean;
begin
	result := DoEval(ekGlobalResource, fileName, resourceId);
end;

procedure TTcl.InitInterp(_interp: pTcl_Interp; _safe: boolean);
var
	x, c: integer;
    local, PrevSafe, primary, done: boolean;
    PrevInterp: pTcl_Interp;
    nsPtr: pTcl_Namespace;
    callFrame: Tcl_CallFrame;
    str: string;
    p, q: pChar;
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'InitInterp', 'AInterp=%p, ASafe=%d, IsLibrary=%d', [_interp, integer(_safe), integer(IsLibrary)]);
{$ENDIF}

	if (_interp = nil) or (IndexOfInterpreters(_interp) >= 0) then
    	exit;

	if (FNamespace <> '') then
    begin
    	nsPtr := Tcl_FindNamespace(_interp, pChar(FNamespace), nil, 0);
     	if (nsPtr <> nil) and (toNoOpExistingNS in FOptions) then
			exit;
	end else
    	nsPtr := nil;

{$IFDEF TSLC_DEBUG}
	TraceCompProc(0, self, 'InitInterp', 'NS=%s, Addr=%p, NoOp=%d, Bind=%d',
    	[FNamespace, nsPtr, integer(toNoOpExistingNS in FOptions), integer(toBindExistingNS in FOptions)]);
{$ENDIF}

	TrackInterp(_interp);

	local := IsLocalInterp(_interp);
    primary := FInterp = _interp;
    PrevSafe := FSafe;
    try
	    if primary then
	    begin
    		if _safe then
	        	MakeSafe;
    	    FActive := True;
	    end else
    		FSafe := _safe;
    except
   		if primary then
        begin
	        FInterp := nil;
            FActive := False;
          	Tcl_DeleteInterp(_interp);
        end else
          	FSafe := PrevSafe;
		UntrackInterp(_interp);
        raise;
    end;
	Tcl_Preserve(_interp);

{$IFDEF TSLC_DEBUG}
	TraceCompProc(0, self, 'InitInterp', 'AInterp=%p, Local=%d, Primary=%d', [_interp, integer(local), integer(primary)]);
{$ENDIF}
	PrevInterp := FInterp;
//    FInterp := _interp;
    try try
		Tcl_Preserve(_interp); // Work-around for untraced problem when error raised in following block
       	BeforeInitInterp(_interp);
		if local then
        begin
        	if (toPerformInit in FOptions) and (Tcl_Init(_interp) <> TCL_OK) then      //v0.7
				DoInitError(_interp);
//	            TclError(Tcl_GetStringResult(_interp));
        end;



        if (FNamespace <> '') then
        begin
			if (nsPtr = nil) or not (toBindExistingNS in FOptions) then
				nsPtr := Tcl_CreateNamespace(_interp, pChar(FNamespace), self, TslcNamespaceDeleteProc);
            if nsPtr = nil then
	            TclError(Tcl_GetStringResult(_interp));
        end;
		if primary then
        	FNsPtr := nsPtr;

        if (toTslcVersion in FOptions)
        	and not Tslc.GetVar(_interp, cTslcVersion, '', str, flagsOEM(TCL_GLOBAL_ONLY))
	        and not (Tslc.SetVar(_interp, cTslcVersion, '', TslcVersion, flagsOEM(TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG))
            and Tslc.SetVar(_interp, cTslcIssue, '', TslcIssue, flagsOEM(TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG))) then
			TclError(Tcl_GetStringResult(_interp));

	   	with FCommands do
	   	begin
	   		c := count - 1;
		   	for x := 0 to c do
	      		if Assigned(items[x]) then
	            	if InstallCommand(TTclCommand(items[x]), _interp) <> TCL_OK then
                    	TclError(Tcl_GetStringResult(_interp));
	   	end;

	    with FTraces do
	   	begin
	   		c := count - 1;
	      	for x := 0 to c do
	      		if Assigned(items[x]) then
                	if InstallTrace(TTclTrace(items[x]), _interp) <> TCL_OK then
                    	TclError(FmtLoadStr(sTslcVarTraceError_SS,[ TTclTrace(items[x]).VarName, Tcl_GetStringResult(_interp)]));
	   	end;

        if (FExportPattern <> '') and (FNamespace <> '') then
        begin
            if Tcl_PushCallFrame(_interp, callFrame, nsPtr, 0) <> TCL_OK then
            	TclError(Tcl_GetStringResult(_interp));
            try
            	str := FExportPattern;
             	p := pChar(str);
                done := p^ = #0;
                while not done do
                begin
					while p^ = #32 do inc(p);
        			q := p;
                    while not (q^ in [#32, #0]) do inc(q);
					done := q^ = #0;
                    q^ := #0;
		        	if (Tcl_Export(_interp, nsPtr, p, 0) <> TCL_OK) then
    			    	TclError(Tcl_GetStringResult(_interp));
                    p := q;
                    inc(p);
                end;
            finally
            	Tcl_PopCallFrame(_interp);
            end;
      		if (FImportPattern <> '') then
            begin
                str := FNamespace + '::' + FImportPattern;
                if Tcl_Import(_interp, nil, pChar(str), integer(toImportOverwrite in FOptions)) <> TCL_OK then
					TclError(Tcl_GetStringResult(_interp));
            end;
        end;

        with FBridgeList do
        	for x:= 0 to Count - 1 do
            with TTclBridge(items[x]) do
            	if Assigned(Server) then
                	Server.InitInterp(_interp, _safe);

		// Channels
        with FChannels do
        	for x:= 0 to Count - 1 do
            	TTclChannel(items[x]).RegisterChannel(_interp);

	   	AfterInitInterp(_interp);
		Tcl_Release(_interp); // Somehow, _interp gets unpreserved as indicated by Access Viol in Shutdown in Catch Block
        						// The extra Preserve will suffice for this prob.

    finally
        FInterp := PrevInterp;
    	if not primary then
        	FSafe := PrevSafe;
        if not local then
        	Tcl_Release(_interp);
    end;
    except
       	if local then
        begin
//        	Tcl_Preserve(_interp);
           	ShutDownInterp(_interp);
        end;
        raise;
    end;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, self, 'InitInterp', 'AInterp: %p, ASafe=%d, IsLibrary=%d', [_interp, integer(_safe), integer(IsLibrary)]);
{$ENDIF}
end;

procedure TTcl.InstallChannel(channel: TTclChannel);
var
	x: integer;
begin
	Channel.FreeNotification(self);
	for x:= 0 to InterpreterCount - 1 do
    	Channel.RegisterChannel(interpreters[x]);
end;

procedure TTcl.InsertChannel(channel: TTclChannel); // ???
begin
	if channel = nil then
    	exit;
	if FChannels = nil then
    	FChannels := TList.Create;
    if FChannels.indexOf(channel) < 0 then
    begin
	    FChannels.add(channel); // what about interp
        InstallChannel(channel);
    end;
end;

procedure TTcl.ReadChannels(Reader: TReader);
var
	str: string;
    p: pChar;
begin
	Reader.ReadListBegin;
    if FChannels <> nil then
    begin
		if FChannels.Count > 0 then
        	TslcMessage('Called Reader ReadChannels with FChannels.Count <> 0', tmError);
    	FChannels.Clear // ??? what about existing interps;
    end else
    	FChannels := TList.Create;
    while not Reader.EndOfList do
    begin
	    str := Reader.ReadString;
		GetMem(p, length(str) + 1);
        strpcopy(p, str);
        FChannels.add(p);
    end;
    Reader.ReadListEnd;
end;

procedure TTcl.RemoveChannel(channel: TTclChannel);
begin
	if FChannels <> nil then
	   	FChannels.Remove(channel); // ??? what about interp
end;

procedure TTcl.RemoveChannels;
var
	x: integer;
    chan: TTclChannel;
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'RemoveChannels', '', [0]);
{$ENDIF}
	if FChannels <> nil then
    for x:= 0 to FChannels.Count - 1 do
    begin
    	chan := TTclChannel(FChannels.items[x]);
        FChannels.items[x] := nil;
    	if chan <> nil then
//        	chan.UnregisterTcl(self);
    end;
    FChannels.Clear;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, self, 'RemoveChannels', '', [0]);
{$ENDIF}
end;

function TTcl.IndexOfAux(AInterp: pTcl_Interp): integer;
var
	i: integer;
begin
	result := -1;
    if AInterp = nil then
    	exit;
	with FAuxInterps do
	for i:= 0 to Count - 1 do
    	if items[i] = AInterp then
        begin
        	result := i;
            exit;
        end;
end;

function TTcl.IndexOfInterpreters(AInterp: pTcl_Interp): integer;
var
	i: integer;
begin
	result := -1;
    if AInterp = nil then
    	exit;
    with FInterpList do
    for i:= 0 to Count - 1 do
    	if items[i] = AInterp then
        begin
        	result := i;
            exit;
        end;
end;

function TTcl.InstallCommand(cmd: TTclCommand; AInterp: pTcl_Interp): integer;
var
    x: integer;
begin
    result := TCL_OK;
    if not (coAutoInstall in cmd.Options) then
    	exit;
    if AInterp <> nil then
        result := cmd.Install(AInterp)
    else if Assigned(FInterpList) then
    with FInterpList do
    	for x:= 0 to Count - 1 do
            if Assigned(items[x]) then
            	result := result or cmd.Install(pTcl_Interp(items[x]));
    FError := result;
end;

function TTcl.InstallTrace(trace: TTclTrace; AInterp: pTcl_Interp): integer;
var
    x: integer;
begin
	result := TCL_OK;

    if AInterp <> nil then
    	result := trace.Install(AInterp)
    else if Assigned(FInterpList) then
    with FInterpList do
    	for x:= 0 to Count - 1 do
            if Assigned(items[x]) then
            	result := trace.Install(pTcl_Interp(items[x])) or result;
    FError := result;
end;

procedure TTcl.InterpDelete(AInterp: pTcl_Interp);
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'InterpDelete', 'AInterp: %p', [AInterp]);
{$ENDIF}
	ShutDownInterp(AInterp);
	if not (csDestroying in ComponentState) then
    	DoInterpDelete(AInterp);
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, self, 'InterpDelete', 'AInterp: %p', [AInterp]);
{$ENDIF}
end;

function TTcl.IsLocalInterp(AInterp: pTcl_Interp): boolean;
begin
	result := (AInterp <> nil) and ((FInterp = AInterp) or (IndexOfAux(AInterp) >= 0));
end;

function  TTcl.LinkBoolean(varName: string; var b: longbool; readOnly: boolean): boolean; 	// "C" booleans are integers
begin
	result := SafeCheckInterp;
    if not result then exit;
    result := Tslc.LinkBoolean(FInterp, varName, b, readOnly);
end;

function  TTcl.LinkDouble(varName: string; var d: double; readOnly: boolean): boolean;
begin
	result := SafeCheckInterp;
    if not result then exit;
    result := Tslc.LinkDouble(FInterp, varName, d, readOnly);
end;

function  TTcl.LinkInteger(varName: string; var i: integer; readOnly: boolean): boolean;
begin
	result := SafeCheckInterp;
    if not result then exit;
    result := tslc.LinkInteger(FInterp, varName, i, readOnly);
end;

function  TTcl.LinkString(varName: string; var p: pChar; readOnly: boolean): boolean;
begin
	result := SafeCheckInterp;
    if not result then exit;
    result := tslc.LinkString(FInterp, varName, p, readOnly);
end;

procedure TTcl.Loaded;
var
	x: integer;
    p: pChar;
    comp: TComponent;
begin
//	if not (csDesigning in ComponentState) then InitTcl(''); // ??? moved to open; v1.0 5/19/97
	try try
// 		Locate Channel objects and replace names for instance
		if FChannels <> nil then
	        if Owner = nil then
    	    	FChannels.Clear
        	else with FChannels do
            begin
		        for x:= 0 to count -1 do
		        begin
        			p := pChar(items[x]);
					comp := Owner.FindComponent(p);
                    FreeMem(p);
                    if comp is TTclChannel then
                    begin
						items[x] := comp;
                        InstallChannel(TTclChannel(comp));
                    end else
                    	items[x] := nil;
                end;
				pack;
            end;

{$IFDEF TSLC_DEBUG}
		TraceCompProc(0, self, 'Loaded', 'Streamed Active %d', [integer(FStreamedActive)]);
{$ENDIF}
		if FStreamedActive then
    		SetActive(True);
//		if FStreamedAutoActive then
//        	SetAutoActive(True);
    except
    	on E:Exception do
        if csDesigning in ComponentState then
        	TslcMessage(E.Message, tmError)
        else
        	raise;
    end;
    finally
		inherited Loaded; // Want to know if csLoading inside of InitInterp
    end;

end;

procedure TTcl.MakeSafe;
begin
	if Assigned(FInterp) then
	   	Tcl_MakeSafe(FInterp);
   	FSafe := True;
end;

function TTcl.Merge(list: TStrings): string;
begin
	result := MergeList(list);
end;

procedure TTcl.MoveCommand(curIdx, newIdx: integer); //v1.0
begin
	FCommands.Move(curIdx, newIdx);
end;

procedure TTcl.MoveTrace(curIdx, newIdx: integer); //v1.0
begin
	FTraces.Move(curIdx, newIdx);
end;

procedure TTcl.Notification(AComponent: TComponent; Operation: TOperation);
begin
	inherited Notification(AComponent, Operation);
    if (AComponent = Owner) and (Operation = opRemove) then
    begin
    	Close;
        FInterp := nil; // TslcIsLibrary will prevent FInterp = nil.
    end else if AComponent is TTclChannel then
    	RemoveChannel(AComponent as TTclChannel);
end;

procedure TTcl.Open;
begin
	if Active then
    	exit;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'Open', 'csDesigning in ComponentState = %d', [integer(csDesigning in ComponentState)]);
{$ENDIF}
    InitTcl; //('', self);
    if Assigned(FInterp) then
    	TclError(LoadStr(sTslcOpFailActiveInterp));
    BeforeOpen;
	FInterp := Tcl_CreateInterp;
    CheckInterp;
	InitInterp(FInterp, FSafe); // Sets FActive := True
    AfterOpen;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, self, 'Open', '', [0]);
{$ENDIF}
end;

procedure TTcl.PkgProvide(package, version: string);
begin
	CheckInterp;
    TslcPkgProvide(FInterp, package, version);
end;

procedure TTcl.RemoveCommand(cmd: TTclCommand);
begin
	if cmd = nil then exit;
	UninstallCommand(cmd); // v1.0
//   	DeleteTclCommand(cmd.Command);
    cmd.FTcl := nil;
   	FCommands.Remove(cmd);
end;

procedure TTcl.RemoveFromInitLists;
begin
	TslcEnterCritical;
    try
		TslcInitList.Remove(self);
    finally
    	TslcLeaveCritical;
    end;
end;

procedure TTcl.RemoveBridge(ABridge: TTclBridge);
var
	idx, x: integer;
begin
	if csDestroying in componentState then
    	exit;
	idx := FBridgeList.IndexOf(ABridge);
    if (idx < 0) or (ABridge = nil) then
    	exit;
	FBridgeList.Delete(idx);
	if Assigned(ABridge.Server) then
	for x := 0 to InterpreterCount - 1 do
		ABridge.Server.UnserviceInterp(Interpreters[x]);
end;

procedure TTcl.RemoveTrace(trace: TTclTrace);
begin
	if trace = nil then exit;
    UninstallTrace(trace);
    trace.FTcl := nil;
	FTraces.Remove(trace);
end;

function TTcl.ResultStrings(list: TStrings): integer;
begin
	if not SafeCheckInterp then
    	result := 0
    else
		result := TslcAddTextToStrings(Tcl_GetStringResult(FInterp), list);
end;

function TTcl.SafeCheckInterp: boolean;
begin
	Result := Assigned(FInterp);
{
	if not TslcIsLibrary then
    begin
    	CheckInterp;
        result := true;
    end else
    begin
	    result := Assigned(FInterp);
    	if not Result then
    		TslcMessage(LoadStr(sTslcAccessInvalidInterp), tmError);
    end;
}
end;

procedure TTcl.ServiceInterp(AInterp: pTcl_Interp);
begin
	if AInterp <> nil then
		InitInterp(AInterp, Tcl_IsSafe(AInterp) <> 0);
end;

procedure TTcl.SetActive(value: boolean);
begin
	if value = FActive then exit;
    if csReading in ComponentState then
    	FStreamedActive := value
    else if value then
    	Open
    else
   		Close;
//	if value and not (csDesigning in ComponentState) then InitTcl(''); // ??? moved to open //v1.0 5/19/97
end;

procedure TTcl.SetAutoActive(value: boolean);
begin
{	if csReading in ComponentState then
    	FStreamedAutoActive := value
    else} if FAutoActive = value then
    	exit
    else
    	FAutoActive := value;
end;

procedure TTcl.SetExportPattern(value: string);
begin
	value := trim(value);
    if value = FExportPattern then
    	exit;
	CheckActive;
    FExportPattern := value;
end;

procedure TTcl.SetImportPattern(value: string);
begin
	value := trim(value);
    if value = FImportPattern then
    	exit;
    CheckActive;
    FImportPattern := value;
end;

procedure TTcl.SetNamespace(value: string);
begin
	value := trim(value);
    if value = FNamespace then
    	exit;
	CheckActive;
    FNamespace := value;
end;

procedure TTcl.SetChildOrder(Child: TComponent; Order: Integer);
begin
end;

procedure TTcl.SetSafe(value: boolean);
begin
	if value = FSafe then exit;
    if not Assigned(FInterp) then
    	FSafe := value
    else if value then
    	MakeSafe;
end;

function  TTcl.SetVar(varName, elemName, newValue: string; flags: TTclFlags): boolean;
begin
	result := SafeCheckInterp;
    if not result then exit;
    result := Tslc.SetVar(FInterp, varName, elemName, newValue, flags);
    if result then
    	FError := TCL_OK
    else
    	FError := TCL_ERROR;
end;

procedure TTcl.ShutDownAll;
var
	p: pTcl_Interp;
    c: integer;
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'ShutDownAll', '', [0]);
{$ENDIF}
	with FInterpList do
		while Count > 0 do
	    begin
        	c := Count;
	    	p := pTcl_Interp(items[count-1]);
	        if p <> nil then
	        	ShutDownInterp(p);
            if Count = c then
				Delete(Count - 1);
	    end;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, self, 'ShutDownAll', '', [0]);
{$ENDIF}
end;

procedure TTcl.ShutDownInterp(AInterp: pTcl_Interp);
begin
{$IFDEF TSLC_DEBUG}
	TraceCompProc(1, self, 'ShutDownInterp', 'AInterp: %p', [AInterp]);
{$ENDIF}
	if AInterp <> nil then
    begin
	    UntrackInterp(AInterp);
	    if IsLocalInterp(AInterp) then
	    begin
{$IFDEF TSLC_DEBUG}
		TraceCompProc(0, self, 'ShutDownInterp', 'Primary Interp: %p, AInterp: %p, AInterp Deleted: %d', [FInterp, AInterp, Tcl_InterpDeleted(AInterp)]);
{$ENDIF}
	    	if (Tcl_InterpDeleted(AInterp) = 0) then
	    		Tcl_DeleteInterp(AInterp);
	       	Tcl_Release(AInterp);
		    if FInterp = AInterp then
	    	begin
		    	FInterp := nil;
			    FNsPtr := nil;
	    		FActive := False;
		    end else //must be aux
		        FAuxInterps.Remove(AInterp);
	    end;
	end;
{$IFDEF TSLC_DEBUG}
	TraceCompProc(-1, self, 'ShutDownInterp', 'AInterp: %p', [AInterp]);
{$ENDIF}
end;

function TTcl.SplitList(literal: string; list: TStrings): boolean;
begin
	result := SafeCheckInterp;
    if not result then exit;
    result := Tslc.SplitList(FInterp, literal, list);
	if result then
    	FError := TCL_OK
    else
    	FError := TCL_ERROR;
end;

procedure TTcl.TrackInterp(_interp: pTcl_Interp);
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(0, self, 'TrackInterp', 'AInterp: %p',[_interp]);
{$ENDIF}
   	FInterpList.add(_interp);
	Tcl_CallWhenDeleted(_interp, TslcIDP_TTcl, FOldSelf);
end;

procedure TTcl.UnlinkBridges;
var
	x: integer;
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'UnlinkBridges', '',[0]);
{$ENDIF}
	with FBridgeList do
    for x := 0 to Count - 1 do
    	if TTclBridge(items[x]).Client = FOldSelf then // ??? else ha!!!
        	TTclBridge(items[x]).FClient := nil;
    FBridgeList.Clear;
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'UnlinkBridges', '',[0]);
{$ENDIF}
end;

procedure  TTcl.UnlinkVar(varName: string);
begin
	if not SafeCheckInterp then exit;
    Tslc.UnlinkVar(FInterp, varName);
end;

procedure TTcl.UnserviceInterp(AInterp: pTcl_Interp);
begin
    ShutDownInterp(AInterp);
end;

function TTcl.UnsetVar(varName, elemName: string; flags: TTclFlags): boolean;
begin
	result := SafeCheckInterp;
    if not result then exit;
    result := Tslc.UnsetVar(FInterp, varName, elemName, flags);
end;

procedure TTcl.UntrackAll;
var
	p: pTcl_Interp;
    c: integer;
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'UntrackInterp', '',[0]);
{$ENDIF}
	with FInterpList do
		while Count > 0 do
	    begin
        	c := Count;
	    	p := pTcl_Interp(items[count-1]);
	        if p <> nil then
	        	UntrackInterp(p);
            if Count = c then
				Delete(Count - 1);
	    end;
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'UntrackInterp', '',[0]);
{$ENDIF}
end;

procedure TTcl.UntrackInterp(_interp: pTcl_Interp); // no longer interested in interps & TTcl interdependencies
var
	i: integer;
{$IFDEF TSLC_DEBUG}
	hits: integer;
begin
    TraceCompProc(1, self, 'UntrackInterp', 'AInterp: %p',[_interp]);
    hits := 0;
{$ELSE}
begin
{$ENDIF}
{$IFDEF TSLC_DEBUG}
	TraceFmt(0, 'TTcl.UntrackInterp %p, TTcl: %s. Interp Deleted = %d', [_interp, Name, Tcl_InterpDeleted(_interp)]);
{$ENDIF}
	with FInterpList do
    begin
    	i := IndexOf(_interp);
    	while i >= 0 do
        begin
{$IFDEF TSLC_DEBUG}
			inc(hits);
		    TraceCompProc(0, self, 'UntrackInterp', 'Unhooking Callbacks, AInterp: %p, AInterp Deleted: %d',[_interp, Tcl_InterpDeleted(_interp)]);
{$ENDIF}
            Delete(i);
			if not (tsInterpDeleteProc in FTclState) then
				Tcl_DontCallWhenDeleted(_interp, TslcIDP_TTcl, FOldSelf);
	    	i := IndexOf(_interp);
        end;
    end;
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'UntrackInterp', 'AInterp: %p, Hits: %d',[_interp, hits]);
{$ENDIF}
end;

procedure TTcl.UninstallCommand(cmd: TTclCommand);
var
    x: integer;
begin
 	if Assigned(cmd) and Assigned(FInterpList) then
    with FInterpList do
	    for x:= 0 to Count - 1 do
        	if items[x] <> nil then
				cmd.Uninstall(pTcl_interp(items[x]));
end;

procedure TTcl.UninstallCommands;
var
	x: integer;
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'UninstallCommands', '',[0]);
{$ENDIF}
	for x:= 0 to CommandCount - 1 do
		UninstallCommand(Commands[x]);
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'UninstallCommands', '',[0]);
{$ENDIF}
end;

procedure TTcl.UninstallInterpCommands(AInterp: pTcl_Interp);
var
	x: integer;
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'UninstallInterpCommands', 'AInterp: %p',[AInterp]);
{$ENDIF}
	for x:= 0 to CommandCount - 1 do
    	Commands[x].Uninstall(AInterp);
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'UninstallInterpCommands', 'AInterp: %p',[AInterp]);
{$ENDIF}
end;

procedure TTcl.UninstallTrace(trace: TTclTrace);
var
    x: integer;
begin
	if Assigned(FInterpList) and Assigned(trace) then
    with FInterpList do
	    for x:= 0 to Count - 1 do
			if items[x] <> nil then
            	trace.Uninstall(pTcl_Interp(items[x]));
end;

procedure TTcl.UninstallTraces;
var
	x: integer;
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'UninstallTraces', '',[0]);
{$ENDIF}
    for x:= 0 to TraceCount - 1 do
    	UninstallTrace(Traces[x]);
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'UninstallTraces', '',[0]);
{$ENDIF}
end;

procedure TTcl.UninstallInterpTraces(AInterp: pTcl_Interp);
var
	x: integer;
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'UninstallInterpTraces', 'AInterp: %p',[AInterp]);
{$ENDIF}
	for x:= 0 to TraceCount - 1 do
    	Traces[x].Uninstall(AInterp);
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'UninstallInterpTraces', 'AInterp: %p',[AInterp]);
{$ENDIF}
end;

procedure TTcl.WriteChannels(Writer: TWriter);
var
	x: integer;
begin
	Writer.WriteListBegin;
	if FChannels <> nil then
    for x:= 0 to FChannels.Count - 1 do
    	if FChannels.items[x] <> nil then
	    	Writer.WriteString(TComponent(FChannels.items[x]).name);
    Writer.WriteListEnd;
end;


{~~~ TTclTrace ~~~}
constructor TTclTrace.Create(AOwner: TComponent);
begin
   	inherited Create(AOwner);
    FOldSelf := Self;
{$IFDEF TSLC_DEBUG}
    TraceCompProc(0, self, 'Create', 'Self: %p',[pointer(Self)]);
{$ENDIF}
end;

destructor TTclTrace.Destroy;
var
	x: integer;
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'Destroy', 'Self: %p',[pointer(FOldSelf)]);
{$ENDIF}
	Destroying;
    UninstallAll; // Frees FTraceList
	if Assigned(FTcl) then FTcl.RemoveTrace(self);
   	inherited Destroy;
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, SD('(TTclTrace)'), 'Destroy', 'Self: %p',[pointer(FOldSelf)]);
{$ENDIF}
end;

procedure TTclTrace.DefineProperties(Filer: TFiler);
begin
end;

procedure TTclTrace.DoInterpDelete(AInterp: pTcl_Interp);
begin
	if Assigned(FOnInterpDelete) then
    	FOnInterpDelete(Self, AInterp);
end;

procedure TTclTrace.DoTrace(AVarName, AElemName: string; flags: TTclFlags; var result: string; var success: boolean);
begin
    if Assigned(FOnTrace) then
	   	FOnTrace(self, AVarName, AElemName, flags, result, success);
end;

function TTclTrace.GetVar(var value: string; flags: TTclFlags): boolean;
begin
	if Tcl <> nil then
    	result := Tcl.GetVar(VarName, ElemName, value, flags)
    else
    	result := False;
end;

function TTclTrace.SetVar(newValue: string; flags: TTclFlags): boolean;
begin
	if Tcl <> nil then
    	result := Tcl.SetVar(VarName, ElemName, newValue, flags)
    else
    	result := False;
end;

function TTclTrace.GetInterp: pTcl_Interp;
begin
	CheckInterp(FInterp);
    result := FInterp;
end;

function TTclTrace.GetParentComponent: TComponent;
begin
	Result := FTcl;
end;

function TTclTrace.HasParent: Boolean;
begin
  	HasParent := FTcl <> nil;
end;

procedure TTclTrace.SetParentComponent(Value: TComponent);
begin
	if FTcl = Value then exit;
   	if Assigned(FTcl) and
    	not (csDestroying in FTcl.ComponentState) and
        not (csLoading in ComponentState) then FTcl.RemoveTrace(self);
	if Value is TTcl then
	   	TTcl(Value).AddTrace(self)
    else FTcl := nil;
end;

procedure TTclTrace.SetTcl(ATcl: TTcl);
begin
	if FTcl = ATcl then exit;
	if Assigned(FTcl) and not (csDestroying in FTcl.ComponentState) then FTcl.RemoveTrace(self);
   	if Assigned(ATcl) then ATcl.AddTrace(self)
    else FTcl := nil;
end;

procedure TTclTrace.CheckActive;
begin
	if Assigned(FTcl) and FTcl.Active then
   		TclError(LoadStr(sTslcOpFailActiveTrace));
end;

procedure TTclTrace.SetVarName(AName: TTclIdent);
begin
	AName := Trim(AName);
	if AName = FVarName then exit;
	CheckActive;
   	FVarName := AName;
end;

procedure TTclTrace.SetElemName(AName: TTclIdent);
begin
	AName := Trim(AName);
	if AName = FElemName then exit;
   	CheckActive;
   	FElemName := AName;
end;

procedure TTclTrace.SetName(const NewName: TComponentName);
var
	_NewName: TTclNewName;
    msg: TNameMsg;
begin
	inherited SetName(NewName);
	if (csDesigning in ComponentState) and Assigned(Tcl) and Assigned(Tcl.Designer) then
    begin
		_NewName.Comp := Self;
        _NewName.NewName := NewName;
        msg.msg := WM_NAMECHANGE;
        msg.wParam := 0;
        msg.lParam := LongInt(@_NewName);
        Tcl.Designer.Dispatch(msg);
//		SendMessage(Tcl.Designer.Handle, WM_NAMECHANGE, 0, LongInt(@_NewName));
    end;
end;

procedure TTclTrace.SetFlags(AFlags: TTclFlags);
begin
	if AFlags = FFlags then exit;
   	CheckActive;
   	FFlags := AFlags;
end;

function TTclTrace.ExecTrace(_interp: pTcl_Interp; AVarName: pChar; AElemName: pChar; flags: integer): pChar;
var
	newValue: string;
   	success: boolean;
    prevInterp: pTcl_Interp;
begin
	Result := nil;
    prevInterp := FInterp;
    try
	    FInterp := _interp;
	   	if True then //not (csDesigning in componentState) then
	   	begin
	      	success := true;
	      	newValue := strpas(Tcl_GetStringResult(FInterp));
	        try
				DoTrace(strpas(AVarName), strpas(AElemName), flagsOEM(flags), newValue, success);
	    	  	if newValue <> strpas(Tcl_GetStringResult(FInterp)) then
		    	 	Tcl_SetResult(FInterp, pChar(newValue), TTclFreeProc(TCL_VOLATILE));
				if not success then result := pChar(LoadStr(sTslcError));
			except  // v0.7 ??? 2/11/97
		    	on E: ETclError do
	    	    begin
		    	 	Tcl_SetResult(FInterp, pChar(E.Message), TTclFreeProc(TCL_VOLATILE));
	        	    Result := pChar(LoadStr(sTslcError));
		        end;
	    	    on E: Exception do
	        	begin
	        		if True { coCatchAll in Tcl.Options} then
		            begin
			    	 	Tcl_SetResult(FInterp, pChar(E.Message), TTclFreeProc(TCL_VOLATILE));
			            Result := pChar(LoadStr(sTslcError));
	            	end else raise;
	            end;
	        end;
        end;
    finally
    	FInterp := prevInterp;
	end;
end;

function TTclTrace.Install(AInterp: pTcl_Interp): integer;
var
	e, v: string;
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'Install', 'AInterp: %p',[AInterp]);
{$ENDIF}
	result := TCL_OK;
    v := FVarName;
    e := FElemName;
	if v = '' then
    	exit;
    if e = '' then
	   	result := Tcl_TraceVar(AInterp, pChar(v), oemFlags(Flags), TslcTraceProc, self)
	else
       	result := Tcl_TraceVar2(AInterp, pChar(v), pChar(e), oemFlags(Flags), TslcTraceProc, self);
	TrackInterp(AInterp);
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'Install', 'AInterp: %p',[AInterp]);
{$ENDIF}
end;

procedure TTclTrace.InterpDelete(AInterp: pTcl_Interp);
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'InterpDelete', 'AInterp: %p',[AInterp]);
{$ENDIF}
	UntrackInterp(AInterp); // Tcl Assoc Data will be cleaned up when Interp is *actually* deleted
    if not (csDestroying in ComponentState) then
		DoInterpDelete(AInterp);
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'InterpDelete', 'AInterp: %p',[AInterp]);
{$ENDIF}
end;

procedure TTclTrace.TrackInterp(AInterp: pTcl_Interp);
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'TrackInterp', 'AInterp: %p',[AInterp]);
{$ENDIF}
	if FInterpList = nil then
    	FInterpList := TList.Create;
    Tcl_CallWhenDeleted(AInterp, TslcIDP_TTclTrace, Self);
    FInterpList.add(AInterp);
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'TrackInterp', 'AInterp: %p',[AInterp]);
{$ENDIF}
end;

procedure TTclTrace.Uninstall(AInterp: pTcl_Interp);
var
	e, v: string;
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'Uninstall', 'AInterp: %p',[AInterp]);
{$ENDIF}
	v := FVarName;
    e := FElemName;
    if v <> '' then
    begin
	    if e = '' then
	      	Tcl_UntraceVar(AInterp, pChar(v), oemFlags(Flags), TslcTraceProc, self)
	    else
	      	Tcl_UntraceVar2(AInterp, pChar(v), pChar(e), oemFlags(Flags), TslcTraceProc, self);
		UntrackInterp(AInterp);
    end;
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'Uninstall', 'AInterp: %p',[AInterp]);
{$ENDIF}
end;

procedure TTclTrace.UninstallAll;
begin
	if FInterpList = nil then
    	exit;
    while FInterpList.Count > 0 do
    	Uninstall(pTcl_Interp(FInterpList.Last));
	FInterpList.Free;
    FInterpList := nil;
end;

procedure TTclTrace.UntrackInterp(AInterp: pTcl_Interp);
var
	x: integer;
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'UntrackInterp', 'AInterp: %p',[AInterp]);
{$ENDIF}
	if FInterpList <> nil then
    begin
		x := FInterpList.IndexOf(AInterp);
	    if x >= 0 then
	    begin
			if not (tsInterpDeleteProc in FTclState) then
		    	Tcl_DontCallWhenDeleted(pTcl_Interp(FInterpList.items[x]), TslcIDP_TTclTrace, FOldSelf);
	        FInterpList.Delete(x);
	    end;
    end;
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'UntrackInterp', 'AInterp: %p',[AInterp]);
{$ENDIF}
end;

function TTclTrace.Variable: string;
begin
	result := VarName;
    if (result <> '') and (ElemName <> '') then
    	result := format('%s(%s)', [result, ElemName]);
end;


{~~~ TTclCommand ~~~}

constructor TTclCommand.Create(AOwner: TComponent);
begin
   	inherited Create(AOwner);
    FOldSelf := Self;
	FTcl := nil;
   	FClientData := nil;
   	FCommand := '';
    FCmdMetaInfo := TList.Create;
    FHashMethod := chUpperCase;
    FInterp := nil;
   	FMinArgs := 0;
   	FMaxArgs := 0;
   	FErrorMsg := '';
    FMode := cmBoth;
    FOptions :=  [coCallParams, coCallSwitches, coParse, coRaiseInvalidSwitch, coCatchAll, coObjectCommand, coAutoInstall];
    FOnCreate  := nil;
   	FOnCommand := nil;
   	FOnDestroy := nil;
    FOnHash := nil;
    FOnPrepare := nil;
    FSwitches := TList.create;
    FSwitchPrefix := spDash;
    FSwitchPrefixOther := '-'; //v0.7
    FSwitchValues := TStringList.create;
    FParams	:= TList.create;
	FParamValues := TStringList.create;
end;

destructor TTclCommand.Destroy;
var
	x: integer;
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'Destroy', 'Self: %p',[pointer(FOldSelf)]);
{$ENDIF}
	Destroying;
    DoDestroy;
//    BreakLoop; //v1.0 good for excess ExecCommand processing
	StopEvaluating;
	while FCmdMetaInfo.Count > 0 do // need valid command info
    	DeleteCmdMetaInfo(pTcl_CmdMetaInfo(FCmdMetaInfo.last));
    UninstallAll;
	if Assigned(FTcl) then
    	FTcl.RemoveCommand(self);
    DestroySwitches;
    FSwitches.free;
    DestroyParams;
//  DeleteCmdMetaInfo was here...
    FCmdMetaInfo.Free;
    FParams.free;
    FParamValues.free;
    FSwitchValues.free;
	inherited destroy;
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, SD('(TTclCommand)'), 'Destroy', 'Self: %p',[pointer(FOldSelf)]);
{$ENDIF}
end;

function TTclCommand.IsTslcCmdInfo(pInfo: pTcl_CmdInfo): boolean;
begin
	with pInfo^ do
		result := ((ClientData = self) or (ObjClientData = self)) and
    			((@Proc = @TslcCommandProc) or (@ObjProc = @TslcObjCommandProc)) and
                	(@DeleteProc = @TslcCmdDeleteProc);
end;

function TTclCommand.AddCmdMetaInfo(fullName: string; ATcl_Command: pTcl_Command; _interp: pTcl_Interp):pTcl_CmdMetaInfo;
var
	info: Tcl_CmdInfo;
begin
    if (Tcl_GetCommandInfo(_interp, pChar(fullName), info) = 0) or
    	not IsTslcCmdInfo(@info) then
    	TclError(FmtLoadStr(sTslcFailGetCmdInfo_S, [fullName]));

	GetMem(result, sizeof(Tcl_CmdMetaInfo));
    GetMem(result^.fullName, length(fullName) + 1);
    strpcopy(result^.fullName, fullName);
    result^.HashEntry := ATcl_Command;
    result^.Interp := _interp;
    result^.Command := self;
    result^.Destroyed := nil;

//    result^.HashEntry^.DeleteData := result;
    info.DeleteData := result;
    if Tcl_SetCommandInfo(_interp, pChar(fullName), info) = 0 then
    begin
    	FreeMem(result^.fullName);
        FreeMem(result);
        TclError(FmtLoadStr(sTslcFailSetCmdInfo_S, [fullName]));
    end;


{$IFDEF TSLC_DEBUG}
   	with ATcl_Command^ do
	    TraceCompProc(0, self, 'AddCmdMetaInfo', 'AInterp: %p, AFullName: %s',[_interp, fullName]);
        //Tcl_GetHashKey(Tcl_GetCommandTable(_interp),result^.HashEntry^.hPtr)]);
{$ENDIF}
	FCmdMetaInfo.Add(result);
end;

procedure TTclCommand.DeleteCmdMetaInfo(AMetaInfo: pTcl_CmdMetaInfo);
var
	idx: integer;
    info: Tcl_CmdInfo;
{$IFDEF TSLC_DEBUG}
	p: pChar;
    he, cd: pointer;
{$ENDIF}
begin
	if AMetaInfo = nil then // ??? Paranoia
    	exit;
	idx := FCmdMetaInfo.IndexOf(AMetaInfo);
{$IFDEF TSLC_DEBUG}
	if idx >= 0 then
	    TraceCompProc(0, self, 'DeleteCmdMetaInfo', 'Command: %s, FullName: %s',[Command, AMetaInfo^.FullName])
    else
    	TraceCompProc(0, self, 'DeleteCmdMetaInfo', 'Command: %s, No Meta Info', [Command]);
{$ENDIF}
    if idx >= 0 then
    begin
  		try
			if AMetaInfo^.Destroyed <> nil then
            	AMetaInfo^.Destroyed^ := 1;
	    	FCmdMetaInfo.Delete(idx);
		    if  (Tcl_InterpDeleted(AMetaInfo^.interp) = 0) and
            	(Tcl_GetCommandInfo(AMetaInfo^.interp, pChar(AMetaInfo^.fullName), info) <> 0) and
				IsTslcCmdInfo(@info) then
            begin
				info.DeleteData := nil;
		        Tcl_SetCommandInfo(AMetaInfo^.interp, pChar(AMetaInfo^.fullName), info);
            end;
		finally
            FreeMem(AMetaInfo^.fullName);
    	    FreeMem(AMetaInfo);
        end;
    end;
end;

procedure TTclCommand.DoCommand(var result: string; var success: boolean);
begin
	if Assigned(FOnCommand) then
	   	FOnCommand(self, result, success);
end;

procedure TTclCommand.DoCreate;
begin
    if Assigned(FOnCreate) then
    	FOnCreate(self);
end;

procedure TTclCommand.DoDestroy;
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'DoDestroy', '',[0]);
{$ENDIF}
	if Assigned(FOnDestroy) then
    	FOnDestroy(self);
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'DoDestroy', '',[0]);
{$ENDIF}
end;

procedure TTclCommand.DoException(var message: string; var ignore: boolean; E: Exception);
begin
	if Assigned(FOnException) then
    try
		FOnException(Self, message, ignore, E);
    except
		on E:ETclError do
        begin
        	message := E.Message;
            ignore := False;
        end;
        on E:Exception do
        begin
	    	if coCatchAll in FOptions then
            begin
				message := E.Message;
                ignore := False;
            end else
            	raise;
    	end;
    end;
end;

procedure TTclCommand.DoInterpDelete(AInterp: pTcl_Interp);
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'DoInterpDelete', 'AInterp: %p',[AInterp]);
{$ENDIF}
	if Assigned(FOnInterpDelete) then
    	FOnInterpDelete(Self, AInterp);
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'DoInterpDelete', 'AInterp: %p',[AInterp]);
{$ENDIF}
end;

procedure TTclCommand.DoPrepare(var result: string; var success: boolean);
begin
	if Assigned(FOnPrepare) then
    	FOnPrepare(Self, result, success);
end;

procedure TTclCommand.DoSafeScriptDelete(AInterp: pTcl_Interp; ACmdMetaInfo: pTcl_CmdMetaInfo);
var
	dead: integer;
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'DoSafeScriptDelete', 'AInterp: %p',[AInterp]);
{$ENDIF}
	dead := 0;
	try
		ACmdMetaInfo^.Destroyed := @dead;
    	try
		   	DoScriptDelete(AInterp);
        finally
{$IFDEF TSLC_DEBUG}
		    TraceCompProc(0, SD('(TTclCommand)'), 'DoSafeScriptDelete', 'In Process..., Self = %p', [pointer(FOldSelf)]);
{$ENDIF}
	        if dead = 0 then
                DeleteCmdMetaInfo(ACmdMetaInfo);
        end;
    except
    	on E:Exception do
			TslcMessage(E.Message, tmError);
    end;
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, SD('(TTclCommand)'), 'DoSafeScriptDelete', 'Self: %p, AInterp: %p',[pointer(FOldSelf), AInterp]);
{$ENDIF}
end;

procedure TTclCommand.DoScriptDelete(AInterp: pTcl_Interp);
begin
	if Assigned(FOnScriptDelete) then
    	FOnScriptDelete(Self, AInterp);
end;

function TTclCommand.BuildParam: TTclCmdParamClass;
begin
	result := TTclCmdParam;
end;

function TTclCommand.BuildSwitch: TTclCmdSwitchClass;
begin
	result := TTclCmdSwitch;
end;

function TTclCommand.GetArgv(index: integer): string;
begin
	if FEvaluating <= 0 then
    	TclError(FmtLoadStr(sTslcNotEvaluatingCommand_S,[Command]));
	if (index < 0) or (index >= FArgc) then
    	TclError(FmtLoadStr(sTslcArgvIndexOutOfRange_D, [index]));
	if FObjectArgs then
    	result := Tcl_GetStringFromObj(pTcl_Obj(ArgvItem(FArgv, index)), nil)
    else
		result := ArgvItem(FArgv, index);
end;

{$IFDEF VER90}
procedure TTclCommand.GetChildren(Proc: TGetChildProc);
{$ELSE}
procedure TTclCommand.GetChildren(Proc: TGetChildProc; Root: TComponent);
{$ENDIF}
var
	x: integer;
begin
	for x := 0 to FSwitches.Count - 1 do
		Proc(FSwitches[x]);
    for x := 0 to FParams.Count - 1 do
    	Proc(FParams[x]);
end;

function TTclCommand.GetCmdMetaInfo(index: integer): pTcl_CmdMetaInfo;
begin
	result := pTcl_CmdMetaInfo(FCmdMetaInfo.items[index]);
end;

function TTclCommand.GetCmdMetaInfoCount: integer;
begin
	result := FCmdMetaInfo.Count;
end;

function TTclCommand.GetFlag(index: integer): Boolean;
begin
	if (index < 0) or (index > 31) then
    	TclError(LoadStr(sTslcFlagIndexOutOfRange));
    result := FFlags and ( 1 shl index ) <> 0;
end;

function TTclCommand.GetInterp: pTcl_Interp;
begin
	CheckInterp(FInterp);
    result := FInterp;
end;

function TTclCommand.GetHashValues(index: integer): integer;
begin
	if (index < 0) or (index >= MAX_HASH_VALUES) then
    	TclError(LoadStr(sTslcHashValueOutOfRange));
    if (FHashed and (1 shl index)) <> 0 then
    	result := FHashValues[index]
    else
    begin
		case FHashMethod of
            chUpperCase:
            	result := TslcHash.Hash(pChar(UpperCase(ParamValues[index])));
			chLowerCase:
            	result := TslcHash.Hash(pChar(LowerCase(ParamValues[index])));
            chOnHash:
            	if not Assigned(FOnHash) then
                	TclError(LoadStr(sTslcNoHashMethod))
                else
                	FOnHash(Self, index, ParamValues[index], result);
        else
           	result := TslcHash.Hash(pChar(ParamValues[index]));
        end;
	    FHashValues[index] := result;
    	FHashed := FHashed or (1 shl index);
    end;
end;

function TTclCommand.GetInterpResult:string;
begin
	if FEmulation then
    	result := FEmulResult^
    else if Interp <> nil then
    	result := strpas(Tcl_GetStringResult(Interp))
    else
    	result := '';
end;

function TTclCommand.GetInterpreterCount: integer;
begin
	if Assigned(FInterpList) then
    	result := FInterpList.Count
    else
    	result := 0;
end;

function TTclCommand.GetInterpreters(index: integer): pTcl_Interp;
begin
	if (index < 0) or (not Assigned(FInterpList)) or (index > FInterpList.Count - 1) then
		TclError(LoadStr(sTslcInterpIndexOutOfRange));
    result := FInterpList.items[index];
end;

function TTclCommand.GetObject(index: integer): pTcl_Obj;
begin
	if FEvaluating <= 0 then
    	TclError(FmtLoadStr(sTslcNotEvaluatingCommand_S,[Command]));
	if not FObjectArgs or (index < 0) or (index >= FArgc) then
    	TclError(FmtLoadStr(sTslcArgvIndexOutOfRange_D, [index]));
   	result := pTcl_Obj(ArgvItem(FArgv, index));
end;

function TTclCommand.GetObjectCount: integer;
begin
	if FEvaluating <= 0 then
    	TclError(FmtLoadStr(sTslcNotEvaluatingCommand_S,[Command]));
    if FObjectArgs then
    	result := FArgc
    else
    	result := 0;
end;

function TTclCommand.GetParamValue(index: integer): string;
begin
	result := FParamValues.strings[index];
end;

function TTclCommand.GetParamValuesCount: integer;
begin
	result := FParamValues.Count;
end;

function TTclCommand.GetRawArgv: Tcl_Argv;
begin
	if FEvaluating > 0 then
    	result := FArgv
    else
    	result := nil;
end;

function TTclCommand.GetSwitchValue(index: integer): string;
begin
	result := FSwitchValues.strings[index];
end;

function TTclCommand.GetSwitchValueSwitch(index: integer): TTclCmdSwitch;
begin
	result := FSwitchValues.objects[index] as TTclCmdSwitch;
end;

function TTclCommand.GetSwitchValuesCount: integer;
begin
	result := FSwitchValues.Count;
end;

procedure TTclCommand.DefineProperties(Filer: TFiler);
begin
end;

procedure TTclCommand.SetMode(m: TTclCommandMode);
begin
    if FMode = m then exit;
	if Assigned(Tcl) then
		Tcl.CheckActive;
	FMode := m;
end;

procedure TTclCommand.SetOptions(o: TTclCommandOptions);
begin
	FOptions := o;
    // ??? Should install/remove TslcCmdDeleteProc in Tcl_SetCommandInfo for each in Tcl.InterpList where coFreeOnDeleteCommand.
end;

procedure TTclCommand.SetTcl(ATcl: TTcl);
begin
	if FTcl = ATcl then exit;
   	if Assigned(FTcl) and not (csDestroying in FTcl.ComponentState) then FTcl.RemoveCommand(self);
   	if Assigned(ATcl) then ATcl.AddCommand(self)
    else FTcl := nil;
end;

procedure TTclCommand.CheckActive;
begin
	if Assigned(FTcl) and FTcl.Active then
	   	TclError(LoadStr(sTslcOpFailActiveCommand));
end;

procedure TTclCommand.SetChildOrder(Child: TComponent; Order: Integer);
begin
end;

procedure TTclCommand.SetFlag(index: integer; value: Boolean);
begin
	if (index < 0) or (index > 31) then
    	TclError(LoadStr(sTslcFlagIndexOutOfRange));
	if value then
		FFlags := FFlags or ( 1 shl index )
    else
    	FFlags := FFlags and not (1 shl index);
end;

procedure TTclCommand.SetMaxArgs(value: Byte);
begin
	if value = FMaxArgs then
    	exit;
    FMaxArgs := value;
    if FMaxArgs < FMinArgs then
    	FMinArgs := FMaxArgs;
end;

procedure TTclCommand.SetMinArgs(value: Byte);
begin
	if value = FMinArgs then
    	exit;
    FMinArgs := value;
    if FMaxArgs < FMinArgs then
    	FMaxArgs := FMinArgs;
end;

procedure TTclCommand.SetName(const NewName: TComponentName);
var
	_NewName: TTclNewName;
    msg: TNameMsg;
begin
	inherited SetName(NewName);
	if (csDesigning in ComponentState) and Assigned(Tcl) and Assigned(Tcl.Designer) then
    begin
		_NewName.Comp := Self;
        _NewName.NewName := NewName;
        msg.msg := WM_NAMECHANGE;
        msg.wParam := 0;
        msg.lParam := LongInt(@_NewName);
        Tcl.Designer.Dispatch(msg);
//		SendMessage(Tcl.Designer.Handle, WM_NAMECHANGE, 0, LongInt(@_NewName));
    end;
end;

procedure TTclCommand.SetCommand(ACommand: TTclIdent);
var
	hot: boolean;
begin
	ACommand := Trim(ACommand);
	if FCommand = ACommand then exit;
	hot := FCommand <> '';
    if hot then
	   	CheckActive;
	FCommand := ACommand;
	if (FTcl <> nil) and (FTcl.InstallCommand(Self, nil) <> TCL_OK) then
    	TclError(FmtLoadStr(sTslcErrorCommandInstall_S, [FCommand]));
end;

procedure TTclCommand.SetInterpResult(AResult: string);
begin
	if FEmulation then
    	FEmulResult^ := AResult
    else
		Tcl_SetResult(Interp, pChar(AResult), TTclFreeProc(TCL_VOLATILE));
end;

procedure TTclCommand.BreakLoop;
begin
	FBreak := True;
end;

function TTclCommand.CommandLine: string;
var
	x: integer;
begin
    for x:= 0 to FArgc - 1 do
    	if x = 0 then
        	result := ArgvItem(FArgv, x)
        else
        	result := result + ' ' + ArgvItem(FArgv, x);
end;

function TTclCommand.DoFindSwitch(ASwitch: string): TTclCmdSwitch;
var
	x, len, alen, clen: integer;
    found: boolean;
begin
	found := False;
	with FSwitches do
	for x := 0 to Count - 1 do
    begin
    	result := TTclCmdSwitch(items[x]);
//            if result.Switch = '' then continue;
		with Result do
		begin
			clen := MinCompare;
			if clen = 0 then
            begin
		      	if CaseSensitive then
	    	    begin
	            	if CanAppend then
	                	found := Copy(ASwitch, 1, length(Switch)) = Switch
	                else
	                	found := ASwitch = Switch;
	            end else
	            begin
	            	if CanAppend then
	                	found := TslcTextEqual(Copy(ASwitch, 1, length(Switch)), Switch)
	                else
	                	found := TslcTextEqual(ASwitch, Result.Switch);
	            end;
            end else
            begin
          		len := length(Switch);
                alen := length(ASwitch);
		      	if CaseSensitive then
	    	    begin
					if alen > len then
                       	found := CanAppend and (Copy(ASwitch, 1, len) = Switch)
                    else if alen = len then
                    	found := ASwitch = Switch
                    else if clen <= alen then
                    	found := ASwitch = Copy(Switch, 1, alen)
                    else
                    	found := False;
	            end else
	            begin
                	if alen > len then
                       	found := CanAppend and TslcTextEqual(Copy(ASwitch, 1, len), Switch)
                    else if alen = len then
                    	found := TslcTextEqual(ASwitch, Switch)
                    else if clen <= alen then
                    	found := TslcTextEqual(ASwitch, Copy(Switch, 1, alen))
                    else
                    	found := False;
	            end;
			end;
        end;
        if found then exit;
	end;
    if coRaiseInvalidSwitch in Options then
    	TclErrorFmt(LoadStr(sTslcRaiseInvalidSwitch_SS), [ASwitch, Command]);
    result := nil;
end;

function TTclCommand.Emulate(var emulResult: string; argc: integer; argv: Tcl_Argv): boolean;
var
	_argv: Tcl_Argv;
    p: pChar;
    x, count: integer;
begin
	FEmulation := True;
    try
    	FEmulResult := @EmulResult;
		count := argc;
        inc(count);
        GetMem(_argv, count * sizeof(pChar));
        GetMem(p, length(Command) + 1);
        strpcopy(p, Command);
        AssignArgvItem(_argv, 0, p);
        for x := 1 to argc do
        	AssignArgvItem(_argv, x, ArgvItem(argv, x - 1));
        try
        	result := ExecCommand(nil, count, _argv) = TCL_OK;
        finally
        	FreeMem(ArgvItem(_argv, 0));
            FreeMem(_argv);
        end;
    finally
    	FEmulation := False;
    end;
end;

function TTclCommand.EmulateArray(var emulResult: string; const args: array of pChar): boolean;
var
	argv: Tcl_Argv;
    p: pChar;
    x, y, count, h: integer;
begin
	FEmulation := True;
    try
    	FEmulResult := @EmulResult;
		h := High(args);
        count := 1; // for command
        for x := 0 to h do
        	if Assigned(args[x]) then inc(count);
		GetMem(argv, count * sizeof(pChar));
        GetMem(p, length(Command) + 1);
        strpcopy(p, Command);
        AssignArgvItem(argv, 0, p);
        y := 1;
        for x := 0 to h do
			if Assigned(args[x]) then
            begin
            	AssignArgvItem(argv, y, args[x]);
                inc(y);
            end;
         try
         	result := ExecCommand(nil, count, argv) = TCL_OK;
         finally
         	FreeMem(p);
            FreeMem(argv);
         end;
    finally
    	FEmulation := False;
    end;
end;

function TTclCommand.EmulateList(var emulResult: string; argList: TStrings): boolean;
var
    argv: Tcl_Argv;
    p: pChar;
    x, count: integer;
begin
	FEmulation := True;
    try
		FEmulResult := @EmulResult;
        if Assigned(argList) then
			count := argList.count
        else
        	count := 0;
        inc(count);
	    GetMem(argv, count * sizeof(pChar));
        GetMem(p, length(Command) + 1);
        strpcopy(p, Command);
        AssignArgvItem(argv, 0, p);
    	for x := 1 to count - 1 do
	    begin
    	    GetMem(p, length(argList.strings[x-1]) + 1);
           	strpcopy(p, argList.strings[x-1]);
	        AssignArgvItem(argv, x, p);
    	end;
		try
	        result := ExecCommand(nil, count, argv) = TCL_OK;
        finally
		    for x := 0 to count - 1 do
    		    FreeMem(ArgvItem(argv, x));
			FreeMem(argv);
        end;
    finally
    	FEmulation := False;
    end;
end;

function TTclCommand.DoExecCommand(_interp: pTcl_Interp; _argc: integer; _argv: Tcl_Argv; isObj: boolean): integer;
const
	cHighArgIndex = 63;
var
	arg, newValue: string;
   	success, SkipDefault, DoExec, DoParse, ParseSwitches: boolean;
    cmdSwitch, lastSwitch: TTclCmdSwitch;
    a, p, switchCnt, paramCnt, relParam, relParamCnt: integer;
    DefParam: TTclCmdParam;
    ParamPos: TTclCmdParamPos;
    q: pChar;
    prevInterp: pTcl_Interp;
    pLen, cLen, prevArgc: integer;
    prevArgv: Tcl_Argv;
    prevArg: integer;
    prevObjArgs: boolean;
    switchArgIndex, paramArgIndex: array[0..cHighArgIndex] of integer;
    deletionFlag: integer;
begin
	Result := TCL_OK;
    deletionFlag := 0;
    FDeletionFlag := @deletionFlag;
    prevInterp := FInterp;
    prevArgc := FArgc;
    prevArgv := FArgv;
    prevArg  := FArg;
    prevObjArgs := FObjectArgs;
//   	if not (csDesigning in componentState) then
    try try
    	FArg := 0;
		FHashed := 0;
        inc(FEvaluating);
        FParamValues.Clear;
        FSwitchValues.Clear;

		FInterp := _interp;
        FArgc := _argc;
        FArgv := _argv;
        FObjectArgs := IsObj;

		with FSwitches do //v1.0
		for a:= 0 to count - 1 do
	        with TTclCmdSwitch(items[a]) do
    	    begin
            	FHits := 0;
                FRelativeParamCount := 0;
                FRelativeParam := -1; // just in case of attempt
                FHijacked := False;
        	end;

        DoParse := coParse in FOptions;
        if DoParse then
        begin
			lastSwitch := nil;
            relParamCnt := 0;
            paramCnt := 0;
			switchCnt := 0;
        	ParseSwitches := True;
	        for a := 1 to FArgc - 1 do
    	    begin
				if isObj then
                	q := Tcl_GetStringFromObj(pTcl_Obj(ArgvItem(FArgv, a)), nil)
                else
	        	    q := ArgvItem(FArgv, a);
            	if isSwitch(q^) and ParseSwitches then
	            begin
    	        	arg := strpas(q + 1);
                    cmdSwitch := DoFindSwitch(arg);
                    if (cmdSwitch <> nil) and (cmdSwitch.FHits > 0) then
	                begin
                    	if soRaiseDuplicate in cmdSwitch.Options then
			        		TclErrorFmt(LoadStr(sTslcRaiseDupSwitch_SS), [arg, Command]);
                    	if soIgnoreDuplicate in cmdSwitch.Options then
                    		cmdSwitch := nil;
                    end;
                    if cmdSwitch <> nil then
                    begin
                    	inc(cmdSwitch.FHits);
	                    if soHaltSwitchParsing in cmdSwitch.Options then
    	                	ParseSwitches := False;
        		    	FSwitchValues.addObject(arg, cmdSwitch);
                     	if switchCnt <= cHighArgIndex then
	                        switchArgIndex[switchCnt] := a;
                        inc(switchCnt);
                    end;
                    if lastSwitch <> nil then
                	begin
            			if lastSwitch.FRequireParams > relParamCnt then
                        	TclErrorFmt('%s switch requires %d relative parameter(s)',
                            	[lastSwitch.switch, lastSwitch.FRequireParams]);
                        if relParamCnt > 0 then
                        begin
                            if soHijackRelative in lastSwitch.FOptions then
                            begin
								lastSwitch.FSwitchValue := FParamValues.Strings[relParam];
                                lastSwitch.FHijacked := True;
                                FParamValues.Delete(relParam);
								dec(paramCnt);
        	   	                if relParamCnt > 1 then
                		        begin
	                    			lastSwitch.FRelativeParam := relParam;
		    	                    lastSwitch.FRelativeParamCount := relParamCnt - 1
        						end;
                            end else
                            begin
		                    	lastSwitch.FRelativeParam := relParam;
    		                    lastSwitch.FRelativeParamCount := relParamCnt;
                            end;
                        end;
                    end;
                    relParamCnt := 0;
                    lastSwitch := cmdSwitch;
	            end else
                begin
    	        	FParamValues.add(strpas(q));
                    if relParamCnt = 0 then
                    begin
       					relParam := paramCnt;
                    end;
                    inc(relParamCnt);
    				if paramCnt <= cHighArgIndex then
	            		paramArgIndex[paramCnt] := a;
                    inc(paramCnt);
                end;
        	end;
            if (lastSwitch <> nil) then
	        begin
				if lastSwitch.FRequireParams > relParamCnt then
                  	TclErrorFmt('%s switch requires %d relative parameter(s)',
                       	[lastSwitch.switch, lastSwitch.FRequireParams]);
                if relParamCnt > 0 then
                begin
                	if soHijackRelative in lastSwitch.FOptions then
                    begin
                    	lastSwitch.FSwitchValue := FParamValues.Strings[relParam];
                        lastSwitch.FHijacked := True;
                        FParamValues.Delete(relParam);
                        dec(paramCnt);
                        if relParamCnt > 1 then
                        begin
	                    	lastSwitch.FRelativeParam := relParam;
    	                    lastSwitch.FRelativeParamCount := relParamCnt - 1
        				end;
                    end else
                    begin
                    	lastSwitch.FRelativeParam := relParam;
                        lastSwitch.FRelativeParamCount := relParamCnt;
                    end;
                end;
            end;
    	    if coCountSwitches in FOptions then
        		inc(paramCnt, FSwitchValues.Count);
			if (FMinArgs <> 0) and ((paramCnt < FMinArgs) or (paramCnt > FMaxArgs)) then
		    begin
                dec(FEvaluating);
      			Result := TCL_ERROR;
            	InterpResult := FErrorMsg;
                FArgc := prevArgc;
                FArgv := prevArgv;
                FArg  := prevArg;
                FObjectArgs := prevObjArgs;
                FInterp := prevInterp;
	         	exit;
    	  	end;
        end;
		success := true;
      	newValue := InterpResult;
        
		if not (csDestroying in ComponentState) then // ??? not likely
	        DoPrepare(newValue, success); //v0.7

		FBreak := False;
        FStop  := False;
        if DoParse and (coCallSwitches in FOptions) then
		with FSwitchValues do
        for a := 0 to Count - 1 do
        begin
			if FBreak then
            	Break; // destructor calls BreakLoop, no need to check csDestroying for each loop
	    	if Assigned(objects[a]) then with TTclCmdSwitch(objects[a]) do
            begin
				if a <= cHighArgIndex then
	            	FArg := SwitchArgIndex[a]
                else
                	FArg := -1;
	        	Result := ExecSwitch(newValue, strings[a]);
               	if (Result <> TCL_OK) or  (deletionFlag <> 0) then
                	break;
		    end;
        end;
        if (deletionFlag = 0) and (Result = TCL_OK) and  DoParse and (coCallParams in FOptions) then
     	with FParamValues do
        for a := 0 to Count - 1 do
        begin
        	if FBreak then
            	Break; // destructor calls BreakLoop, no need to check csDestroying for each loop
			DefParam := nil;
            SkipDefault := False;
			ParamPos := 1 shl a;
            arg := strings[a];
            with FParams do
            for p := 0 to Count - 1 do with TTclCmdParam(items[p]) do
            begin
            	if FBreak then Break;
				if p <= cHighArgIndex then
					FArg := ParamArgIndex[p]
                else
                	FArg := -1;
            	DoExec := False;
				if IsPosition(ParamPos) then
           		begin
                	cLen := MinCompare;
                    pLen := Length(arg);
    	       		if Default then
                  		DefParam := TTclCmdParam(items[p])
                    else if Param = '' then
                    	DoExec := True
                    else if (cLen > 0) and (pLen >= cLen) and (pLen <= FLen) then
                    begin
                    	if CaseSensitive then
                     		DoExec := Copy(param, 1, pLen) = arg
                        else
                        	DoExec := TslcTextEqual(arg, Copy(param, 1, pLen));
                    end else
                    begin
	        	        if CaseSensitive then
    	                   	DoExec := arg = param
	    	            else
                	      	DoExec := TslcTextEqual(arg, param);
                    end;
                end;
                if DoExec then
                begin
                	Result := ExecParam(a + 1, newValue, arg);
                    SkipDefault := True;
                end;
                if (Result <> TCL_OK) or (deletionFlag <> 0) then
                	break;
			end;
            if Assigned(DefParam) and (deletionFlag = 0) and not SkipDefault then
            	DefParam.ExecParam(a + 1, newValue, arg);
        end;

		if (Result = TCL_OK) and (deletionFlag = 0) and not FStop then
        begin
			FArg := 0;
    	    DoCommand(newValue, success);
			if not success then
            	Result := TCL_ERROR;
        end;

		if deletionFlag = 0 then
	        InterpResult := newValue;

    except
    	on E: ETclError do
        begin
        	newValue := E.Message;
            success := False;
    		if deletionFlag = 0 then
	        	DoException(newValue, success, E);
			if not success then
	            Result := TCL_ERROR;
    		if deletionFlag = 0 then
	            InterpResult := newValue;
        end;
        on E: Exception do // v0.7 ??? 2/11/97
        begin
        	if (coCatchAll in FOptions) or Assigned(FOnException) or (deletionFlag <> 0) then
            begin
            	newValue := E.Message;
                success := False;
    			if deletionFlag = 0 then
	                DoException(newValue, success, E);
                if not success then
		            Result := TCL_ERROR;
                if deletionFlag = 0 then
	    	        InterpResult := newValue;
            end else raise;
        end;
   	end;
    finally
		FDeletionFlag := nil;
    	if deletionFlag = 0 then
        begin
			dec(FEvaluating);
	        FArgc := prevArgc;
	        FArgv := prevArgv;
	        FArg  := prevArg;
	        FObjectArgs := prevObjArgs;
	    	FInterp := prevInterp;
        end else
        	result := TCL_DESTROYED;
    end;
end;

function TTclCommand.ExecCommand(_interp: pTcl_Interp; _argc: integer; _argv: Tcl_Argv): integer;
begin
	result := DoExecCommand(_interp, _argc, _argv, False);
end;

function TTclCommand.ExecObjCommand(_interp: pTcl_Interp; _objc: integer; _objv: ppTcl_Obj): integer;
begin
	result := DoExecCommand(_interp, _objc, Tcl_argv(_objv), True);
end;

function TTclCommand.FindSwitch(ASwitch: string): TTclCmdSwitch;
var
	doRaise: boolean;
begin
	doRaise := coRaiseInvalidSwitch in FOptions;
    if doRaise then
	    exclude(FOptions, coRaiseInvalidSwitch);
    try
    	result := DoFindSwitch(ASwitch);
    finally
    	if doRaise then
        	include(FOptions, coRaiseInvalidSwitch);
    end;
end;


function  TTclCommand.GetArgument(arg, argc: integer; argv: Tcl_Argv; var value: string): boolean;
var
	x, argIter: integer;
begin
	Result := False;
	if arg = 0 then
    begin
    	value := strpas(ArgvItem(argv, 0));
        result := True;
        exit;
    end;
    argIter := 0;
	for x := 1 to argc - 1 do
		if not IsSwitch(ArgvItem(argv, x)^) then
        begin
        	inc(argIter);
			if argIter = arg then
    	    begin
        		value := strpas(ArgvItem(argv, x));
                result := True;
                exit;
            end;
        end;
end;

procedure TTclCommand.AddParam(AParam: TTclCmdParam);
begin
	if AParam = nil then exit;
    FParams.add(AParam);
    AParam.FCommand := self;
end;

procedure TTclCommand.AddSwitch(ASwitch: TTclCmdSwitch);
begin
	if ASwitch = nil then exit;
    FSwitches.add(ASwitch);
    ASwitch.FCommand := self;
end;

procedure TTclCommand.DestroyParams;
var
	param: TTclCmdParam;
begin
	while FParams.Count > 0 do
    begin
    	param := FParams.Last;
        RemoveParam(param);
        param.free;
    end;
end;

procedure TTclCommand.DestroySwitches;
var
	switch: TTclCmdSwitch;
begin
	while FSwitches.Count > 0 do
    begin
        switch := FSwitches.Last;
        RemoveSwitch(switch);
        switch.free;
    end;
end;

function TTclCommand.Install(AInterp: pTcl_Interp): integer;
var
    cmdHash: pTcl_Command;
	info: Tcl_CmdInfo;
    namespace: string;
begin

	if (Tcl_GetCommandInfo(AInterp, 'rename', info) <> 0) then
	begin
        if (TslcRenameCommand = nil) or (info.objClientData <> TslcRenameCommand) then
        begin
        	if TslcRenameCommand = nil then
            begin
            	TslcRenameCommand := TTclRenameCommand.Create(nil);
                TslcRenameInfo := info;
            end;
{$IFDEF VER90}
			if Tcl_CreateObjCommand(AInterp, 'rename', TTclObjCmdProc(TslcObjCommandProc), TslcRenameCommand, nil) = nil then

{$ELSE}
			if Tcl_CreateObjCommand(AInterp, 'rename', TslcObjCommandProc, TslcRenameCommand, nil) = nil then
{$ENDIF}
				TclError('Unable to install "rename" command');
		end;
    end;


{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'Install', 'AInterp: %p',[AInterp]);
{$ENDIF}

	result := TCL_OK;
    if Trim(FCommand) = '' then
    begin
{$IFDEF TSLC_DEBUG}
	    TraceCompProc(-1, self, 'Install', 'AInterp: %p, Empty Command(NoOp)',[AInterp]);
{$ENDIF}
	   	exit;
    end;
   	if Tcl_IsSafe(AInterp) <> 0 then // Safe
    begin
    	if Mode = cmNormal then
        begin
{$IFDEF TSLC_DEBUG}
		    TraceCompProc(-1, self, 'Install', 'AInterp: %p, Normal Command, Safe Interp - No Install',[AInterp]);
{$ENDIF}
	        exit;
        end;
    end else // not Safe
    	if Mode = cmSafe then
        begin
{$IFDEF TSLC_DEBUG}
		    TraceFmt(-1, '%s.Install %s, AInterp: %p, Safe Command, Unsafe Interp - No Install',[ClassName, Name, AInterp]);
{$ENDIF}
	        exit;
        end;

	if (Tcl <> nil) and (Tcl.Namespace <> '') then
    	namespace := Format('%s::%s', [Tcl.Namespace, FCommand])
    else
    	namespace := FCommand;
    if (coNoCreateExists in Options) and (Tcl_GetCommandInfo(AInterp, pChar(namespace), info) <> 0) then
    begin
{$IFDEF TSLC_DEBUG}
	    TraceCompProc(-1, self, 'Install', 'AInterp: %p, Command Exists(NoOp)',[AInterp]);
{$ENDIF}
    	exit;
	end;
	if coObjectCommand in Options then
{$IFDEF VER90}
		cmdHash := Tcl_CreateObjCommand(AInterp, pChar(namespace), TTclObjCmdProc(TslcObjCommandProc), self, TslcCmdDeleteProc)
{$ELSE}
		cmdHash := Tcl_CreateObjCommand(AInterp, pChar(namespace), TslcObjCommandProc, self, TslcCmdDeleteProc)
{$ENDIF}
	else
{$IFDEF VER90}
		cmdHash := Tcl_CreateCommand(AInterp, pChar(namespace), TTclCmdProc(TslcCommandProc), self, TslcCmdDeleteProc);
{$ELSE}
		cmdHash := Tcl_CreateCommand(AInterp, pChar(namespace), TslcCommandProc, self, TslcCmdDeleteProc);
{$ENDIF}

	if cmdHash <> nil then
    	AddCmdMetaInfo(namespace, cmdHash, AInterp)
    else
    	result := TCL_ERROR;
	TrackInterp(AInterp);
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'Install', 'AInterp: %p',[AInterp]);
{$ENDIF}
end;

function TslcInvokeCmd(interp: pTcl_Interp; pInfo: pTcl_CmdInfo; argc: integer; argv: Tcl_Argv; objectArgs: boolean): integer;
var
	_argv: Tcl_Argv;
    x: integer;
begin
	with pInfo^ do
	begin
        if IsNativeObjectProc <> 0 then
        begin
			if objectArgs then
            	result := ObjProc(ObjClientData, Interp, argc, ppTcl_Obj(argv))
            else
            	result := Proc(ClientData, Interp, argc, argv); // ??? coerce object call
        end else
        begin
			if objectArgs then
            begin
		        GetMem(_argv, argc * sizeof(pChar));
		        try
		    	    for x := 0 to argc - 1 do
			        	AssignArgvItem(_argv, x, Tcl_GetStringFromObj(pTcl_Obj(ArgvItem(argv, x)), nil));
	    	    	result := Proc(ClientData, Interp, argc, _argv);
		        finally
	    	        FreeMem(_argv);
		        end;
            end else
            	Proc(ClientData, Interp, argc, argv);
	    end;
    end;
end;

function TTclCommand.InvokeCmd(pInfo: pTcl_CmdInfo): integer;
begin
	if FEvaluating <= 0 then
    	TclError(FmtLoadStr(sTslcNotEvaluatingCommand_S,[Command]));
    result := TslcInvokeCmd(Interp, pInfo, FArgc, FArgv, FObjectArgs);
end;

function TTclCommand.InvokeCommand(cmd: TTclCommand): integer;
begin
	result := cmd.DoExecCommand(FInterp, FArgc, FArgv, FObjectArgs);
end;

function TTclCommand.IsSwitch(c: char): boolean;
begin
	case FSwitchPrefix of
    	spDash:
        	isSwitch := c = '-';
        spSlash:
        	isSwitch := c = '/';
        spDashSlash:
        	isSwitch := (c = '-') or (c = '/');
        spOther:                                     //v0.7
        	isSwitch := c = FSwitchPrefixOther;
        spNone:                                      //v0.7
        	isSwitch := False;
    else
    	isSwitch := False;
    end;
end;

procedure TTclCommand.Loaded;
begin
	inherited Loaded;
    DoCreate;
end;

procedure TTclCommand.MoveParam(curIdx, newIdx: integer); //v1.0
begin
	FParams.Move(curIdx, newIdx);
end;

procedure TTclCommand.MoveSwitch(curIdx, newIdx: integer); //v1.0
begin
	FSwitches.Move(curIdx, newIdx);
end;

function TTclCommand.ParamValueDef(index: integer; default: string): string;
begin
	if (index < 0) or (index >= ParamValuesCount) then
    	result := default
    else
    	result := ParamValues[index];
end;

procedure TTclCommand.RemoveParam(AParam: TTclCmdParam);
begin
	if AParam = nil then exit;
    AParam.FCommand := nil;
    FParams.Remove(AParam);
end;

procedure TTclCommand.RemoveSwitch(ASwitch: TTclCmdSwitch);
begin
	if ASwitch = nil then exit;
    ASwitch.FCommand := nil;
   	FSwitches.Remove(ASwitch);
end;

function TTclCommand.GetParam(index: integer): TTclCmdParam;
begin
	result := FParams[index];
end;

function TTclCommand.GetParamCount: integer;
begin
	result := FParams.Count;
end;

function TTclCommand.GetSwitch(index: integer): TTclCmdSwitch;
begin
	result := FSwitches.items[index];
end;

function TTclCommand.GetSwitchCount: integer;
begin
	result := FSwitches.Count;
end;


function TTclCommand.GetParentComponent: TComponent;
begin
	Result := FTcl;
end;

function TTclCommand.HasParent: Boolean;
begin
	HasParent := FTcl <> nil;
end;

procedure TTclCommand.SetHashEvent(event: TTclCmdHashEvent);
begin
	if @event <> nil then
    	FHashMethod := chOnHash
    else
    	FHashMethod := chUpperCase;
    FOnHash := event;
end;

procedure TTclCommand.SetHashMethod(value: TTclCommandHashMethod);
begin
	if (value = chOnHash) and (@FOnHash = nil) and (csDesigning in ComponentState) then
		TslcMessage(LoadStr(sTslcHashMethodWarning), tmWarning);
	FHashMethod := value;
end;

procedure TTclCommand.SetParentComponent(Value: TComponent);
begin
	if FTcl = Value then exit;
   	if Assigned(FTcl) and
    	not (csDestroying in FTcl.ComponentState) and
        not (csLoading in ComponentState) then FTcl.RemoveCommand(self);
	if Value is TTcl then
    	TTcl(Value).AddCommand(self)
    else FTcl := nil;
end;

procedure TTclCommand.StopEvaluating;
begin
	FStop := True;
	BreakLoop;
end;

procedure TTclCommand.InterpDelete(AInterp: pTcl_Interp);
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'InterpDelete', 'AInterp: %p',[AInterp]);
{$ENDIF}
	UntrackInterp(AInterp); // Tcl Assoc Data will be cleaned up when Interp is *actually* deleted
    if not (csDestroying in ComponentState) then
		DoInterpDelete(AInterp);
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'InterpDelete', 'AInterp: %p',[AInterp]);
{$ENDIF}
end;

procedure TTclCommand.TrackInterp(AInterp: pTcl_Interp);
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'TrackInterp', 'AInterp: %p',[AInterp]);
{$ENDIF}
	if FInterpList = nil then
    	FInterpList := TList.Create;
    Tcl_CallWhenDeleted(AInterp, TslcIDP_TTclCommand, Self);
    FInterpList.add(AInterp);
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'TrackInterp', 'AInterp: %p',[AInterp]);
{$ENDIF}
end;


procedure TTclCommand.Uninstall(AInterp: pTcl_Interp);
var
	cmdName: string;
	info: Tcl_CmdInfo;
begin
    if Command = '' then
    	exit;
    cmdName := Command;
	if (Tcl_GetCommandInfo(AInterp, pChar(cmdName), Tcl_CmdInfo(info)) <> 0) and
		IsTslcCmdInfo(@info) then
    begin
{$IFDEF TSLC_DEBUG}
	    TraceCompProc(0, self, 'Uninstall', 'AInterp: %p',[AInterp]);
{$ENDIF}
		Tcl_DeleteCommand(AInterp, pChar(cmdName));
	end;
    UntrackInterp(AInterp);
end;

procedure TTclCommand.UninstallAll;
var
	x: integer;
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'UninstallAll', '',[0]);
{$ENDIF}
	if FInterpList <> nil then
    begin
	    while FInterpList.Count > 0 do
	    	Uninstall(pTcl_Interp(FInterpList.Last));
		FInterpList.Free;
	    FInterpList := nil;
    end;
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'UninstallAll', '',[0]);
{$ENDIF}
end;

procedure TTclCommand.UntrackInterp(AInterp: pTcl_Interp);
var
	x: integer;
begin
{$IFDEF TSLC_DEBUG}
    TraceCompProc(1, self, 'UntrackInterp', 'AInterp: %p',[AInterp]);
{$ENDIF}

	if FInterpList <> nil then
    begin
		x := FInterpList.IndexOf(AInterp);
	    if x >= 0 then
	    begin
			if not (tsInterpDeleteProc in FTclState) then
		    	Tcl_DontCallWhenDeleted(pTcl_Interp(FInterpList.items[x]), TslcIDP_TTclCommand, FOldSelf);
	        FInterpList.Delete(x);
	    end;
    end;
    if ((FInterpList = nil) or (FInterpList.Count = 0)) and (coAutoFree in FOptions) and not (csDestroying in ComponentState) then
    	Free;
{$IFDEF TSLC_DEBUG}
    TraceCompProc(-1, self, 'UntrackInterp', 'AInterp: %p',[AInterp]);
{$ENDIF}
end;


{~~~ TTclCmdSwitch ~~~}

constructor TTclCmdSwitch.Create(AOwner: TComponent);
begin
    FCanAppend := True;
    inherited Create(AOwner);
end;

destructor TTclCmdSwitch.Destroy;
begin
	if Assigned(FCommand) then FCommand.RemoveSwitch(self);
	inherited Destroy;
end;

procedure TTclCmdSwitch.DefineProperties(Filer: TFiler);
begin
end;

procedure TTclCmdSwitch.DoSwitch(ASwitch: string; var result: string; var success: boolean);
begin
	if Assigned(FOnSwitch) then
    	FOnSwitch(self, ASwitch, result, success);
end;

function  TTclCmdSwitch.ExecSwitch(var newValue: string; ASwitch: string): integer;
var
    success: boolean;
begin
	// ETclErrors caught in TTclCommand.ExecCommand;
    success := True;
    try
    	FPValue := pChar(ASwitch);
	    DoSwitch(ASwitch, newValue, success);
	 	if success then
	    	Result := TCL_OK
	    else
	    	Result := TCL_ERROR;
    finally
    	FPValue := nil;
    end;
end;

function TTclCmdSwitch.GetParentComponent: TComponent;
begin
	Result := FCommand;
end;

function TTclCmdSwitch.GetSwitchValue: string;
begin
	if FHijacked then
    	result := FSwitchValue
    else if FPValue <> nil then
    	result := Split(FPValue)
    else
    	result := '';
end;

function TTclCmdSwitch.HasParent: Boolean;
begin
	HasParent := FCommand <> nil;
end;

procedure TTclCmdSwitch.SetParentComponent(Value: TComponent);
begin
	if FCommand = Value then exit;
   	if Assigned(FCommand) and
        not (csLoading in ComponentState) then FCommand.RemoveSwitch(self);
	if Value is TTclCommand then
	   	TTclCommand(Value).AddSwitch(self)
    else FCommand := nil;
end;

procedure TTclCmdSwitch.SetCommand(ACommand: TTclCommand);
begin
	if FCommand = ACommand then exit;
	if Assigned(FCommand) then FCommand.RemoveSwitch(self);
   	if Assigned(ACommand) then ACommand.AddSwitch(self)
    else FCommand := nil;
end;

procedure TTclCmdSwitch.SetName(const NewName: TComponentName);
var
	_NewName: TTclNewName;
    msg: TNameMsg;
begin
	inherited SetName(NewName);
	if (csDesigning in ComponentState) and Assigned(Command) and
    	Assigned(Command.Tcl) and Assigned(Command.Tcl.Designer) then
    begin
		_NewName.Comp := Self;
        _NewName.NewName := NewName;
        msg.msg := WM_NAMECHANGE;
        msg.wParam := 0;
        msg.lParam := LongInt(@_NewName);
        Command.Tcl.Designer.Dispatch(msg);
//		SendMessage(Command.Tcl.Designer.Handle, WM_NAMECHANGE, 0, LongInt(@_NewName));
    end;
end;

procedure TTclCmdSwitch.SetSwitch(ASwitch: string);
begin
	FSwitch := Trim(ASwitch);
//    if FSwitch = '' then Position := 0;
end;

function TTclCmdSwitch.Split(ASwitch: string): string;
begin
	result := ASwitch;                  // No Validation on ASwitch
    Delete(Result, 1, length(FSwitch));
end;

function TTclCmdSwitch.SplitDef(ASwitch, Default: string): string; //v1.0
begin
	result := Split(ASwitch);
    if result = '' then
    	result := Default;
end;

{~~~ TTclCmdParam ~~~}

constructor TTclCmdParam.Create(AOwner: TComponent);
begin
	FCaseSensitive := False;
    FDefault := False;
    FParam := '';
    FPosition := -1;
    FCommand := nil;
    FOnParam := nil;
    inherited Create(AOwner);
end;

destructor TTclCmdParam.Destroy;
begin
	if Assigned(FCommand) then FCommand.RemoveParam(self);
	inherited Destroy;
end;

procedure TTclCmdParam.DefineProperties(Filer: TFiler);
begin
end;

procedure TTclCmdParam.DoParam(APos: integer; AParam: string; var result: string; var success: boolean);
begin
    if Assigned(FOnParam) then
    	FOnParam(self, APos, AParam, result, success);
end;

function  TTclCmdParam.ExecParam(APos: integer; var newValue: string; AParam: string): integer;
var
    success: boolean;
begin
	// ETclErrors caught in TTclCommand.ExecCommand;
	success := True;
    DoParam(APos, AParam, newValue, success);
    if success then
    	Result := TCL_OK
    else
    	Result := TCL_ERROR;
end;

function TTclCmdParam.GetParentComponent: TComponent;
begin
	Result := FCommand;
end;

function TTclCmdParam.HasParent: Boolean;
begin
	HasParent := FCommand <> nil;
end;

function TTclCmdParam.IsPosition(APos: TTclCmdParamPos): boolean;
begin
	result := (APos and FPosition) <> 0;
end;

procedure TTclCmdParam.SetParentComponent(Value: TComponent);
begin
	if FCommand = Value then exit;
   	if Assigned(FCommand) and
        not (csLoading in ComponentState) then FCommand.RemoveParam(self);
	if Value is TTclCommand then
	   	TTclCommand(Value).AddParam(self)
    else FCommand := nil;
end;

procedure TTclCmdParam.SetCommand(ACommand: TTclCommand);
begin
	if FCommand = ACommand then exit;
	if Assigned(FCommand) then FCommand.RemoveParam(self);
   	if Assigned(ACommand) then ACommand.AddParam(self)
    else FCommand := nil;
end;

procedure TTclCmdParam.SetPosition(pos: TTclCmdParamPos);
begin
	if pos = FPosition then exit;
	if not (csLoading in ComponentState) and
    	(csDesigning in ComponentState) and
    	(pos = 0) and (TslcMessage(LoadStr(sTslcZeroPosPreventsCBs), tmConfirm) = 0) then exit;
    FPosition := pos;
end;

procedure TTclCmdParam.SetName(const NewName: TComponentName);
var
	_NewName: TTclNewName;
    msg: TNameMsg;
begin
	inherited SetName(NewName);
	if (csDesigning in ComponentState) and Assigned(Command) and
    	Assigned(Command.Tcl) and Assigned(Command.Tcl.Designer) then
    begin
		_NewName.Comp := Self;
        _NewName.NewName := NewName;
        msg.msg := WM_NAMECHANGE;
        msg.wParam := 0;
        msg.lParam := LongInt(@_NewName);
        Command.Tcl.Designer.Dispatch(msg);
//		SendMessage(Command.Tcl.Designer.Handle, WM_NAMECHANGE, 0, LongInt(@_NewName));
    end;
end;

procedure TTclCmdParam.SetParam(AParam: string);
begin
	FParam := AParam;
    FLen := Length(FParam);
end;

initialization
	TslcPrepareCritical;
	TslcInitList := TList.create;
    TslcPrepareTrace;
	with TslcChannelType do
    begin
    	typeName		:= 'TslcChannel';
        blockModeProc	:= @TslcChannelBlockMode;
        closeProc		:= @TslcChannelClose;
        inputProc		:= @TslcChannelInput;
        ouputProc		:= @TslcChannelOutput;
        seekProc		:= @TslcChannelSeek;
        setOptionProc	:= @TslcChannelSetOption;
        getOptionProc	:= @TslcChannelGetOption;
        watchProc		:= @TslcChannelWatch;
        getHandleProc	:= @TslcChannelGetHandle;
	end;

finalization
	TslcInitList.free;
    TslcDoneTrace;
    TslcDoneCritical;

end.


