mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-09-06 16:50:25 +02:00
+ Added Checks for all simple field types.
+ Initial implementation of Insert/Append
This commit is contained in:
michael
parent
2c4cddd82d
commit
056d6d2716
@ -16,6 +16,8 @@
|
||||
**********************************************************************}
|
||||
program createds;
|
||||
|
||||
{$mode delphi}
|
||||
|
||||
uses ddg_rec,sysutils;
|
||||
|
||||
Type IndexFile = File Of Longint;
|
||||
@ -41,9 +43,18 @@ begin
|
||||
For I:=1 to 100 do
|
||||
begin
|
||||
S:=Format('This is person %d.',[i]);
|
||||
ARec.Name:=S;
|
||||
ARec.ShoeSize:=I;
|
||||
ARec.height:=I*0.001;
|
||||
With Arec Do
|
||||
begin
|
||||
Name:=S;
|
||||
height:=I*0.001;
|
||||
LongField:=i*4;
|
||||
ShoeSize:=I;
|
||||
WordField:=i*2;
|
||||
DateTimeField:=Now;
|
||||
TimeField:=Time;
|
||||
DateField:=Date;
|
||||
Even:=(I mod 2) = 0
|
||||
end;
|
||||
Write(F,ARec);
|
||||
end;
|
||||
Close(F);
|
||||
@ -55,7 +66,11 @@ begin
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 1999-10-24 17:07:54 michael
|
||||
Revision 1.3 1999-11-11 17:31:09 michael
|
||||
+ Added Checks for all simple field types.
|
||||
+ Initial implementation of Insert/Append
|
||||
|
||||
Revision 1.2 1999/10/24 17:07:54 michael
|
||||
+ Added copyright header
|
||||
|
||||
}
|
||||
@ -272,10 +272,22 @@ begin
|
||||
FDefaultFields:=FieldCount=0;
|
||||
DoBeforeOpen;
|
||||
Try
|
||||
{$ifdef dsdebug}
|
||||
Writeln ('Calling internal open');
|
||||
{$endif}
|
||||
InternalOpen;
|
||||
FBOF:=True;
|
||||
{$ifdef dsdebug}
|
||||
Writeln ('Setting state to browse');
|
||||
{$endif}
|
||||
SetState(dsBrowse);
|
||||
{$ifdef dsdebug}
|
||||
Writeln ('Setting buffer size');
|
||||
{$endif}
|
||||
SetBufListSize(DefaultBufferCount);
|
||||
{$ifdef dsdebug}
|
||||
Writeln ('Getting next records');
|
||||
{$endif}
|
||||
GetNextRecords;
|
||||
DoAfterOpen;
|
||||
DoAfterScroll;
|
||||
@ -366,7 +378,7 @@ end;
|
||||
function TDataset.GetCanModify: Boolean;
|
||||
|
||||
begin
|
||||
//!! To be implemented
|
||||
Result:=True;
|
||||
end;
|
||||
|
||||
procedure TDataset.GetChildren(Proc: TGetChildProc; Root: TComponent);
|
||||
@ -416,9 +428,9 @@ begin
|
||||
Case FieldType of
|
||||
ftUnknown : Result:=Tfield;
|
||||
ftString: Result := TStringField;
|
||||
ftSmallint: Result := TLongIntField;
|
||||
ftSmallint: Result := TSmallIntField;
|
||||
ftInteger: Result := TLongintField;
|
||||
ftWord: Result := TLongintField;
|
||||
ftWord: Result := TWordField;
|
||||
ftBoolean: Result := TBooleanField;
|
||||
ftFloat: Result := TFloatField;
|
||||
ftDate: Result := TDateField;
|
||||
@ -455,7 +467,7 @@ begin
|
||||
Shifted:=FRecordCount=FBufferCount;
|
||||
If Shifted then
|
||||
begin
|
||||
ShiftBuffers(1);
|
||||
ShiftBuffers(0,1);
|
||||
Dec(FRecordCount);
|
||||
end;
|
||||
{$ifdef dsdebug}
|
||||
@ -475,7 +487,7 @@ begin
|
||||
begin
|
||||
if shifted then
|
||||
begin
|
||||
ShiftBuffers(-1);
|
||||
ShiftBuffers(0,-1);
|
||||
inc(FRecordCount);
|
||||
end;
|
||||
CursorPosChanged;
|
||||
@ -511,7 +523,7 @@ begin
|
||||
If Shifted Then
|
||||
begin
|
||||
SetCurrentRecord(0);
|
||||
ShiftBuffers(-1);
|
||||
ShiftBuffers(0,-1);
|
||||
end;
|
||||
Result:=GetRecord(FBuffers[0],gmPrior,True)=grOK;
|
||||
If Result then
|
||||
@ -529,7 +541,7 @@ begin
|
||||
begin
|
||||
If Shifted then
|
||||
begin
|
||||
ShiftBuffers(1);
|
||||
ShiftBuffers(0,1);
|
||||
end;
|
||||
CursorPosChanged;
|
||||
end;
|
||||
@ -641,11 +653,26 @@ begin
|
||||
Value:=I;
|
||||
If Value>FBufferCount then
|
||||
begin
|
||||
{$ifdef dsdebug}
|
||||
Writeln ('Reallocating memory :',(Value+1)*SizeOf(PChar));
|
||||
{$endif}
|
||||
ReAllocMem(FBuffers,(Value+1)*SizeOf(PChar));
|
||||
FillChar(FBuffers[FBufferCount+1],(Value-FBufferCount)*SizeOF(Pchar),#0);
|
||||
{$ifdef dsdebug}
|
||||
Writeln ('Filling memory :',(Value-FBufferCount)*SizeOf(PChar));
|
||||
{$endif}
|
||||
FillChar(FBuffers[FBufferCount],(Value+1-FBufferCount)*SizeOF(Pchar),#0);
|
||||
{$ifdef dsdebug}
|
||||
Writeln ('Filled memory :');
|
||||
{$endif}
|
||||
Try
|
||||
{$ifdef dsdebug}
|
||||
Writeln ('Assigning buffers :',(Value+1)*SizeOf(PChar));
|
||||
{$endif}
|
||||
For I:=FBufferCount to Value do
|
||||
FBuffers[i]:=AllocRecordBuffer;
|
||||
{$ifdef dsdebug}
|
||||
Writeln ('Assigned buffers :',(Value+1)*SizeOf(PChar));
|
||||
{$endif}
|
||||
except
|
||||
I:=FBufferCount;
|
||||
While (I<=Value) and (FBuffers[i]<>Nil) do
|
||||
@ -676,7 +703,9 @@ procedure TDataset.SetCurrentRecord(Index: Longint);
|
||||
begin
|
||||
If FCurrentRecord<>Index then
|
||||
begin
|
||||
{$ifdef DSdebug}
|
||||
Writeln ('Setting current record to',index);
|
||||
{$endif}
|
||||
Case GetBookMarkFlag(FBuffers[Index]) of
|
||||
bfCurrent : InternalSetToRecord(FBuffers[Index]);
|
||||
bfBOF : InternalFirst;
|
||||
@ -788,14 +817,12 @@ end;
|
||||
|
||||
procedure TDataset.Append;
|
||||
|
||||
|
||||
begin
|
||||
//!! To be implemented
|
||||
DoInsertAppend(True);
|
||||
end;
|
||||
|
||||
procedure TDataset.AppendRecord(const Values: array of const);
|
||||
|
||||
|
||||
begin
|
||||
//!! To be implemented
|
||||
end;
|
||||
@ -838,14 +865,12 @@ end;
|
||||
|
||||
procedure TDataset.Close;
|
||||
|
||||
|
||||
begin
|
||||
Active:=False;
|
||||
end;
|
||||
|
||||
function TDataset.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Longint;
|
||||
|
||||
|
||||
begin
|
||||
Result:=0;
|
||||
end;
|
||||
@ -878,11 +903,76 @@ begin
|
||||
//!! To be implemented
|
||||
end;
|
||||
|
||||
procedure TDataset.DoInsertAppend(DoAppend : Boolean);
|
||||
|
||||
Var Buffer : PChar;
|
||||
BookBeforeInsert : TBookmarkStr;
|
||||
begin
|
||||
If Not CanModify then
|
||||
DatabaseError(SDatasetReadOnly,Self);
|
||||
CheckBrowseMode;
|
||||
DoBeforeInsert;
|
||||
DoBeforeScroll;
|
||||
If Not DoAppend then
|
||||
begin
|
||||
// need to scroll up al buffers after current one,
|
||||
// but copy current bookmark to insert buffer.
|
||||
BookBeforeInsert:=Bookmark;
|
||||
ShiftBuffers(FActiveRecord,1);
|
||||
// Active buffer is now edit buffer. Initialize.
|
||||
InitRecord(ActiveBuffer);
|
||||
// Put bookmark in edit buffer.
|
||||
if FRecordCount=0 then
|
||||
SetBookmarkFlag(ActiveBuffer,bfBOF)
|
||||
else
|
||||
SetBookMarkData(ActiveBuffer,Pointer(BookBeforeInsert));
|
||||
// update buffer count.
|
||||
If FRecordCount<FBufferCount then
|
||||
Inc(FRecordCount);
|
||||
end
|
||||
else
|
||||
// Tricky, need to get last record and scroll down.
|
||||
begin
|
||||
Buffer:=FBuffers[0];
|
||||
InitRecord(Buffer);
|
||||
// just mark buffer as last. GetPreviousrecords will do an internallast
|
||||
// Because of this...
|
||||
SetBookMarkFlag(Buffer,bfEOF);
|
||||
FRecordCount:=1;
|
||||
GetPriorRecords;
|
||||
end;
|
||||
SetState(dsInsert);
|
||||
try
|
||||
DoOnNewRecord;
|
||||
except
|
||||
UpdateCursorPos;
|
||||
resync([]);
|
||||
raise;
|
||||
end;
|
||||
// mark as not modified.
|
||||
FModified:=False;
|
||||
// Final events.
|
||||
DoAfterInsert;
|
||||
DoAfterScroll;
|
||||
end;
|
||||
|
||||
procedure TDataset.Edit;
|
||||
|
||||
|
||||
begin
|
||||
//!! To be implemented
|
||||
If Not CanModify then
|
||||
DatabaseError(SDatasetReadOnly,Self);
|
||||
If State in [dsedit,dsinsert] then exit;
|
||||
If FRecordCount = 0 then
|
||||
begin
|
||||
Insert;
|
||||
Exit;
|
||||
end;
|
||||
CheckBrowseMode;
|
||||
DoBeforeEdit;
|
||||
If Not TryDoing(@InternalEdit,OnEditError) then
|
||||
exit;
|
||||
SetState(dsedit);
|
||||
DoAfterEdit;
|
||||
end;
|
||||
|
||||
procedure TDataset.EnableControls;
|
||||
@ -1009,9 +1099,8 @@ end;
|
||||
|
||||
procedure TDataset.Insert;
|
||||
|
||||
|
||||
begin
|
||||
//!! To be implemented
|
||||
DoInsertAppend(False);
|
||||
end;
|
||||
|
||||
procedure TDataset.InsertRecord(const Values: array of const);
|
||||
@ -1185,7 +1274,7 @@ begin
|
||||
// keep current position.
|
||||
ShiftCount:=FActiveRecord;
|
||||
// Reposition on 0
|
||||
ShiftBuffers(FRecordCount-1);
|
||||
ShiftBuffers(0,FRecordCount-1);
|
||||
ActivateBuffers;
|
||||
Count:=0;
|
||||
Writeln ('Getting previous',ShiftCount,' records');
|
||||
@ -1215,6 +1304,32 @@ begin
|
||||
//!! To be implemented
|
||||
end;
|
||||
|
||||
Function Tdataset.TryDoing (P : TDataOperation; Ev : TDatasetErrorEvent) : Boolean;
|
||||
|
||||
Var Retry : TDataAction;
|
||||
|
||||
begin
|
||||
Result:=True;
|
||||
Retry:=daRetry;
|
||||
while Retry=daRetry do
|
||||
Try
|
||||
P;
|
||||
except
|
||||
On E : EDatabaseError do
|
||||
begin
|
||||
retry:=daFail;
|
||||
If Assigned(Ev) then
|
||||
Ev(Self,E,Retry);
|
||||
Case Retry of
|
||||
daFail : Raise;
|
||||
daAbort : Result:=False;
|
||||
end;
|
||||
end;
|
||||
else
|
||||
Raise;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDataset.UpdateCursorPos;
|
||||
|
||||
begin
|
||||
@ -1239,7 +1354,7 @@ begin
|
||||
Result:=FFieldList.Count;
|
||||
end;
|
||||
|
||||
Procedure TDataset.ShiftBuffers (Distance : longint);
|
||||
Procedure TDataset.ShiftBuffers (Offset, Distance : longint);
|
||||
|
||||
Var Temp : Pointer;
|
||||
MoveSize : Longint;
|
||||
@ -1247,12 +1362,12 @@ Var Temp : Pointer;
|
||||
Procedure ShiftBuffersUp;
|
||||
begin
|
||||
{$ifdef DSDEBUG}
|
||||
writeln ('Shifting buffers up with distance :',Distance);
|
||||
writeln ('Shifting buffers up from ',OffSet,' with distance :',Distance);
|
||||
writeln ('Moving ',(FBufferCount-Distance), ' Buffers at ',Distance);
|
||||
{$endif}
|
||||
Move(FBuffers[0],Temp^,MoveSize);
|
||||
Move(FBuffers[Distance],FBuffers[0],(FBufferCount-Distance)*SizeOf(Pchar));
|
||||
Move(Temp^,FBuffers[FBufferCount-Distance],MoveSize);
|
||||
Move(FBuffers[Offset],Temp^,MoveSize);
|
||||
Move(FBuffers[Offset+Distance],FBuffers[Offset],(FBufferCount-Distance-Offset)*SizeOf(Pchar));
|
||||
Move(Temp^,FBuffers[FBufferCount-Distance-Offset],MoveSize);
|
||||
end;
|
||||
|
||||
Procedure ShiftBuffersDown;
|
||||
@ -1284,7 +1399,11 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.3 1999-11-09 13:33:47 peter
|
||||
Revision 1.4 1999-11-11 17:31:09 michael
|
||||
+ Added Checks for all simple field types.
|
||||
+ Initial implementation of Insert/Append
|
||||
|
||||
Revision 1.3 1999/11/09 13:33:47 peter
|
||||
* reallocmem fixes
|
||||
|
||||
Revision 1.2 1999/10/24 17:07:54 michael
|
||||
|
||||
10
fcl/db/db.pp
10
fcl/db/db.pp
@ -769,6 +769,7 @@ type
|
||||
FRecordCount: Longint;
|
||||
FRecordSize: Word;
|
||||
FState: TDataSetState;
|
||||
Procedure DoInsertAppend(DoAppend : Boolean);
|
||||
Procedure DoInternalOpen;
|
||||
Procedure DoInternalClose;
|
||||
Function GetBuffer (Index : longint) : Pchar;
|
||||
@ -776,7 +777,8 @@ type
|
||||
Procedure RemoveField (Field : TField);
|
||||
Procedure SetActive (Value : Boolean);
|
||||
Procedure SetField (Index : Longint;Value : TField);
|
||||
Procedure ShiftBuffers (Distance : Longint);
|
||||
Procedure ShiftBuffers (Offset,Distance : Longint);
|
||||
Function TryDoing (P : TDataOperation; Ev : TDatasetErrorEvent) : Boolean;
|
||||
Procedure UpdateFieldDefs;
|
||||
protected
|
||||
procedure ActivateBuffers; virtual;
|
||||
@ -1256,7 +1258,11 @@ end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.3 1999-11-09 13:33:47 peter
|
||||
Revision 1.4 1999-11-11 17:31:09 michael
|
||||
+ Added Checks for all simple field types.
|
||||
+ Initial implementation of Insert/Append
|
||||
|
||||
Revision 1.3 1999/11/09 13:33:47 peter
|
||||
* reallocmem fixes
|
||||
|
||||
Revision 1.2 1999/10/24 17:07:54 michael
|
||||
|
||||
@ -40,10 +40,15 @@ Const
|
||||
SNotConnected = 'Operation cannot be performed on an disconnected database';
|
||||
SConnected = 'Operation cannot be performed on an connected database';
|
||||
SNoSuchRecord = 'Could not find the requested record.';
|
||||
SDatasetReadOnly = 'Dataset is read-only.';
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 1999-10-24 17:07:54 michael
|
||||
Revision 1.3 1999-11-11 17:31:09 michael
|
||||
+ Added Checks for all simple field types.
|
||||
+ Initial implementation of Insert/Append
|
||||
|
||||
Revision 1.2 1999/10/24 17:07:54 michael
|
||||
+ Added copyright header
|
||||
|
||||
}
|
||||
@ -1,5 +1,7 @@
|
||||
unit DDG_DS;
|
||||
|
||||
{$define dsdebug}
|
||||
|
||||
interface
|
||||
|
||||
uses Db, Classes, DDG_Rec;
|
||||
@ -251,7 +253,13 @@ begin
|
||||
Result := PChar(Buffer)^ <> #0;
|
||||
end;
|
||||
1: Move(PDDGData(ActiveBuffer)^.Height, Buffer^, Field.DataSize);
|
||||
2: Move(PDDGData(ActiveBuffer)^.ShoeSize, Buffer^, Field.DataSize);
|
||||
2: Move(PDDGData(ActiveBuffer)^.LongField, Buffer^, Field.DataSize);
|
||||
3: Move(PDDGData(ActiveBuffer)^.ShoeSize, Buffer^, Field.DataSize);
|
||||
4: Move(PDDGData(ActiveBuffer)^.WordField, Buffer^, Field.DataSize);
|
||||
5: Move(PDDGData(ActiveBuffer)^.DateTimeField, Buffer^, Field.DataSize);
|
||||
6: Move(PDDGData(ActiveBuffer)^.TimeField, Buffer^, Field.DataSize);
|
||||
7: Move(PDDGData(ActiveBuffer)^.DateField, Buffer^, Field.DataSize);
|
||||
8: Move(PDDGData(ActiveBuffer)^.Even, Buffer^, Field.DataSize);
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -308,7 +316,13 @@ begin
|
||||
FieldDefs.Clear;
|
||||
TFieldDef.Create(FieldDefs, 'Name', ftString, SizeOf(TNameStr), False, 1);
|
||||
TFieldDef.Create(FieldDefs, 'Height', ftFloat, 0, False, 2);
|
||||
TFieldDef.Create(FieldDefs, 'ShoeSize', ftInteger, 0, False, 3);
|
||||
TFieldDef.Create(FieldDefs, 'LongField',ftInteger, 0, False, 3);
|
||||
TFieldDef.Create(FieldDefs, 'ShoeSize', ftSmallint, 0, False, 4);
|
||||
TFieldDef.Create(FieldDefs, 'WordField', ftword, 0, false, 5);
|
||||
TFieldDef.Create(FieldDefs, 'DateTimeField', ftDateTime, 0, false, 6);
|
||||
TFieldDef.Create(FieldDefs, 'TimeField',ftTime, 0, false, 7);
|
||||
TFieldDef.Create(FieldDefs, 'DateField',ftDate, 0, false, 8);
|
||||
TFieldDef.Create(FieldDefs, 'Booleanfield',ftboolean, 0, False, 9);
|
||||
end;
|
||||
|
||||
procedure TDDGDataSet.InternalLast;
|
||||
@ -396,13 +410,25 @@ begin
|
||||
BookmarkSize := SizeOf(Integer); // initialize bookmark size for VCL
|
||||
InternalInitFieldDefs; // initialize FieldDef objects
|
||||
// Create TField components when no persistent fields have been created
|
||||
{$ifdef dsdebug}
|
||||
writeln ('Creating Fields');
|
||||
{$endif}
|
||||
if DefaultFields then CreateFields;
|
||||
{$ifdef dsdebug}
|
||||
writeln ('Binding Fields');
|
||||
{$endif}
|
||||
BindFields(True); // bind FieldDefs to actual data
|
||||
except
|
||||
{$ifdef dsdebug}
|
||||
Writeln ('Caught Exception !!');
|
||||
{$endif}
|
||||
CloseFile(FDataFile);
|
||||
FillChar(FDataFile, SizeOf(FDataFile), 0);
|
||||
raise;
|
||||
end;
|
||||
{$ifdef dsdebug}
|
||||
Writeln ('End of internalopen');
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
procedure TDDGDataSet.InternalPost;
|
||||
|
||||
@ -2,6 +2,8 @@ unit DDG_Rec;
|
||||
|
||||
interface
|
||||
|
||||
uses sysutils;
|
||||
|
||||
type
|
||||
|
||||
// arbitary-length array of char used for name field
|
||||
@ -12,7 +14,13 @@ type
|
||||
TDDGData = record
|
||||
Name: TNameStr;
|
||||
Height: Extended;
|
||||
ShoeSize: Integer;
|
||||
LongField : Longint;
|
||||
ShoeSize: SmallInt;
|
||||
WordField : Word;
|
||||
DatetimeField : TDateTime;
|
||||
TimeField : TDateTime;
|
||||
DateField : TDateTime;
|
||||
Even : Boolean;
|
||||
end;
|
||||
|
||||
// Pascal file of record which holds "table" data:
|
||||
|
||||
@ -1030,6 +1030,7 @@ constructor TBooleanField.Create(AOwner: TComponent);
|
||||
|
||||
begin
|
||||
Inherited Create(AOwner);
|
||||
SetDataType(ftBoolean);
|
||||
DisplayValues:='True;False';
|
||||
end;
|
||||
|
||||
@ -1734,7 +1735,11 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 1999-10-24 17:07:54 michael
|
||||
Revision 1.3 1999-11-11 17:31:09 michael
|
||||
+ Added Checks for all simple field types.
|
||||
+ Initial implementation of Insert/Append
|
||||
|
||||
Revision 1.2 1999/10/24 17:07:54 michael
|
||||
+ Added copyright header
|
||||
|
||||
}
|
||||
@ -44,6 +44,7 @@ Procedure DumpField(F : Tfield);
|
||||
begin
|
||||
With F do
|
||||
begin
|
||||
writeln ('-------------------------------------');
|
||||
Writeln ('FieldName : ',FieldName);
|
||||
Writeln ('FieldNo : ',FieldNo);
|
||||
Writeln ('Index : ',Index);
|
||||
@ -87,6 +88,7 @@ begin
|
||||
With Data do
|
||||
While NOT EOF do
|
||||
begin
|
||||
Writeln ('================================================');
|
||||
For I:=0 to FieldCount-1 do
|
||||
DumpFieldData(Fields[I]);
|
||||
Next;
|
||||
@ -176,7 +178,11 @@ begin
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 1999-10-24 17:07:54 michael
|
||||
Revision 1.3 1999-11-11 17:31:09 michael
|
||||
+ Added Checks for all simple field types.
|
||||
+ Initial implementation of Insert/Append
|
||||
|
||||
Revision 1.2 1999/10/24 17:07:54 michael
|
||||
+ Added copyright header
|
||||
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user