paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-20 22:49:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-db: memds: implemented basic blob support. Blobs are allocated in memory only. Saving to stream/file is not supported yet. Bug #26476

Browse Source 
git-svn-id: trunk@31027 -
This commit is contained in:
lacak 2015-06-12 07:28:50 +00:00
parent 1ec8a3bde9
commit 8214e72841
3 changed files with 189 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

215
packages/fcl-db/src/memds/memds.pp
View File

@ -46,29 +46,31 @@ type
MDSError=class(Exception);
PRecInfo=^TMTRecInfo;
TMTRecInfo=record
Bookmark: Longint;
BookmarkFlag: TBookmarkFlag;
end;
{ TMemDataset }
TMemDataset=class(TDataSet)
private
FOpenStream : TStream;
FFileName : String;
FFileModified : Boolean;
FStream: TMemoryStream;
FRecInfoOffset: integer;
FRecCount: integer;
FRecSize: integer;
FCurrRecNo: integer;
FIsOpen: boolean;
FTableIsCreated: boolean;
FFilterBuffer: TRecordBuffer;
ffieldoffsets: PInteger;
ffieldsizes: PInteger;
type
TMDSBlobList = class(TFPList)
public
procedure Clear; reintroduce;
end;
var
FOpenStream : TStream;
FFileName : String;
FFileModified : Boolean;
FStream: TMemoryStream;
FRecInfoOffset: integer;
FRecCount: integer;
FRecSize: integer;
FCurrRecNo: integer;
FIsOpen: boolean;
FTableIsCreated: boolean;
FFilterBuffer: TRecordBuffer;
ffieldoffsets: PInteger;
ffieldsizes: PInteger;
FBlobs: TMDSBlobList;
function GetRecordBufferPointer(p:TRecordBuffer; Pos:Integer):TRecordBuffer;
function GetIntegerPointer(p:PInteger; Pos:Integer):PInteger;
@ -126,17 +128,16 @@ type
// If SaveData=False, a size 0 block should be written.
Procedure SaveDataToStream(F : TStream; SaveData : Boolean); virtual;
public
constructor Create(AOwner:tComponent); override;
constructor Create(AOwner:TComponent); override;
destructor Destroy; override;
function BookmarkValid(ABookmark: TBookmark): Boolean; override;
function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
function Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): boolean; override;
function Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant; override;
procedure CreateTable;
Function DataSize : Integer;
Procedure Clear(ClearDefs : Boolean);{$IFNDEF FPC} overload; {$ENDIF}
Procedure Clear;{$IFNDEF FPC} overload; {$ENDIF}
Procedure SaveToFile(AFileName : String);{$IFNDEF FPC} overload; {$ENDIF}
@ -183,7 +184,7 @@ type
implementation
uses
Variants, FmtBCD;
DBConst, Variants, FmtBCD;
ResourceString
SErrFieldTypeNotSupported = 'Fieldtype of Field "%s" not supported.';
@ -192,8 +193,40 @@ ResourceString
SErrInvalidMarkerAtPos = 'Wrong data stream marker at position %d. Got %d, expected %d';
SErrNoFileName = 'Filename must not be empty.';
type
TMDSRecInfo=record
Bookmark: Longint;
BookmarkFlag: TBookmarkFlag;
end;
PRecInfo=^TMDSRecInfo;
TMDSBlobField = record
Buffer: Pointer; // pointer to memory allocated for Blob data
Size: PtrInt; // size of Blob data
end;
{ TMDSBlobStream }
TMDSBlobStream = class(TStream)
private
FField : TBlobField;
FDataSet : TMemDataset;
FBlobField : TMDSBlobField;
FPosition : PtrInt;
FModified : boolean;
procedure AllocBlobField(NewSize: PtrInt);
procedure FreeBlobField;
public
constructor Create(Field: TField; Mode: TBlobStreamMode);
destructor Destroy; override;
function Seek(const Offset: int64; Origin: TSeekOrigin): int64; override;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
end;
Const
SizeRecInfo = SizeOf(TMTRecInfo);
SizeRecInfo = SizeOf(TMDSRecInfo);
procedure unsetfieldisnull(nullmask: pbyte; const x: integer);
@ -259,22 +292,110 @@ begin
S.WriteBuffer(Value[1],L);
end;
{ TMDSBlobStream }
constructor TMDSBlobStream.Create(Field: TField; Mode: TBlobStreamMode);
begin
FField := Field as TBlobField;
FDataSet := Field.DataSet as TMemDataset;
if not Field.GetData(@FBlobField) then // IsNull
begin
FBlobField.Buffer := nil;
FBlobField.Size := 0;
end;
if Mode = bmWrite then
// release existing Blob
FreeBlobField;
end;
destructor TMDSBlobStream.Destroy;
begin
if FModified then
begin
if FBlobField.Size = 0 then // Empty blob = IsNull
FField.SetData(nil)
else
FField.SetData(@FBlobField);
end;
inherited;
end;
procedure TMDSBlobStream.FreeBlobField;
begin
FDataSet.FBlobs.Remove(FBlobField.Buffer);
FreeMem(FBlobField.Buffer, FBlobField.Size);
FBlobField.Buffer := nil;
FBlobField.Size := 0;
FModified := True;
end;
procedure TMDSBlobStream.AllocBlobField(NewSize: PtrInt);
begin
FDataSet.FBlobs.Remove(FBlobField.Buffer);
ReAllocMem(FBlobField.Buffer, NewSize);
FDataSet.FBlobs.Add(FBlobField.Buffer);
FModified := True;
end;
function TMDSBlobStream.Seek(const Offset: int64; Origin: TSeekOrigin): int64;
begin
Case Origin of
soBeginning : FPosition := Offset;
soEnd : FPosition := FBlobField.Size + Offset;
soCurrent : FPosition := FPosition + Offset;
end;
Result := FPosition;
end;
function TMDSBlobStream.Read(var Buffer; Count: Longint): Longint;
var p: Pointer;
begin
if FPosition + Count > FBlobField.Size then
Count := FBlobField.Size - FPosition;
p := FBlobField.Buffer + FPosition;
Move(p^, Buffer, Count);
Inc(FPosition, Count);
Result := Count;
end;
function TMDSBlobStream.Write(const Buffer; Count: Longint): Longint;
var p: Pointer;
begin
AllocBlobField(FPosition+Count);
p := FBlobField.Buffer + FPosition;
Move(Buffer, p^, Count);
Inc(FBlobField.Size, Count);
Inc(FPosition, Count);
Result := Count;
end;
{ TMemDataset.TMDSBlobList }
procedure TMemDataset.TMDSBlobList.Clear;
var i: integer;
begin
for i:=0 to Count-1 do FreeMem(Items[i]);
inherited Clear;
end;
{ ---------------------------------------------------------------------
TMemDataset
---------------------------------------------------------------------}
constructor TMemDataset.Create(AOwner:tComponent);
constructor TMemDataset.Create(AOwner:TComponent);
begin
inherited create(aOwner);
inherited Create(AOwner);
FStream:=TMemoryStream.Create;
FRecCount:=0;
FRecSize:=0;
FRecInfoOffset:=0;
FCurrRecNo:=-1;
BookmarkSize := sizeof(Longint);
FIsOpen:=False;
FBlobs := TMDSBlobList.Create;
end;
destructor TMemDataset.Destroy;
@ -282,6 +403,8 @@ begin
FStream.Free;
FreeMem(FFieldOffsets);
FreeMem(FFieldSizes);
FBlobs.Clear;
FBlobs.Free;
inherited Destroy;
end;
@ -295,6 +418,20 @@ begin
Result := (ReqBookmark>=0) and (ReqBookmark<FRecCount);
end;
function TMemDataset.CreateBlobStream(Field: TField; Mode: TBlobStreamMode
): TStream;
begin
// Blobs are not saved to stream/file !
if Mode = bmWrite then
begin
if not (State in [dsEdit, dsInsert, dsFilter, dsCalcFields]) then
DatabaseErrorFmt(SNotEditing, [Name], Self);
if Field.ReadOnly and not (State in [dsSetKey, dsFilter]) then
DatabaseErrorFmt(SReadOnlyField, [Field.DisplayName]);
end;
Result := TMDSBlobStream.Create(Field, Mode);
end;
function TMemDataset.MDSGetRecordOffset(ARecNo: integer): longint;
begin
Result:=FRecSize*ARecNo
@ -302,7 +439,7 @@ end;
function TMemDataset.MDSGetFieldOffset(FieldNo: integer): integer;
begin
result:= getIntegerpointer(ffieldoffsets, fieldno-1)^;
Result:= getIntegerPointer(ffieldoffsets, fieldno-1)^;
end;
procedure TMemDataset.RaiseError(Fmt: String; Args: array of const);
@ -333,10 +470,12 @@ begin
ftTime,
ftDate: result:=SizeOf(TDateTime);
ftFmtBCD: result:=SizeOf(TBCD);
ftWideString,
ftFixedWideChar: result:=(FD.Size+1)*SizeOf(WideChar);
ftWideString, ftFixedWideChar:
result:=(FD.Size+1)*SizeOf(WideChar);
ftBytes: result := FD.Size;
ftVarBytes: result := FD.Size + SizeOf(Word);
ftBlob, ftMemo, ftWideMemo:
result := SizeOf(TMDSBlobField);
else
RaiseError(SErrFieldTypeNotSupported,[FD.Name]);
end;
@ -533,6 +672,7 @@ Var
begin
CheckMarker(F,smData);
Size:=ReadInteger(F);
FBlobs.Clear;
FStream.Clear;
FStream.CopyFrom(F,Size);
FRecCount:=Size div FRecSize;
@ -654,9 +794,8 @@ begin
FIsOpen:=False;
FFileModified:=False;
// BindFields(False);
if DefaultFields then begin
if DefaultFields then
DestroyFields;
end;
end;
procedure TMemDataset.InternalPost;
@ -872,6 +1011,7 @@ end;
procedure TMemDataset.Clear(ClearDefs : Boolean);
begin
FBlobs.Clear;
FStream.Clear;
FRecCount:=0;
FCurrRecNo:=-1;
@ -907,7 +1047,7 @@ begin
for i:= 0 to Count-1 do
begin
GetIntegerPointer(FFieldOffsets, i)^ := FRecSize;
GetIntegerPointer(FFieldSizes, i)^ := MDSGetbufferSize(i+1);
GetIntegerPointer(FFieldSizes, i)^ := MDSGetBufferSize(i+1);
FRecSize:= FRecSize+GetIntegerPointer(FFieldSizes, i)^;
end;
FRecInfoOffset:=FRecSize;
@ -918,10 +1058,7 @@ procedure TMemDataset.CreateTable;
begin
CheckInactive;
FStream.Clear;
FRecCount:=0;
FCurrRecNo:=-1;
FIsOpen:=False;
Clear(False);
calcrecordlayout;
FTableIsCreated:=True;
end;

14
packages/fcl-db/tests/memdstoolsunit.pas
View File

@ -7,7 +7,7 @@ interface
uses
Classes, SysUtils, toolsunit,
db,
Memds;
MemDS;
type
{ TMemDSConnector }
@ -81,7 +81,7 @@ begin
testTimeValues[2] := '23:59:59.000';
testTimeValues[3] := '23:59:59.003';
MemDs := TMemDataset.Create(nil);
MemDS := TMemDataset.Create(nil);
with MemDS do
begin
Name := 'FieldDataset';
@ -100,6 +100,11 @@ begin
FieldDefs.Add('FFIXEDCHAR',ftFixedChar,10);
FieldDefs.Add('FLARGEINT',ftLargeint);
FieldDefs.Add('FFMTBCD',ftFmtBCD);
FieldDefs.Add('FBLOB',ftBlob);
FieldDefs.Add('FMEMO',ftMemo);
FieldDefs.Add('FWIDESTRING',ftWideString);
FieldDefs.Add('FFIXEDWIDECHAR',ftFixedWideChar);
FieldDefs.Add('FWIDEMEMO',ftWideMemo);
CreateTable;
Open;
for i := 0 to testValuesCount-1 do
@ -120,6 +125,11 @@ begin
FieldByName('FFIXEDCHAR').AsString := PadRight(testStringValues[i], 10);
FieldByName('FLARGEINT').AsLargeInt := testLargeIntValues[i];
FieldByName('FFMTBCD').AsBCD := StrToBCD(testFmtBCDValues[i], Self.FormatSettings);
FieldByName('FBLOB').AsString := testValues[ftBlob, i];
FieldByName('FMEMO').AsString := testValues[ftMemo, i];
FieldByName('FWIDESTRING').AsWideString := testValues[ftWideString, i];
FieldByName('FFIXEDWIDECHAR').AsWideString := testValues[ftFixedWideChar, i];
FieldByName('FWIDEMEMO').AsWideString := testValues[ftWideMemo, i];
Post;
end;
Close;

2
packages/fcl-db/tests/testspecifictmemdataset.pas
View File

@ -10,7 +10,7 @@ interface
uses
Classes, SysUtils,
fpcunit, testregistry,
testregistry,
ToolsUnit;
type