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

///////////////////////////////////////////////////////////////////////////////
//
//  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 Classes, SysUtils, Bde, Tslc, BDEClass, DBTables;

const
	cFLDDescDelta = 8;
    cIDXDescDelta = 4;
    cRINTDescDelta = 4;
    cSECDescDelta = 4;
    cVCHKDescDelta = 4;
	cOptDescDelta = 4;
    cOptDataDelta = 32;

type
	TRestructureOption = (roAll, roFields, roIndexes, roRefInt, roSecurity, roValChecks, roKeyViol, roProblems, roPack, roOptions );
    TRestructureOptions = set of TRestructureOption;
	TBoolStr = array[False..True] of string[10];

    TTclCommandBDE = class(TTclCommand)
    private
		FBoolStr: TBoolStr;
		FErrorList: TList;
        FErrorCount: integer; // Will help in faster processing...
		FProperties: TStrings;
        function GetErrorCode(index: integer): integer;
        function GetErrorMessage(index: integer): string;
        function GetErrorNativeError(index: integer): integer;
        function GetErrorSubCode(index: integer): integer;
        function GetErrorCategory(index: integer): integer;

		function GetPropertiesCount: integer;
        function GetProperties(const name: string): string;
        function GetPropertiesName(index: integer): string;
        procedure SetProperties(const name: string; value: string);

    protected
		procedure DoCommand(var result: string; var success: boolean); override;
        procedure DoException(var message: string; var ignore: boolean; E: Exception); override;

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

		procedure PropertiesClear;
        procedure PropertiesDelete(index: integer);
        function PropertiesIndexOf(const name: string): integer;

		property BoolStr: TBoolStr read FBoolStr;
        property ErrorCount: integer read FErrorCount;
        property ErrorMessage[index: integer]: string read GetErrorMessage;
        property ErrorCode[index: integer]: integer read GetErrorCode;
        property ErrorSubCode[index: integer]: integer read GetErrorSubCode;
        property ErrorCategory[index: integer]: integer read GetErrorCategory;
        property ErrorNativeError[index: integer]: integer read GetErrorNativeError;
        property Properties[const name: string]: string read GetProperties write SetProperties;
        property PropertiesCount: integer read GetPropertiesCount;
        property PropertiesName[index: integer]: string read GetPropertiesName;

    end;

	TTclCommandDesc = class(TTclCommandBDE)
	private
        FCurProps: CURProps; // Initialized in InternalOpen;
    	FFldDsc: TBDEFLDDesc;
        FIdxDsc: TBDEIDXDesc;
        FRefDsc: TBDERINTDesc;
        FSecDsc: TBDESECDesc;
        FValDsc: TBDEVCHKDesc;
        FOptDsc: TBDEOptDesc;

        FKeyViol,
        FProblems: string;

		procedure PrepareCRTblDesc(var tblDesc: CRTblDesc; ATableName, ATableType, APassword: string; flags:TRestructureOptions);
		procedure SyncFLDDesc(index: integer; var pfd: pFLDDesc); // Support routine that returns  FLDDesc for VCHKDesc.FldNum


	protected
    	procedure ActiveOrDie; // if hCursor = nil then Error()

		// Turn on Compiler Hints/Warnings to ensure that abstracts are defined in derived classes
        function GetDatabaseName: string; virtual; abstract; // Property reader
        function GetDatabaseType: string; virtual; abstract; // Property reader
        function GethCursor: hDbiCur; virtual; abstract; // Property reader. Must return nil if table closed.
        function GethDb: hDbiDb; virtual; abstract; //  Needed to get Security Descriptors. Property reader.
		function GetLanguage: string; virtual; abstract;
		function GetLocale: Pointer; virtual; abstract;
        function GetSessionName: string; virtual; abstract;
        function GetTableName: string; virtual; abstract; // Needed to get Security Descriptors. Property reader.
		function GetTableType: string; virtual; abstract; // Property reader
        procedure SetDatabaseName(value: string); virtual; abstract; // Property writer
        procedure SetDatabaseType(value: string); virtual; abstract; // Property writer
        procedure SetSessionName(value: string); virtual; abstract; // Property writer
		procedure SetTableName(name: string); virtual; abstract; // Property writer
		procedure SetTableType(value: string); virtual; abstract; // Property writer
        procedure InternalOpen; // must be called by Open to open descriptors.

	public
    	constructor Create(AOwner: TComponent); // Calls inherited and allocates descriptor buffers (nothing else.)
        destructor Destroy; override; // Calls Close and Frees descriptor buffers.
            // inherited Destroy will result in a call to your Close override.

        procedure Close; virtual; // Minimal Requirements: Close cursor and set hCursor to nil and call inherited.
        procedure Open; virtual; abstract; // Minimal Requirements: Open cursor then call InternalOpen.

        procedure Error(msg: string); // raises ETclError
		procedure CreateTable(hDb: hDbiDb; ATableName, ATableType, APassword: string; overWrite: boolean; flags: TRestructureOptions);
		procedure Restructure(hDb: hDbiDb; ATableName, ATableType, APassword, ASaveAs: string; flags: TRestructureOptions);
        procedure LoadFromFile(const fileName: string);
        procedure LoadFromStream(stream: TStream);
        procedure SaveToFile(const fileName: string);
        procedure SaveToStream(stream: TStream);

		property CurProps: CURProps read FCurProps write FCurProps;
        property DatabaseName: string read GetDatabaseName write SetDatabaseName;
        property DatabaseType: string read GetDatabaseType write SetDatabaseType;
		property hCursor: hDBICur read GethCursor;
        property hDb: hDbiDb read GethDb;
        property KeyViol: string read FKeyViol write FKeyViol; // Storage for KeyViolation Table. Can be empty string.
        	// if (roKeyViol in flags) and (KeyViol = '') then DbiRestructure will automatically create name.

		property Language: string read GetLanguage;
		property Locale: Pointer read GetLocale;
		property Problems: string read FProblems write FProblems; // Same as KeyViol except used for Problems Table.
		property SessionName: string read GetSessionName write SetSessionName;
		property TableName: string read GetTableName write SetTableName;
        property TableType: string read GetTableType write SetTableType;


		property FldDsc: TBDEFLDDesc read FFldDsc;
        property IdxDsc: TBDEIDXDesc read FIdxDsc;
        property RefDsc: TBDERINTDesc read FRefDsc;
        property SecDsc: TBDESECDesc read FSecDsc;
        property ValDsc: TBDEVCHKDesc read FValDsc;
        property OptDsc: TBDEOptDesc read FOptDsc;

	end;


implementation
uses BdeMisc, Db, TslcUtil, TslcPlat, TslcHash;

type
	TTslcDBError = class // Mostly TDBError except for overhead of Exception Object passed to constructor. TDBError won't allow nil
	private
		FErrorCode: DBIResult;
		FNativeError: Longint;
		FMessage: string;
		function GetCategory: Byte;
		function GetSubCode: Byte;
	public
		constructor Create(ErrorCode: DBIResult; NativeError: Longint; Message: string);
		property Category: Byte read GetCategory;
		property ErrorCode: DBIResult read FErrorCode;
		property SubCode: Byte read GetSubCode;
		property Message: string read FMessage;
		property NativeError: Longint read FNativeError;
	end;

constructor TTslcDBError.Create(ErrorCode: DBIResult; NativeError: Longint; Message: string);
begin
	FErrorCode := ErrorCode;
	FNativeError := NativeError;
	FMessage := Message;
end;

function TTslcDBError.GetCategory: Byte;
begin
  Result := Hi(FErrorCode);
end;

function TTslcDBError.GetSubCode: Byte;
begin
  Result := Lo(FErrorCode);
end;


function FmtStoreDBEngineError(E: EDBEngineError; var ErrorList: TList; var ErrorCount: integer): string;
	function FmtError( EBDE: TDBError): string;
    begin
		// Good place to provide more info about Error Codes
    	result := format('%s - Category: %d, ErrorCode: 0x%x, SubCode: 0x%x', [EBDE.Message, EBDE.Category, EBDE.ErrorCode, EBDE.SubCode]);
    end;
    procedure StoreError( EBDE: TDBError);
    begin
		if ErrorList = nil then
        	ErrorList := TList.Create
        else if ErrorCount = 0 then
        	ErrorList.Clear; // Cleared only when necessary. If FErrorCount is zero, then first time for this Exception
		ErrorList.Add(TTslcDBError.Create(EBDE.ErrorCode, EBDE.NativeError, EBDE.Message));
        inc(ErrorCount);
    end;
var
	x: integer;
begin
   	for x:= 0 to E.ErrorCount - 1 do
    begin
    	// store error info into properties
        StoreError(E.Errors[x]);

        // format general message
        if x = 0 then
        	result := FmtError(E.Errors[x])
        else
        	result := result + #13 + FmtError(E.Errors[x]);
    end;
end;


{~~~TTclCommandBDE~~~}

constructor TTclCommandBDE.Create(AOwner: TComponent);
begin
	inherited Create(AOwner);
	FBoolStr[False] := '0';
	FBoolStr[True] := '1';
end;

destructor TTclCommandBDE.Destroy;
begin
	inherited Destroy;
	FErrorList.Free;
    FProperties.Free;
end;

function TTclCommandBDE.GetErrorCode(index: integer): integer;
begin
	result := TTslcDBError(FErrorList.items[index]).ErrorCode;
end;

function TTclCommandBDE.GetErrorMessage(index: integer): string;
begin
	result := TTslcDBError(FErrorList.items[index]).Message;
end;

function TTclCommandBDE.GetErrorNativeError(index: integer): integer;
begin
	result := TTslcDBError(FErrorList.items[index]).NativeError;
end;

function TTclCommandBDE.GetErrorSubCode(index: integer): integer;
begin
	result := TTslcDBError(FErrorList.items[index]).SubCode;
end;

function TTclCommandBDE.GetErrorCategory(index: integer): integer;
begin
	result := TTslcDBError(FErrorList.items[index]).Category;
end;

const
	hash_			: integer = 0;
    hashBOOL		: integer = 0;
    hashERROR		: integer = 0;

    hashPROPERTIES	: integer = 0;
    hashPROPS	  	: integer = 0;
    hashVALUE		: integer = 0;
    hashNAME		: integer = 0;
    hashINDEXOF		: integer = 0;
    hashDELETE		: integer = 0;
    hashCLEAR		: integer = 0;

procedure TTclCommandBDE.DoCommand(var result: string; var success: boolean);
var
	x, cnt, hash: integer;
    b: boolean;
    list: TStrings;
begin
	cnt := ParamValuesCount;
    hash := HashValues[0];
	if hash = hashBOOL then
	begin
		if (cnt < 2) or (cnt > 3) then
			TclError(ErrorMsg);
		b := TslcStrTruth(ParamValues[1]);
		result := BoolStr[b];
		if cnt > 2 then
			FBoolStr[b] := Copy(ParamValues[2], 1, 5);
		exit;
	end;
    if hash = hashERROR then
    begin
      	if cnt = 1 then
		begin
           	for x:= 0 to FErrorCount - 1 do
               	if x = 0 then
                   	result := ErrorMessage[x]
                else
                   	result := result + #13 + ErrorMessage[x];
        end else if cnt = 2 then
        begin
           	if not TslcTextEqual(ParamValues[1], 'COUNT') then
               	TclError(ErrorMsg);
			result := inttostr(FErrorCount);
        end else if cnt = 3 then
        begin
           	x := TslcStrToInt(ParamValues[2]);
            if TslcTextEqual(ParamValues[1], 'MESSAGE') then
               	result := ErrorMessage[x]
            else if TslcTextEqual(ParamValues[1], 'CODE') then
               	result := inttostr(ErrorCode[x])
            else if TslcTextEqual(ParamValues[1], 'SUBCODE') then
               	result := inttostr(ErrorSubCode[x])
            else if TslcTextEqual(ParamValues[1], 'NATIVEERROR') then
               	result := inttostr(ErrorNativeError[x])
            else if TslcTextEqual(ParamValues[1], 'CATEGORY') then
               	result := inttostr(ErrorCategory[x])
            else
               	TclError(ErrorMsg);
        end else
           	TclError(ErrorMsg);
        exit;
    end;
    if (hash = hashPROPERTIES) or (hash = hashPROPS) then
    begin
        if cnt < 2 then
           	TclError(ErrorMsg);
        hash := HashValues[1];
		if hash = hashVALUE then
        begin
			if cnt = 3 then
				result := Properties[ParamValues[2]]
            else if cnt = 4 then
               	Properties[ParamValues[2]] := ParamValues[3]
            else
               	TclError(ErrorMsg);
            exit;
        end;
        if hash = hashNAME then
        begin
           	if cnt < 3 then
            begin
               	list := TStringList.Create;
                try
	               	for x:= 0 to PropertiesCount - 1 do
                       	list.add(PropertiesName[x]);
                    result := MergeList(list);
                finally
                   	list.free;
                end;
	 		end else if cnt = 3 then
               	result := PropertiesName[TslcStrToInt(ParamValues[2])]
            else
               	TclError(ErrorMsg);
            exit;
        end;
        if hash = hashINDEXOF then
        begin
           	if cnt <> 3 then
              	TclError(ErrorMsg);
            result := inttostr(PropertiesIndexOf(ParamValues[2]));
           	exit;
        end;
		if hash = hashDELETE then
        begin
           	if cnt <> 3 then
               	TclError(ErrorMsg);
            PropertiesDelete(TslcStrToInt(ParamValues[2]));
            exit;
        end;
        if hash = hashCLEAR then
        begin
          	PropertiesClear;
            exit;
        end;
        TclError(ErrorMsg);
    end;
	TclErrorFmt('Unknown command: %s' + #13 + '%s', [CommandLine, ErrorMsg]);
end;

procedure TTclCommandBDE.DoException(var message: string; var ignore: boolean; E: Exception);
begin
	FErrorCount := 0;
	if E is EDBEngineError then
    	message := FmtStoreDBEngineError(E as EDBEngineError, FErrorList, FErrorCount);
end;

function TTclCommandBDE.GetPropertiesCount: integer;
begin
	if FProperties = nil then
    	result := 0
    else
    	result := FProperties.Count;
end;

function TTclCommandBDE.GetProperties(const name: string): string;
begin
	if FProperties <> nil then
    	result := FProperties.values[name]
    else
    	result := '';
end;

function TTclCommandBDE.GetPropertiesName(index: integer): string;
begin
	if FProperties = nil then
    	raise EListError.Create('Index Out Of Range')
    else
    	result := FProperties.Names[index];
end;


procedure TTclCommandBDE.PropertiesClear;
begin
	if FProperties <> nil then
    	FProperties.Clear;
end;

procedure TTclCommandBDE.PropertiesDelete(index: integer);
begin
	if FProperties = nil then
    	EListError.Create('Index Out Of Range')
    else
    	FProperties.Delete(index);
end;

function TTclCommandBDE.PropertiesIndexOf(const name: string): integer;
begin
	if FProperties = nil then
    	result := -1
    else
    	FProperties.IndexOfName(name);

end;

procedure TTclCommandBDE.SetProperties(const name: string; value: string);
begin
	if FProperties = nil then
    	FProperties := TStringList.Create;
    FProperties.Values[name] := value;
end;


{~~~TTclCommandDesc~~~}
procedure TTclCommandDesc.ActiveOrDie;
begin
	if hCursor = nil then
    	Error('Cannot perform operation on closed table');
end;

constructor TTclCommandDesc.Create(AOwner: TComponent);
begin
	inherited Create(AOwner);
    FFldDsc := TBDEFLDDesc.Create(cFLDDescDelta);
    FIdxDsc := TBDEIDXDesc.Create(cIDXDescDelta);
    FRefDsc := TBDERINTDesc.Create(cRINTDescDelta);
    FSecDsc := TBDESECDesc.Create(cSECDescDelta);
    FValDsc := TBDEVCHKDesc.Create(cVCHKDescDelta);
    FValDsc.OnSyncFLDDesc := SyncFLDDesc;
    FOptDsc := TBDEOptDesc.Create(cOptDescDelta, cOptDataDelta);
end;

destructor TTclCommandDesc.Destroy;
begin
	Close;
	FFldDsc.Free;
    FIdxDsc.Free;
    FRefDsc.Free;
    FSecDsc.Free;
    FValDsc.Free;
	FOptDsc.Free;
    inherited Destroy;
end;

procedure TTclCommandDesc.Close;
begin
 	FFldDsc.Close;
    FIdxDsc.Close;
    FRefDsc.Close;
    FSecDsc.Close;
    FValDsc.Close;
    FOptDsc.Close;
end;

procedure TTclCommandDesc.Error(msg: string);
begin
	TclError(msg);
end;

procedure TTclCommandDesc.InternalOpen;
begin
	ActiveOrDie;
    Check(DbiGetCursorProps(hCursor, FCurProps));
    FFldDsc.Open(hDb, hCursor, Locale, @FCurProps);
    FIdxDsc.Open(hDb, hCursor, Locale, @FCurProps);
    FRefDsc.Open(hDb, hCursor, Locale, @FCurProps);
    FSecDsc.Open(hDb, hCursor, @FCurProps, Locale, TableName, TableType);
    FValDsc.Open(hDb, hCursor, Locale, @FCurProps);
end;

procedure TTclCommandDesc.LoadFromFile(const fileName: string);
var
	strm: TStream;
begin
	strm := TFileStream.Create(fileName, fmOpenRead);
	try
    	LoadFromStream(strm);
	finally
    	strm.Free;
	end;
end;

procedure TTclCommandDesc.LoadFromStream(stream: TStream);
const
	cError = 'Error Reading Stream';

	function ReadString: string;
    var
    	l: integer;
    begin
		if stream.Read(l, sizeof(integer)) <> sizeof(integer) then
			TclError(cError);
        SetString(Result, nil, l);
        if stream.Read(pChar(Result)^, l) <> l then
        	TclError(cError);
    end;

    procedure ReadDesc(desc: TBDEDesc);
    var
    	c, l: integer;
    begin
		if stream.Read(c, sizeof(integer)) <> sizeof(integer) then
        	TclError(cError);
		if c > 0 then
	        desc.Inflate(c);
		if stream.Read(l, sizeof(integer)) <> sizeof(integer) then
        	TclError(cError);
		if l > 0 then
			if stream.Read(desc.GetOpPointer^, l) <> l then
    	    	TclError(cError);
		if stream.Read(l, sizeof(integer)) <> sizeof(integer) then
        	TclError(cError);
        if l > 0 then
	        if stream.Read(desc.GetDescPointer^, l) <> l then
    	    	TclError(cError);
    end;

begin
	Close;

    DatabaseName := ReadString;
    DatabaseType := ReadString;
    KeyViol := ReadString;
//    Language := ReadString;
	ReadString;
    Problems := ReadString;
	TableName := ReadString;
    TableType := ReadString;

	ReadDesc(FldDsc);
    ReadDesc(IdxDsc);
    ReadDesc(RefDsc);
    ReadDesc(SecDsc);
    ReadDesc(ValDsc);
end;

procedure TTclCommandDesc.PrepareCRTblDesc(var tblDesc: CRTblDesc; ATableName, ATableType, APassword: string; flags: TRestructureOptions);
	function UpdateItem(flag: TRestructureOption; var ops: pCROpType; var desc: pointer; ADesc: TBDEDesc): integer;
    begin
		if (flag in flags) and (ADesc.Count > 0) then
        begin
        	pointer(ops) := ADesc.GetOpPointer;
            desc := ADesc.GetDescPointer;
	       	result := ADesc.Count;
        end else
        begin
        	ops := nil;
            desc := nil;
            result := 0;
        end;
    end;

begin
	FillChar( tblDesc, SizeOf(tblDesc), 0 );
	with tblDesc do
    begin
		AnsiToNative(Locale, pChar(ATableName), szTblName, DBIMAXTBLNAMELEN);
        if Trim(ATableType) <> '' then
        	AnsiToNative(Locale, pChar(Trim(ATableType)), szTblType, DBIMAXNAMELEN);
      	bProtected := Trim(APassword) <> '';
        if bProtected then
        	AnsiToNative(Locale, pChar(Trim(APassword)), szPassword, DBIMAXNAMELEN);
        bPack := roPack in flags;
		iFldCount := UpdateItem(roFields, pecrFldOp, pointer(pFldDesc), FFldDsc);
        iIdxCount := UpdateItem(roIndexes, pecrIdxOp, pointer(pIdxDesc), FIdxDsc);
        iRintCount := UpdateItem(roRefInt, pecrRintOp, pointer(pRintDesc), FRefDsc);
        iSecRecCount := UpdateItem(roSecurity, pecrSecOp, pointer(pSecDesc), FSecDsc);
        iValChkCount := UpdateItem(roValChecks, pecrValChkOp, pointer(pVchkDesc), FValDsc);
		if roOptions in flags then
        begin
	        iOptParams := FOptDsc.Count;
	        pfldOptParams := FOptDsc.GetDescPointer;
	        pOptData := FOptDsc.Data;
        end;
    end;
end;

procedure TTclCommandDesc.CreateTable(hDb: hDbiDb; ATableName, ATableType, APassword: string; overWrite: boolean; flags: TRestructureOptions);
var
	tblDesc: CRTblDesc;
begin
	PrepareCRTblDesc(tblDesc, ATableName, ATableType, APassword, flags);

    Check(DbiCreateTable(hDb, overWrite, tblDesc));
end;

procedure TTclCommandDesc.Restructure(hDb: hDbiDb; ATableName, ATableType, APassword, ASaveAs: string; flags: TRestructureOptions);
var
	tblDesc: CRTblDesc;
    KeyViolBuf, ProblemsBuf, SaveAs: DBIPATH; //array[0..DBIMAXPATHLEN] of char;
    p, k, s: pChar;
begin
	PrepareCRTblDesc(tblDesc, ATableName, ATableType, APassword, flags);

    if roKeyViol in flags then
    	k := AnsiToNative(Locale, pChar(Trim(KeyViol)), KeyViolBuf, DBIMAXPATHLEN)
    else
        k := nil;
    if roProblems in flags then
    	p := AnsiToNative(Locale, pChar(Trim(Problems)), ProblemsBuf, DBIMAXPATHLEN)
    else
    	p := nil;
    if Trim(ASaveAs) <> '' then
        s := AnsiToNative(Locale, pChar( Trim(ASaveAs)), SaveAs, DBIMAXPATHLEN)
    else
        s := nil;

	Check(DbiDoRestructure(hDb, 1, @tblDesc, s, k, p, False));

end;

procedure TTclCommandDesc.SaveToFile(const fileName: string);
var
	strm: TStream;
begin
	strm := TFileStream.Create(fileName, fmCreate);
	try
    	SaveToStream(strm);
	finally
    	strm.Free;
	end;
end;

procedure TTclCommandDesc.SaveToStream(stream: TStream);
	procedure WriteString(str: string);
    var
    	l: integer;
    begin
		l := length(str);
        stream.Write(l, sizeof(integer));
        stream.Write(pChar(str)^, l);
    end;

    procedure WriteDesc(desc: TBDEDesc);
    var
    	c, l: integer;
    begin
    	c := desc.Count;
        stream.Write(c, sizeof(integer));
		l := c * desc.GetOpSize;
		stream.Write(l, sizeof(integer));
        if l > 0 then
	    	stream.Write(desc.GetOpPointer^, l);
        l := c * desc.GetDescSize;
        stream.Write(l, sizeof(integer));
        if l > 0 then
	        stream.Write(Desc.GetDescPointer^, l);
    end;


begin
    WriteString(DatabaseName);
    WriteString(DatabaseType);
    WriteString(KeyViol);
    WriteString(Language);
    WriteString(Problems);
    WriteString(TableName);
    WriteString(TableType);

	WriteDesc(FldDsc);
    WriteDesc(IdxDsc);
    WriteDesc(RefDsc);
    WriteDesc(SecDsc);
    WriteDesc(ValDsc);

end;

procedure TTclCommandDesc.SyncFLDDesc(index: integer; var pfd: pFLDDesc);
begin
	pfd := FFldDsc.Desc[index];
end;

const
 	HashArray: pHashArray = nil;

	cCountHashValues = 10;
	_HashCount_: integer = cCountHashValues;
	cHashValues: array[0..cCountHashValues,0..1] of pChar = (
    	(@_HashCount_,		''),  // not counted. Used to store array size. See TslcHash.HashCount()
    	(@hash_,			''),
        (@hashBOOL,			'BOOL'),
        (@hashERROR,		'ERROR'),
	    (@hashPROPERTIES,	'PROPERTIES'),
    	(@hashPROPS,		'PROPS'),
		(@hashVALUE,		'VALUE'),
		(@hashNAME,			'NAME'),
		(@hashINDEXOF,		'INDEXOF'),
		(@hashDELETE,		'DELETE'),
		(@hashCLEAR,		'CLEAR'));

initialization

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

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

/////////////////////////////////////////////////////////////////////////////////////
//  Move into main program file and check for unit collisions. This can't be
//  performed in unit initialization since the other unit may not be initialized.
//
//  Uses BdeMisc, TclDbTbl, TclDbDef;
//  CheckHashCollisions2(TclDbTbl.HashArray, TclDbDef.HashArray);
//
//   - or -
//
//  Call CheckHashCollisionsAll after all units are initialized for comprehensive Collision Check
//  in HashArrays that were InitializeHashValues(..., True)
//


end.


