dbf.pas

tDBF is new ver, this is BDS 2007 insta

  if (FCursor = nil) or VarIsNull(KeyValues) then exit;

  saveRecNo := FCursor.SequentialRecNo;
  try
    if LocateRecord(KeyFields, KeyValues, []) then
    begin
      // FFilterBuffer contains record buffer
      saveState := SetTempState(dsCalcFields);
      try
        CalculateFields(FFilterBuffer);
        if KeyValues = FieldValues[KeyFields] then
           Result := FieldValues[ResultFields];
      finally
        RestoreState(saveState);
      end;
    end;
  finally
    FCursor.SequentialRecNo := saveRecNo;
  end;
end;

function TDbf.Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean;
var
  saveRecNo: integer;
begin
  if FCursor = nil then
  begin
    Result := false;
    exit;
  end;

  DoBeforeScroll;
  saveRecNo := FCursor.SequentialRecNo;
  FLocateRecNo := -1;
  Result := LocateRecord(KeyFields, KeyValues, Options);
  CursorPosChanged;
  if Result then
  begin
    if FLocateRecNo <> -1 then
      FCursor.PhysicalRecNo := FLocateRecNo;
    Resync([]);
    DoAfterScroll;
  end else
    FCursor.SequentialRecNo := saveRecNo;
end;

function TDbf.LocateRecordLinear(const KeyFields: String; const KeyValues: Variant;
    Options: TLocateOptions): Boolean;
var
  lstKeys              : TList;
  iIndex               : Integer;
  Field                : TField;
  bMatchedData         : Boolean;
  bVarIsArray          : Boolean;
  varCompare           : Variant;

  function CompareValues: Boolean;
  var
    sCompare: String;
  begin
    if (Field.DataType = ftString) then
    begin
      sCompare := VarToStr(varCompare);
      if loCaseInsensitive in Options then
      begin
        Result := AnsiCompareText(Field.AsString,sCompare) = 0;
        if not Result and (iIndex = lstKeys.Count - 1) and (loPartialKey in Options) and
          (Length(sCompare) < Length(Field.AsString)) then
        begin
          if Length(sCompare) = 0 then
            Result := true
          else
            Result := AnsiCompareText (Copy (Field.AsString,1,Length (sCompare)),sCompare) = 0;
        end;
      end else begin
        Result := Field.AsString = sCompare;
        if not Result and (iIndex = lstKeys.Count - 1) and (loPartialKey in Options) and
          (Length (sCompare) < Length (Field.AsString)) then
        begin
          if Length (sCompare) = 0 then
            Result := true
          else
            Result := Copy(Field.AsString, 1, Length(sCompare)) = sCompare;
        end;
      end;
    end
    else
      Result := Field.Value = varCompare;
  end;

var
  SaveState: TDataSetState;
  lPhysRecNo: integer;
begin
  Result := false;
  bVarIsArray := false;
  lstKeys := TList.Create;
  FFilterBuffer := TempBuffer;
  SaveState := SetTempState(dsFilter);
  try
    GetFieldList(lstKeys, KeyFields);
    if VarArrayDimCount(KeyValues) = 0 then
      bMatchedData := lstKeys.Count = 1
    else if VarArrayDimCount (KeyValues) = 1 then
    begin
      bMatchedData := VarArrayHighBound (KeyValues,1) + 1 = lstKeys.Count;
      bVarIsArray := true;
    end else
      bMatchedData := false;
    if bMatchedData then
    begin
      FCursor.First;
      while not Result and FCursor.Next do
      begin
        lPhysRecNo := FCursor.PhysicalRecNo;
        if (lPhysRecNo = 0) or not FDbfFile.IsRecordPresent(lPhysRecNo) then
          break;
        
        FDbfFile.ReadRecord(lPhysRecNo, @PDbfRecord(FFilterBuffer)^.DeletedFlag);
        Result := FShowDeleted or (PDbfRecord(FFilterBuffer)^.DeletedFlag <> '*');
        if Result and Filtered then
          DoFilterRecord(Result);
        
        iIndex := 0;
        while Result and (iIndex < lstKeys.Count) Do
        begin
          Field := TField (lstKeys [iIndex]);
          if bVarIsArray then
            varCompare := KeyValues [iIndex]
          else
            varCompare := KeyValues;
          Result := CompareValues;
          Inc(iIndex);
        end;
      end;
    end;
  finally
    lstKeys.Free;
    RestoreState(SaveState);
  end;
end;

function TDbf.LocateRecordIndex(const KeyFields: String; const KeyValues: Variant;
    Options: TLocateOptions): Boolean;
var
  searchFlag: TSearchKeyType;
  matchRes: Integer;
  lTempBuffer: array [0..100] of Char;
  acceptable, checkmatch: boolean;
begin
  if loPartialKey in Options then
    searchFlag := stGreaterEqual
  else
    searchFlag := stEqual;
  if TIndexCursor(FCursor).VariantToBuffer(KeyValues, @lTempBuffer[0]) = etString then
    Translate(@lTempBuffer[0], @lTempBuffer[0], true);
  Result := FIndexFile.SearchKey(@lTempBuffer[0], searchFlag);
  if not Result then
    exit;

  checkmatch := false;
  repeat
    if ReadCurrentRecord(TempBuffer, acceptable) = grError then
    begin
      Result := false;
      exit;
    end;
    if acceptable then break;
    checkmatch := true;
    FCursor.Next;
  until false;

  if checkmatch then
  begin
    matchRes := TIndexCursor(FCursor).IndexFile.MatchKey(@lTempBuffer[0]);
    if loPartialKey in Options then
      Result := matchRes <= 0
    else
      Result := matchRes =  0;
  end;

  FFilterBuffer := TempBuffer;
end;

function TDbf.LocateRecord(const KeyFields: String; const KeyValues: Variant;
    Options: TLocateOptions): Boolean;
var
  lCursor, lSaveCursor: TVirtualCursor;
  lSaveIndexName, lIndexName: string;
  lIndexDef: TDbfIndexDef;
  lIndexFile, lSaveIndexFile: TIndexFile;
begin
  lCursor := nil;
  lSaveCursor := nil;
  lIndexFile := nil;
  lSaveIndexFile := FIndexFile;
  if (FCursor is TIndexCursor) 
    and (TIndexCursor(FCursor).IndexFile.Expression = KeyFields) then
  begin
    lCursor := FCursor;
  end else begin
    lIndexDef := FIndexDefs.GetIndexByField(KeyFields);
    if lIndexDef <> nil then
    begin
      lIndexName := ParseIndexName(lIndexDef.IndexFile);
      lIndexFile := FDbfFile.GetIndexByName(lIndexName);
      if lIndexFile <> nil then
      begin
        lSaveCursor := FCursor;
        lCursor := TIndexCursor.Create(lIndexFile);
        lSaveIndexName := lIndexFile.IndexName;
        lIndexFile.IndexName := lIndexName;
        FIndexFile := lIndexFile;
      end;
    end;
  end;
  if lCursor <> nil then
  begin
    FCursor := lCursor;
    Result := LocateRecordIndex(KeyFields, KeyValues, Options);
    if lSaveCursor <> nil then
    begin
      FCursor.Free;
      FCursor := lSaveCursor;
    end;
    if lIndexFile <> nil then
    begin
      FLocateRecNo := FIndexFile.PhysicalRecNo;
      lIndexFile.IndexName := lSaveIndexName;
      FIndexFile := lSaveIndexFile;
    end;
  end else
    Result := LocateRecordLinear(KeyFields, KeyValues, Options);
end;

{$endif}

procedure TDbf.TryExclusive;
begin
  // are we active?
  if Active then
  begin
    // already in exclusive mode?
    FDbfFile.TryExclusive;
    // update file mode
    FExclusive := not FDbfFile.IsSharedAccess;
    FReadOnly := FDbfFile.Mode = pfReadOnly;
  end else begin
    // just set exclusive to true
    FExclusive := true;
    FReadOnly := false;
  end;
end;

procedure TDbf.EndExclusive;
begin
  if Active then
  begin
    // call file handler
    FDbfFile.EndExclusive;
    // update file mode
    FExclusive := not FDbfFile.IsSharedAccess;
    FReadOnly := FDbfFile.Mode = pfReadOnly;
  end else begin
    // just set exclusive to false
    FExclusive := false;
  end;
end;

function TDbf.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; {override virtual}
var
  MemoPageNo: Integer;
  MemoFieldNo: Integer;
  lBlob: TDbfBlobStream;
begin
  // check if in editing mode if user wants to write
  if (Mode = bmWrite) or (Mode = bmReadWrite) then
    if not (State in [dsEdit, dsInsert]) then
{$ifdef DELPHI_3}
      DatabaseError(SNotEditing);
{$else}
      DatabaseError(SNotEditing, Self);
{$endif}
  // already created a `placeholder' blob for this field?
  MemoFieldNo := Field.FieldNo - 1;
  if FBlobStreams^[MemoFieldNo] = nil then
    FBlobStreams^[MemoFieldNo] := TDbfBlobStream.Create(Field);
  lBlob := FBlobStreams^[MemoFieldNo].AddReference;
  // update pageno of blob <-> location where to read/write in memofile
  if FDbfFile.GetFieldData(Field.FieldNo-1, ftInteger, GetCurrentBuffer, @MemoPageNo, false) then
  begin
    // read blob? different blob?
    if (Mode = bmRead) or (Mode = bmReadWrite) then
    begin
      if MemoPageNo <> lBlob.MemoRecNo then
      begin
        FDbfFile.MemoFile.ReadMemo(MemoPageNo, lBlob);
        lBlob.ReadSize := lBlob.Size;
        lBlob.Translate(false);
      end;
    end else begin
      lBlob.Size := 0;
      lBlob.ReadSize := 0;
    end;
    lBlob.MemoRecNo := MemoPageNo;
  end else
  if not lBlob.Dirty or (Mode = bmWrite) then
  begin
    // reading and memo is empty and not written yet, or rewriting
    lBlob.Size := 0;
    lBlob.ReadSize := 0;
    lBlob.MemoRecNo := 0;
  end;
  { this is a hack, we actually need to know per user who's modifying, and who is not }
  { Mode is more like: the mode of the last "creation" }
  { if create/free is nested, then everything will be alright, i think ;-) }
  lBlob.Mode := Mode;
  { this is a hack: we actually need to know per user what it's position is }
  lBlob.Position := 0;
  Result := lBlob;
end;

{$ifdef SUPPORT_NEW_TRANSLATE}

function TDbf.Translate(Src, Dest: PChar; ToOem: Boolean): Integer; {override virtual}
var
  FromCP, ToCP: Cardinal;
begin
  if (Src <> nil) and (Dest <> nil) then
  begin
    if Assigned(FOnTranslate) then
    begin
      Result := FOnTranslate(Self, Src, Dest, ToOem);
      if Result = -1 then
        Result := StrLen(Dest);
    end else begin
      if FTranslationMode <> tmNoneNeeded then
      begin
        if ToOem then
        begin
          FromCP := GetACP;
          ToCP := FDbfFile.UseCodePage;
        end else begin
          FromCP := FDbfFile.UseCodePage;
          ToCP := GetACP;
        end;
      end else begin
        FromCP := GetACP;
        ToCP := FromCP;
      end;
      Result := TranslateString(FromCP, ToCP, Src, Dest, -1);
    end;
  end else
    Result := 0;
end;

{$else}

procedure TDbf.Translate(Src, Dest: PChar; ToOem: Boolean); {override virtual}
var
  FromCP, ToCP: Cardinal;
begin
  if (Src <> nil) and (Dest <> nil) then
  begin
    if Assigned(FOnTranslate) then
    begin
      FOnTranslate(Self, Src, Dest, ToOem);
    end else begin
      if FTranslationMode <> tmNoneNeeded then
      begin
        if ToOem then
        begin
          FromCP := GetACP;
          ToCP := FDbfFile.UseCodePage;
        end else begin
          FromCP := FDbfFile.UseCodePage;
          ToCP := GetACP;
        end;
        TranslateString(FromCP, ToCP, Src, Dest, -1);
      end;
    end;
  end;
end;

{$endif}

procedure TDbf.ClearCalcFields(Buffer: PChar);
var
  lRealBuffer, lCalcBuffer: PChar;
begin
  lRealBuffer := @pDbfRecord(Buffer)^.DeletedFlag;
  lCalcBuffer := lRealBuffer + FDbfFile.RecordSize;
  FillChar(lCalcBuffer^, CalcFieldsSize, 0);
end;

procedure TDbf.InternalSetToRecord(Buffer: PChar); {override virtual abstract from TDataset}
var
  pRecord: pDbfRecord;
begin
  if Buffer <> nil then
  begin
    pRecord := pDbfRecord(Buffer);
    if pRecord^.BookmarkFlag = bfInserted then
    begin
      // do what ???
    end else begin
      FCursor.SequentialRecNo := pRecord^.SequentialRecNo;
    end;
  end;
end;

function TDbf.IsCursorOpen: Boolean; {override virtual abstract from TDataset}
begin
  Result := FCursor <> nil;
end;

function TDbf.FieldDefsStored: Boolean;
begin
  Result := StoreDefs and (FieldDefs.Count > 0);
end;

procedure TDbf.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);