unit DBFToolsUnit; { Sets up dbf datasets for testing Tests expect Get*Dataset to return a dataset with structure and test data, but closed. } {$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF} // If defined, save the dbf files when done and print out location to stdout: {.$DEFINE KEEPDBFFILES} interface uses Classes, SysUtils, toolsunit, DB, Dbf, dbf_common; type { TDBFDBConnector } TDBFDBConnector = class(TDBConnector) protected procedure CreateNDatasets; override; procedure CreateFieldDataset; override; procedure DropNDatasets; override; procedure DropFieldDataset; override; // InternalGetNDataset reroutes to ReallyInternalGetNDataset function InternalGetNDataset(n: integer): TDataset; override; function InternalGetFieldDataset: TDataSet; override; // GetNDataset allowing trace dataset if required; // if trace is on, use a TDbfTraceDataset instead of TDBFAutoClean function ReallyInternalGetNDataset(n: integer; Trace: boolean): TDataset; public function GetTraceDataset(AChange: boolean): TDataset; override; end; { TDBFAutoClean } // DBF descendant that saves to a memory stream instead of file TDBFAutoClean = class(TDBF) private FBackingStream: TMemoryStream; FIndexBackingStream: TMemoryStream; FMemoBackingStream: TMemoryStream; FCreatedBy: string; public // Keeps track of which function created the dataset, useful for troubleshooting property CreatedBy: string read FCreatedBy write FCreatedBy; constructor Create; constructor Create(AOwner: TComponent); override; destructor Destroy; override; function UserRequestedTableLevel: integer; end; { TDbfTraceDataset } TDbfTraceDataset = class(TdbfAutoClean) protected procedure SetCurrentRecord(Index: longint); override; procedure RefreshInternalCalcFields(Buffer: PChar); override; procedure InternalInitFieldDefs; override; procedure CalculateFields(Buffer: PChar); override; procedure ClearCalcFields(Buffer: PChar); override; end; implementation uses FmtBCD; function GetNewTempDBFName: string; // Scans temp directory for dbf names and adds var Res: TSearchRec; Path, Name: string; FileAttr: LongInt; Attr,NextFileNo: Integer; begin NextFileNo:=0; Attr := faAnyFile; if FindFirst(IncludeTrailingPathDelimiter(GetTempDir)+'*.dbf', Attr, Res) = 0 then begin Path := GetTempDir; repeat Name := ConcatPaths([Path, Res.Name]); FileAttr := FileGetAttr(Name); if FileAttr and faDirectory = 0 then begin // Capture alphabetically latest name try //... only if it is numeric if strtoint(ChangeFileExt(Res.Name,''))>NextFileNo then NextFileNo:=strtoint(ChangeFileExt(Res.Name,'')); except // apparently not numeric end; end until FindNext(Res) <> 0; end; FindClose(Res); // now we now the latest file, add 1, and paste the temp directory in front of it NextFileNo:=NextFileNo+1; Result:=IncludeTrailingPathDelimiter(GetTempDir)+IntToStr(NextFileNo)+'.DBF'; end; { TDBFAutoClean } function TDBFAutoClean.UserRequestedTableLevel: integer; // User can specify table level as a connector param, e.g.: // connectorparams=4 // If none given, default to DBase IV var TableLevelProvided: integer; begin TableLevelProvided := StrToIntDef(dbconnectorparams, 4); if not (TableLevelProvided in [3, 4, 5, 7, TDBF_TABLELEVEL_FOXPRO, TDBF_TABLELEVEL_VISUALFOXPRO]) then begin Result := -1; // hope this crashes the tests so user is alerted. //Invalid tablelevel specified in connectorparams= field. Aborting exit; end; Result := TableLevelProvided; end; constructor TDBFAutoClean.Create; begin // Create storage for data: FBackingStream:=TMemoryStream.Create; FIndexBackingStream:=TMemoryStream.Create; FMemoBackingStream:=TMemoryStream.Create; // Create a unique name (within the 10 character DBIII limit): TableName := FormatDateTime('hhnnssz',Now())+'_'+inttostr(random(99)); TableLevel := UserRequestedTableLevel; Storage:=stoMemory; UserStream:=FBackingStream; UserIndexStream:=FIndexBackingStream; UserMemoStream:=FMemoBackingStream; CreateTable; //this will also write out the dbf header to disk/stream end; constructor TDBFAutoClean.Create(AOwner: TComponent); begin inherited Create(AOwner); Self.Create; end; destructor TDBFAutoClean.Destroy; {$IFDEF KEEPDBFFILES} var FileName: string; {$ENDIF} begin {$IFDEF KEEPDBFFILES} Close; FileName := GetNewTempDBFName; FBackingStream.SaveToFile(FileName); FIndexBackingStream.SaveToFile(ChangeFileExt(FileName, '.mdx')); if Self.TableLevel in [TDBF_TABLELEVEL_FOXPRO, TDBF_TABLELEVEL_VISUALFOXPRO] then FMemoBackingStream.SaveToFile(ChangeFileExt(FileName, '.fpt')) else FMemoBackingStream.SaveToFile(ChangeFileExt(FileName, '.dbt')); writeln('TDBFAutoClean: file created by ',CreatedBy,' left file: ',FileName); {$ENDIF} inherited Destroy; FBackingStream.Free; FIndexBackingStream.Free; end; procedure TDBFDBConnector.CreateNDatasets; begin // All datasets are created in InternalGet*Dataset end; procedure TDBFDBConnector.CreateFieldDataset; begin // All datasets are created in InternalGet*Dataset end; procedure TDBFDBConnector.DropNDatasets; begin // Nothing to be done here; the dataset is cleaned up in TDBFAutoClean.Destroy end; procedure TDBFDBConnector.DropFieldDataset; begin // Nothing to be done here; the dataset is cleaned up in TDBFAutoClean.Destroy end; function TDBFDBConnector.InternalGetNDataset(n: integer): TDataset; begin result:=ReallyInternalGetNDataset(n,false); end; function TDBFDBConnector.InternalGetFieldDataset: TDataSet; var i: integer; begin Result := (TDbfAutoClean.Create(nil) as TDataSet); with (Result as TDBFAutoClean) do begin CreatedBy:='InternalGetFieldDataset'; FieldDefs.Add('ID', ftInteger); FieldDefs.Add('FSTRING', ftString, 10); FieldDefs.Add('FSMALLINT', ftSmallint); FieldDefs.Add('FINTEGER', ftInteger); FieldDefs.Add('FWORD', ftWord); FieldDefs.Add('FBOOLEAN', ftBoolean); FieldDefs.Add('FFLOAT', ftFloat); // Field types only available in (Visual) FoxPro if (Result as TDBF).TableLevel >= TDBF_TABLELEVEL_FOXPRO then FieldDefs.Add('FCURRENCY', ftCurrency); if (Result as TDBF).TableLevel >= TDBF_TABLELEVEL_FOXPRO then FieldDefs.Add('FBCD', ftBCD); FieldDefs.Add('FDATE', ftDate); FieldDefs.Add('FDATETIME', ftDateTime); FieldDefs.Add('FLARGEINT', ftLargeint); FieldDefs.Add('FMEMO', ftMemo); CreateTable; Open; for i := 0 to testValuesCount - 1 do begin Append; FieldByName('ID').AsInteger := i; FieldByName('FSTRING').AsString := testStringValues[i]; FieldByName('FSMALLINT').AsInteger := testSmallIntValues[i]; FieldByName('FINTEGER').AsInteger := testIntValues[i]; FieldByName('FWORD').AsInteger := testWordValues[i]; FieldByName('FBOOLEAN').AsBoolean := testBooleanValues[i]; FieldByName('FFLOAT').AsFloat := testFloatValues[i]; if (Result as TDBF).TableLevel >= TDBF_TABLELEVEL_FOXPRO then FieldByName('FCURRENCY').AsCurrency := testCurrencyValues[i]; // work around missing TBCDField.AsBCD: if (Result as TDBF).TableLevel >= TDBF_TABLELEVEL_FOXPRO then FieldByName('FBCD').AsBCD := StrToBCD(testFmtBCDValues[i],Self.FormatSettings); FieldByName('FDATE').AsDateTime := StrToDate(testDateValues[i], 'yyyy/mm/dd', '-'); FieldByName('FDATETIME').AsDateTime := StrToDateTime(testValues[ftDateTime,i], Self.FormatSettings); FieldByName('FLARGEINT').AsLargeInt := testLargeIntValues[i]; FieldByName('FMEMO').AsString := testStringValues[i]; Post; end; Close; end; end; function TDBFDBConnector.ReallyInternalGetNDataset(n: integer; Trace: boolean): TDataset; var countID: integer; begin if Trace then Result := (TDbfTraceDataset.Create(nil) as TDataSet) else Result := (TDBFAutoClean.Create(nil) as TDataSet); with (Result as TDBFAutoclean) do begin CreatedBy:='InternalGetNDataset('+inttostr(n)+')'; FieldDefs.Add('ID', ftInteger); FieldDefs.Add('NAME', ftString, 50); CreateTable; Open; if n > 0 then for countId := 1 to n do begin Append; FieldByName('ID').AsInteger := countID; FieldByName('NAME').AsString := 'TestName' + IntToStr(countID); // Explicitly call .post, since there could be a bug which disturbs // the automatic call to post. (example: when TDataset.DataEvent doesn't // work properly) Post; end; if state = dsinsert then Post; Close; end; end; function TDBFDBConnector.GetTraceDataset(AChange: boolean): TDataset; begin // Mimic TDBConnector.GetNDataset if AChange then FChangedDatasets[NForTraceDataset] := True; Result := ReallyInternalGetNDataset(NForTraceDataset,true); FUsedDatasets.Add(Result); end; { TDbfTraceDataset } procedure TDbfTraceDataset.SetCurrentRecord(Index: longint); begin DataEvents := DataEvents + 'SetCurrentRecord' + ';'; inherited SetCurrentRecord(Index); end; procedure TDbfTraceDataset.RefreshInternalCalcFields(Buffer: PChar); begin DataEvents := DataEvents + 'RefreshInternalCalcFields' + ';'; inherited RefreshInternalCalcFields(Buffer); end; procedure TDbfTraceDataset.InternalInitFieldDefs; var i: integer; IntCalcFieldName: string; begin // To fake an internal calculated field, set its fielddef InternalCalcField // property to true, before the dataset is opened. // This procedure takes care of setting the automatically created fielddef's // InternalCalcField property to true. (works for only one field) IntCalcFieldName := ''; for i := 0 to FieldDefs.Count - 1 do if fielddefs[i].InternalCalcField then IntCalcFieldName := FieldDefs[i].Name; inherited InternalInitFieldDefs; if IntCalcFieldName <> '' then with FieldDefs.find(IntCalcFieldName) do begin InternalCalcField := True; end; end; procedure TDbfTraceDataset.CalculateFields(Buffer: PChar); begin DataEvents := DataEvents + 'CalculateFields' + ';'; inherited CalculateFields(Buffer); end; procedure TDbfTraceDataset.ClearCalcFields(Buffer: PChar); begin DataEvents := DataEvents + 'ClearCalcFields' + ';'; inherited ClearCalcFields(Buffer); end; initialization RegisterClass(TDBFDBConnector); end.