{ rxmemds unit Copyright (C) 2005-2017 Lagunov Aleksey alexs75@yandex.ru and Lazarus team original conception from rx library for Delphi (c) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version with the following modification: As a special exception, the copyright holders of this library give you permission to link this library with independent modules to produce an executable, regardless of the license terms of these independent modules,and to copy and distribute the resulting executable under terms of your choice, provided that you also meet, for each linked independent module, the terms and conditions of the license of that module. An independent module is a module which is not derived from or based on this library. If you modify this library, you may extend this exception to your version of the library, but you are not obligated to do so. If you do not wish to do so, delete this exception statement from your version. This program 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 Library General Public License for more details. You should have received a copy of the GNU Library 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. } unit rxmemds; {$I rx.inc} interface uses SysUtils, Classes, DB, ex_rx_datapacket, bufdataset_parser; { TRxMemoryData } type TMemBlobData = string; TMemBlobArray = array[0..256] of TMemBlobData; PMemBlobArray = ^TMemBlobArray; TMemoryRecord = class; TLoadMode = (lmCopy, lmAppend); TCompareRecords = function (Item1, Item2: TMemoryRecord): Integer of object; TRxMemoryData = 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; FFileName: string; FFileStream : TFileStream; FDatasetReader : TRxDataPacketReader; FPacketRecords: Integer; FFilterBuffer : pchar; FNullmaskSize : byte; FBRecordCount : integer; FParser : TBufDatasetParser; function IntAllocRecordBuffer: PChar; procedure IntLoadFielddefsFromFile; procedure IntLoadRecordsFromFile; procedure SetPacketRecords(const AValue: Integer); function AddRecord: TMemoryRecord; procedure CopyRecord(RecordData, Buffer: PChar); 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;overload; function FindFieldData(Buffer: Pointer; FieldNo:Integer): Pointer;overload; function GetMemoryRecord(Index: Integer): TMemoryRecord; function GetCapacity: Integer; function RecordFilter: Boolean; procedure SetCapacity(Value: Integer); procedure ClearRecords; procedure InitBufferPointers(GetProps: Boolean); procedure ParseFilter(const AFilter: string); protected procedure AssignMemoryRecord(Rec: TMemoryRecord; Buffer: PChar); function GetActiveRecBuf(var RecBuf: PChar): Boolean; virtual; procedure InitFieldDefsFromFields; procedure RecordToBuffer(Rec: TMemoryRecord; Buffer: PChar); procedure SetMemoryRecordData(Buffer: PChar; Pos: Integer); virtual; procedure SetAutoIncFields(Buffer: PChar); virtual; function CompareRecords(Item1, Item2: TMemoryRecord): Integer; virtual; function GetBlobData(Field: TField; Buffer: PChar): TMemBlobData; procedure SetBlobData(Field: TField; Buffer: PChar; Value: TMemBlobData); function AllocRecordBuffer: PChar; override; procedure FreeRecordBuffer(var Buffer: PChar); override; function BCDToCurr(BCD: Pointer; var Curr: Currency): Boolean; function CurrToBCD(const Curr: Currency; BCD: Pointer; Precision, Decimals: Integer): Boolean; procedure InternalInitRecord(Buffer: PChar); override; procedure ClearCalcFields(Buffer: PChar); override; function GetRecord(Buffer: PChar; 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; procedure CloseBlob(Field: TField); override; procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override; function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override; {$IFDEF NoAutomatedBookmark} procedure InternalGotoBookmark(ABookmark: TBookmark); override; {$ELSE} procedure InternalGotoBookmark(ABookmark: Pointer); override; {$ENDIF} procedure InternalSetToRecord(Buffer: PChar); override; procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override; procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override; function GetIsIndexField(Field: TField): Boolean; override; procedure InternalFirst; override; procedure InternalLast; override; procedure InitRecord(Buffer: PChar); override; procedure InternalAddRecord(Buffer: Pointer; DoAppend: 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; function GetAnyRecField(SrcRecNo:integer; AField:TField):variant; procedure SetFilterText(const Value: String); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function BookmarkValid(ABookmark: 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; function GetCurrentRecord(Buffer: PChar): 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 SortOnFieldsEx(const FieldNames: string; CaseInsensitive: Boolean = True; Asc: array of boolean); procedure EmptyTable; procedure CloseOpen; procedure CopyStructure(Source: TDataSet); function LoadFromDataSet(Source: TDataSet; ARecordCount: Integer; Mode: TLoadMode): Integer; function SaveToDataSet(Dest: TDataSet; ARecordCount: Integer): Integer; procedure AppendRecord(const Values: array of const); procedure MoveUp; procedure MoveDown; procedure ExchangeRec(ARecNo1, ARecNo2: Integer); procedure SetDatasetPacket(AReader : TRxDataPacketReader); procedure GetDatasetPacket(AWriter : TRxDataPacketReader); procedure LoadFromStream(AStream : TStream; Format: TRxDataPacketFormat = dfBinary); procedure SaveToStream(AStream : TStream; Format: TRxDataPacketFormat = dfBinary); procedure LoadFromFile(AFileName: string = ''; Format: TRxDataPacketFormat = dfAny); procedure SaveToFile(AFileName: string = ''; Format: TRxDataPacketFormat = dfAny); published property Capacity: Integer read GetCapacity write SetCapacity default 0; property Active; property AutoCalcFields; property Filtered; property FieldDefs; // property ObjectView default False; 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; property FileName : string read FFileName write FFileName; property PacketRecords : Integer read FPacketRecords write SetPacketRecords default 10; end; { TMemBlobStream } TMemBlobStream = class(TStream) private FField: TBlobField; FDataSet: TRxMemoryData; FBuffer: PChar; 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; function Write(const Buffer; Count: Longint): Longint; override; function Seek(Offset: Longint; Origin: Word): Longint; override; procedure Truncate; end; { TMemoryRecord } TMemoryRecord = class(TPersistent) private FMemoryData: TRxMemoryData; FID: Integer; FData: Pointer; FBlobs: PMemBlobArray; function GetIndex: Integer; procedure SetMemoryData(Value: TRxMemoryData; UpdateParent: Boolean); protected procedure SetIndex(Value: Integer); virtual; public constructor Create(MemoryData: TRxMemoryData); virtual; constructor CreateEx(MemoryData: TRxMemoryData; UpdateParent: Boolean); virtual; destructor Destroy; override; property MemoryData: TRxMemoryData read FMemoryData; property ID: Integer read FID write FID; property Index: Integer read GetIndex write SetIndex; property Data: Pointer read FData; end; implementation uses CustApp, rxdconst, LazUTF8, rxdbutils, dbconst, Variants, math, LResources; const ftBlobTypes = [ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary, ftOraBlob, ftOraClob]; ftSupported = [ftString, ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat, ftCurrency, ftDate, ftTime, ftDateTime, ftAutoInc, ftBCD, ftBytes, ftVarBytes, ftADT, ftFixedChar, ftWideString, ftLargeint, ftVariant, ftGuid] + ftBlobTypes; fkStoredFields = [fkData]; GuidSize = 38; { Utility routines } procedure FinalizeBlobFields(BlobArray:PMemBlobArray; BlobFieldCount:integer); var i:integer; begin for i:=0 to BlobFieldCount-1 do BlobArray^[i]:=''; end; function CompareFields(Data1, Data2: Pointer; FieldType: TFieldType; CaseInsensitive: Boolean): Integer; begin Result := 0; case FieldType of ftString: if CaseInsensitive then Result := UTF8CompareText(PChar(Data1), PChar(Data2)) else Result := UTF8CompareStr(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; ftFixedChar: if CaseInsensitive then Result := UTF8CompareText(PChar(Data1), PChar(Data2)) else Result := UTF8CompareStr(PChar(Data1), PChar(Data2)); ftWideString: if CaseInsensitive then Result := UTF8CompareText(WideCharToString(PWideChar(Data1)), WideCharToString(PWideChar(Data2))) else Result := UTF8CompareStr(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 := UTF8CompareText(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); ftBoolean: Result := SizeOf(WordBool); ftFloat: Result := SizeOf(Double); ftCurrency: Result := SizeOf(Double); ftBCD: Result := 34; ftDate, ftTime: Result := SizeOf(Longint); ftDateTime: Result := SizeOf(TDateTime); ftBytes: Result := Size; ftVarBytes: Result := Size + 2; ftAutoInc: Result := SizeOf(Longint); ftADT: Result := 0; ftFixedChar: Inc(Result); ftWideString: Result := (Result + 1) * 2; 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); {$IFDEF ENABLE_Child_Defs} for I := 0 to ChildDefs.Count - 1 do CalcDataSize(ChildDefs[I], DataSize); {$ENDIF} 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 = packed record BookmarkData: TBookmarkData; BookmarkFlag: TBookmarkFlag; end; { TMemoryRecord } constructor TMemoryRecord.Create(MemoryData: TRxMemoryData); begin CreateEx(MemoryData, True); end; constructor TMemoryRecord.CreateEx(MemoryData: TRxMemoryData; 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: TRxMemoryData; 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 begin FinalizeBlobFields(FBlobs, FMemoryData.BlobFieldCount); Freemem(FBlobs, FMemoryData.BlobFieldCount * SizeOf(TMemBlobData)); end; FBlobs:=nil; 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 GetMem(FBlobs, Value.BlobFieldCount * SizeOf(TMemBlobData)); FillChar(FBlobs^, Value.BlobFieldCount * SizeOf(Pointer), 0); FinalizeBlobFields(FBlobs, Value.BlobFieldCount); // 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); FillChar(FData^, DataSize, 0); 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; { TRxMemoryData } constructor TRxMemoryData.Create(AOwner: TComponent); begin inherited Create(AOwner); FParser := nil; FRecordPos := -1; FLastID := Low(Integer); FAutoInc := 1; FRecords := TList.Create; end; destructor TRxMemoryData.Destroy; begin inherited Destroy; FreeIndexList; ClearRecords; FRecords.Free; ReallocMem(FOffsets, 0); if Assigned(FParser) then FreeAndNil(FParser); end; { Records Management } function TRxMemoryData.GetCapacity: Integer; begin if FRecords <> nil then Result := FRecords.Capacity else Result := 0; end; procedure TRxMemoryData.SetCapacity(Value: Integer); begin if FRecords <> nil then FRecords.Capacity := Value; end; function TRxMemoryData.AddRecord: TMemoryRecord; begin Result := TMemoryRecord.Create(Self); end; function TRxMemoryData.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 TRxMemoryData.InsertRecord(Index: Integer): TMemoryRecord; begin Result := AddRecord; Result.Index := Index; end; function TRxMemoryData.GetMemoryRecord(Index: Integer): TMemoryRecord; begin Result := TMemoryRecord(FRecords[Index]); end; { Field Management } function TRxMemoryData.BCDToCurr(BCD: Pointer; var Curr: Currency): Boolean; begin Move(BCD^, Curr, SizeOf(Currency)); Result := True; end; function TRxMemoryData.CurrToBCD(const Curr: Currency; BCD: Pointer; Precision, Decimals: Integer): Boolean; begin Move(Curr, BCD^, SizeOf(Currency)); Result := True; end; procedure TRxMemoryData.InitFieldDefsFromFields; var I: Integer; Offset: Word; FD:TFieldDef; 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; { Create FieldDefs from persistent fields if needed } if FieldDefs.Count = 0 then for I := 0 to FieldCount - 1 do begin FD:=FieldDefs.AddFieldDef; // FD.DisplayName:=Fields[I].DisplayName; FD.Name:=Fields[I].FieldName; FD.Size:=Fields[I].Size; FD.DataType:=Fields[I].DataType; if Fields[I].Required then FD.Attributes:= FD.Attributes + [faRequired]; if Fields[I] is TFloatField then FD.Precision:=TFloatField(Fields[I]).Precision; end; { Calculate fields offsets } ReallocMem(FOffsets, FieldDefs.Count * SizeOf(Word)); for I := 0 to FieldDefs.Count - 1 do begin FOffsets^[I] := Offset; with FieldDefs[I] do begin if (DataType in ftSupported - ftBlobTypes) then Inc(Offset, CalcFieldLen(DataType, Size) + 1); end; end; end; function TRxMemoryData.FindFieldData(Buffer: Pointer; Field: TField): Pointer; var Index: Integer; begin {.$IFDEF TEST_RXMDS} Index := FieldDefs.IndexOf(Field.FieldName); // if Index <> Field.FieldNo - 1 then raise exception.Create('Index <> Field.FieldNo - 1'); {.$ENDIF} // Index := Field.FieldNo - 1; // Result:=FindFieldData(Buffer, Index); end; function TRxMemoryData.FindFieldData(Buffer: Pointer; FieldNo: Integer): Pointer; begin Result := nil; if (FieldNo >= 0) and (Buffer <> nil) and (FieldDefs[FieldNo].DataType in ftSupported - ftBlobTypes) then Result := Pointer(PtrInt(PChar(Buffer)) + FOffsets^[FieldNo]); end; { Buffer Manipulation } function TRxMemoryData.CalcRecordSize: Integer; var I: Integer; begin Result := 0; for I := 0 to FieldDefs.Count - 1 do CalcDataSize(FieldDefs[I], Result); end; procedure TRxMemoryData.InitBufferPointers(GetProps: Boolean); begin if GetProps then FRecordSize := CalcRecordSize; FBookmarkOfs := FRecordSize + CalcFieldsSize; FBlobOfs := FBookmarkOfs + SizeOf(TMemBookmarkInfo); FRecBufSize := FBlobOfs + BlobFieldCount * SizeOf(TMemBlobData);//Pointer); end; procedure TRxMemoryData.ParseFilter(const AFilter: string); begin // parser created? if Length(AFilter) > 0 then begin if (FParser = nil) and IsCursorOpen then begin FParser := TBufDatasetParser.Create(Self); end; // is there a parser now? if FParser <> nil then begin // set options FParser.PartialMatch := not (foNoPartialCompare in FilterOptions); FParser.CaseInsensitive := foCaseInsensitive in FilterOptions; // parse expression FParser.ParseExpression(AFilter); end; end; end; procedure TRxMemoryData.ClearRecords; begin while FRecords.Count > 0 do TObject(FRecords.Last).Free; FLastID := Low(Integer); FRecordPos := -1; end; function TRxMemoryData.AllocRecordBuffer: PChar; begin Result := StrAlloc(FRecBufSize); InternalInitRecord(Result); { FillChar(Result^, FRecBufSize, 0); if BlobFieldCount > 0 then begin // Initialize(PMemBlobArray(Result + FBlobOfs)^[0]);//, BlobFieldCount); // FillChar(PMemBlobArray(Result + FBlobOfs)^, BlobFieldCount * SizeOf(Pointer),0);//, BlobFieldCount); FinalizeBlobFields(PMemBlobArray(Result + FBlobOfs), BlobFieldCount); end;} end; procedure TRxMemoryData.FreeRecordBuffer(var Buffer: PChar); var n:integer; FieldPtr:PChar; begin //correctly release field memory for complex types for n:=0 to FieldDefs.Count-1 do if FieldDefs.Items[n].DataType = ftVariant then begin FieldPtr:=FindFieldData(Buffer, n); if FieldPtr <> nil then begin PBoolean(FieldPtr)^:=False; Inc(FieldPtr); Finalize( PVariant(FieldPtr)^ ); end; end; if BlobFieldCount > 0 then FinalizeBlobFields(PMemBlobArray(Buffer + FBlobOfs), BlobFieldCount); StrDispose(Buffer); Buffer := nil; end; procedure TRxMemoryData.ClearCalcFields(Buffer: PChar); begin FillChar(Buffer[FRecordSize], CalcFieldsSize, 0); end; procedure TRxMemoryData.InternalInitRecord(Buffer: PChar); var I: Integer; begin FillChar(Buffer^, FBlobOfs, 0); FillChar(PByteArray(Buffer + FBlobOfs)^, BlobFieldCount * SizeOf(Pointer), 0); for I := 0 to BlobFieldCount - 1 do begin PMemBlobArray(Buffer + FBlobOfs)^[I] := ''; end; end; procedure TRxMemoryData.InitRecord(Buffer: PChar); begin inherited InitRecord(Buffer); with PMemBookmarkInfo(Buffer + FBookmarkOfs)^ do begin BookmarkData := Low(Integer); BookmarkFlag := bfInserted; end; end; procedure TRxMemoryData.CopyRecord(RecordData, Buffer:PChar); var n, FieldSize:Integer; FieldPtr, BufPtr:PChar; DataType:TFieldType; begin for n:=0 to FieldDefs.Count-1 do begin FieldPtr:=FindFieldData(RecordData, n); BufPtr:=FindFieldData(Buffer, n); if FieldPtr = nil then Continue; PBoolean(BufPtr)^:=PBoolean(FieldPtr)^; Inc(FieldPtr); Inc(BufPtr); DataType:=FieldDefs.Items[n].DataType; if DataType = ftVariant then begin PVariant(BufPtr)^:=PVariant(FieldPtr)^; end else begin FieldSize:=FieldDefs.Items[n].Size; Move( FieldPtr^, BufPtr^, CalcFieldLen(DataType, FieldSize) ); end; end; end; function TRxMemoryData.GetCurrentRecord(Buffer: PChar): 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); CopyRecord(Records[FRecordPos].Data, Buffer); Result := True; end; end; end; procedure TRxMemoryData.RecordToBuffer(Rec: TMemoryRecord; Buffer: PChar); var I: Integer; begin //Move(Rec.Data^, Buffer^, FRecordSize); CopyRecord(Rec.Data, Buffer); 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 TRxMemoryData.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; var Accept: Boolean; begin Result := grOk; Accept := True; case GetMode of gmPrior: if FRecordPos <= 0 then begin Result := grBOF; FRecordPos := -1; end else begin repeat Dec(FRecordPos); if Filtered then Accept := RecordFilter; until Accept or (FRecordPos < 0); if not Accept then begin Result := grBOF; FRecordPos := -1; end; end; gmCurrent: if (FRecordPos < 0) or (FRecordPos >= RecordCount) then Result := grError else if Filtered then begin if not RecordFilter then Result := grError; end; gmNext: if FRecordPos >= RecordCount - 1 then Result := grEOF else begin repeat Inc(FRecordPos); if Filtered then Accept := RecordFilter; until Accept or (FRecordPos > RecordCount - 1); if not Accept then begin Result := grEOF; FRecordPos := RecordCount - 1; end; end; end; if Result = grOk then RecordToBuffer(Records[FRecordPos], Buffer) else if (Result = grError) and DoCheck then Error(SMemNoRecords); end; function TRxMemoryData.GetRecordSize: Word; begin Result := FRecordSize; end; function TRxMemoryData.GetActiveRecBuf(var RecBuf: PChar): Boolean; begin case State of dsBrowse: if IsEmpty then RecBuf := nil else RecBuf := ActiveBuffer; dsEdit, dsInsert: RecBuf := ActiveBuffer; dsCalcFields: RecBuf := CalcBuffer; dsFilter: RecBuf := TempBuffer; else RecBuf := nil; end; Result := RecBuf <> nil; end; {$IFDEF FIX_BUG_FieldNo} function GetFieldNo(DS:TDataSet; Field:TField):integer; var i:integer; begin for i:=0 to DS.FieldDefs.Count-1 do if DS.FieldDefs[i].Name = Field.FieldName then begin Result:=i+1; exit; end; Result:=0; end; {$ENDIF} function TRxMemoryData.GetFieldData(Field: TField; Buffer: Pointer): Boolean; var RecBuf, Data: PChar; VarData: Variant; begin Result := False; if not GetActiveRecBuf(RecBuf) then Exit; {$IFDEF FIX_BUG_FieldNo} if GetFieldNo(Self, Field) > 0 then {$ELSE} if Field.FieldNo > 0 then {$ENDIF} begin Data := FindFieldData(RecBuf, Field); if Data <> nil then begin Result := Boolean(Data[0]); Inc(Data); if Field.DataType in [ftString, ftFixedChar, ftWideString, ftGuid] then Result := Result and (StrLen(Data) > 0); if Result and (Buffer <> nil) then if Field.DataType = ftVariant then begin VarData := PVariant(Data)^; PVariant(Buffer)^ := VarData; end else Move(Data^, Buffer^, CalcFieldLen(Field.DataType, Field.Size)); end; end else begin if State in [dsBrowse, dsEdit, dsInsert, dsCalcFields] then begin Inc(RecBuf, FRecordSize + Field.Offset); Result := Boolean(RecBuf[0]); if Result and (Buffer <> nil) then Move(RecBuf[1], Buffer^, Field.DataSize); end; end; end; procedure TRxMemoryData.SetFieldData(Field: TField; Buffer: Pointer); var RecBuf, Data: PChar; VarData: Variant; PBl:PBoolean; begin if not (State in dsWriteModes) then ErrorFmt(SNotEditing, [Name]); GetActiveRecBuf(RecBuf); with Field do begin {$IFDEF FIX_BUG_FieldNo} if GetFieldNo(Self, Field) > 0 then {$ELSE} if Field.FieldNo > 0 then {$ENDIF} begin if State in [dsCalcFields, dsFilter] then ErrorFmt(SNotEditing, [Name]); if ReadOnly and not (State in [dsSetKey, dsFilter]) then ErrorFmt(SFieldReadOnly, [DisplayName]); Validate(Buffer); if FieldKind <> fkInternalCalc then begin Data := FindFieldData(RecBuf, Field); if Data <> nil then begin if DataType = ftVariant then begin if (Buffer = nil) or VarIsNull(PVariant(Buffer)^) or VarIsEmpty(PVariant(Buffer)^) or VarIsEmptyParam(PVariant(Buffer)^) then FillChar(Data^, CalcFieldLen(DataType, Size), 0) else begin Boolean(Data[0]):=True; Inc(Data); PVariant(Data)^ := PVariant(Buffer)^; end; end else begin PBl:=Pointer(Data); // Boolean(Data^{[0]}) := Assigned(Buffer);//LongBool(Buffer); // Pbl^:=Assigned(Buffer); PBoolean(Pointer(Data))^:= Assigned(Buffer); Inc(Data); if Assigned(Buffer) then Move(Buffer^, Data^, CalcFieldLen(DataType, Size)) else FillChar(Data^, CalcFieldLen(DataType, Size), 0); end; end; end; end else {fkCalculated, fkLookup} begin Inc(RecBuf, FRecordSize + Offset); Boolean(RecBuf[0]) := LongBool(Buffer); if Boolean(RecBuf[0]) then Move(Buffer^, RecBuf[1], DataSize); end; if not (State in [dsCalcFields, dsFilter, dsNewValue]) then DataEvent(deFieldChange, ptrint(Field)); end; end; { Filter } procedure TRxMemoryData.SetFiltered(Value: Boolean); begin if Active then begin CheckBrowseMode; if Filtered <> Value then begin inherited SetFiltered(Value); First; end; end else inherited SetFiltered(Value); end; procedure TRxMemoryData.SetOnFilterRecord(const Value: TFilterRecordEvent); begin if Active then begin CheckBrowseMode; inherited SetOnFilterRecord(Value); if Filtered then First; end else inherited SetOnFilterRecord(Value); end; function TRxMemoryData.RecordFilter: Boolean; var SaveState: TDataSetState; RecBuf: PChar; begin Result := True; if Assigned(OnFilterRecord) then begin if (FRecordPos >= 0) and (FRecordPos < RecordCount) then begin SaveState := SetTempState(dsFilter); try RecordToBuffer(Records[FRecordPos], TempBuffer); OnFilterRecord(Self, Result); except CustomApplication.HandleException(Self); end; if Result and (Length(Filter) > 0) then begin if GetActiveRecBuf(RecBuf) then Result := Boolean((FParser.ExtractFromBuffer(RecBuf))^); end; RestoreState(SaveState); end else Result := False; end; end; { Blobs } function TRxMemoryData.GetBlobData(Field: TField; Buffer: PChar): TMemBlobData; begin Result := PMemBlobArray(Buffer + FBlobOfs)^[Field.Offset]; end; procedure TRxMemoryData.SetBlobData(Field: TField; Buffer: PChar; Value: TMemBlobData); begin if (Buffer = ActiveBuffer) then begin if State = dsFilter then Error(SNotEditing); PMemBlobArray(Buffer + FBlobOfs)^[Field.Offset] := Value; end; end; procedure TRxMemoryData.CloseBlob(Field: TField); begin if (FRecordPos >= 0) and (FRecordPos < FRecords.Count) and (State = dsEdit) then PMemBlobArray(ActiveBuffer + FBlobOfs)^[Field.Offset] := PMemBlobArray(Records[FRecordPos].FBlobs)^[Field.Offset] else PMemBlobArray(ActiveBuffer + FBlobOfs)^[Field.Offset] := ''; end; function TRxMemoryData.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; begin Result := TMemBlobStream.Create(Field as TBlobField, Mode); end; { Bookmarks } function TRxMemoryData.BookmarkValid(ABookmark: TBookmark): Boolean; begin {$IFDEF NoAutomatedBookmark} Result := FActive and (TBookmarkData(ABookmark^) > Low(Integer)) and (TBookmarkData(ABookmark^) <= FLastID); {$ELSE} Result := FActive and Assigned(ABookmark) and (TBookmarkData(pointer(ABookmark)^) > Low(Integer)) and (TBookmarkData(pointer(ABookmark)^) <= FLastID); {$ENDIF} end; function TRxMemoryData.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; begin if (Bookmark1 = nil) and (Bookmark2 = nil) then Result := 0 else if (Bookmark1 <> nil) and (Bookmark2 = nil) then Result := 1 else if (Bookmark1 = nil) and (Bookmark2 <> nil) then Result := -1 {$IFDEF NoAutomatedBookmark} else if TBookmarkData(Bookmark1^) > TBookmarkData(Bookmark2^) then {$ELSE} else if TBookmarkData(pointer(Bookmark1)^) > TBookmarkData(pointer(Bookmark2)^) then {$ENDIF} Result := 1 {$IFDEF NoAutomatedBookmark} else if TBookmarkData(Bookmark1^) < TBookmarkData(Bookmark2^) then {$ELSE} else if TBookmarkData(pointer(Bookmark1)^) < TBookmarkData(pointer(Bookmark2)^) then {$ENDIF} Result := -1 else Result := 0; end; procedure TRxMemoryData.GetBookmarkData(Buffer: PChar; Data: Pointer); begin Move(PMemBookmarkInfo(Buffer + FBookmarkOfs)^.BookmarkData, Data^, SizeOf(TBookmarkData)); end; procedure TRxMemoryData.SetBookmarkData(Buffer: PChar; Data: Pointer); begin Move(Data^, PMemBookmarkInfo(Buffer + FBookmarkOfs)^.BookmarkData, SizeOf(TBookmarkData)); end; function TRxMemoryData.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; begin Result := PMemBookmarkInfo(Buffer + FBookmarkOfs)^.BookmarkFlag; end; procedure TRxMemoryData.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); begin PMemBookmarkInfo(Buffer + FBookmarkOfs)^.BookmarkFlag := Value; end; {$IFDEF NoAutomatedBookmark} procedure TRxMemoryData.InternalGotoBookmark(ABookmark: TBookmark); {$ELSE} procedure TRxMemoryData.InternalGotoBookmark(ABookmark: Pointer); {$ENDIF} var Rec: TMemoryRecord; SavePos: Integer; Accept: Boolean; begin Rec := FindRecordID(TBookmarkData(ABookmark^)); if Rec <> nil then begin Accept := True; SavePos := FRecordPos; try FRecordPos := Rec.Index; if Filtered then Accept := RecordFilter; finally if not Accept then FRecordPos := SavePos; end; end; end; { Navigation } procedure TRxMemoryData.InternalSetToRecord(Buffer: PChar); begin InternalGotoBookmark(@PMemBookmarkInfo(Buffer + FBookmarkOfs)^.BookmarkData); end; procedure TRxMemoryData.InternalFirst; begin FRecordPos := -1; end; procedure TRxMemoryData.InternalLast; begin FRecordPos := FRecords.Count; end; { Data Manipulation } procedure TRxMemoryData.AssignMemoryRecord(Rec: TMemoryRecord; Buffer: PChar); var I: Integer; begin //Move(Buffer^, Rec.Data^, FRecordSize); CopyRecord(Buffer, PChar(Rec.Data)); for I := 0 to BlobFieldCount - 1 do PMemBlobArray(Rec.FBlobs)^[I] := PMemBlobArray(Buffer + FBlobOfs)^[I]; end; procedure TRxMemoryData.SetMemoryRecordData(Buffer: PChar; Pos: Integer); var Rec: TMemoryRecord; begin if State = dsFilter then Error(SNotEditing); Rec := Records[Pos]; AssignMemoryRecord(Rec, Buffer); end; procedure TRxMemoryData.SetAutoIncFields(Buffer: PChar); var I, Count: Integer; Data: PChar; begin Count := 0; for I := 0 to FieldCount - 1 do if (Fields[I].FieldKind in fkStoredFields) and (Fields[I].DataType = ftAutoInc) then begin Data := FindFieldData(Buffer, Fields[I]); if Data <> nil then begin Boolean(Data[0]) := True; Inc(Data); Move(FAutoInc, Data^, SizeOf(Longint)); Inc(Count); end; end; if Count > 0 then Inc(FAutoInc); end; procedure TRxMemoryData.InternalAddRecord(Buffer: Pointer; DoAppend: Boolean); var RecPos: Integer; Rec: TMemoryRecord; begin if DoAppend then begin Rec := AddRecord; FRecordPos := FRecords.Count - 1; end else begin if FRecordPos = -1 then RecPos := 0 else RecPos := FRecordPos; Rec := InsertRecord(RecPos); FRecordPos := RecPos; end; SetAutoIncFields(Buffer); SetMemoryRecordData(Buffer, Rec.Index); end; procedure TRxMemoryData.InternalDelete; var Accept: Boolean; begin Records[FRecordPos].Free; if FRecordPos >= FRecords.Count then Dec(FRecordPos); Accept := True; repeat if Filtered then Accept := RecordFilter; if not Accept then Dec(FRecordPos); until Accept or (FRecordPos < 0); if FRecords.Count = 0 then FLastID := Low(Integer); end; procedure TRxMemoryData.InternalPost; var RecPos: Integer; begin if State = dsEdit then SetMemoryRecordData(ActiveBuffer, FRecordPos) else begin if State in [dsInsert] then SetAutoIncFields(ActiveBuffer); if FRecordPos >= FRecords.Count then begin SetMemoryRecordData(ActiveBuffer, AddRecord.Index); FRecordPos := FRecords.Count - 1; end else begin if FRecordPos = -1 then RecPos := 0 else RecPos := FRecordPos; SetMemoryRecordData(ActiveBuffer, InsertRecord(RecPos).Index); FRecordPos := RecPos; end; end; end; procedure TRxMemoryData.OpenCursor(InfoQuery: Boolean); begin if not InfoQuery then begin if FieldCount > 0 then FieldDefs.Clear; InitFieldDefsFromFields; end; FActive := True; inherited OpenCursor(InfoQuery); end; procedure TRxMemoryData.InternalOpen; begin BookmarkSize := SizeOf(TBookmarkData); if DefaultFields then CreateFields; BindFields(True); InitBufferPointers(True); InternalFirst; end; procedure TRxMemoryData.InternalClose; begin ClearRecords; FAutoInc := 1; BindFields(False); if DefaultFields then DestroyFields; FreeIndexList; FActive := False; end; procedure TRxMemoryData.InternalHandleException; begin CustomApplication.HandleException(Self); end; procedure TRxMemoryData.InternalInitFieldDefs; begin end; function TRxMemoryData.IsCursorOpen: Boolean; begin Result := FActive; end; { Informational } function TRxMemoryData.GetRecordCount: Integer; begin Result := FRecords.Count; end; function TRxMemoryData.GetRecNo: Integer; begin CheckActive; UpdateCursorPos; if (FRecordPos = -1) and (RecordCount > 0) then Result := 1 else Result := FRecordPos + 1; end; procedure TRxMemoryData.SetRecNo(Value: Integer); begin if (Value > 0) and (Value <= FRecords.Count) then begin FRecordPos := Value - 1; Resync([]); end; end; function TRxMemoryData.GetAnyRecField(SrcRecNo: integer; AField: TField ): variant; var Data1: PChar; I: Integer; Item:TMemoryRecord; begin Item:=Records[SrcRecNo]; Data1 := FindFieldData(Item.Data, AField); Inc(Data1); //Skip null flag case AField.DataType of ftString:Result := PChar(Data1); ftSmallint:Result:=SmallInt(Data1^); ftInteger, ftDate, ftTime, ftAutoInc:Result:=Longint(Data1^); ftWord:Result:=Word(Data1^); ftBoolean:Result:=WordBool(Data1^); ftFloat, ftCurrency:Result:=PDouble(Data1)^; ftDateTime:Result:=PDateTime(Data1)^; ftFixedChar:Result:=PChar(Data1); ftWideString:Result:=PWideChar(Data1); ftLargeint:Result:=Int64(Data1^); ftVariant: begin Result := PVariant(Data1)^; end; ftGuid:Result:=PChar(Data1); else Result:=null; end; end; procedure TRxMemoryData.SetFilterText(const Value: String); begin if Value = Filter then exit; // parse ParseFilter(Value); // call dataset method inherited; // refilter dataset if filtered if IsCursorOpen and Filtered then Resync([]); end; function TRxMemoryData.IsSequenced: Boolean; begin Result := not Filtered; end; { DataSet locate routines } function DataSetLocateThrough(DataSet: TDataSet; const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; var FieldCount: Integer; Fields: TList; function CompareField(Field: TField; Value: Variant): Boolean; var S,S1: string; begin if Field.DataType = ftString then begin S := Field.AsString; S1:=Value; if (loPartialKey in Options) then Delete(S, Length(S1) + 1, MaxInt); if (loCaseInsensitive in Options) then Result := UTF8CompareText(S, S1) = 0 else Result := UTF8CompareStr(S, S1) = 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; var Bookmark: TBookmark; 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.GetBookmark; try with DataSet do begin First; while not EOF do begin Result := CompareRecord; if Result then Break; Next; end; end; finally {$IFDEF NoAutomatedBookmark} if not Result and DataSet.BookmarkValid(PChar(Bookmark)) then {$ELSE} if not Result and DataSet.BookmarkValid(Bookmark) then {$ENDIF} DataSet.GotoBookmark(Bookmark); end; finally DataSet.FreeBookmark(Bookmark); DataSet.EnableControls; end; finally Fields.Free; end; end; function TRxMemoryData.Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; begin DoBeforeScroll; Result := DataSetLocateThrough(Self, KeyFields, KeyValues, Options); if Result then begin DataEvent(deDataSetChange, 0); DoAfterScroll; end; end; { Table Manipulation } procedure TRxMemoryData.EmptyTable; begin if Active then begin CheckBrowseMode; ClearRecords; ClearBuffers; DataEvent(deDataSetChange, 0); end; end; procedure TRxMemoryData.CloseOpen; begin Close; Open; end; procedure TRxMemoryData.CopyStructure(Source: TDataSet); procedure CheckDataTypes(FieldDefs: TFieldDefs); var I: Integer; begin for I := FieldDefs.Count - 1 downto 0 do begin if not (FieldDefs.Items[I].DataType in ftSupported) then FieldDefs.Items[I].Free {$IFDEF ENABLE_Child_Defs} else CheckDataTypes(FieldDefs[I].ChildDefs); {$ENDIF} end; end; var I: Integer; begin CheckInactive; for I := FieldCount - 1 downto 0 do Fields[I].Free; if (Source = nil) then Exit; Source.FieldDefs.Update; // FieldDefs.Assign(Source.FieldDefs); // FieldDefs := Source.FieldDefs; FieldDefs.Clear; for i:=0 to Source.FieldDefs.Count-1 do FieldDefs.Add(Source.FieldDefs[i].Name, Source.FieldDefs[i].DataType, Source.FieldDefs[i].Size, Source.FieldDefs[i].Required); CheckDataTypes(FieldDefs); CreateFields; end; (* procedure AssignRecord(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 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; 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 if F.DataType = FSrc.DataType then F.Assign(FSrc) else F.AsString := FSrc.AsString; end; end; end; end; *) function TRxMemoryData.LoadFromDataSet(Source: TDataSet; ARecordCount: Integer; Mode: TLoadMode): Integer; var SourceActive: Boolean; MovedCount: Integer; begin Result := 0; if Source = Self then Exit; SourceActive := Source.Active; Source.DisableControls; try DisableControls; try Filtered := False; with Source do begin Open; CheckBrowseMode; UpdateCursorPos; end; if Mode = lmCopy then begin Close; CopyStructure(Source); end; FreeIndexList; if not Active then Open; Resync([]); CheckBrowseMode; if ARecordCount > 0 then MovedCount := ARecordCount else begin Source.First; MovedCount := MaxInt; end; try while not Source.EOF do begin Append; AssignRecord(Source, Self, True); Post; Inc(Result); if Result >= MovedCount then Break; Source.Next; end; finally First; end; finally EnableControls; end; finally if not SourceActive then Source.Close; Source.EnableControls; end; end; function TRxMemoryData.SaveToDataSet(Dest: TDataSet; ARecordCount: Integer): Integer; var MovedCount: Integer; begin Result := 0; if Dest = Self then Exit; CheckBrowseMode; UpdateCursorPos; Dest.DisableControls; try DisableControls; try if not Dest.Active then Dest.Open else Dest.CheckBrowseMode; if ARecordCount > 0 then MovedCount := ARecordCount else begin First; MovedCount := MaxInt; end; try while not EOF do begin Dest.Append; AssignRecord(Self, Dest, True); Dest.Post; Inc(Result); if Result >= MovedCount then Break; Next; end; finally Dest.First; end; finally EnableControls; end; finally Dest.EnableControls; end; end; procedure TRxMemoryData.AppendRecord(const Values: array of const); var I: Integer; begin if State <> dsInsert then Append; for I := 0 to High(Values) do Fields[I].AssignValue(Values[I]); Post; end; procedure TRxMemoryData.MoveUp; begin if (FRecords.Count > 1) and (FRecordPos > 0) then ExchangeRec(FRecordPos, FRecordPos + 1); end; procedure TRxMemoryData.MoveDown; begin if (FRecords.Count > 1) and (FRecordPos < FRecords.Count - 1) then ExchangeRec(FRecordPos + 1, FRecordPos + 2); end; procedure TRxMemoryData.ExchangeRec(ARecNo1, ARecNo2: Integer); begin CheckActive; CheckBrowseMode; if (ARecNo1 <> ARecNo2) and (ARecNo1 > 0) and (ARecNo2 > 0) and (ARecNo1 <= FRecords.Count) and (ARecNo2 <= FRecords.Count) then begin FRecords.Exchange(ARecNo1 - 1, ARecNo2 - 1); Resync([]); end; end; { Index Related } procedure TRxMemoryData.SortOnFields(const FieldNames: string; CaseInsensitive: Boolean = True; Descending: Boolean = False); begin CreateIndexList(FieldNames); FCaseInsensitiveSort := CaseInsensitive; FDescendingSort := Descending; try Sort; except FreeIndexList; raise; end; end; procedure TRxMemoryData.SortOnFieldsEx(const FieldNames: string; CaseInsensitive: Boolean; Asc: array of boolean); begin end; procedure TRxMemoryData.Sort; var Pos: TBookmark; begin if Active and (FRecords <> nil) and (FRecords.Count > 0) then begin Pos := GetBookmark; try QuickSort(0, FRecords.Count - 1, @CompareRecords); SetBufListSize(0); InitBufferPointers(False); try RecalcBufListSize; // SetBufListSize(BufferCount + 1); except SetState(dsInactive); CloseCursor; raise; end; finally GotoBookmark(Pos); FreeBookmark(Pos); end; Resync([]); end; end; procedure TRxMemoryData.QuickSort(L, R: Integer; Compare: TCompareRecords); var I, J: Integer; P: TMemoryRecord; begin repeat I := L; J := R; P := Records[(L + R) shr 1]; repeat while Compare(Records[I], P) < 0 do Inc(I); while Compare(Records[J], P) > 0 do Dec(J); if I <= J then begin FRecords.Exchange(I, J); Inc(I); Dec(J); end; until I > J; if L < J then QuickSort(L, J, Compare); L := I; until I >= R; end; function TRxMemoryData.CompareRecords(Item1, Item2: TMemoryRecord): Integer; var Data1, Data2: PChar; F: TField; I: Integer; begin Result := 0; if FIndexList <> nil then begin for I := 0 to FIndexList.Count - 1 do begin F := TField(FIndexList[I]); Data1 := FindFieldData(Item1.Data, F); if Data1 <> nil then begin Data2 := FindFieldData(Item2.Data, F); if Data2 <> nil then begin if Boolean(Data1[0]) and Boolean(Data2[0]) then begin Inc(Data1); Inc(Data2); Result := CompareFields(Data1, Data2, F.DataType, FCaseInsensitiveSort); end else if Boolean(Data1[0]) then Result := 1 else if Boolean(Data2[0]) then Result := -1; if FDescendingSort then Result := -Result; end; end; if Result <> 0 then Exit; end; end; if (Result = 0) then begin if Item1.ID > Item2.ID then Result := 1 else if Item1.ID < Item2.ID then Result := -1; if FDescendingSort then Result := -Result; end; end; function TRxMemoryData.GetIsIndexField(Field: TField): Boolean; begin if FIndexList <> nil then Result := FIndexList.IndexOf(Field) >= 0 else Result := False; end; procedure TRxMemoryData.CreateIndexList(const FieldNames: string); var Pos: Integer; F: TField; begin if FIndexList = nil then FIndexList := TList.Create else FIndexList.Clear; Pos := 1; while Pos <= Length(FieldNames) do begin F := FieldByName(ExtractFieldName(FieldNames, Pos)); if (F.FieldKind = fkData) and (F.DataType in ftSupported - ftBlobTypes) then FIndexList.Add(F) else ErrorFmt(SFieldTypeMismatch, [F.DisplayName]); end; end; procedure TRxMemoryData.FreeIndexList; begin FIndexList.Free; FIndexList := nil; end; function TRxMemoryData.IntAllocRecordBuffer: PChar; begin // do nothing end; procedure TRxMemoryData.IntLoadFielddefsFromFile; begin FDatasetReader.LoadFielddefs(FieldDefs); if DefaultFields then CreateFields; end; procedure TRxMemoryData.IntLoadRecordsFromFile; var StoreState : TDataSetState; AddRecordBuffer : boolean; ARowState : TRowState; AUpdOrder : integer; begin FDatasetReader.InitLoadRecords; StoreState:=SetTempState(dsFilter); while FDatasetReader.GetCurrentRecord do begin ARowState := FDatasetReader.GetRecordRowState(AUpdOrder); FDatasetReader.RestoreRecord(self); inc(FBRecordCount); FDatasetReader.GotoNextRecord; end; RestoreState(StoreState); if assigned(FFileStream) then begin FreeAndNil(FFileStream); FreeAndNil(FDatasetReader); end; end; procedure TRxMemoryData.SetPacketRecords(const AValue: Integer); begin if FPacketRecords=AValue then exit; FPacketRecords:=AValue; end; procedure TRxMemoryData.SetDatasetPacket(AReader: TRxDataPacketReader); var StoreDSState : TDataSetState; ARowState : TRowState; AUpdOrder : integer; begin FDatasetReader := AReader; DisableControls; try Filtered := False; Close; // must be inactive to do IntLoadFielddefsFromFile // load fields defs IntLoadFielddefsFromFile; FreeIndexList; if not Active then Open; Resync([]); // clears buffers if empty dataset CheckBrowseMode; FDatasetReader.InitLoadRecords; try while FDatasetReader.GetCurrentRecord do begin Append; ARowState := FDatasetReader.GetRecordRowState(AUpdOrder); // added for binary export FDatasetReader.RestoreRecord(TRxMemoryData(Self)); Post; FDatasetReader.GotoNextRecord; inc(FBRecordCount); end; finally First; end; finally EnableControls; end; if assigned(FFileStream) then begin FreeAndNil(FFileStream); FreeAndNil(FDatasetReader); end; end; procedure TRxMemoryData.GetDatasetPacket(AWriter: TRxDataPacketReader); var StoreDSState : TDataSetState; begin CheckBrowseMode; UpdateCursorPos; FDatasetReader := AWriter; try DisableControls; try FDatasetReader.StoreFieldDefs(FieldDefs); First; while not EOF do begin // ** NOTE ** had to cast self to TRxMemoryData just save current values // otherwise the as string value in ex_rx_datapacket would not write. FDatasetReader.StoreRecord(TRxMemoryData(Self),[]); Next; end; FDatasetReader.FinalizeStoreRecords; finally EnableControls; end; finally FDatasetReader := nil; end; end; procedure TRxMemoryData.LoadFromStream(AStream: TStream; Format: TRxDataPacketFormat); var APacketReaderReg : TRxDatapacketReaderRegistration; APacketReader : TRxDataPacketReader; begin if GetRegisterDatapacketReader(AStream,format,APacketReaderReg) then APacketReader := APacketReaderReg.ReaderClass.create(AStream) else DatabaseError(SStreamNotRecognised); try SetDatasetPacket(APacketReader); finally APacketReader.Free; end; end; procedure TRxMemoryData.SaveToStream(AStream: TStream; Format: TRxDataPacketFormat); var APacketReaderReg : TRxDatapacketReaderRegistration; APacketWriter : TRxDataPacketReader; begin if GetRegisterDatapacketReader(Nil,format,APacketReaderReg) then APacketWriter := APacketReaderReg.ReaderClass.create(AStream) else DatabaseError(SNoReaderClassRegistered); try GetDatasetPacket(APacketWriter); finally APacketWriter.Free; end; end; procedure TRxMemoryData.LoadFromFile(AFileName: string; Format: TRxDataPacketFormat); var AFileStream : TFileStream; begin if AFileName='' then AFileName := FFileName; AFileStream := TFileStream.Create(AFileName,fmOpenRead); try LoadFromStream(AFileStream, Format); finally AFileStream.Free; end; end; procedure TRxMemoryData.SaveToFile(AFileName: string; Format: TRxDataPacketFormat); var AFileStream : TFileStream; begin if AFileName='' then AFileName := FFileName; AFileStream := TFileStream.Create(AFileName,fmCreate); try SaveToStream(AFileStream, Format); finally AFileStream.Free; end; end; { TMemBlobStream } constructor TMemBlobStream.Create(Field: TBlobField; Mode: TBlobStreamMode); begin FMode := Mode; FField := Field; FDataSet := FField.DataSet as TRxMemoryData; if not FDataSet.GetActiveRecBuf(FBuffer) then Exit; if not FField.Modified and (Mode <> bmRead) then begin if FField.ReadOnly then ErrorFmt(SFieldReadOnly, [FField.DisplayName]); if not (FDataSet.State in [dsEdit, dsInsert]) then Error(SNotEditing); FCached := True; end else FCached := (FBuffer = FDataSet.ActiveBuffer); FOpened := True; if Mode = bmWrite then Truncate; end; destructor TMemBlobStream.Destroy; begin if FOpened and FModified then FField.Modified := True; if FModified then try FDataSet.DataEvent(deFieldChange, ptrint(FField)); except CustomApplication.HandleException(Self); // Application.HandleException(Self); end; end; function TMemBlobStream.GetBlobFromRecord(Field: TField): TMemBlobData; var Rec: TMemoryRecord; Pos: Integer; begin Result := ''; Pos := FDataSet.FRecordPos; if (Pos < 0) and (FDataSet.RecordCount > 0) then Pos := 0 else if Pos >= FDataSet.RecordCount then Pos := FDataSet.RecordCount - 1; if (Pos >= 0) and (Pos < FDataSet.RecordCount) then begin Rec := FDataSet.Records[Pos]; if Rec <> nil then Result := PMemBlobArray(Rec.FBlobs)^[FField.Offset]; end; end; function TMemBlobStream.Read(var Buffer; Count: Longint): Longint; begin Result := 0; if FOpened then begin if Count > Size - FPosition then Result := Size - FPosition else Result := Count; if Result > 0 then begin if FCached then begin Move(PChar(FDataSet.GetBlobData(FField, FBuffer))[FPosition], Buffer, Result); Inc(FPosition, Result); end else begin Move(PChar(GetBlobFromRecord(FField))[FPosition], Buffer, Result); Inc(FPosition, Result); end; end; end; end; function TMemBlobStream.Write(const Buffer; Count: Longint): Longint; var Temp: TMemBlobData; begin Result := 0; if FOpened and FCached and (FMode <> bmRead) then begin Temp := FDataSet.GetBlobData(FField, FBuffer); if Length(Temp) < FPosition + Count then SetLength(Temp, FPosition + Count); Move(Buffer, PChar(Temp)[FPosition], Count); FDataSet.SetBlobData(FField, FBuffer, Temp); Inc(FPosition, Count); Result := Count; FModified := True; end; end; function TMemBlobStream.Seek(Offset: Longint; Origin: Word): Longint; begin case Origin of 0: FPosition := Offset; 1: Inc(FPosition, Offset); 2: FPosition := GetBlobSize + Offset; end; Result := FPosition; end; procedure TMemBlobStream.Truncate; begin if FOpened and FCached and (FMode <> bmRead) then begin FDataSet.SetBlobData(FField, FBuffer, ''); FModified := True; end; end; function TMemBlobStream.GetBlobSize: Longint; begin Result := 0; if FOpened then if FCached then Result := Length(FDataSet.GetBlobData(FField, FBuffer)) else Result := Length(GetBlobFromRecord(FField)) end; initialization RegisterPropertyToSkip(TRxMemoryData, 'OnFilterRecordEx', 'Old property', ''); end.