dbf.pas

OICQ黑客工具。可以查看对方IP地址

    BEGIN
      fDBFHeader.BytesInRecords := fRecordSize;
      fDBFHeader.NumberOfRecords := fRecordCount;
      WriteHeader;
    END;

  // disconnet field objects
  BindFields(False);
  // destroy field object (if not persistent)
  if DefaultFields then
    DestroyFields;

  // free the internal list field offsets
  if Assigned(FFileOffset) then
    FFileOffset.Free;
  FFileOffset := nil;
  if Assigned(FFileWidth) then
    FFileWidth.Free;
  FFileWidth := nil;
  if Assigned(FFileDecimals) then
    FFileDecimals.Free;
  FFileDecimals := nil;
  FCurrentRecord := -1;

  // close the file
  FIsTableOpen := False;
  FStream.Free;
  FStream := nil;
end;

// ____________________________________________________________________________
// TDBF.IsCursorOpen
// I: is table open
function TDBF.IsCursorOpen: Boolean;
begin
  Result := FIsTableOpen;
end;

// ____________________________________________________________________________
// TDBF.WriteHeader
procedure TDBF.WriteHeader;
begin
//  Assert(FStream<>nil,'fStream=Nil');
  if fStream <> nil then
    begin
      FSTream.Seek(0,soFromBeginning);
      FStream.WriteBuffer(fDBFHeader,SizeOf(TDbfHeader));
    end;
end;

// ____________________________________________________________________________
// TDBF.Create
constructor TDBF.Create(AOwner:tComponent);
BEGIN
  inherited create(aOwner);
  fRecordHeaderSize := SizeOf(tRecordHeader);
END;

// ____________________________________________________________________________
// TDBF.CreateTable
// I: Create a new table/file
procedure TDBF.CreateTable;
var
  Ix : Integer;
//  DescribF : TBDescribField;
  Offs : Integer;
  Fld : TDbfField;
  FldName : PChar;
  i : integer;
begin
  CheckInactive;
  //  InternalInitFieldDefs;
  // create the new file
  if FileExists (FTableName) and
    (MessageDlg ('File ' + FTableName +
      ' already exists. OK to override?',
      mtConfirmation, [mbYes, mbNo], 0) = mrNo) then
    Exit;
  if FieldDefs.Count = 0 then
  begin
    for Ix := 0 to FieldCount - 1 do
    begin
      with Fields[Ix] do
      begin
        if FieldKind = fkData then
          FieldDefs.Add(FieldName,DataType,Size,Required);
      end;
    end;
  end;
  FStream := TFileStream.Create (FTableName,
    fmCreate or fmShareExclusive);
  try
    FillChar(fDBFHeader,SizeOf(TDbfHeader),0);
    fDBFHeader.BytesInRecords := 0; // filled later
    fDBFHeader.NumberOfRecords := 0; // empty
    WriteHeader;
    Offs:=0;
    for Ix:=0 to FieldDefs.Count-1 do
      begin
        with FieldDefs.Items[Ix] do
        begin
          FillChar(Fld,SizeOf(TDbfField),#0);
          Fld.FieldType := 'C';
          Fld.Width := Size;
          GetMem(FldName,SizeOf(FieldDefs.Items[Ix].Name));
          OemToChar(PChar(FieldDefs.Items[Ix].Name),FldName);
          for i := 1 to Length(FldName) do
            Fld.FieldName[i] := FldName[i];
          Fld.FieldName[Length(FldName)+1] := #0;
          FreeMem(FldName);
          Inc(Offs,Fld.Width);
          FStream.Write(Fld,SizeOf(TDbfField));
        end;
      end;
    fStartData := FStream.Position;
    fDBFHeader.BytesInRecords := Offs;
    FRecordSize := Offs+FRecordHeaderSize;
    WriteHeader;
  finally
    // close the file
    fStream.Free;
    fStream := nil;
  end;
end;

// ____________________________________________________________________________
// TDBF.PackTable
//Enhancement: Remove all deleted items from the table.
Procedure TDBF.PackTable;
var
  NewStream, OldStream : tStream;
  PC : PChar;
  Ix : Integer;
//  DescribF : TBDescribField;
  NewDataFileHeader : tDBFHeader;
  DataBuffer : Pointer;
  NumberOfFields : integer;
  Fld : TDBFField;
BEGIN
  OldStream := Nil;
  NewStream := Nil;
  CheckInactive;
//  if Active then
//    raise eBinaryDataSetError.Create ('Dataset must be closed before packing.');
  if fTableName = '' then
    raise EDBFError.Create('Table name not specified.');
  if not FileExists (FTableName) then
    raise EDBFError.Create('Table '+fTableName+' does not exist.');
  PC := @fTablename[1];
  CopyFile(PChar(PC),PChar(PC+',old'+#0),False);
  // create the new file
  if FieldDefs.Count = 0 then
  begin
    for Ix := 0 to FieldCount - 1 do
    begin
      with Fields[Ix] do
      begin
        if FieldKind = fkData then
          FieldDefs.Add(FieldName,DataType,Size,Required);
      end;
    end;
  end;
  TRY
    NewStream := TFileStream.Create (FTableName+',new',
      fmCreate or fmShareExclusive);
    OldStream := tFileStream.Create (fTableName+',old',
      fmOpenRead or fmShareExclusive);
    OldStream.ReadBuffer(NewDataFileHeader,SizeOf(TDbfHeader));
    NewStream.WriteBuffer(NewDataFileHeader,SizeOf(TDbfHeader));
    NumberOfFields := ((NewDataFileHeader.BytesInHeader-sizeof(TDbfHeader))div 32);
    for IX := 0 to NumberOfFields do
      BEGIN
        OldStream.Read(Fld,SizeOf(TDbfField));
        NewStream.Write(Fld,SizeOf(TDbfField));
      END;
    GetMem(DataBuffer,NewDataFileHeader.BytesInRecords);
    REPEAT
      IX := OldStream.Read(DataBuffer^,NewDataFileHeader.BytesInRecords);
      if (IX = NewDataFileHeader.BytesInRecords) and (pRecordHeader(DataBuffer)^.DeletedFlag <> '*') then
        NewStream.WRite(DataBuffer^,NewDataFileHeader.BytesInRecords);
    Until IX <> NewDataFileHeader.BytesInRecords;
    FreeMem(DataBuffer,NewDataFileHeader.BytesInRecords);
  finally
    // close the file
    NewStream.Free;
    OldStream.Free;
  end;
  CopyFile(PChar(PC+',new'+#0),PChar(PC),False);
  DeleteFile(Pchar(PC+',new'+#0));
  DeleteFile(Pchar(PC+',old'+#0));
END;

// ____________________________________________________________________________
// TDBF._SwapRecords
// Enhancement: Quick swap of two records.  Used primarily for sorting.
Procedure TDBF._SwapRecords(Rec1,REc2:Integer);
VAR
  Buffer1, Buffer2 : PChar;
  Bookmark1, BOokmark2 : TBookmarkFlag;
BEGIN
  Rec1 := Rec1 - 1;
  Rec2 := Rec2 - 1;
  if Rec1 < 0 then Exit;
  if Rec2 < 0 then Exit;
  Buffer1 := AllocRecordBuffer;
  Buffer2 := AllocRecordBuffer;
  _ReadRecord(Buffer1,Rec1);
  _ReadRecord(Buffer2,Rec2);
  Bookmark1 := GetBookmarkFlag(Buffer1);
  Bookmark2 := GetBookmarkFlag(Buffer2);
  SetBookmarkFlag(Buffer1,Bookmark2);
  SetBookmarkFlag(Buffer2,Bookmark1);
  _WriteRecord(Buffer1,Rec2);
  _WriteRecord(Buffer2,Rec1);
  StrDispose(Buffer1);
  StrDispose(Buffer2);
END;

// ____________________________________________________________________________
// TDBF._CompareRecords
// Compare two records.  Returns -1 if REC1 < REC2, 0 if REC1 = REC2, or
// 1 if REC1 > REC2.
Function TDBF._CompareRecords(SortFields:Array of String;Rec1,Rec2:Integer):Integer; FAR;
{-Compare the records Rec1, Rec2 and return -1 if Rec1 < Rec2, 0 if Rec1 = Rec2,
  1 if Rec1 > Rec2 }
VAR
  IX : Integer;

  Function CompareHelper(KeyId:String;Rec1,Rec2:Integer):Integer;
  VAR
    SKey1, SKey2 : String;
    IKey1, IKey2 : Integer;
    fKey1, fKey2 : Double;
    dKey1, dKey2 : tDateTime;
    CompareType : tFieldType;
    KeyField : tField;
  BEGIN
    KeyField := FieldByName(KeyID);
    CompareType := KeyField.DataType;
    Case CompareType of
      ftFloat,
      ftCurrency,
      ftBCD :
        BEGIN
          _ReadRecord(ActiveBuffer,Rec1-1);
          fKey1 := KeyField.AsFloat;
          _ReadRecord(ActiveBuffer,Rec2-1);
          fKey2 := KeyField.AsFloat;
          if fKey1 < fKey2 then
            Result := -1
          else
            if fKey1 > fKey2 then
              Result := 1
            else
              Result := 0;
        END;
      ftSmallInt,
      ftInteger,
      ftWord :
        BEGIN
          _ReadRecord(ActiveBuffer,Rec1-1);
          IKey1 := KeyField.AsInteger;
          _ReadRecord(ActiveBuffer,Rec2-1);
          IKey2 := KeyField.AsInteger;
          if IKey1 < IKey2 then
            Result := -1
          else
            if IKey1 > IKey2 then
              Result := 1
            else
              Result := 0;
        END;
      ftDate,
      ftTime,
      ftDateTime :
        BEGIN
          _ReadRecord(ActiveBuffer,Rec1-1);
          dKey1 := KeyField.AsDateTime;
          _ReadRecord(ActiveBuffer,Rec2-1);
          dKey2 := KeyField.AsDateTime;
          if dKey1 < dKey2 then
            Result := -1
          else
            if dKey1 > dKey2 then
              Result := 1
            else
              Result := 0;
        END;
      else
        BEGIN
          _ReadRecord(ActiveBuffer,Rec1-1);
          SKey1 := KeyField.AsString;
          _ReadRecord(ActiveBuffer,Rec2-1);
          SKey2 := KeyField.AsString;
          if SKey1 < SKey2 then
            Result := -1
          else
            if SKey1 > SKey2 then
              Result := 1
            else
              Result := 0;
        END;
    END;
  END;

BEGIN
  IX := 0;
  REPEAT // Loop through all available sortfields until not equal or no more sort fiels.
    Result := CompareHelper(SortFields[IX],Rec1,Rec2);
    Inc(IX);
  UNTIL (Result <> 0) or (IX > High(SortFields));
END;


// ____________________________________________________________________________
// TDBF.SortTable
// Enhancement: Sort the table by the fields passed.
Procedure TDBF.SortTable(SortFields : Array of String);

  { This is the main sorting routine. It is passed the number of elements and the
    two callback routines. The first routine is the function that will perform
    the comparison between two elements. The second routine is the procedure that
    will swap two elements if necessary } // Source: UNDU #8

  procedure QSort(uNElem: Integer);
  { uNElem - number of elements to sort }

    procedure qSortHelp(pivotP: Integer; nElem: word);
    label
      TailRecursion,
      qBreak;
    var
      leftP, rightP, pivotEnd, pivotTemp, leftTemp: word;
      lNum: Integer;
      retval: integer;
    begin
      TailRecursion:
        if (nElem <= 2) then
          begin
            if (nElem = 2) then

              begin
                rightP := pivotP +1;
                if (_CompareRecords(SortFields,pivotP, rightP) > 0) then
                  _SwapRecords(pivotP, rightP);
              end;
            exit;
          end;
        rightP := (nElem -1) + pivotP;
        leftP :=  (nElem shr 1) + pivotP;
        { sort pivot, left, and right elements for "median of 3" }
        if (_CompareRecords(SortFields,leftP, rightP) > 0) then _SwapRecords(leftP, rightP);
        if (_CompareRecords(SortFields,leftP, pivotP) > 0) then _SwapRecords(leftP, pivotP)

        else if (_CompareRecords(SortFields,pivotP, rightP) > 0) then _SwapRecords(pivotP, rightP);
        if (nElem = 3) then
          begin
            _SwapRecords(pivotP, leftP);
            exit;
          end;
        { now for the classic Horae algorithm }
        pivotEnd := pivotP + 1;
        leftP := pivotEnd;
        repeat
          retval := _CompareRecords(SortFields,leftP, pivotP);
          while (retval <= 0) do
            begin
              if (retval = 0) then
                begin
                  _SwapRecords(LeftP, PivotEnd);
                  Inc(PivotEnd);
                end;
              if (leftP < rightP) then
                Inc(leftP)
              else
                goto qBreak;
              retval := _CompareRecords(SortFields,leftP, pivotP);