// CopyCat replication suite<p/>

// Copyright (c) 2014 Microtec Communications. For any questions or technical

// support, contact us at [email protected]<p/>

// <p/>

// Based on the RxMemDS unit from the Rx library<p/>

// <p/>

// The original Rx code is Copyright (c) 2001,2002 SGB Software Copyright (c) 1997,

// 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev

unit CcMemDS;

{$I CC.INC}

interface

{$IFNDEF NEXTGEN}

uses

{$IFDEF MSWINDOWS} Windows, {$ENDIF}

SysUtils, Classes, CcProviders, DB{$IFDEF CC_UseVariants}, Variants{$ENDIF}

{$IFDEF CC_D6}, SqlTimSt {$ENDIF};

{ TCcMemoryData }

type

TLoadMode = (lmCopy, lmAppend);

{$IFNDEF CC_D6}

PByte = ^Byte;

{$ENDIF}

{ TCcWideStringField = class (TWideStringField)

end; }

TMemBlobData = ansistring;

TMemBlobArray = array [0 .. 0] of TMemBlobData;

PMemBlobArray = ^TMemBlobArray;

TMemoryRecord = class;

TCompareRecords = function(Item1, Item2: TMemoryRecord): Integer of object;

{$IFDEF UNICODE}

PCcMemBuffer = TRecordBuffer;

{$ELSE}

PCcMemBuffer = PChar;

{$ENDIF UNICODE}

{$IFDEF CC_D2K6}

TCcWideMemoField = class(TWideMemoField)

protected

function GetIsNull: Boolean; override;

function GetAsVariant: Variant; override;

procedure SetVarValue(const Value: Variant); override;

end;

{$ENDIF}

TCcMemoField = class(TMemoField)

protected

function GetIsNull: Boolean; override;

procedure SetVarValue(const Value: Variant); override;

public

function GetAsVariant: Variant; override;

end;

// Summary:

// In-memory TDataSet descendant.

// Description:

// TCcInternalMemoryData is based on the RxLib TRxMemoryData component.

TCcInternalMemoryData = class(TDataSet)

private

FRecordPos: Integer;

FRecordSize: Integer;

FBookmarkOfs: Integer;

FBlobOfs: Integer;

FRecBufSize: Integer;

FOffsets: PWordArray;

FLastID: Integer;

FAutoInc: Longint;

FActive: Boolean;

FRecords: TList;

FIndexList: TList;

FCaseInsensitiveSort: Boolean;

FDescendingSort: Boolean;

function AddRecord: TMemoryRecord;

function InsertRecord(Index: Integer): TMemoryRecord;

function FindRecordID(ID: Integer): TMemoryRecord;

procedure CreateIndexList(const FieldNames: string);

procedure FreeIndexList;

procedure QuickSort(L, R: Integer; Compare: TCompareRecords);

procedure Sort;

function CalcRecordSize: Integer;

function FindFieldData(Buffer: Pointer; Field: TField): Pointer;

function GetMemoryRecord(Index: Integer): TMemoryRecord;

function GetCapacity: Integer;

function RecordFilter: Boolean;

procedure SetCapacity(Value: Integer);

procedure ClearRecords;

procedure InitBufferPointers(GetProps: Boolean);

protected

function GetFieldClass(FieldType: TFieldType): TFieldClass; override;

procedure AssignMemoryRecord(Rec: TMemoryRecord; Buffer: PCcMemBuffer);

function GetActiveRecBuf(var RecBuf: PCcMemBuffer): Boolean; virtual;

procedure InitFieldDefsFromFields;

procedure RecordToBuffer(Rec: TMemoryRecord; Buffer: PCcMemBuffer);

procedure SetMemoryRecordData(Buffer: PCcMemBuffer; Pos: Integer); virtual;

procedure SetAutoIncFields(Buffer: PCcMemBuffer); virtual;

function CompareRecords(Item1, Item2: TMemoryRecord): Integer; virtual;

function GetBlobData(Field: TField; Buffer: PCcMemBuffer): TMemBlobData;

procedure SetBlobData(Field: TField; Buffer: PCcMemBuffer; Value: TMemBlobData);

function AllocRecordBuffer: PCcMemBuffer; override;

procedure FreeRecordBuffer(var Buffer: PCcMemBuffer); override;

procedure InternalInitRecord(Buffer: PCcMemBuffer); override;

procedure ClearCalcFields(Buffer: PCcMemBuffer); override;

function GetRecord(Buffer: PCcMemBuffer; GetMode: TGetMode;

DoCheck: Boolean): TGetResult; override;

function GetRecordSize: Word; override;

procedure SetFiltered(Value: Boolean); override;

procedure SetOnFilterRecord(const Value: TFilterRecordEvent); override;

procedure SetFieldData(Field: TField; Buffer: Pointer); override;

{$IFDEF CC_D2K13}

procedure SetFieldData(Field: TField; Buffer: TValueBuffer); overload; override;

{$ENDIF}

procedure CloseBlob(Field: TField); override;

procedure GetBookmarkData(Buffer: PCcMemBuffer; Data: Pointer); override;

function GetBookmarkFlag(Buffer: PCcMemBuffer): TBookmarkFlag; override;

{$IFDEF UNICODE}

procedure InternalGotoBookmark(Bookmark: Pointer); override;

{$ELSE}

procedure InternalGotoBookmark(Bookmark: TBookmark); override;

{$ENDIF}

procedure InternalSetToRecord(Buffer: PCcMemBuffer); override;

procedure SetBookmarkFlag(Buffer: PCcMemBuffer; Value: TBookmarkFlag); override;

procedure SetBookmarkData(Buffer: PCcMemBuffer; Data: Pointer); override;

function GetIsIndexField(Field: TField): Boolean; override;

procedure InternalFirst; override;

procedure InternalLast; override;

procedure InitRecord(Buffer: PCcMemBuffer); override;

procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;

procedure InternalDelete; override;

procedure InternalPost; override;

procedure InternalClose; override;

procedure InternalHandleException; override;

procedure InternalInitFieldDefs; override;

procedure InternalOpen; override;

procedure OpenCursor(InfoQuery: Boolean); override;

function IsCursorOpen: Boolean; override;

function GetRecordCount: Integer; override;

function GetRecNo: Integer; override;

procedure SetRecNo(Value: Integer); override;

property Records[index: Integer]: TMemoryRecord read GetMemoryRecord;

procedure DataConvert(Field: TField; Source, Dest: Pointer; ToNative: Boolean); override;

{$IFDEF CC_DXE6}

procedure DataConvert(Field: TField; Source: TValueBuffer; var Dest: TValueBuffer; ToNative: Boolean); override;

{$ENDIF}

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

function BookmarkValid(Bookmark: TBookmark): Boolean; override;

function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override;

function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;

function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;

{$IFDEF CC_D2K13}

function GetFieldData(Field: TField; {$IFDEF CC_D2K14}var {$ENDIF}Buffer: TValueBuffer): Boolean; overload; override;

{$ENDIF}

function GetCurrentRecord(Buffer: PCcMemBuffer): Boolean; override;

function IsSequenced: Boolean; override;

function Locate(const KeyFields: string; const KeyValues: Variant;

Options: TLocateOptions): Boolean; override;

procedure SortOnFields(const FieldNames: string;

CaseInsensitive: Boolean = True; Descending: Boolean = False);

procedure EmptyTable;

function SaveToDataSet(Dest: TDataSet; RecordCount: Integer): Integer;

property Capacity: Integer read GetCapacity write SetCapacity default 0;

property Active;

published

property BeforeOpen;

property AfterOpen;

property BeforeClose;

property AfterClose;

property BeforeInsert;

property AfterInsert;

property BeforeEdit;

property AfterEdit;

property BeforePost;

property AfterPost;

property BeforeCancel;

property AfterCancel;

property BeforeDelete;

property AfterDelete;

property BeforeScroll;

property AfterScroll;

property OnCalcFields;

property OnDeleteError;

property OnEditError;

property OnFilterRecord;

property OnNewRecord;

property OnPostError;

end;

//Summary:

//In-memory TDataSet descendant.

//Description:

//TCcMemoryData is an in-memory TDataSet descendant, used as an ancestor for

//TCcDataSet.

TCcMemoryData = class(TCcInternalMemoryData)

private

lFirst: Boolean;

procedure CreateDataSetFields;

procedure EmptyAndClose;

procedure CopyStructure(Source: TCCQuery); overload;

procedure CopyStructure(Source: TDataSet); overload;

protected

FAutoCreateFieldDefs: Boolean;

procedure DoBeforeClose; override;

procedure DoBeforeOpen; override;

procedure OpenCursor(InfoQuery: Boolean); override;

public

constructor Create(AOwner: TComponent); override;

procedure SortRows(const FieldNames: string; CaseInsensitive: Boolean);

function LoadFromDataSet(Source: TCCQuery; lTrimCharFields,

lCopyStructure: Boolean; lEmptyStringsToNull: Boolean): Integer; overload;

function LoadFromDataSet(Source: TCCQuery): Integer; overload;

function LoadFromDataSet(Source: TDataSet; RecordCount: Integer; Mode: TLoadMode): Integer; overload;

procedure AddField(Name: string; DataType: TFieldType; Size: Integer);

end;

TMemBlobStream = class(TStream)

private

FField: TBlobField;

FDataSet: TCcInternalMemoryData;

FBuffer: PCcMemBuffer;

FMode: TBlobStreamMode;

FOpened: Boolean;

FModified: Boolean;

FPosition: Longint;

FCached: Boolean;

function GetBlobSize: Longint;

function GetBlobFromRecord(Field: TField): TMemBlobData;

public

constructor Create(Field: TBlobField; Mode: TBlobStreamMode);

destructor Destroy; override;

function Read(var Buffer; Count: Longint): Longint; override;

{$IFDEF CC_D2K13}

function Write(const Buffer: TBytes; Offset, Count: Longint): Longint; overload; override;

{$ENDIF}

function Write(const Buffer; Count: Longint): Longint; override;

{$IFDEF CC_D2K12}

function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;

{$ENDIF}

function Seek(Offset: Longint; Origin: Word): Longint; override;

procedure Truncate;

end;

TMemoryRecord = class(TPersistent)

private

FMemoryData: TCcInternalMemoryData;

FID: Integer;

FData: Pointer;

FBlobs: Pointer;

function GetIndex: Integer;

procedure SetMemoryData(Value: TCcInternalMemoryData; UpdateParent: Boolean);

protected

procedure SetIndex(Value: Integer); virtual;

public

constructor Create(MemoryData: TCcInternalMemoryData); virtual;

constructor CreateEx(MemoryData: TCcInternalMemoryData; UpdateParent: Boolean); virtual;

destructor Destroy; override;

property MemoryData: TCcInternalMemoryData read FMemoryData;

property ID: Integer read FID write FID;

property index: Integer read GetIndex write SetIndex;

property Data: Pointer read FData;

end;

{$IFDEF WIN32}

function DataSetLocateThrough(DataSet: TDataSet; const KeyFields: string;

const KeyValues: Variant; Options: TLocateOptions): Boolean;

{$ENDIF}

procedure RxAssignRecord(Source, Dest: TDataSet; ByName: Boolean);

procedure _DBError(const Msg: string);

function Min(A, B: Longint): Longint;

{$ENDIF}

implementation

{$IFNDEF NEXTGEN}

uses

DbConsts, {$IFDEF CC_D2K14}VCL.Forms{$ELSE} Forms{$ENDIF}, ComObj;

resourcestring

SMemNoRecords = 'No data found';

const

ftBlobTypes = [ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftParadoxOle,

ftDBaseOle, ftTypedBinary, ftOraBlob, ftOraClob

{$IFDEF CC_D2K6}, ftWideMemo{$ENDIF}];

ftSupported = [ftString, ftSmallint, ftInteger, ftWord, ftBoolean,

ftFloat, ftCurrency, ftDate, ftTime, ftDateTime, ftAutoInc, ftBCD,

{$IFDEF CC_D6}

ftTimestamp, ftFMTBcd,

{$ENDIF}

{$IFDEF CC_D2K6}

ftOraInterval, ftFixedWideChar,

{$ENDIF}

{$IFDEF CC_D2K9}

ftLongWord,

{$ENDIF}

{$IFDEF CC_D2K13}

ftSingle,

{$ENDIF}

ftDataSet, ftBytes, ftVarBytes, ftADT, ftFixedChar, ftWideString, ftLargeint,

ftVariant, ftGuid] + ftBlobTypes;

fkStoredFields = [fkData];

GuidSize = 38;

{ Utility routines }

procedure RxAssignRecord(Source, Dest: TDataSet; ByName: Boolean);

var

I: Integer;

F, FSrc: TField;

begin

if not(Dest.State in dsEditModes) then

_DBError(SNotEditing);

if ByName then

begin

for I := 0 to Source.FieldCount - 1 do

begin

F := Dest.FindField(Source.Fields[I].FieldName);

if F <> nil then

begin

{$IFDEF WIN32}

F.Value := Source.Fields[I].Value;

{$ELSE}

if (F.DataType = Source.Fields[I].DataType) and

(F.DataSize = Source.Fields[I].DataSize) then

F.Assign(Source.Fields[I])

else

F.AsString := Source.Fields[I].AsString;

{$ENDIF}

end;

end;

end

else

begin

for I := 0 to Min(Source.FieldDefs.Count - 1, Dest.FieldDefs.Count - 1) do

begin

F := Dest.FindField(Dest.FieldDefs[I].Name);

FSrc := Source.FindField(Source.FieldDefs[I].Name);

if (F <> nil) and (FSrc <> nil) then

begin

{$IFDEF WIN32}

F.Value := FSrc.Value;

{$ELSE}

if F.DataType = FSrc.DataType then

F.Assign(FSrc)

else

F.AsString := FSrc.AsString;

{$ENDIF}

end;

end;

end;

end;

procedure _DBError(const Msg: string);

begin

DatabaseError(Msg);

end;

{$IFDEF WIN32}

function DataSetLocateThrough(DataSet: TDataSet; const KeyFields: string;

const KeyValues: Variant; Options: TLocateOptions): Boolean;

var

FieldCount: Integer;

Fields: TList;

{$IFDEF UNICODE}

Bookmark: TBytes;

{$ELSE}

Bookmark: TBookmarkStr;

{$ENDIF}

function CompareField(Field: TField; Value: Variant): Boolean;

var

S: string;

begin

if Field.DataType = ftString then

begin

S := Field.AsString;

if (loPartialKey in Options) then

Delete(S, Length(Value) + 1, MaxInt);

if (loCaseInsensitive in Options) then

Result := AnsiCompareText(S, Value) = 0

else

Result := AnsiCompareStr(S, Value) = 0;

end

else

Result := (Field.Value = Value);

end;

function CompareRecord: Boolean;

var

I: Integer;

begin

if FieldCount = 1 then

Result := CompareField(TField(Fields.First), KeyValues)

else

begin

Result := True;

for I := 0 to FieldCount - 1 do

Result := Result and CompareField(TField(Fields[I]), KeyValues[I]);

end;

end;

begin

Result := False;

with DataSet do

begin

CheckBrowseMode;

if BOF and EOF then

Exit;

end;

Fields := TList.Create;

try

DataSet.GetFieldList(Fields, KeyFields);

FieldCount := Fields.Count;

Result := CompareRecord;

if Result then

Exit;

DataSet.DisableControls;

try

Bookmark := DataSet.Bookmark;

try

with DataSet do

begin

First;

while not EOF do

begin

Result := CompareRecord;

if Result then

Break;

Next;

end;

end;

finally

{$IFDEF UNICODE}

if not Result and

DataSet.BookmarkValid(Bookmark) then

DataSet.Bookmark := Bookmark;

{$ELSE}

if not Result and

DataSet.BookmarkValid(PChar(Bookmark)) then

DataSet.Bookmark := Bookmark;

{$ENDIF}

end;

finally

DataSet.EnableControls;

end;

finally

Fields.Free;

end;

end;

{$ENDIF}

function CompareFields(Data1, Data2: Pointer; FieldType: TFieldType;

CaseInsensitive: Boolean): Integer;

begin

Result := 0;

case FieldType of

ftString:

if CaseInsensitive then

Result := AnsiCompareText(PChar(Data1), PChar(Data2))

else

Result := AnsiCompareStr(PChar(Data1), PChar(Data2));

ftSmallint:

if SmallInt(Data1^) > SmallInt(Data2^) then

Result := 1

else if SmallInt(Data1^) < SmallInt(Data2^) then

Result := -1;

ftInteger, ftDate, ftTime, ftAutoInc:

if Longint(Data1^) > Longint(Data2^) then

Result := 1

else if Longint(Data1^) < Longint(Data2^) then

Result := -1;

ftWord:

if Word(Data1^) > Word(Data2^) then

Result := 1

else if Word(Data1^) < Word(Data2^) then

Result := -1;

ftBoolean:

if WordBool(Data1^) and not WordBool(Data2^) then

Result := 1

else if not WordBool(Data1^) and WordBool(Data2^) then

Result := -1;

ftFloat, ftCurrency:

if Double(Data1^) > Double(Data2^) then

Result := 1

else if Double(Data1^) < Double(Data2^) then

Result := -1;

ftDateTime:

if TDateTime(Data1^) > TDateTime(Data2^) then

Result := 1

else if TDateTime(Data1^) < TDateTime(Data2^) then

Result := -1;

{$IFDEF CC_D6}

ftTimestamp:

if SQLTimeStampToDateTime(TSQLTimeStamp(Data1^)) > SQLTimeStampToDateTime(TSQLTimeStamp(Data2^)) then

Result := 1

else if SQLTimeStampToDateTime(TSQLTimeStamp(Data1^)) < SQLTimeStampToDateTime(TSQLTimeStamp(Data2^)) then

Result := -1;

{$ENDIF}

ftFixedChar:

if CaseInsensitive then

Result := AnsiCompareText(PChar(Data1), PChar(Data2))

else

Result := AnsiCompareStr(PChar(Data1), PChar(Data2));

ftWideString:

if CaseInsensitive then

Result := AnsiCompareText(WideCharToString(PWideChar(Data1)),

WideCharToString(PWideChar(Data2)))

else

Result := AnsiCompareStr(WideCharToString(PWideChar(Data1)),

WideCharToString(PWideChar(Data2)));

ftLargeint:

if Int64(Data1^) > Int64(Data2^) then

Result := 1

else if Int64(Data1^) < Int64(Data2^) then

Result := -1;

ftVariant:

Result := 0;

ftGuid:

Result := AnsiCompareText(PChar(Data1), PChar(Data2));

end;

end;

function CalcFieldLen(FieldType: TFieldType; Size: Word): Word;

begin

if not(FieldType in ftSupported) then

Result := 0

else

if FieldType in ftBlobTypes then

Result := SizeOf(Longint)

else

begin

Result := Size;

case FieldType of

ftString:

Inc(Result);

ftSmallint:

Result := SizeOf(SmallInt);

ftInteger:

Result := SizeOf(Longint);

ftWord:

Result := SizeOf(Word);

{$IFDEF CC_D2K6}

ftOraInterval:

Inc(Result);

{$ENDIF}

{$IFDEF CC_D2K13}

ftSingle:

Result := SizeOf(single);

{$ENDIF}

{$IFDEF CC_D2K9}

ftLongWord:

Result := SizeOf(LongWord);

{$ENDIF}

ftBoolean:

Result := SizeOf(WordBool);

ftFloat:

Result := SizeOf(Double);

ftCurrency:

Result := SizeOf(Double);

ftBCD:

Result := 34;

{$IFDEF CC_D6}

ftFMTBcd:

Result := 34;

{$ENDIF}

ftDate, ftTime:

Result := SizeOf(Longint);

ftDateTime:

Result := SizeOf(TDateTime);

{$IFDEF CC_D6}

ftTimestamp:

Result := SizeOf(TSQLTimeStamp);

{$ENDIF}

ftBytes:

Result := Size;

ftVarBytes:

Result := Size + 2;

ftAutoInc:

Result := SizeOf(Longint);

ftADT:

Result := 0;

ftFixedChar:

Inc(Result);

ftWideString:

Result := (Result + 1) * SizeOf(WideChar);

ftLargeint:

Result := SizeOf(Int64);

ftVariant:

Result := SizeOf(Variant);

ftGuid:

Result := GuidSize + 1;

end;

end;

end;

procedure CalcDataSize(FieldDef: TFieldDef; var DataSize: Integer);

var

I: Integer;

begin

with FieldDef do

begin

if DataType in ftSupported - ftBlobTypes then

Inc(DataSize, CalcFieldLen(DataType, Size) + 1);

for I := 0 to ChildDefs.Count - 1 do

CalcDataSize(ChildDefs[I], DataSize);

end;

end;

procedure Error(const Msg: string);

begin

DatabaseError(Msg);

end;

procedure ErrorFmt(const Msg: string; const Args: array of const);

begin

DatabaseErrorFmt(Msg, Args);

end;

type

TBookmarkData = Integer;

PMemBookmarkInfo = ^TMemBookmarkInfo;

TMemBookmarkInfo = record

BookmarkData: TBookmarkData;

BookmarkFlag: TBookmarkFlag;

end;

{ TMemoryRecord }

constructor TMemoryRecord.Create(MemoryData: TCcInternalMemoryData);

begin

CreateEx(MemoryData, True);

end;

constructor TMemoryRecord.CreateEx(MemoryData: TCcInternalMemoryData; UpdateParent: Boolean);

begin

inherited Create;

SetMemoryData(MemoryData, UpdateParent);

end;

destructor TMemoryRecord.Destroy;

begin

SetMemoryData(nil, True);

inherited Destroy;

end;

function TMemoryRecord.GetIndex: Integer;

begin

if FMemoryData <> nil then

Result := FMemoryData.FRecords.IndexOf(Self)

else

Result := -1;

end;

procedure TMemoryRecord.SetMemoryData(Value: TCcInternalMemoryData; UpdateParent: Boolean);

var

I: Integer;

DataSize: Integer;

begin

if FMemoryData <> Value then

begin

if FMemoryData <> nil then

begin

FMemoryData.FRecords.Remove(Self);

if FMemoryData.BlobFieldCount > 0 then

Finalize(PMemBlobArray(FBlobs)[0], FMemoryData.BlobFieldCount);

ReallocMem(FBlobs, 0);

ReallocMem(FData, 0);

FMemoryData := nil;

end;

if Value <> nil then

begin

if UpdateParent then

begin

Value.FRecords.Add(Self);

Inc(Value.FLastID);

FID := Value.FLastID;

end;

FMemoryData := Value;

if Value.BlobFieldCount > 0 then

begin

ReallocMem(FBlobs, Value.BlobFieldCount * SizeOf(Pointer));

Initialize(PMemBlobArray(FBlobs)[0], Value.BlobFieldCount);

end;

DataSize := 0;

for I := 0 to Value.FieldDefs.Count - 1 do

CalcDataSize(Value.FieldDefs[I], DataSize);

ReallocMem(FData, DataSize);

end;

end;

end;

procedure TMemoryRecord.SetIndex(Value: Integer);

var

CurIndex: Integer;

begin

CurIndex := GetIndex;

if (CurIndex >= 0) and (CurIndex <> Value) then

FMemoryData.FRecords.Move(CurIndex, Value);

end;

{ TCcInternalMemoryData }

constructor TCcInternalMemoryData.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FRecordPos := -1;

FLastID := low(Integer);

FAutoInc := 1;

FRecords := TList.Create;

end;

destructor TCcInternalMemoryData.Destroy;

begin

inherited Destroy;

FreeIndexList;

ClearRecords;

FRecords.Free;

ReallocMem(FOffsets, 0);

end;

{ Records Management }

function TCcInternalMemoryData.GetCapacity: Integer;

begin

if FRecords <> nil then

Result := FRecords.Capacity

else

Result := 0;

end;

procedure TCcInternalMemoryData.SetCapacity(Value: Integer);

begin

if FRecords <> nil then

FRecords.Capacity := Value;

end;

function TCcInternalMemoryData.AddRecord: TMemoryRecord;

begin

Result := TMemoryRecord.Create(Self);

end;

function TCcInternalMemoryData.FindRecordID(ID: Integer): TMemoryRecord;

var

I: Integer;

begin

for I := 0 to FRecords.Count - 1 do

begin

Result := TMemoryRecord(FRecords[I]);

if Result.ID = ID then

Exit;

end;

Result := nil;

end;

function TCcInternalMemoryData.InsertRecord(Index: Integer): TMemoryRecord;

begin

Result := AddRecord;

Result.Index := index;

end;

function TCcInternalMemoryData.GetMemoryRecord(Index: Integer): TMemoryRecord;

begin

Result := TMemoryRecord(FRecords[index]);

end;

{ Field Management }

procedure TCcInternalMemoryData.InitFieldDefsFromFields;

var

I: Integer;

Offset: Word;

begin

if FieldDefs.Count = 0 then

begin

for I := 0 to FieldCount - 1 do

begin

with Fields[I] do

if (FieldKind in fkStoredFields) and not(DataType in ftSupported) then

ErrorFmt(SUnknownFieldType, [DisplayName]);

end;

FreeIndexList;

end;

Offset := 0;

inherited InitFieldDefsFromFields;

{ Calculate fields offsets }

ReallocMem(FOffsets, FieldDefList.Count * SizeOf(Word));

for I := 0 to FieldDefList.Count - 1 do

begin

FOffsets^[I] := Offset;

with FieldDefList[I] do

if (DataType in ftSupported - ftBlobTypes) then

Inc(Offset, CalcFieldLen(DataType, Size) + 1);

end;

end;

function TCcInternalMemoryData.FindFieldData(Buffer: Pointer; Field: TField): Pointer;

var

Index: Integer;

DataType: TFieldType;

begin

Result := nil;

index := FieldDefList.IndexOf(Field.FullName);

if (index >= 0) and (Buffer <> nil) then

begin

DataType := FieldDefList[index].DataType;

if DataType in ftSupported then

if DataType in ftBlobTypes then

Result := Pointer(GetBlobData(Field, Buffer))

else

Result := (PCcMemBuffer(Buffer) + FOffsets[index]);

end;

end;

{ Buffer Manipulation }

function TCcInternalMemoryData.CalcRecordSize: Integer;

var

I: Integer;

begin

Result := 0;

for I := 0 to FieldDefs.Count - 1 do

CalcDataSize(FieldDefs[I], Result);

end;

procedure TCcInternalMemoryData.InitBufferPointers(GetProps: Boolean);

begin

if GetProps then

FRecordSize := CalcRecordSize;

FBookmarkOfs := FRecordSize + CalcFieldsSize;

FBlobOfs := FBookmarkOfs + SizeOf(TMemBookmarkInfo);

FRecBufSize := FBlobOfs + BlobFieldCount * SizeOf(Pointer);

end;

procedure TCcInternalMemoryData.ClearRecords;

begin

while FRecords.Count > 0 do

TObject(FRecords.Last).Free;

FLastID := low(Integer);

FRecordPos := -1;

end;

function WideStrLen(AStr: PWideChar): Integer;

begin

Result := 0;

while (PChar(AStr)^ <> #0) or ((PChar(AStr) + 1)^ <> #0) do

begin

Inc(Result);

AStr := PWideChar(PAnsiChar(AStr) + 2);

end;

end;

{$IFDEF CC_DXE6}

procedure TCcInternalMemoryData.DataConvert(Field: TField; Source: TValueBuffer; var Dest: TValueBuffer; ToNative: Boolean);

begin

{ if (Field.DataType = ftWideString) or (Field.DataType = ftFixedWideChar) then

StrLCopy(PChar(Dest), PChar(Source), WideStrLen(PWideChar(Source)))

else }

inherited DataConvert(Field, Source, Dest, ToNative);

end;

{$ENDIF}

procedure TCcInternalMemoryData.DataConvert(Field: TField; Source, Dest: Pointer; ToNative: Boolean);

{$IFNDEF CC_D2K6}

var

L: Integer;

p: PChar;

{$ENDIF}

begin

if (Field.DataType = ftWideString) {$IFDEF CC_D2K6} or (Field.DataType = ftFixedWideChar){$ENDIF} then

{$IFNDEF CC_D2K6}

if Field.FieldKind in [fkCalculated, fkLookup] then

PLongWord(Dest)^ := PLongWord(Source)^

else if ToNative then

begin

L := Length(WideString(Source^)) * SizeOf(WideChar);

Move(WideString(Source^)[1], PWideChar(Dest)^, L);

p := PChar(Dest) + L;

p^ := #0;

(p + 1)^ := #0;

end

else

SetString(WideString(Dest^), PWideChar(Source), WideStrLen(PWideChar(Source)))

{$ELSE}

{$IFDEF CC_DXE6}

StrLCopy(PChar(Dest), PChar(Source), WideStrLen(PWideChar(Source)))

{$ELSE}

inherited DataConvert(Field, Source, Dest, ToNative)

{$ENDIF}

{$ENDIF}

else

inherited DataConvert(Field, Source, Dest, ToNative);

end;

function TCcInternalMemoryData.AllocRecordBuffer: PCcMemBuffer;

begin

{$IFDEF CC_D2K9}

GetMem(Result, FRecBufSize);

{$ELSE}

Result := StrAlloc(FRecBufSize);

{$ENDIF CC_D2K9}

if BlobFieldCount > 0 then

Initialize(PMemBlobArray(Result + FBlobOfs)[0], BlobFieldCount);

end;

procedure TCcInternalMemoryData.FreeRecordBuffer(var Buffer: PCcMemBuffer);

begin

if BlobFieldCount > 0 then

Finalize(PMemBlobArray(Buffer + FBlobOfs)[0], BlobFieldCount);

{$IFDEF CC_D2K9}

FreeMem(Buffer);

{$ELSE}

StrDispose(Buffer);

{$ENDIF CC_D2K9}

Buffer := nil;

end;

procedure TCcInternalMemoryData.ClearCalcFields(Buffer: PCcMemBuffer);

begin

FillChar(Buffer[FRecordSize], CalcFieldsSize, 0);

end;

procedure TCcInternalMemoryData.InternalInitRecord(Buffer: PCcMemBuffer);

var

I: Integer;

begin

FillChar(Buffer^, FBlobOfs, 0);

for I := 0 to BlobFieldCount - 1 do

PMemBlobArray(Buffer + FBlobOfs)[I] := '';

end;

procedure TCcInternalMemoryData.InitRecord(Buffer: PCcMemBuffer);

begin

inherited InitRecord(Buffer);

with PMemBookmarkInfo(Buffer + FBookmarkOfs)^ do

begin

BookmarkData := low(Integer);

BookmarkFlag := bfInserted;

end;

end;

function TCcInternalMemoryData.GetCurrentRecord(Buffer: PCcMemBuffer): Boolean;

begin

Result := False;

if not IsEmpty and (GetBookmarkFlag(ActiveBuffer) = bfCurrent) then

begin

UpdateCursorPos;

if (FRecordPos >= 0) and (FRecordPos < RecordCount) then

begin

Move(Records[FRecordPos].Data^, Buffer^, FRecordSize);

Result := True;

end;

end;

end;

procedure TCcInternalMemoryData.RecordToBuffer(Rec: TMemoryRecord; Buffer: PCcMemBuffer);

var

I: Integer;

begin

Move(Rec.Data^, Buffer^, FRecordSize);

with PMemBookmarkInfo(Buffer + FBookmarkOfs)^ do

begin

BookmarkData := Rec.ID;

BookmarkFlag := bfCurrent;

end;

for I := 0 to BlobFieldCount - 1 do

PMemBlobArray(Buffer + FBlobOfs)[I] := PMemBlobArray(Rec.FBlobs)[I];

GetCalcFields(Buffer);

end;

function TCcInternalMemoryData.GetRecord(Buffer: PCcMemBuffer; GetMode: TGetMode;

DoCheck: Boolean): TGetResult;

var

Accept: Boolean;