paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-15 17:19:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Implemented TBufDataset.IndexFieldNames (+test)

Browse Source 
* Fixed some db-error messages

git-svn-id: trunk@10006 -
This commit is contained in:
joost 2008-01-26 23:37:04 +00:00
parent 35abcb60f3
commit 3bc2f94398
3 changed files with 141 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
packages/fcl-db/src/base/bufdataset.pas
View File

@ -170,11 +170,13 @@ type
{$ENDIF}
function GetCurrentBuffer: PChar;
procedure CalcRecordSize;
function GetIndexFieldNames: String;
function GetIndexName: String;
procedure InitialiseIndex(AIndex: TBufIndex);
function LoadBuffer(Buffer : PChar): TGetResult;
function GetFieldSize(FieldDef : TFieldDef) : longint;
function GetRecordUpdateBuffer : boolean;
procedure SetIndexFieldNames(const AValue: String);
procedure SetIndexName(AValue: String);
{$IFNDEF ARRAYBUF}
procedure SetMaxIndexesCount(const AValue: Integer);
@ -251,6 +253,7 @@ type
property OnUpdateError: TResolverErrorEvent read FOnUpdateError write SetOnUpdateError;
property IndexDefs : TIndexDefs read GetIndexDefs;
property IndexName : String read GetIndexName write SetIndexName;
property IndexFieldNames : String read GetIndexFieldNames write SetIndexFieldNames;
end;
implementation
@ -350,6 +353,7 @@ begin
{$ENDIF}
FIndexesCount:=0;
InternalAddIndex('DEFAULT_ORDER','');
InternalAddIndex('','');
FCurrentIndex:=@FIndexes[0];
FIndexDefs := TIndexDefs.Create(Self);
@ -409,7 +413,11 @@ var PCurRecLinkItem : PBufRecLinkItem;
begin
// This simply copies the index...
if not assigned(AIndex.Fields) then
AIndex.Fields := FieldByName(AIndex.FieldsName);
begin
AIndex.Fields := FindField(AIndex.FieldsName);
if not assigned(AIndex.Fields) then
DatabaseErrorFmt(SErrIndexBasedOnUnkField,[AIndex.FieldsName]);
end;
{$IFNDEF ARRAYBUF}
case AIndex.Fields.DataType of
ftString : Comparefunc := @DBCompareText;
@ -891,6 +899,23 @@ begin
Result := (FCurrentUpdateBuffer < length(FUpdateBuffer)) and CompareBuf(FCurrentUpdateBuffer);
end;
procedure TBufDataset.SetIndexFieldNames(const AValue: String);
begin
if AValue<>'' then
begin
FIndexes[1].Fields := nil;
FIndexes[1].FieldsName:=AValue;
FCurrentIndex:=@FIndexes[1];
if active then
begin
BuildIndex(FIndexes[1]);
Resync([rmCenter]);
end;
end
else
SetIndexName('');
end;
procedure TBufDataset.SetIndexName(AValue: String);
var i : integer;
begin
@ -1145,8 +1170,11 @@ begin
FAllPacketsFetched := True;
if FIndexesCount>0 then for x := 1 to FIndexesCount-1 do
begin
BuildIndex(FIndexes[x]);
FIndexes[x].FCurrentRecBuf:=FIndexes[x].FFirstRecBuf;
if not ((x=1) and (FIndexes[1].FieldsName='')) then
begin
BuildIndex(FIndexes[x]);
FIndexes[x].FCurrentRecBuf:=FIndexes[x].FFirstRecBuf;
end;
end;
Exit;
end;
@ -1702,6 +1730,14 @@ begin
end;
end;
function TBufDataset.GetIndexFieldNames: String;
begin
if FCurrentIndex<>@FIndexes[1] then
result := ''
else
result := FCurrentIndex^.FieldsName;
end;
function TBufDataset.GetIndexName: String;
begin
result := FCurrentIndex^.Name;
@ -1954,7 +1990,7 @@ begin
if AFields='' then DatabaseError(SNoIndexFieldNameGiven);
{$IFNDEF ARRAYBUF}
if active and (FIndexesCount=FMaxIndexesCount-1) then
if active and (FIndexesCount=FMaxIndexesCount) then
DatabaseError(SMaxIndexes);
{$ENDIF}

2
packages/fcl-db/src/sqldb/sqldb.pp
View File

@ -1920,7 +1920,7 @@ end;
constructor TServerIndexDefs.create(ADataset: TDataset);
begin
if not (ADataset is TCustomSQLQuery) then
DatabaseError(SErrNotASQLQuery);
DatabaseErrorFmt(SErrNotASQLQuery,[ADataset.Name]);
inherited create(ADataset);
end;

100
packages/fcl-db/tests/testdbbasics.pas
View File

@ -53,6 +53,9 @@ type
procedure TestAddIndexActiveDS;
procedure TestAddIndexEditDS;
procedure TestIndexFieldNames;
procedure TestIndexFieldNamesAct;
procedure TestNullAtOpen;
procedure TestSupportIntegerFields;
@ -1002,6 +1005,103 @@ begin
end;
end;
procedure TTestDBBasics.TestIndexFieldNamesAct;
var ds : TBufDataset;
AFieldType : TFieldType;
FList : TStringList;
i : integer;
begin
ds := DBConnector.GetFieldDataset as TBufDataset;
with ds do
begin
AFieldType:=ftString;
FList := TStringList.Create;
FList.Sorted:=true;
FList.CaseSensitive:=True;
FList.Duplicates:=dupAccept;
open;
while not eof do
begin
flist.Add(FieldByName('F'+FieldTypeNames[AfieldType]).AsString);
Next;
end;
IndexFieldNames:='F'+FieldTypeNames[AfieldType];
first;
i:=0;
while not eof do
begin
AssertEquals(flist[i],FieldByName('F'+FieldTypeNames[AfieldType]).AsString);
inc(i);
Next;
end;
while not bof do
begin
dec(i);
AssertEquals(flist[i],FieldByName('F'+FieldTypeNames[AfieldType]).AsString);
Prior;
end;
AssertEquals('F'+FieldTypeNames[AfieldType],IndexFieldNames);
IndexFieldNames:='ID';
first;
i:=0;
while not eof do
begin
AssertEquals(testStringValues[i],FieldByName('F'+FieldTypeNames[AfieldType]).AsString);
inc(i);
Next;
end;
AssertEquals('ID',IndexFieldNames);
IndexFieldNames:='';
first;
i:=0;
while not eof do
begin
AssertEquals(testStringValues[i],FieldByName('F'+FieldTypeNames[AfieldType]).AsString);
inc(i);
Next;
end;
AssertEquals('',IndexFieldNames);
end;
end;
procedure TTestDBBasics.TestIndexFieldNames;
var ds : TBufDataset;
AFieldType : TFieldType;
PrevValue : String;
begin
ds := DBConnector.GetFieldDataset as TBufDataset;
with ds do
begin
AFieldType:=ftString;
IndexFieldNames:='F'+FieldTypeNames[AfieldType];
open;
PrevValue:='';
while not eof do
begin
AssertTrue(FieldByName('F'+FieldTypeNames[AfieldType]).AsString>=PrevValue);
PrevValue:=FieldByName('F'+FieldTypeNames[AfieldType]).AsString;
Next;
end;
AssertEquals('F'+FieldTypeNames[AfieldType],IndexFieldNames);
end;
end;
procedure TTestDBBasics.TestcalculatedField_OnCalcfields(DataSet: TDataSet);
begin