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

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

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

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

WilliamB@ByrneLitho.com
------------------------------------------------------------------------}
unit uTslcBde;
                          
///////////////////////////////////////////////////////////////////////////////
//
//  uTslcBde.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


interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Bde, Db, DbTables, Tslc, TclTk, TclDbDef, TslcServ, StdCtrls;

type

  TBDEMod = class(TTclThreadServer)
    TclBde: TTcl;
    TclCmd_Table: TTclCommand;
    TclCmd_ScriptCallback: TTclCommand;
    TclCmd_Session: TTclCommand;
    TclCmd_StoredProc: TTclCommand;
    TclCmd_StoredProc_database: TTclCmdSwitch;
    TclCmd_StoredProc_proc: TTclCmdSwitch;
    TclCmd_Query: TTclCommand;
    TclCmd_Query_database: TTclCmdSwitch;
    TclCmd_Database: TTclCommand;
    TclCmd_DataSource: TTclCommand;
    TclCmd_Table_database: TTclCmdSwitch;
    TclCmd_Table_table: TTclCmdSwitch;
    TclCmd_Table_db: TTclCmdSwitch;
    TclCmd_StoredProc_db: TTclCmdSwitch;
    TclCmd_Query_db: TTclCmdSwitch;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    TclCmd_LockBox: TTclCommand;
    TclCmd_PasswordCallback: TTclCommand;
    procedure TclCmd_TableCreate(Sender: TTclCommand);
    procedure TclCmd_TableDestroy(Sender: TTclCommand);
    procedure TclCmd_TableCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_ScriptCallbackCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclBdeBeforeOpen(Sender: TTcl);
    procedure TclCmd_ScriptCallbackInterpDelete(Sender: TObject;
      AInterp: pTcl_Interp);
    procedure TclCmd_StoredProcCommand(Sender: TTclCommand; var result: string;
      var success: Boolean);
    procedure TclCmd_StoredProcCreate(Sender: TTclCommand);
    procedure TclCmd_StoredProcDestroy(Sender: TTclCommand);
    procedure TclCmd_StoredProcPrepare(Sender: TTclCommand; var result: string; var success: boolean);
    procedure TclCmd_StoredProc_procSwitch(Sender: TTclCmdSwitch; ASwitch: string;
      var result: string; var success: Boolean);
    procedure TclCmd_StoredProc_databaseSwitch(Sender: TTclCmdSwitch; ASwitch: string;
      var result: string; var success: Boolean);
    procedure TclCmd_QueryCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_QueryCreate(Sender: TTclCommand);
    procedure TclCmd_QueryDestroy(Sender: TTclCommand);
    procedure TclCmd_QueryPrepare(Sender: TTclCommand; var result: string; var success: boolean);
    procedure TclCmd_Query_databaseSwitch(Sender: TTclCmdSwitch;
      ASwitch: string; var result: string; var success: Boolean);
    procedure TclCmd_SessionCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_SessionCreate(Sender: TTclCommand);
    procedure TclCmd_SessionDestroy(Sender: TTclCommand);
    procedure TclCmd_DatabaseCreate(Sender: TTclCommand);
    procedure TclCmd_DatabaseDestroy(Sender: TTclCommand);
    procedure TclCmd_DatabaseCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_DataSourceCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclBdeAfterInitInterp(Sender: TObject; AInterp: pTcl_Interp);
    procedure TclCmd_Table_databaseSwitch(Sender: TTclCmdSwitch;
      ASwitch: string; var result: string; var success: Boolean);
    procedure TclCmd_Table_tableSwitch(Sender: TTclCmdSwitch;
      ASwitch: string; var result: string; var success: Boolean);
    procedure TclCmd_LockBoxCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCmd_TablePrepare(Sender: TTclCommand; var result: String;
      var success: Boolean);
    procedure TclCmd_PasswordCallbackCommand(Sender: TTclCommand;
      var result: String; var success: Boolean);
    procedure TclCmd_PasswordCallbackInterpDelete(Sender: TObject;
      AInterp: pTcl_Interp);
  private
    { Private declarations }
    ScriptCallback, ScriptCallbackData: string;
    CallbackInterp: pTcl_Interp;
    PasswordCallback, PasswordCallbackData: string;
    PasswordInterp: pTcl_Interp;
    FRestBuf: RESTCbDesc;
   	FBDERestCallback: TBDECallback;
    FProgBuf: CBPROGRESSDesc;
    FBDEProgCallback: TBDECallback;
	FSession: TSession;
    function BDERestCallback(CBInfo: pointer): CBRType;
    function BDEProgCallback(CBInfo: pointer): CBRType;

	procedure PasswordDialogKiller(Sender: TObject; var Continue: Boolean);

  public
    { Public declarations }
    constructor Create(AOwner: TComponent; AThreadId: integer); override;
    destructor Destroy; override;
	class function GetThreadServer(AThreadId: integer): TBDEMod;
    function GetDefaultSession: TSession;
    procedure Serve(AClient: TTcl); override;
    procedure ServeInterp(AInterp: pTcl_Interp); override;
    procedure Unserve(AClient: TTcl);

  end;

function BDEServeThread(AThreadId: integer; AClient: TTcl): TBDEMod;
function BDEServeThreadInterp(AThreadId: integer; AInterp: pTcl_Interp): TBDEMod;


const
	TSLC_BDE_VERSION_MAJOR = 1;
    TSLC_BDE_VERSION_MINOR = 0;
    TSLC_BDE_VERSION_ISSUE = 'a';
    TSLC_BDE_NAME = 'TslcBDE';


implementation
uses BdeMisc, BdeClass, DynaData, TclDbTbl, TslcPlat, TslcUtil, TslcHash, TslcRsrc, TslcLock;

{$R *.DFM}

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

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


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


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

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

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

procedure TBDEMod.ServeInterp(AInterp: pTcl_Interp);
begin
	if AInterp = nil then
    	exit;
	TclBde.ServiceInterp(AInterp);
end;

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

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

// Support structure for TTclCmdDBDataSet types
type
	pRESTCbDesc = ^RESTCbDesc;

	TTclCmdTableData = class
    public
    	DatabaseName: string;
    	TableName: string;
    end;


function TBDEMod.GetDefaultSession: TSession;
begin
    if FSession <> nil then
    	Result := FSession
    else
    	Result := Session;
end;


{~~~ DBTable Command ~~~}
procedure TBDEMod.TclCmd_TableCreate(Sender: TTclCommand);
begin
	Sender.ClientData := TTclCmdTableData.Create; // used later by switches.
end;

procedure TBDEMod.TclCmd_TableDestroy(Sender: TTclCommand);
begin
	Sender.ClientData.free;
end;

procedure TBDEMod.TclCmd_TablePrepare(Sender: TTclCommand;
  var result: String; var success: Boolean);
begin
	with Sender.ClientData as TTclCmdTableData do
    begin
    	DatabaseName := '';
        TableName := '';
    end;
end;

procedure TBDEMod.TclCmd_Table_databaseSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	with Sender.Command.ClientData as TTclCmdTableData do
    	DatabaseName := Sender.SwitchValue;
end;

procedure TBDEMod.TclCmd_Table_tableSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	with Sender.Command.ClientData as TTclCmdTableData do
    	TableName := Sender.SwitchValue;
end;

procedure TBDEMod.TclCmd_TableCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
    data: TTclCmdTableData;
begin
	data := Sender.ClientData as TTclCmdTableData;
    try
        with TTclCmdDbTable.Create(Sender.Owner) do
        begin
        	Command := Sender.ParamValues[0];
			DatabaseName := data.DatabaseName;
            TableName := data.TableName;
	    	if FSession <> nil then
    	    	DBDataSet.SessionName := FSession.SessionName;
            Install(Sender.Interp);
		end;
    except
    	on ETclError do
        	raise;
        on E:Exception do
	       	TclError(E.Message);
    end;
end;

{~~~ DBQuery Command ~~~}
procedure TBDEMod.TclCmd_QueryCreate(Sender: TTclCommand);
begin
	Sender.ClientData := TTclCmdTableData.Create; // used later by switches.
end;

procedure TBDEMod.TclCmd_QueryDestroy(Sender: TTclCommand);
begin
	Sender.ClientData.Free;
end;

procedure TBDEMod.TclCmd_QueryPrepare(Sender: TTclCommand; var result: string; var success: boolean);
begin
	with Sender.ClientData as TTclCmdTableData do
    begin
    	DatabaseName := '';
//        TableName := '';
    end;
end;

procedure TBDEMod.TclCmd_Query_databaseSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	with Sender.Command.ClientData as TTclCmdTableData do
    	DatabaseName := Sender.SwitchValue;
end;

procedure TBDEMod.TclCmd_QueryCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
    data: TTclCmdTableData;
begin
	data := Sender.ClientData as TTclCmdTableData;
    try
        with TTclCmdDbQuery.Create(Sender.Owner) do
        begin
        	Command := Sender.ParamValues[0];
			DatabaseName := data.DatabaseName;
	    	if FSession <> nil then
    	    	DBDataSet.SessionName := FSession.SessionName;
            Install(Sender.Interp);
		end;
    except
    	on ETclError do
        	raise;
        on E:Exception do
	       	TclError(E.Message);
    end;
end;


{~~~ DBProc Command ~~~}
procedure TBDEMod.TclCmd_StoredProc_procSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	with Sender.Command.ClientData as TTclCmdTableData do
    	TableName := Sender.SwitchValue;
end;

procedure TBDEMod.TclCmd_StoredProc_databaseSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	with Sender.Command.ClientData as TTclCmdTableData do
		DatabaseName := Sender.SwitchValue;
end;

procedure TBDEMod.TclCmd_StoredProcCreate(Sender: TTclCommand);
begin
	Sender.ClientData := TTclCmdTableData.Create; // used later by switches.
end;

procedure TBDEMod.TclCmd_StoredProcDestroy(Sender: TTclCommand);
begin
	Sender.ClientData.Free;
end;

procedure TBDEMod.TclCmd_StoredProcPrepare(Sender: TTclCommand; var result: string; var success: boolean);
begin
	with Sender.ClientData as TTclCmdTableData do
    begin
    	DatabaseName := '';
        TableName := '';
    end;
end;

procedure TBDEMod.TclCmd_StoredProcCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
    data: TTclCmdTableData;
begin
	data := Sender.ClientData as TTclCmdTableData;
    try
        with TTclCmdDbProc.Create(Sender.Owner) do
        begin
        	Command := Sender.ParamValues[0];
			DatabaseName := data.DatabaseName;
            TableName := data.TableName; // override writes StoredProcName
    		if FSession <> nil then
        		DBDataSet.SessionName := FSession.SessionName;
            Install(Sender.Interp);
		end;
    except
    	on ETclError do
        	raise;
        on E:Exception do
	       	TclError(E.Message);
    end;
end;

// For handling BDE restructure callbacks in script
function TBDEMod.BDERestCallback(CBInfo: pointer): CBRType;
const
	cRestError : array[DBIERR_OBJIMPLICITLYDROPPED..DBIERR_FIELDMUSTBETRIMMED] of string[25] = (
    	'ObjImplicityDropped', 'ObjMayBeTruncated', 'ObjImplicitlyModified', 'ValidateData', 'ValFieldModified',
        'TableLevelChanged', 'CopyLinkedTables', 'OtherServerLoaded', 'ObjImplicitlyTruncated', 'VchkMayNotBeEnforced',
        'MultipleUniqRecs', 'FieldMustBeTrimmed');

var
	info, expr: string;
    iter, errCode: integer;
    p: pRESTCbDesc;

    procedure FormatInfo;
	begin
    	if (errCode >= DBIERR_OBJIMPLICITLYDROPPED) and (errCode <= DBIERR_FIELDMUSTBETRIMMED) then
        	info := cRestError[errCode]
        else
        	info := 'Unknown callback message';
        case p^.eRestrObjType of
            restrNEWFLD,
            restrOLDFLD:
            	info := Format('%s. Field: %s', [info, p^.uObjDesc.fldDesc.szName]);
            restrNEWINDEX,
            restrOLDINDEX:
            	info := Format('%s. Index: %s', [info, p^.uObjDesc.idxDesc.szName]);
            restrNEWVCHK,
            restrOLDVCHK:
            	info := Format('%s. ValCheck - Field #%d', [info, p^.uObjDesc.vchkDesc.iFldNum]);
            restrNEWRINT,
            restrOLDRINT:
            	info := Format('%s. RefInt: %s', [info, p^.uObjDesc.rintDesc.szRintName]);
            restrNEWSEC,
            restrOLDSEC:
            	info := Format('%s. Security Password: %s', [info, p^.uObjDesc.secDesc.szPassword]);
            restrNEWTABLE:
            	info := Format('%s. ?Table?', [info]);
		end;
    end;
begin
	Result := cbrUSEDEF;
 	p := pRESTCbDesc(CBInfo);
   	errCode :=  p^.iErrCode;
    FormatInfo;
    try
		if (ScriptCallback <> '') and (CallbackInterp <> nil) then
	    begin
        	expr := format('%s Restructure %d {%s} {%s}', [ScriptCallback, errCode, info, ScriptCallbackData]); // the braces force a proper param formatting
			// The following is a direct call to the Tcl API; not through a TTcl object ( convenient in this situation. )
			if Tcl_GlobalEval(CallbackInterp, pChar(expr)) <> TCL_OK then
            	TclError(InterpResult(CallbackInterp))
	        else
            begin
            	expr := InterpResult(CallbackInterp);
                if expr = '' then
                	Result := cbrUSEDEF
                else
		        	Result := StrToCBRType(expr);
            end;
	        if Result = cbrERROR then
	        	Result := cbrABORT;
        end else
        begin
//        	if not SuppressUserInteraction then
		        ShowMessage(info); // ??? weak...
		end;
	except
    	on E:Exception do
        begin
			// ??? Should report E.Message;
        	Result := cbrABORT;
        end;
    end;
end;

function TBDEMod.BDEProgCallback(CBInfo: pointer): CBRType;
var
	p: pCBPROGRESSDesc;
    expr: string;
begin
	Result := cbrUSEDEF;
 	p := pCBPROGRESSDesc(CBInfo);
    try
		if (ScriptCallback <> '') and (CallbackInterp <> nil) then
	    begin
        	expr := format('%s Progress %d {%s} {%s}', [ScriptCallback, p^.iPercentDone, p^.szMsg, ScriptCallbackData]); // the braces force a proper param formatting
			// The following is a direct call to the Tcl API; not through a TTcl object ( convenient in this situation. )
			if Tcl_Eval(CallbackInterp, pChar(expr)) <> TCL_OK then
            	TclError(InterpResult(CallbackInterp))
	        else
	        	Result := StrToCBRType(InterpResult(CallbackInterp));
	        if Result = cbrERROR then
	        	Result := cbrABORT;
        end;
	except
    	on E:Exception do
        begin
			// ??? Should report E.Message;
        	Result := cbrABORT;
        end;
    end;

end;


procedure TBDEMod.TclCmd_ScriptCallbackInterpDelete(Sender: TObject;
  AInterp: pTcl_Interp);
begin
	if AInterp = CallbackInterp then // because multiple interps can pass through a command
    	CallbackInterp := nil;
end;

// For BDE Restructure callbacks.
// The interpreter that handled the script call for *ScriptCallback* will be the responsible
// for handling the callback.
procedure TBDEMod.TclCmd_ScriptCallbackCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	CallbackInterp := nil;
	if Sender.ParamValuesCount > 0 then
    begin
    	if Sender.ParamValuesCount <> 2 then
        	TclError(Sender.ErrorMsg);
		ScriptCallback := Sender.ParamValues[0];
        ScriptCallbackData := Sender.ParamValues[1];
        CallbackInterp := Sender.Interp;
    end else
    	ScriptCallback := '';
end;

procedure TBDEMod.TclBdeBeforeOpen(Sender: TTcl);
begin
	TclError('Bridging Interpreter. Keep Self Closed.');
end;

procedure TBDEMod.PasswordDialogKiller(Sender: TObject; var Continue: Boolean);
var
	expr: String;
begin
	if (ScriptCallback <> '') and (CallbackInterp <> nil) then
	begin
		expr := format('%s Progress %d {%s} {%s}', [PasswordCallback, PasswordCallbackData]); // the braces force a proper param formatting
			// The following is a direct call to the Tcl API; not through a TTcl object ( convenient in this situation. )
		if Tcl_GlobalEval(PasswordInterp, pChar(expr)) <> TCL_OK then
           	TclError(InterpResult(PasswordInterp))
        else
        begin
        	expr := InterpResult(CallbackInterp);
            if expr = '' then
            	expr := '0';
        	Continue := TslcStrTruth(expr);
        end;
    end else
	    Continue := False;
end;

constructor TBDEMod.Create(AOwner: TComponent; AThreadId: integer);
begin
	InitTcl(''); // make sure Tcl procedure pointers get bound. Returns immediately if already initialized.
	inherited Create(AOwner, AThreadId);
    TclBde.AutoActivate := False; // prevents normal library initialization procedure, Tslc_Init, from acting on this TTcl instance.
    TslcEnterCritical;
    try
		if( GetCurrentThreadID = MainThreadID )  Then
		    Session.Open
        else
        begin
        	FSession := TSession.Create(nil);
            FSession.SessionName := Format('Session%d', [GetCurrentThreadID]);
            FSession.OnPassword := PasswordDialogKiller;
            FSession.Open;
        end;
    finally
    	TslcLeaveCritical;
    end;
	FBDERestCallback := TBDECallBack.Create(self, nil, cbRESTRUCTURE, @FRestBuf,
            sizeof(RESTCbDesc), BDERestCallback, True);
    FBDEProgCallback := TBDECallback.Create(self, nil, cbGENPROGRESS, @FProgBuf,
    		sizeof(CBPROGRESSDesc), BDEProgCallback, True);
end;

destructor TBDEMod.Destroy;
begin
    inherited Destroy;
    FBDERestCallback.Free;
    FBDEProgCallback.Free;
    FSession.Free;
end;

procedure TBDEMod.TclCmd_SessionCreate(Sender: TTclCommand);
begin
	// This command is "riding on the back" of a TTclCmdSession object. Since the class already provides the desired
    // subcommands, there's no need to duplicate here. This particular *Session* command provides session command creation, a
    // sessionnames list, and the like. We'll store the implementor, a TTclCmdSession object, of the arguments passed to this
    // command in the ClientData property of the *Session* command. The 'Default' argument is the session name, and True indicates
    // we are attempting to create a clone command for an existing session instance ( the *Default* session already exists.)
	Sender.ClientData := TTclCmdSession.Create(nil, 'Default', True, False);
    Sender.ClientDataNotify; // adds notification so ClientData will get set to nil if something else deletes ClientData.
    						// In this case, TclDbDef.pas.TTclCmdSession.DoInterpDelete will cause the object to free itself.
                            // DoInterpDelete is an event handler that is triggered by the Tcl Engine when an interpreter handle
                            // is deleted.
end;

procedure TBDEMod.TclCmd_SessionDestroy(Sender: TTclCommand);
begin
	Sender.ClientData.Free;
end;

procedure TBDEMod.TclCmd_SessionCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
    list: TStrings;
begin
	                        // Argv[0] is the Command Name; in this case, *Session*
	if Sender.Argc > 1 then // Using the Argc & Argv properties because coParse is reset in Sender.Options. Because only a few sub-
    begin					// commands, CREATE, NAMES,..., are dealt with here, overall parse time will be reduced. InvokeCommand
		if TslcTextEqual(Sender.Argv[1], 'CREATE') then // below calls ExecCommand which parses Argv into SwitchValues & ParamValues
        begin
        	if Sender.Argc <> 3 then
            	TclError(Sender.ErrorMsg);

			with TTclCmdSession.Create(Sender.Owner, Sender.Argv[2], False, True) do
            	Install(Sender.Interp);
            exit;
        end;
        if TslcTextEqual(Sender.Argv[1], 'NAMES') then
        begin
        	if Sender.Argc <> 2 then
            	TclError(Sender.ErrorMsg);
			list := TStringList.Create;
            try
            	Sessions.GetSessionNames(list);
                result := MergeList(list);
            finally
            	list.Free;
            end;
            exit;
        end;
    end;
    success := Sender.InvokeCommand(Sender.ClientData as TTclCmdSession) <> TCL_ERROR;
    result := Sender.InterpResult;
end;

procedure TBDEMod.TclCmd_DatabaseCreate(Sender: TTclCommand);
begin
//
end;

procedure TBDEMod.TclCmd_DatabaseDestroy(Sender: TTclCommand);
begin
//
end;

procedure TBDEMod.TclCmd_DatabaseCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	with TTclCmdDatabase.Create(Sender.Owner, pChar(Sender.ParamValues[0]), False) do
    try
    	if FSession <> nil then
        	Database.SessionName := FSession.SessionName;
    	Install(Sender.Interp);
//        Tcl := Sender.Tcl;
    except
    	Free;
        raise;
    end;
end;

procedure TBDEMod.TclCmd_DataSourceCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	with TTclCmdDataSource.Create(Sender.Owner) do
    try
    	Command := Sender.ParamValues[0];
		Install(Sender.Interp);
//        Tcl := Sender.Tcl;
    except
    	Free;
        raise;
    end;
end;

procedure TBDEMod.TclBdeAfterInitInterp(Sender: TObject;
  AInterp: pTcl_Interp);
var
	ver: string;
begin
	ver := format('%d.%d', [TSLC_BDE_VERSION_MAJOR, TSLC_BDE_VERSION_MINOR]);
	Tcl_PkgProvide(AInterp, TSLC_BDE_NAME, pChar(ver));
end;


procedure TBDEMod.TclCmd_LockBoxCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
begin
	with TTclCmdLockBox.Create(Sender.Owner, Sender.ParamValues[0]) do
    try
    	Install(Sender.Interp);
    except
    	Free;
        raise;
    end;

end;


procedure TBDEMod.TclCmd_PasswordCallbackCommand(Sender: TTclCommand;
  var result: String; var success: Boolean);
begin
	PasswordInterp := nil;
	if Sender.ParamValuesCount > 0 then
    begin
    	if Sender.ParamValuesCount <> 2 then
        	TclError(Sender.ErrorMsg);
		PasswordCallback := Sender.ParamValues[0];
        PasswordCallbackData := Sender.ParamValues[1];
        PasswordInterp := Sender.Interp;
    end else
    	PasswordCallback := '';

end;

procedure TBDEMod.TclCmd_PasswordCallbackInterpDelete(Sender: TObject;
  AInterp: pTcl_Interp);
begin
	if AInterp = PasswordInterp then // because multiple interps can pass through a command
    	PasswordInterp := nil;
end;

initialization
    RegisterTclServer(TBDEMod);
	TslcPrepareCritical;

finalization
    TslcDoneCritical;

end.


