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

///////////////////////////////////////////////////////////////////////////////
//
//  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


interface
uses Windows, TclTk, Tslc, Classes, Bde, Db, DbTables, BdeMisc, TclDbDef;

// The Unit Defines the TTclCmdDbMan class that's derived from TTclCommand
// TTclCmdDbMan makes table manipulation available in scripts.

type

	TTclCmdField = class(TTclCommand)
    private
    	FField: TField;
        FFastMode: boolean;
        F_n: TTclCmdSwitch;
		// FastMode
		procedure _f(Sender: TTclCmdSwitch; ASwitch: string; var result: string; var success: boolean);
    protected
	   	procedure DoCommand(var result: string; var success: boolean); override;
    	procedure DoScriptDelete(AInterp: pTcl_Interp); override;
    public
    	constructor Create(AOwner: TComponent; AField: TField);
        destructor Destroy; override;
        property Field: TField read FField;
        property FastMode: boolean read FFastMode write FFastMode; // parse xtra command args or just return/assign Field values
    end;


	TTclCmdDbDataSet = class(TTclCmdDbDef) // abstract class
    private
//    	FDBDataSet: TDBDataSet;
        ZeroNullNums, OpenDescriptors, KeepDescriptorsOpen: boolean;
//		FTableName, FTableType: string;
		FActive: boolean;
		FMasterSourceCommand: string;
		FDeletionFlag: pInteger;

		// descriptors
		procedure _desc(Sender: TTclCmdSwitch; ASwitch: string; var result: string; var success: boolean);
		// zero Null numbers
		procedure _z(Sender: TTclCmdSwitch; ASwitch: string; var result: string; var success: boolean);
        // keep descriptors open
		procedure _e(Sender: TTclCmdSwitch; ASwitch: string; var result: string; var success: boolean);


		function GetActive: boolean;
        procedure SetActive(value: boolean);

	protected
	   	procedure DoCommand(var result: string; var success: boolean); override;
      	function  DoExecCommand(_interp: pTcl_Interp; _argc: integer; _argv: Tcl_Argv; isObj: boolean): integer; override;
        procedure DoPrepare(var result: string; var success: boolean); override;

        function GetDBDataSet: TDBDataSet; virtual; abstract;
		function GetDataSet: TDataSet; override;
		// Overrides for abstracts in base class. Unless Compiler Warnings/Hints are
		// on, a runtime error can sneek by if the following are not redeclared.
		// Not overriding an abstract should be a Compiler Error instead of a Warning; though, since
		// it's not, it's possible to induce a call to an abstract function.
		function GetDatabaseName: string; override;
		function GetDatabaseType: string; override;
		function GethCursor: hDbiCur; override;
		function GethDb: hDbiDb; override;
        function GetLanguage: string; override;
        function GetLocale: Pointer; override;
        function GetSessionName: string; override;
//		function GetTableName: string; override; // abstract in base class
//		function GetTableType: string; override; // abstract in base class
		procedure SetDatabaseName(name: string); override;
		procedure SetDatabaseType(value: string); override;
        procedure SetSessionName(value: string); override;
//		procedure SetTableName(value: string); override;
//		procedure SetTableType(value: string); override;

	public
    	constructor Create(AOwner: TComponent);
        destructor Destroy; override;
		procedure Close; override;
		procedure Open; override;

        property DBDataSet: TDBDataSet read GetDBDataSet;
        property Active: boolean read GetActive write SetActive default false;
    end;

	TTclCmdDbTable = class(TTclCmdDbDataSet)
    private
    	FTable: TTable;
        FMove: integer;
		// Move
		procedure _m(Sender: TTclCmdSwitch; ASwitch: string; var result: string; var success: boolean);
    protected
    	procedure DoCommand(var result: string; var success: boolean); override;
        procedure DoPrepare(var result: string; var success: boolean); override;
		function GetDBDataSet: TDBDataSet; override;
		function GetTableName: string; override; // abstract in base class
		function GetTableType: string; override; // abstract in base class
		function GetTableTypeName: PChar;
		procedure SetTableName(value: string); override;
		procedure SetTableType(value: string); override;
    public
    	constructor Create(AOwner: TComponent);
        destructor Destroy; override;
    published
    end;

    TTclCmdDbQuery = class(TTclCmdDbDataSet)
    private
    	FQuery: TQuery;
    protected
    	procedure DoCommand(var result: string; var success: boolean); override;
		function GetDBDataSet: TDBDataSet; override;
		function GetTableName: string; override; // abstract in base class
		function GetTableType: string; override; // abstract in base class
		function GetTableTypeName: PChar;
		procedure SetTableName(value: string); override;
		procedure SetTableType(value: string); override;
    public
    	constructor Create(AOwner: TComponent);
        destructor Destroy; override;
    published
    end;


    TTclCmdDbProc = class(TTclCmdDbDataSet)
    private
    	FStoredProc: TStoredProc;
    protected
    	procedure DoCommand(var result: string; var success: boolean); override;
		function GetDBDataSet: TDBDataSet; override;
		function GetTableName: string; override; // abstract in base class
		function GetTableType: string; override; // abstract in base class
		function GetTableTypeName: PChar;
		procedure SetTableName(value: string); override;
		procedure SetTableType(value: string); override;
    public
    	constructor Create(AOwner: TComponent);
        destructor Destroy; override;
    published
    end;


implementation
uses TslcPlat, TclDbPro, SysUtils, TslcUtil, TslcHash;

const
	hash_				: integer = 0;
    hashACTIVE			: integer = 0;
    hashFIRST			: integer = 0;
    hashNEXT			: integer = 0;
    hashPRIOR			: integer = 0;
    hashLAST			: integer = 0;
    hashBOF				: integer = 0;
    hashEOF				: integer = 0;
    hashAPPEND			: integer = 0;
    hashINSERT			: integer = 0;
    hashEDIT			: integer = 0;
    hashPOST			: integer = 0;
    hashCANCEL			: integer = 0;
    hashDELETE			: integer = 0;
    hashREFRESH			: integer = 0;
    hashSOURCE			: integer = 0;
    hashFIELD			: integer = 0;
    hashFIELDCOUNT		: integer = 0;
    hashFIELDNAME		: integer = 0;
    hashFIELDSIZE		: integer = 0;
    hashFIELDTYPE		: integer = 0;
    hashFIELDVALUE		: integer = 0;
    hashVALUE			: integer = 0;
    hashNAME			: integer = 0;
    hashSIZE			: integer = 0;
    hashTYPE			: integer = 0;
    hashISNULL			: integer = 0;
    hashDISPLAYLABEL	: integer = 0;
    hashDISPLAYWIDTH	: integer = 0;
    hashASSIGN			: integer = 0;
    hashRECORDCOUNT		: integer = 0;
    hashMASTERFIELDS	: integer = 0;
    hashMASTERSOURCE	: integer = 0;
    hashINDEXNAME		: integer = 0;
    hashINDEXFIELDNAMES	: integer = 0;
    hashINDEXFIELDCOUNT	: integer = 0;
    hashINDEXFIELDS		: integer = 0;
    hashREGENINDEXES	: integer = 0;
    hashFINDKEY			: integer = 0;
    hashFINDNEAREST		: integer = 0;
    hashFREE			: integer = 0;

	hashTEXT			: integer = 0;
    hashEXECSQL			: integer = 0;
    hashPARAMS			: integer = 0;
    hashCOUNT			: integer = 0;
    hashADD				: integer = 0;
    hashCREATE			: integer = 0;
    hashCLEAR			: integer = 0;
    hashREMOVE			: integer = 0;
    hashINDEXOF			: integer = 0;
    hashBYNAME			: integer = 0;
    hashPREPARE			: integer = 0;
    hashUNPREPARE		: integer = 0;
    hashEXECPROC		: integer = 0;
    hashSTOREDPROCNAME	: integer = 0;

    hashBATCHMOVE		: integer = 0;

    hashCACHEDUPDATES	: integer = 0;
    hashAPPLYUPDATES	: integer = 0;
    hashCANCELUPDATES	: integer = 0;
    hashCOMMITUPDATES	: integer = 0;
    hashREVERTRECORD	: integer = 0;
    hashUPDATESTATUS	: integer = 0;
    hashEXCLUSIVE		: integer = 0;


{~~~ TTclCmdField ~~~}
constructor TTclCmdField.Create(AOwner: TComponent; AField: TField);
begin
	inherited Create(AOwner);
    FField := AField;
    ErrorMsg := 'Syntax: ?FieldObj? [?newValue?] [-m]';
    with TTclCmdSwitch.Create(self) do
    begin
    	Switch := '-';
        Options := [soHaltSwitchParsing];
        Command := Self;
    end;
    with TTclCmdSwitch.Create(Self) do
    begin
    	OnSwitch :=_f;
        Switch := 'f';
        Command := Self;
    end;
    with TTclCmdSwitch.Create(Self) do
    begin
    	OnSwitch := _f;
        Switch := 'm';  // alternate
        Command := Self;
    end;
    F_n := TTclCmdSwitch.Create(Self);
    with F_n do
    begin
    	options := options + [soHijackRelative];
        RequireParams := 1;
        Switch := 'n';  // alternate
        Command := Self;
    end;
end;

destructor TTclCmdField.Destroy;
begin
	inherited Destroy;
end;

procedure TTclCmdField._f(Sender: TTclCmdSwitch; ASwitch: string; var result: string; var success: boolean);
begin
	FFastMode := TslcStrTruth(Sender.SplitDef(ASwitch, '+')); // perhaps a toggle for empty switch or .

end;

procedure TTclCmdField.DoCommand(var result: string; var success: boolean);
var
	cnt, hash, i: integer;
    fld: TField;
begin
	if FFastMode then
	case ParamValuesCount of
    	0:
        begin
	        result := FField.AsString; // not assigned to result by default to help save a little time.
			if (result = '') and (F_n.Hits > 0) then
            	result := F_n.SwitchValue;
    	end;
        1: FField.AsString := ParamValues[0];
    else
    	TclError(ErrorMsg);
    end else
    begin
    	cnt := ParamValuesCount;
		if cnt < 1 then
        	TclError(ErrorMsg);
        hash := HashValues[0];
        if hash = hashNAME then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
            result := FField.FieldName;
        	exit;
        end;
        if hash = hashSIZE then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
            result := inttostr(FField.Size);
        	exit;
        end;
        if hash = hashTYPE then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
            TclError('Not Coded Yet'); // ???
            exit;
        end;
        if hash = hashVALUE then
        begin
        	if cnt > 2 then
            	TclError(ErrorMsg);
            result := FField.AsString;
            if cnt > 1 then
            	FField.AsString := ParamValues[1];
            exit;
        end;
        if hash = hashDISPLAYLABEL then
        begin
        	if cnt > 2 then
            	TclError(ErrorMsg);
            result := FField.DisplayLabel;
            if cnt > 1 then
            	FField.DisplayLabel := ParamValues[1];
            exit;
        end;
        if hash = hashDISPLAYWIDTH then
        begin
        	if cnt > 2 then
            	TclError(ErrorMsg);
            result := inttostr(FField.DisplayWidth);
        	if cnt > 1 then
            	FField.DisplayWidth := TslcStrToInt(ParamValues[1]);
            exit;
        end;
    	if hash = hashASSIGN then
        begin
        	if cnt <> 2 then
            	TclError(ErrorMsg);
			i := strtointdef(ParamValues[1],-1);
            if FField.DataSet = nil then
            	TclError('Null DataSet')
            else with FField.DataSet do
            begin
				if i < 0 then
                	fld := FindField(ParamValues[1])
            	else if (i >= 0) and (i < FieldCount) then
	            	fld := Fields[i]
		        else
                	fld := nil;
                if fld = nil then
                	TclErrorFmt('Invalid Field Reference - %s', [ParamValues[1]])
                else
                	FField := fld;
            end;
            exit;
        end;
        if hash = hashFREE then
        begin
        	Free;
            exit;
        end;
        TclError(ErrorMsg);
    end;
end;

procedure TTclCmdField.DoScriptDelete(AInterp: pTcl_Interp);
begin
	// Assuming that command exists only in a single interpreter
	Free;
end;

{~~~ TTclCmdDbDataSet ~~~}

procedure TTclCmdDbDataSet.Close;
begin
	if KeepDescriptorsOpen then
        KeepDescriptorsOpen := False
    else
		inherited Close;
    DBDataSet.Close;
    FActive := False;
end;

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

function TTclCmdDbDataSet.GetDatabaseName: string;
begin
	result := DBDataSet.DatabaseName;
end;

function TTclCmdDbDataSet.GetDatabaseType: string;
begin
	if DBDataSet.Database <> nil then
    	result := DBDataSet.Database.DriverName
	else
    	result := '';
//    else
//    	TclError('Invalid Database');
end;

function TTclCmdDbDataSet.GetDataSet: TDataSet;
begin
	result := GetDBDataSet;
end;

function TTclCmdDbDataSet.GethCursor: hDbiCur;
begin
	result := DBDataSet.Handle;
end;

function TTclCmdDbDataSet.GethDb: hDbiDb;
begin
	if DBDataSet.Database <> nil then
    	result := DBDataSet.Database.Handle
    else
    	result := nil;
end;

function TTclCmdDbDataSet.GetLanguage: string;
var
	Desc: DBDesc;
    tblName, objName: string;
    buf: array[0..DBIMAXNAMELEN] of char;
    p: pChar;
    IsStandard: boolean;
    list: TStringList;
begin
	CharToOem(strpcopy(buf, GetDatabaseName), buf);
	Check(DbiGetDatabaseDesc(buf, @Desc));
	Desc.szDBType[sizeOf(Desc.szDBType) - 1] := #0;
	OemToChar(Desc.szDBType, Desc.szDBType);
    p := Desc.szDBType;
    IsStandard :=  StrComp(p, 'STANDARD') = 0;
    if IsStandard then
    	p := pChar(GetTableType);
    tblName := GetTableName;
    if IsStandard and (tblName <> '') then
    begin
    	objName := format(':%s:%s',[buf, tblName]);
        if DbiGetLDName(p, pChar(objName), buf) <> DBIERR_NONE then
        begin
        	objName := format('%s\%s',[Desc.szPhyName, tblName]);
	   	    if DbiGetLDName(p, pChar(objName), buf) <> DBIERR_NONE then
            	Check(DbiGetLDName(p, nil, buf));
        end;
    end else
    	Check(DbiGetLDName(p, nil, buf));
	if buf[0] = #0 then
	begin
    	list := TStringList.Create;
        try
        	Session.GetAliasParams(GetDatabaseName, list);
            result := list.Values[szCFGSYSLANGDRV]
        finally
        	list.Free;
        end;
    end else
    	result := buf;
end;

function TTclCmdDbDataSet.GetLocale: Pointer;
begin
	result := DBDataSet.DBLocale;
end;

function TTclCmdDbDataSet.GetSessionName: string;
begin
	result := DBDataSet.SessionName;
end;

procedure TTclCmdDbDataSet.SetActive(value: boolean);
begin
	if FActive = value then exit;
    if value then
    	Open
    else
    	Close;
end;

procedure TTclCmdDbDataSet.SetDatabaseName(name: string);
begin
	DBDataSet.DatabaseName := name;
end;

procedure TTclCmdDbDataSet.SetDatabaseType(value: string);
begin
	if DBDataSet.Database <> nil then
    	DBDataSet.Database.DriverName := value;
//    else
//    	TclError('Invalid Database');
end;

procedure TTclCmdDbDataSet.SetSessionName(value: string);
begin
	DBDataSet.SessionName := value;
end;


function TruthDef(value: string; def: boolean): boolean;
begin
	if value = '' then
    	result := def
    else
    	result := TslcStrTruth(value);
end;

procedure TTclCmdDbDataSet._desc(Sender: TTclCmdSwitch; ASwitch: string; var result: string; var success: boolean);
begin
	OpenDescriptors := TruthDef( Sender.Split(ASwitch), True);
end;

procedure TTclCmdDbDataSet._z(Sender: TTclCmdSwitch; ASwitch: string; var result: string; var success: boolean);
begin
	ZeroNullNums := TruthDef( Sender.Split(ASwitch), True);
end;

procedure TTclCmdDbDataSet._e(Sender: TTclCmdSwitch; ASwitch: string; var result: string; var success: boolean);
begin
	KeepDescriptorsOpen := TruthDef( Sender.Split(ASwitch), True);
end;

constructor TTclCmdDbDataSet.Create(AOwner: TComponent);
const
	cSyntax =
    	'Syntax:' + #13 +
        '<?dbDataSet?> <open [[?databaseName?] <?tableName?>] [-d]|close|first|next|prior|last' + #13 +
        '    |append|insert|edit|post|field <?fieldName?>|value <?fieldName?|?fieldNumber?> [?newValue?]>' + #13 +
        '    |info <0..fldCount-1|databaseName|databaseType|tableName|tableType>' + #13 +
        '    |<fldDesc|idxDesc|refDesc|secDesc|valDesc> <?args?>' + #13 +
        '    |<restructure|createTable> [?databaseName?] <?tableName?> [-xakpwfirsvo]>';

var
	switch: TTclCmdSwitch;
    x: integer;
begin
	inherited Create(AOwner);
	MinArgs := 1;  // Ensure at least one parameter
    MaxArgs := Byte(MaxInt);
	// Show syntax message if wrong number of arguments/parameters are passed to the command.
    // MinArgs and MaxArgs are checked internally prior to calling DoCommand.
    ErrorMsg := cSyntax;
	with TTclCmdSwitch.Create(Self) do
    begin
    	switch := 'z';
        OnSwitch := _z;
        Command := self;
    end;
	switch := TTclCmdSwitch.Create(Self);
    with switch do
    begin
    	switch := 'desc';
        OnSwitch := _desc;
        Command := self;
    end;
    for x:= 0 to SwitchCount - 1 do
    	if Switches[x] = switch then
        begin
        	MoveSwitch(x, 0);
            break;
        end;
    switch := TTclCmdSwitch.Create(Self);
    with switch do
    begin
    	switch := '-';
        Options := [soHaltSwitchParsing];
        Command := Self;
    end;
    for x:= 0 to SwitchCount - 1 do
    	if Switches[x] = switch then
        begin
        	MoveSwitch(x, 0);
            break;
        end;
    with TTclCmdSwitch.Create(Self) do
    begin
    	switch := 'e';
        OnSwitch := _e;
        Command := self;
    end;
end;

destructor TTclCmdDbDataSet.Destroy;
begin
    inherited Destroy;
end;

procedure TTclCmdDbDataSet.DoCommand(var result: string; var success: boolean);
const
	cFieldBase = 1;
var
	cnt: integer;
    hash, fldNum, x: integer;
    fld: TField;
    list: TStringList;
begin
	hash := HashValues[0]; // Note: (index  = 0) is not the first argument; it's the first parameter
                           // We also know that MinArgs guaranteed at least one parameter.
	cnt := ParamValuesCount;
//    try
	    if hash = hashEOF then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
		    result := inttostr(integer(DBDataSet.EOF));
            exit;
        end;
	    if hash = hashBOF then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
	    	result := inttostr(integer(DBDataSet.BOF));
            exit;
        end;
		if hash = hashFIRST then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
            DBDataSet.First;
            exit;
        end;
	    if hash = hashNEXT then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
	    	DBDataSet.Next;
        	exit;
        end;
	    if hash = hashPRIOR then
        begin
			if cnt <> 1 then
            	TclError(ErrorMsg);
	    	DBDataSet.Prior;
            exit;
        end;
	    if hash = hashLAST then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
	    	DBDataSet.Last;
            exit;
        end;
	    if hash = hashVALUE then
        begin
			if (cnt < 2) or (cnt > 3) then
				TclError(ErrorMsg);
	    	fldNum := strtointdef( ParamValues[1], cFieldBase - 1 ); // Let's index fields starting with 1.
	        if fldNum < cFieldBase then // assume reference passed as name
	        	fld := DBDataSet.FindField(ParamValues[1])
	        else if ( fldNum >= cFieldBase ) and (fldNum <= (DBDataSet.FieldCount - 1) + cFieldBase) then
	        	fld := DBDataSet.Fields[fldNum - cFieldBase]
	        else
	        	fld := nil;
	        if fld = nil then
	        	TclErrorFmt('%s - Invalid field reference %s for value operation',[Command, ParamValues[1]])
	        else if fld.IsNull and ZeroNullNums and (fld.DataType in
            	[ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat, ftCurrency]) then
            begin
				case fld.DataType of
                	ftBoolean: result := 'False';
                    ftFloat,
                    ftCurrency: result := '0.0';
                else
                	result := '0';
                end;
			end else
            	result := fld.DisplayText;
            if cnt > 2 then
            	fld.AsString := ParamValues[2];
            exit;
		end;
        if hash = hashAPPEND then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
        	DBDataSet.Append;
            exit;
        end;
        if hash = hashINSERT then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
        	DBDataSet.Insert;
            exit;
        end;
        if hash = hashEDIT then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
        	DBDataSet.Edit;
        	exit;
        end;
        if hash = hashPOST then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
        	DBDataSet.Post;
            exit;
        end;
        if hash = hashCANCEL then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
            DBDataSet.Cancel;
        	exit;
        end;
        if hash = hashDELETE then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
            DBDataSet.Delete;
            exit;
        end;
        if hash = hashREFRESH then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
            DBDataSet.Refresh;
            exit;
        end;
		if hash = hashACTIVE then
        begin
        	if cnt > 2 then
            	TclError(ErrorMsg);
			result := BoolStr[Active];
			if cnt > 1 then
				Active := TslcStrTruth(ParamValues[1]);
			exit;
		end;
        if hash = hashFIELD then
        begin
        	if cnt <> 3 then
            	TclError(ErrorMsg);
	    	fldNum := strtointdef( ParamValues[1], - 1 ); // Let's index fields as zero-based array
	        if fldNum < 0 then // assume reference passed as name
	        	fld := DBDataSet.FindField(ParamValues[1])
	        else if ( fldNum >= 0 ) and (fldNum < DBDataSet.FieldCount) then
	        	fld := DBDataSet.Fields[fldNum]
	        else
	        	fld := nil;
            if fld = nil then
            	TclErrorFmt('Cannot Find Field %s', [ParamValues[1]]);
            with TTclCmdField.Create(Self, fld) do
            begin
            	Command := Self.ParamValues[2];
				Install(Self.Interp);
            end;
            exit;
        end;
        if hash = hashFIELDCOUNT then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
            result := inttostr(DBDataSet.FieldCount);
            exit;
        end;
        if hash = hashFIELDNAME then
        begin
        	TclError('Not Coded'); // ???
        end;
        if hash = hashFIELDTYPE then
        begin
        	TclError('Not Coded'); // ???
        end;
        if hash = hashFIELDSIZE then
        begin
        	TclError('Not Coded'); // ???

	    end;
        if hash = hashRECORDCOUNT then
        begin
        	if cnt <> 1 then
            	TclError(ErrorMsg);
        	result := inttostr(DBDataSet.RecordCount);
            exit;
        end;

		if hash = hashCACHEDUPDATES	then
        begin
        	TclError('Not Coded'); // ???


        end;

        if hash = hashAPPLYUPDATES then
        begin
        	TclError('Not Coded'); // ???

        end;

        if hash  = hashCANCELUPDATES then
        begin
        	TclError('Not Coded'); // ???


        end;

        if hash = hashCOMMITUPDATES	then
        begin
        	TclError('Not Coded'); // ???

        end;

        if hash = hashREVERTRECORD then
        begin
        	TclError('Not Coded'); // ???

        end;

        if hash = hashUPDATESTATUS then
        begin
        	TclError('Not Coded'); // ???

        end;

       	inherited DoCommand(result, success);
//
//  Will be using DoException override to handle Exceptions
//
//    except
//    	on ETclError do  // ETclErrors are Safe exceptions to raise.
//        	raise;
//    	on E:Exception do // if coCatchAll is not in TTclCommand.Options Exception could trickle back into Tcl engine!
//			TclError(E.Message);
//    end;
end;

function TTclCmdDbDataSet.DoExecCommand(_interp: pTcl_Interp; _argc: integer; _argv: Tcl_Argv; isObj: boolean): integer;
var
	PrevZeroNullNums, PrevOpenDescriptors, PrevKeepDescriptorsOpen: boolean;
begin
	// Discovered that a script event, DataSource.OnStateChange, coerced recursion of this command. The first call was
    // <?DataSetObject?> Open -desc
    // A script event handler setup via a DataSource command reacted to the state change on the DataSet command. Within
    // the script for the OnStateChange event was a call to the DataSet command which resulted in a machine call to DoPrepare
	// which in turn reset the OpenDescriptors property to false. To get around the side-effects of this recursion, an
    // override of the primary DoExecCommand function was necessary along with stacking the state variables via local var storage.
    // Note that the state variables ZeroNullNums, OpenDescriptors, and KeepDescriptorsOpen are of interest only during
    // the call to DoExecCommand.
	PrevZeroNullNums := ZeroNullNums;
    PrevOpenDescriptors := OpenDescriptors;
    PrevKeepDescriptorsOpen := KeepDescriptorsOpen;
    result := 0; // Set to zero in case Self is destroyed. DoExecCommand guarantees the return of
       			//  TCL_DESTROYED when Self is destroyed. Exceptions are trapped and will not propogate
                //  when Self is destroyed.
    try
		result := inherited DoExecCommand(_interp, _argc, _argv, isObj);
    finally
    	if result <> TCL_DESTROYED then
        begin
	    	ZeroNullNums := PrevZeroNullNums;
	        OpenDescriptors := PrevOpenDescriptors;
	        KeepDescriptorsOpen := PrevKeepDescriptorsOpen;
        end;
    end;
end;

procedure TTclCmdDbDataSet.DoPrepare(var result: string; var success: boolean);
begin
	inherited DoPrepare(result, success);
	ZeroNullNums := False;
    OpenDescriptors := False;
    KeepDescriptorsOpen := False;
end;


procedure TTclCmdDbDataSet.Open;
begin
   	DBDataSet.Open;
	if OpenDescriptors then
		InternalOpen;
    FActive := True;
end;

{~~~ TTclCmdDbTable ~~~}
// Move
procedure TTclCmdDbTable._m(Sender: TTclCmdSwitch; ASwitch: string; var result: string; var success: boolean);
begin
	FMove := TslcStrToInt(Sender.SplitDef(ASwitch, inttostr(MaxLongInt)));
end;

constructor TTclCmdDbTable.Create(AOwner: TComponent);
begin
	FTable := TTable.Create(nil);
    inherited Create(AOwner);
	MinArgs := 1;
    with TTclCmdSwitch.Create(Self) do
    begin
    	switch := 'm';
        OnSwitch := _m;
        Command := self;
    end;
end;

destructor TTclCmdDbTable.Destroy;
begin
	inherited Destroy;
    FTable.Free;
end;

procedure TTclCmdDbTable.DoCommand(var result: string; var success: boolean);
var
	hash: integer;
    cnt, x, n: integer;
    db: hDBIDb;
    p: pChar;
begin
    hash := HashValues[0];
    cnt := ParamValuesCount;
	if hash = hashMASTERSOURCE then
    begin
    	result := FMasterSourceCommand;
        if cnt > 1 then
        begin
        	if ParamValues[1] = '' then
            	FTable.MasterSource := nil
            else
	        	FTable.MasterSource := DataSourceFromCommand(Interp, ParamValues[1]);
            FMasterSourceCommand := ParamValues[1];
        end;
        exit;
    end;
    if hash = hashMASTERFIELDS then
    begin
    	result := FTable.MasterFields;
        if cnt > 1 then
        	FTable.MasterFields := ParamValues[1];
        exit;
	end;
    if hash = hashINDEXNAME then
    begin
    	result := FTable.IndexName;
        if cnt > 1 then
        	FTable.IndexName := ParamValues[1];
        exit;
    end;
    if hash = hashINDEXFIELDNAMES then
    begin
    	result := FTable.IndexFieldNames;
        if cnt > 1 then
        	FTable.IndexFieldNames := ParamValues[1];
        exit;
    end;
	if hash = hashINDEXFIELDCOUNT then
    begin
    	result := inttostr(FTable.IndexFieldCount);
        exit;
    end;
    if hash = hashINDEXFIELDS then
    begin
    	if cnt <> 2 then
        	TclError(ErrorMsg);
        result := FTable.IndexFields[TslcStrToInt(ParamValues[1])].FieldName;
        exit;
    end;
    if (hash = hashFINDKEY) or (hash = hashFINDNEAREST) then
    begin
		if cnt < 2 then
        	TclError('No values specified for FindKey/FindNearest');
    	with FTable do
        begin
			CheckBrowseMode;
			n := IndexFieldCount;
            if cnt - 1 > n then    // Note: ParamValues[0] is FINDKEY
            	TclError('Number of values for FindKey/FindNearest exceeds number of fields in index')
            else if cnt - 1 < n then
            	n := cnt - 1;
        	SetKey;
			for x := 0 to n - 1 do
                IndexFields[x].AsString := ParamValues[x+1];
            KeyFieldCount := n;
            if hash = hashFINDKEY then
	            result := BoolStr[GotoKey]
            else
            	GotoNearest;
        end;
    	exit;
    end;
    if hash = hashREGENINDEXES then // ??? more comprehensive
    begin
		// if overwrite then delete
		if cnt <> 3 then // for now, must supply database and table names
			TclError(ErrorMsg);
        if KeyViol <> '' then
        	p := pChar(KeyViol)
        else
        	p := nil;
   	   	Check(DbiOpenDatabase(pChar(ParamValues[1]), nil, dbiReadWrite, dbiOpenShared, nil, 0, nil, nil, db));
		try
			for x:= 0 to IdxDsc.Count - 1 do
				Check(DbiAddIndex(db, nil, pChar(ParamValues[2]), pChar(TableType), IdxDsc.Desc[x]^, p));
		finally
			if Assigned(db) then
				Check(DbiCloseDatabase(db));
		end;
        exit;
    end;
    if hash = hashEXCLUSIVE then
    begin
    	if cnt > 2 then
        	TclError(ErrorMsg);
       	result := BoolStr[FTable.Exclusive];
        if cnt = 2 then
        	FTable.Exclusive := TslcStrTruth(ParamValues[1]);
        exit;
    end;
    if hash = hashBATCHMOVE then
    begin
        if cnt < 3 then
        	TclError(ErrorMsg);
        with TBatchMove.Create(nil) do
		try
			Destination := FTable;
{$IFDEF VER90}
        	Source := DataSetFromCommand(Interp, ParamValues[1]);
{$ELSE}
        	Source := DataSetFromCommand(Interp, ParamValues[1]) as TBDEDataSet;
{$ENDIF}
            Mode := TBatchMode(StrToBatchMode(ParamValues[2]));
            RecordCount := FMove;
            if roKeyViol in Flags then // activated by -k switch
            	KeyViolTableName := KeyViol;
            if roProblems in Flags then
            	ProblemTableName := Problems;
            for x:= 3 to cnt - 1 do
				SplitList(Interp, ParamValues[x], Mappings);
			Execute;
    		result := inttostr(MovedCount);
		finally
			Free;
        end;
		exit;
    end;
    inherited DoCommand(result, success);
end;

procedure TTclCmdDbTable.DoPrepare(var result: string; var success: boolean);
begin
    inherited DoPrepare(result, success);
    FMove := MaxLongInt;
end;

function TTclCmdDbTable.GetDBDataSet: TDBDataSet;
begin
	result := FTable;
end;

function TTclCmdDbTable.GetTableName: string;
begin
	result := FTable.TableName;
end;

function TTclCmdDbTable.GetTableType: string;
begin
	result := GetTableTypeName;
end;

// Borrowed from DBTables.pas
function TTclCmdDbTable.GetTableTypeName: PChar;
const
  Names: array[TTableType] of PChar =
{$IFDEF VER90}
    (szPARADOX, szPARADOX, szDBASE, szASCII);
{$ELSE}
{$IFDEF VER100}
    (szPARADOX, szPARADOX, szDBASE, szASCII);
{$ELSE}
    (szPARADOX, szPARADOX, szDBASE, szASCII, szFoxPro);
{$ENDIF}
{$ENDIF}

var
  TableType: TTableType;
  Extension: string;
begin
  Result := nil;
  if (FTable.Database = nil) or not FTable.Database.IsSQLBased then // Allowing FTable.Database to be nil
  begin
    TableType := FTable.TableType;
    if TableType = ttDefault then
    begin
      Extension := ExtractFileExt(GetTableName);
      if CompareText(Extension, '.DBF') = 0 then TableType := ttDBase;
      if CompareText(Extension, '.TXT') = 0 then TableType := ttASCII;
    end;
    Result := Names[TableType];
  end;
end;

procedure TTclCmdDbTable.SetTableName(value: string);
begin
	FTable.TableName := value;
end;

procedure TTclCmdDbTable.SetTableType(value: string);
begin
	if value = '' then
		FTable.TableType := ttDefault
    else if TslcTextEqual(value, szPARADOX) then
    	FTable.TableType := ttParadox
    else if TslcTextEqual(value, szDBASE) then
    	FTable.TableType := ttDBase
    else if TslcTextEqual(value, szASCII) then
    	FTable.TableType := ttASCII
    else
    	TclErrorFmt('Unknown TableType %s', [value]);
end;


// For both TTclCmdDbProc and TTclCmdDbQuery
// Note the difference between Query.Params/StoredProc.Params and TTclCommand.Params/TTclCommand.ParamValues

const
	FieldTypeStr : array[ftUnknown..ftTypedBinary] of pChar =
  	('Unknown', 'String', 'Smallint', 'Integer', 'Word',
   	'Boolean', 'Float', 'Currency', 'BCD', 'Date', 'Time', 'DateTime',
    'Bytes', 'VarBytes', 'AutoInc', 'Blob', 'Memo', 'Graphic',
    'FmtMemo', 'ParadoxOle', 'DBaseOle', 'TypedBinary');

	ParamTypeStr : array[ptUnknown..ptResult] of pChar =
    ('Unknown', 'Input', 'Output', 'InputOutput', 'Result');

function StrToFieldType(value: string): TFieldType;
var
	ft: TFieldType;
begin
	for ft := ftUnknown to ftTypedBinary do
	    if TslcTextEqual(value, FieldTypeStr[ft]) then
    	begin
        	result := ft;
            exit;
        end;
    result := ftUnknown;
end;

function StrToParamType(value: string): TParamType;
var
	pt: TParamType;
begin
	for pt := ptUnknown to ptResult do
    	if TslcTextEqual(value, ParamTypeStr[pt]) then
        begin
        	result := pt;
            exit;
        end;
    result := ptUnknown;
end;

function ParamCommand(Sender: TTclCmdDbDataSet; AParams: TParams; var newValue: string): boolean;
var
	cnt, n, x, idx, hash: integer;
    str: string;
    ft: TFieldType;
    pt: TParamType;
    p: TParam;
begin
	result := True;
	with Sender do // assume we're here because ParamValues[0] induced this procedure;
    begin          // therefore, we'll be inspecting ParamValues[ > 0 ]
    	cnt := ParamValuesCount;
		if cnt < 2 then
        	TclError(ErrorMsg); // ??? weak...
		hash := HashValues[1];
        if hash = hashCOUNT then
        begin
			newValue := inttostr(AParams.Count);
        	exit;
        end;
        if hash = hashCLEAR then
        begin
        	AParams.Clear;
            exit;
        end;
        if hash = hashINDEXOF then
        begin
        	if cnt <> 3 then
            	TclError(ErrorMsg);
    		n := -1;
            str := ParamValues[2];
	        for x:= 0 to AParams.Count - 1 do
				if TslcTextEqual(AParams[x].Name, str) then
                begin
                	n := x;
                	break;
                end;
            exit;
        end;
        if hash = hashCREATE then // hashADD (future) will expect a pointer to a TParam object
        begin
        	if cnt <> 5 then
            	TclError(ErrorMsg);
            ft := StrToFieldType(ParamValues[2]);
            pt := StrToParamType(ParamValues[4]);
            if (ft = ftUnknown) or (pt = ptUnknown) then
            	TclError(ErrorMsg);
			p := AParams.CreateParam(ft, ParamValues[3], pt);
            n := -1;
            for x := 0 to AParams.Count - 1 do
            	if AParams[x] = p then
                begin
                	n := x;
                    break;
                end;
            newValue := inttostr(n);
			exit;
        end;
		if cnt < 3 then
        	TclError(ErrorMsg);
		idx := TslcGetCheckStrRange(ParamValues[1], 0, AParams.Count - 1);
        hash := HashValues[2];
        if hash = hashVALUE then
        begin
        	if cnt > 4 then
	        	TclError(ErrorMsg);
        	if cnt = 3 then
                newValue := AParams[idx].Text
            else // no automatic return of value since type may be input only. cnt determines action
   		    	AParams[idx].Text := ParamValues[3];
        	exit;
        end;
        if hash = hashNAME then
	    begin
	    	if cnt > 4 then
	        	TclError(ErrorMsg);
	        newValue := AParams[idx].Name;
            if cnt = 4 then
            	AParams[idx].Name := ParamValues[3];
	    	exit;
	    end;
        if hash = hashTYPE then
        begin
        	if cnt > 4 then
            	TclError(ErrorMsg);
            newValue := ParamTypeStr[AParams[idx].ParamType];
            if cnt = 4 then // ??? check type
            	AParams[idx].ParamType := StrToParamType(ParamValues[3]);
            exit;
        end;
        if hash = hashFIELDTYPE then
        begin
        	if cnt > 4 then
            	TclError(ErrorMsg);
            newValue := FieldTypeStr[AParams[idx].DataType];
            if cnt = 4 then // ??? check type
            	AParams[idx].DataType := StrToFieldType(ParamValues[3]);
            exit;
        end;
        if hash = hashISNULL then
        begin
        	if cnt <> 3 then
            	TclError(ErrorMsg);
            newValue := BoolStr[AParams[idx].IsNull];
            exit;
        end;
        if hash = hashCLEAR then
        begin
        	if cnt <> 3 then
            	TclError(ErrorMsg);
            AParams[idx].Clear;
            exit;
        end;
        if hash = hashFREE then
        begin
        	if cnt <> 3 then
            	TclError(ErrorMsg);
            AParams[idx].Free;
            exit;
        end;
    end;
    result := False;
end;

{~~~ TTclCmdDbQuery ~~~}
constructor TTclCmdDbQuery.Create(AOwner: TComponent);
begin
	FQuery := TQuery.Create(nil);
    inherited Create(AOwner);
    MinArgs := 1;
end;

destructor TTclCmdDbQuery.Destroy;
begin
	inherited Destroy;
    FQuery.Free;
end;

procedure TTclCmdDbQuery.DoCommand(var result: string; var success: boolean);
var
	hash: integer;
    cnt, x, n: integer;
begin
    cnt := ParamValuesCount;
    hash := HashValues[0];
    if hash = hashPARAMS then
    begin
		if not ParamCommand(Self, FQuery.Params, result) then
        	TclError(ErrorMsg);
        exit;
    end;
    if hash = hashTEXT then // SQL (future) property will allow for TStrings syntax
    begin
		if cnt > 2 then
        	TclError(ErrorMsg);
        if cnt = 1 then
        	result := FQuery.SQL.Text
        else
        	FQuery.SQL.Text := ParamValues[1];
        exit;
    end;
    if hash = hashEXECSQL then
    begin
    	FQuery.ExecSQL;
        exit;
    end;
    if hash = hashPREPARE then
    begin
    	FQuery.Prepare;
        exit;
    end;
    if hash = hashUNPREPARE then
    begin
    	FQuery.Unprepare;
        exit;
    end;
    inherited DoCommand(result, success);
end;

function TTclCmdDbQuery.GetDBDataSet: TDBDataSet;
begin
	result := FQuery;
end;

function TTclCmdDbQuery.GetTableName: string;
begin
	TclError('Unsupported');
end;

function TTclCmdDbQuery.GetTableType: string;
begin
	TclError('Unsupported');
end;

function TTclCmdDbQuery.GetTableTypeName: PChar;
begin
  Result := nil;
end;

procedure TTclCmdDbQuery.SetTableName(value: string);
begin
	TclError('Unsupported');
end;

procedure TTclCmdDbQuery.SetTableType(value: string);
begin
	TclError('Unsupported');
end;


{~~~ TTclCmdDbProc ~~~}
constructor TTclCmdDbProc.Create(AOwner: TComponent);
begin
	FStoredProc := TStoredProc.Create(nil);
    inherited Create(AOwner);
    MinArgs := 1;
end;

destructor TTclCmdDbProc.Destroy;
begin
	inherited Destroy;
    FStoredProc.Free;
end;

procedure TTclCmdDbProc.DoCommand(var result: string; var success: boolean);
var
	hash: integer;
    cnt, x, n: integer;
begin
    cnt := ParamValuesCount;
    hash := HashValues[0];
    if hash = hashPARAMS then
    begin
		if not ParamCommand(Self, FStoredProc.Params, result) then
        	TclError(ErrorMsg);
        exit;
    end;
    if hash = hashEXECPROC then
    begin
    	FStoredProc.ExecProc;
        exit;
    end;
    if hash = hashPREPARE then
    begin
    	FStoredProc.Prepare;
        exit;
    end;
    if hash = hashUNPREPARE then
    begin
    	FStoredProc.Unprepare;
        exit;
    end;
    if hash = hashSTOREDPROCNAME then
    begin
    	if cnt > 2 then
        	TclError(ErrorMsg);
        result := FStoredProc.StoredProcName;
    	if cnt = 2 then
        	FStoredProc.StoredProcName := ParamValues[1];
        exit;
    end;
    inherited DoCommand(result, success);
end;

function TTclCmdDbProc.GetDBDataSet: TDBDataSet;
begin
	result := FStoredProc;
end;

function TTclCmdDbProc.GetTableName: string;
begin
	result := FStoredProc.StoredProcName;
//	TclError('Unsupported');
end;

function TTclCmdDbProc.GetTableType: string;
begin
	TclError('Unsupported');
end;

function TTclCmdDbProc.GetTableTypeName: PChar;
begin
  Result := nil;
end;

procedure TTclCmdDbProc.SetTableName(value: string);
begin
	FStoredProc.StoredProcName := value;
//	TclError('Unsupported');
end;

procedure TTclCmdDbProc.SetTableType(value: string);
begin
	TclError('Unsupported');
end;

const
	HashArray: pHashArray = nil;

	cCountHashValues = 63;
	_HashCount_: integer = cCountHashValues;
	cHashValues: array[0..cCountHashValues,0..1] of pChar = (
		(@_HashCount_,			''), // not counted. Used to store array size. See BdeMisc.HashCount()
    	(@hash_,				''),
        (@hashACTIVE,			'ACTIVE'),
		(@hashFIRST,			'FIRST'),
        (@hashNEXT,				'NEXT'),
        (@hashPRIOR,			'PRIOR'),
        (@hashLAST,				'LAST'),
        (@hashBOF,				'BOF'),
        (@hashEOF,				'EOF'),
        (@hashAPPEND,			'APPEND'),
 		(@hashINSERT,			'INSERT'),
        (@hashEDIT,				'EDIT'),
        (@hashPOST,				'POST'),
        (@hashCANCEL,			'CANCEL'),
        (@hashDELETE,			'DELETE'),
        (@hashREFRESH,			'REFRESH'),
        (@hashSOURCE,			'SOURCE'),
        (@hashFIELD,			'FIELD'),
        (@hashFIELDCOUNT,		'FIELDCOUNT'),
        (@hashFIELDNAME,		'FIELDNAME'),
        (@hashFIELDSIZE,		'FIELDSIZE'),
        (@hashFIELDTYPE,		'FIELDTYPE'),
        (@hashFIELDVALUE,		'FIELDVALUE'),
        (@hashVALUE,			'VALUE'),
	    (@hashNAME,				'NAME'),
    	(@hashSIZE,				'SIZE'),
	    (@hashTYPE,				'TYPE'),
        (@hashISNULL,			'ISNULL'),
        (@hashASSIGN,			'ASSIGN'),
    	(@hashDISPLAYLABEL,		'DISPLAYLABEL'),
	    (@hashDISPLAYWIDTH,		'DISPLAYWIDTH'),
        (@hashRECORDCOUNT,		'RECORDCOUNT'),
		(@hashMASTERFIELDS,		'MASTERFIELDS'),
        (@hashMASTERSOURCE,		'MASTERSOURCE'),
        (@hashINDEXNAME,		'INDEXNAME'),
        (@hashINDEXFIELDNAMES,	'INDEXFIELDNAMES'),
        (@hashINDEXFIELDCOUNT,	'INDEXFIELDCOUNT'),
        (@hashINDEXFIELDS,		'INDEXFIELDS'),
        (@hashREGENINDEXES,		'REGENINDEXES'),
        (@hashFINDKEY,			'FINDKEY'),
        (@hashFINDNEAREST,		'FINDNEAREST'),
        (@hashFREE,				'FREE'),
        (@hashTEXT,				'TEXT'),
        (@hashEXECSQL,			'EXECSQL'),
        (@hashPARAMS,			'PARAMS'),
        (@hashCOUNT,			'COUNT'),
        (@hashADD,				'ADD'),
        (@hashCREATE,			'CREATE'),
        (@hashCLEAR,			'CLEAR'),
        (@hashREMOVE,			'REMOVE'),
        (@hashINDEXOF,			'INDEXOF'),
        (@hashBYNAME,			'BYNAME'),
        (@hashPREPARE,			'PREPARE'),
        (@hashUNPREPARE,		'UNPREPARE'),
        (@hashEXECPROC,			'EXECPROC'),
        (@hashSTOREDPROCNAME,	'STOREDPROCNAME'),
        (@hashBATCHMOVE,		'BATCHMOVE'),
        (@hashCACHEDUPDATES,	'CACHEDUPDATES'),
        (@hashAPPLYUPDATES,		'APPLYUPDATES'),
        (@hashCANCELUPDATES,	'CANCELUPDATES'),
        (@hashCOMMITUPDATES,	'COMMITUPDATES'),
        (@hashREVERTRECORD,		'REVERTRECORD'),
        (@hashUPDATESTATUS,		'UPDATESTATUS'),
        (@hashEXCLUSIVE,		'EXCLUSIVE'));

initialization

    InitializeHashValues(HashArray, pHashArray(@cHashValues), True);

/////////////////////////////////////////////////////////////////////////////////////
//  Uncomment next line to check for any hash collisions within the array
	CheckHashCollisions(HashArray);

end.

