dbf.pas

tDBF is new ver, this is BDS 2007 insta

    // oops, a problem with parsing, clear filter for now
    on E: EDbfError do Filter := EmptyStr;
  end;

  SetIndexName(FIndexName);

// SetIndexName will have made the cursor for us if no index selected :-)
//  if FCursor = nil then FCursor := TDbfCursor.Create(FDbfFile);

  if FMasterLink.Active and Assigned(FIndexFile) then
    CheckMasterRange;
  InternalFirst;

//  FDbfFile.SetIndex(FIndexName);
//  FDbfFile.FIsCursorOpen := true;
end;

function TDbf.GetCodePage: Cardinal;
begin
  if FDbfFile <> nil then
    Result := FDbfFile.UseCodePage
  else
    Result := 0;
end;

function TDbf.GetLanguageStr: String;
begin
  if FDbfFile <> nil then
    Result := FDbfFile.LanguageStr;
end;

function TDbf.LockTable(const Wait: Boolean): Boolean;
begin
  CheckActive;
  Result := FDbfFile.LockAllPages(Wait);
end;

procedure TDbf.UnlockTable;
begin
  CheckActive;
  FDbfFile.UnlockAllPages;
end;

procedure TDbf.InternalEdit;
var
  I: Integer;
begin
  // store recno we are editing
  FEditingRecNo := FCursor.PhysicalRecNo;
  // reread blobs, execute cancel -> clears remembered memo pageno,
  // causing it to reread the memo contents
  for I := 0 to Pred(FieldDefs.Count) do
    if Assigned(FBlobStreams^[I]) then
      FBlobStreams^[I].Cancel;
  // try to lock this record
  FDbfFile.LockRecord(FEditingRecNo, @pDbfRecord(ActiveBuffer)^.DeletedFlag);
  // succeeded!
end;

{$ifndef FPC}
{$ifndef DELPHI_3}

procedure TDbf.InternalInsert; {override virtual from TDataset}
begin
  CursorPosChanged;
end;

{$endif}
{$endif}

procedure TDbf.InternalPost; {override virtual abstract from TDataset}
var
  pRecord: pDbfRecord;
  I, newRecord: Integer;
begin
  // if internalpost is called, we know we are active
  pRecord := pDbfRecord(ActiveBuffer);
  // commit blobs
  for I := 0 to Pred(FieldDefs.Count) do
    if Assigned(FBlobStreams^[I]) then
      FBlobStreams^[I].Commit;
  if State = dsEdit then
  begin
    // write changes
    FDbfFile.UnlockRecord(FEditingRecNo, @pRecord^.DeletedFlag);
    // not editing anymore
    FEditingRecNo := -1;
  end else begin
    // insert
    newRecord := FDbfFile.Insert(@pRecord^.DeletedFlag);
    if newRecord > 0 then
      FCursor.PhysicalRecNo := newRecord;
  end;
  // set flag that TDataSet is about to post...so we can disable resync
  FPosting := true;
end;

procedure TDbf.Resync(Mode: TResyncMode);
begin
  // try to increase speed
  if not FDisableResyncOnPost or not FPosting then
    inherited;
  // clear post flag
  FPosting := false;
end;


{$ifndef SUPPORT_INITDEFSFROMFIELDS}

procedure TDbf.InitFieldDefsFromFields;
var
  I: Integer;
  F: TField;
begin
  { create fielddefs from persistent fields if needed }
  for I := 0 to FieldCount - 1 do
  begin
    F := Fields[I];
    with F do
    if FieldKind = fkData then begin
      FieldDefs.Add(FieldName,DataType,Size,Required);
    end;
  end;
end;

{$endif}

procedure TDbf.CreateTable;
begin
  CreateTableEx(nil);
end;

procedure TDbf.CheckDbfFieldDefs(ADbfFieldDefs: TDbfFieldDefs);
var
  I: Integer;
  TempDef: TDbfFieldDef;

    function FieldTypeStr(const FieldType: char): string;
    begin
      if FieldType = #0 then
        Result := 'NULL'
      else if FieldType > #127 then
        Result := 'ASCII '+IntToStr(Byte(FieldType))
      else
        Result := ' "'+fieldType+'" ';
      Result := ' ' + Result + '(#'+IntToHex(Byte(FieldType),SizeOf(FieldType))+') '
    end;

begin
  if ADbfFieldDefs = nil then exit;

  for I := 0 to ADbfFieldDefs.Count - 1 do
  begin
    // check dbffielddefs for errors
    TempDef := ADbfFieldDefs.Items[I];
    if FTableLevel < 7 then
      if not (TempDef.NativeFieldType in ['C', 'F', 'N', 'D', 'L', 'M']) then
        raise EDbfError.CreateFmt(STRING_INVALID_FIELD_TYPE,
          [FieldTypeStr(TempDef.NativeFieldType), TempDef.FieldName]);
  end;
end;

procedure TDbf.CreateTableEx(ADbfFieldDefs: TDbfFieldDefs);
var
  I: Integer;
  lIndex: TDbfIndexDef;
  lIndexName: string;
  tempFieldDefs: Boolean;
begin
  CheckInactive;
  tempFieldDefs := ADbfFieldDefs = nil;
  try
    try
      if tempFieldDefs then
      begin
        ADbfFieldDefs := TDbfFieldDefs.Create(Self);
        ADbfFieldDefs.DbfVersion := TableLevelToDbfVersion(FTableLevel);

        // get fields -> fielddefs if no fielddefs
{$ifndef FPC_VERSION}
        if FieldDefs.Count = 0 then
          InitFieldDefsFromFields;
{$endif}

        // fielddefs -> dbffielddefs
        for I := 0 to FieldDefs.Count - 1 do
        begin
          with ADbfFieldDefs.AddFieldDef do
          begin
            FieldName := FieldDefs.Items[I].Name;
            FieldType := FieldDefs.Items[I].DataType;
            if FieldDefs.Items[I].Size > 0 then
            begin
              Size := FieldDefs.Items[I].Size;
              Precision := FieldDefs.Items[I].Precision;
            end else begin
              SetDefaultSize;
            end;
          end;
        end;
      end;

      InitDbfFile(pfExclusiveCreate);
      FDbfFile.CopyDateTimeAsString := FInCopyFrom and FCopyDateTimeAsString;
      FDbfFile.DbfVersion := TableLevelToDbfVersion(FTableLevel);
      FDbfFile.FileLangID := FLanguageID;
      FDbfFile.Open;
      FDbfFile.FinishCreate(ADbfFieldDefs, 512);

      // if creating memory table, copy stream pointer
      if FStorage = stoMemory then
        FUserStream := FDbfFile.Stream;

      // create all indexes
      for I := 0 to FIndexDefs.Count-1 do
      begin
        lIndex := FIndexDefs.Items[I];
        lIndexName := ParseIndexName(lIndex.IndexFile);
        FDbfFile.OpenIndex(lIndexName, lIndex.SortField, true, lIndex.Options);
      end;
    except
      // dbf file created?
      if (FDbfFile <> nil) and (FStorage = stoFile) then
      begin
        FreeAndNil(FDbfFile);
        SysUtils.DeleteFile(FAbsolutePath+FTableName);
      end;
      raise;
    end;
  finally
    // free temporary fielddefs
    if tempFieldDefs and Assigned(ADbfFieldDefs) then
      ADbfFieldDefs.Free;
    FreeAndNil(FDbfFile);
  end;
end;

procedure TDbf.EmptyTable;
begin
  Zap;
end;

procedure TDbf.Zap;
begin
  // are we active?
  CheckActive;
  FDbfFile.Zap;
end;

procedure TDbf.RestructureTable(ADbfFieldDefs: TDbfFieldDefs; Pack: Boolean);
begin
  CheckInactive;

  // check field defs for errors
  CheckDbfFieldDefs(ADbfFieldDefs);

  // open dbf file
  InitDbfFile(pfExclusiveOpen);
  FDbfFile.Open;

  // do restructure
  try
    FDbfFile.RestructureTable(ADbfFieldDefs, Pack);
  finally
    // close file
    FreeAndNil(FDbfFile);
  end;
end;

procedure TDbf.PackTable;
var
  oldIndexName: string;
begin
  CheckBrowseMode;
  // deselect any index while packing
  oldIndexName := IndexName;
  IndexName := EmptyStr;
  // pack
  FDbfFile.RestructureTable(nil, true);
  // reselect index
  IndexName := oldIndexName;
end;

procedure TDbf.CopyFrom(DataSet: TDataSet; FileName: string; DateTimeAsString: Boolean; Level: Integer);
var
  lPhysFieldDefs, lFieldDefs: TDbfFieldDefs;
  lSrcField, lDestField: TField;
  I: integer;
begin
  FInCopyFrom := true;
  lFieldDefs := TDbfFieldDefs.Create(nil);
  lPhysFieldDefs := TDbfFieldDefs.Create(nil);
  try
    if Active then
      Close;
    FilePath := ExtractFilePath(FileName);
    TableName := ExtractFileName(FileName);
    FCopyDateTimeAsString := DateTimeAsString;
    TableLevel := Level;
    if not DataSet.Active then
      DataSet.Open;
    DataSet.FieldDefs.Update;
    // first get a list of physical field defintions
    // we need it for numeric precision in case source is tdbf
    if DataSet is TDbf then
    begin
      lPhysFieldDefs.Assign(TDbf(DataSet).DbfFieldDefs);
      IndexDefs.Assign(TDbf(DataSet).IndexDefs);
    end else begin
{$ifdef SUPPORT_FIELDDEF_TPERSISTENT}
      lPhysFieldDefs.Assign(DataSet.FieldDefs);
{$endif}      
      IndexDefs.Clear;
    end;
    // convert list of tfields into a list of tdbffielddefs
    // so that our tfields will correspond to the source tfields
    for I := 0 to Pred(DataSet.FieldCount) do
    begin
      lSrcField := DataSet.Fields[I];
      with lFieldDefs.AddFieldDef do
      begin
        if Length(lSrcField.Name) > 0 then
          FieldName := lSrcField.Name
        else
          FieldName := lSrcField.FieldName;
        FieldType := lSrcField.DataType;
        Required := lSrcField.Required;
        if (1 <= lSrcField.FieldNo) 
            and (lSrcField.FieldNo <= lPhysFieldDefs.Count) then
        begin
          Size := lPhysFieldDefs.Items[lSrcField.FieldNo-1].Size;
          Precision := lPhysFieldDefs.Items[lSrcField.FieldNo-1].Precision;
        end;
      end;
    end;

    CreateTableEx(lFieldDefs);
    Open;
    DataSet.First;
{$ifdef USE_CACHE}
    FDbfFile.BufferAhead := true;
    if DataSet is TDbf then
      TDbf(DataSet).DbfFile.BufferAhead := true;
{$endif}      
    while not DataSet.EOF do
    begin
      Append;
      for I := 0 to Pred(FieldCount) do
      begin
        lSrcField := DataSet.Fields[I];
        lDestField := Fields[I];
        if not lSrcField.IsNull then
        begin
          if lSrcField.DataType = ftDateTime then
          begin
            if FCopyDateTimeAsString then
            begin
              lDestField.AsString := lSrcField.AsString;
              if Assigned(FOnCopyDateTimeAsString) then
                FOnCopyDateTimeAsString(Self, lDestField, lSrcField)
            end else
              lDestField.AsDateTime := lSrcField.AsDateTime;
          end else
            lDestField.Assign(lSrcField);
        end;
      end;
      Post;
      DataSet.Next;
    end;
    Close;
  finally
{$ifdef USE_CACHE}
    if (DataSet is TDbf) and (TDbf(DataSet).DbfFile <> nil) then
      TDbf(DataSet).DbfFile.BufferAhead := false;
{$endif}      
    FInCopyFrom := false;
    lFieldDefs.Free;
    lPhysFieldDefs.Free;
  end;
end;

function TDbf.FindRecord(Restart, GoForward: Boolean): Boolean;
var
  oldRecNo: Integer;
begin
  CheckBrowseMode;
  DoBeforeScroll;
  Result := false;
  UpdateCursorPos;
  oldRecNo := RecNo;
  try
    FFindRecordFilter := true;
    if GoForward then
    begin
      if Restart then FCursor.First;
      Result := GetRecord(FTempBuffer, gmNext, false) = grOK;
    end else begin
      if Restart then FCursor.Last;
      Result := GetRecord(FTempBuffer, gmPrior, false) = grOK;
    end;
  finally
    FFindRecordFilter := false;
    if not Result then
    begin
      RecNo := oldRecNo;
    end else begin
      CursorPosChanged;
      Resync([]);
      DoAfterScroll;
    end;
  end;
end;

{$ifdef SUPPORT_VARIANTS}

function TDbf.Lookup(const KeyFields: string; const KeyValues: Variant;
  const ResultFields: string): Variant;
var
//  OldState:  TDataSetState;
  saveRecNo: integer;
  saveState: TDataSetState;
begin
  Result := Null;