dbf_idxfile.pas

tDBF is new ver, this is BDS 2007 insta

//==============================================================================
//============ TIndexFile
//==============================================================================
constructor TIndexFile.Create(ADbfFile: Pointer);
var
  I: Integer;
begin
  inherited Create;

  // clear variables
  FOpened := false;
  FRangeActive := false;
  FUpdateMode := umCurrent;
  FModifyMode := mmNormal;
  FTempMode := TDbfFile(ADbfFile).TempMode;
  FRangeIndex := -1;
  SelectIndexVars(-1);
  for I := 0 to MaxIndexes - 1 do
  begin
    FParsers[I] := nil;
    FRoots[I] := nil;
    FLeaves[I] := nil;
    FIndexHeaderModified[I] := false;
  end;

  // store pointer to `parent' dbf file
  FDbfFile := ADbfFile;
end;

destructor TIndexFile.Destroy;
begin
  // close file
  Close;

  // call ancestor
  inherited Destroy;
end;

procedure TIndexFile.Open;
var
  I: Integer;
  ext: string;
  localeError: TLocaleError;
  localeSolution: TLocaleSolution;
  DbfLangId: Byte;
begin
  if not FOpened then
  begin
    // open physical file
    OpenFile;

    // page offsets are not related to header length
    PageOffsetByHeader := false;
    // we need physical page locks
    VirtualLocks := false;

    // not selected index expression => can't edit yet
    FCanEdit := false;
    FUserKey := nil;
    FUserRecNo := -1;
    FHeaderLocked := -1;
    FHeaderPageNo := 0;
    FForceClose := false;
    FForceReadOnly := false;
    FMdxTag := nil;

    // get index type
    ext := UpperCase(ExtractFileExt(FileName));
    if (ext = '.MDX') then
    begin
      FEntryHeaderSize := 4;
      FPageHeaderSize := 8;
      FEntryBof := @Entry_Mdx_BOF;
      FEntryEof := @Entry_Mdx_EOF;
      HeaderSize := 2048;
      RecordSize := 1024;
      PageSize := 512;
      if FileCreated then
      begin
        FIndexVersion := TDbfFile(FDbfFile).DbfVersion;
        if FIndexVersion = xBaseIII then
          FIndexVersion := xBaseIV;
      end else begin
        case PMdxHdr(Header)^.MdxVersion of
          3: FIndexVersion := xBaseVII;
        else
          FIndexVersion := xBaseIV;
        end;
      end;
      case FIndexVersion of
        xBaseVII:
          begin
            FMdxTag := TMdx7Tag.Create;
            FTempMdxTag := TMdx7Tag.Create;
          end;
      else
        FMdxTag := TMdx4Tag.Create;
        FTempMdxTag := TMdx4Tag.Create;
      end;
      // get mem for all index headers..we're going to cache these
      for I := 0 to MaxIndexes - 1 do
      begin
        GetMem(FIndexHeaders[I], RecordSize);
        FillChar(FIndexHeaders[I]^, RecordSize, 0);
      end;
      // set pointers to first index
      FIndexHeader := FIndexHeaders[0];
    end else begin
      // don't waste memory on another header block: we can just use
      // the pagedfile one, there is only one index in this file
      FIndexVersion := xBaseIII;
      FEntryHeaderSize := 8;
      FPageHeaderSize := 4;
      FEntryBof := @Entry_Ndx_BOF;
      FEntryEof := @Entry_Ndx_EOF;
      HeaderSize := 512;
      RecordSize := 512;
      // have to read header first before we can assign following vars
      FIndexHeaders[0] := Header;
      FIndexHeader := Header;
      // create default root
      FParsers[0] := TDbfIndexParser.Create(FDbfFile);
      FRoots[0] := TNdxPage.Create(Self);
      FCurrentParser := FParsers[0];
      FRoot := FRoots[0];
      FSelectedIndex := 0;
      // parse index expression
      FCurrentParser.ParseExpression(PIndexHdr(FIndexHeader)^.KeyDesc);
      // set index locale
      FCollation := BINARY_COLLATION;
    end;

    // determine how to open file
    if FileCreated then
    begin
      FillChar(Header^, HeaderSize, 0);
      Clear;
    end else begin
      // determine locale type
      localeError := leNone;
      if (FIndexVersion >= xBaseIV) then
      begin
        // get parent language id
        DbfLangId := GetDbfLanguageId;
        // no ID?
        if (DbfLangId = 0) { and (TDbfFile(FDbfFile).DbfVersion = xBaseIII)} then
        begin
          // if dbf is version 3, no language id, if no MDX language, use binary
          if PMdxHdr(Header)^.Language = 0 then
            FCollation := BINARY_COLLATION
          else
            FCollation := GetCollationTable(PMdxHdr(Header)^.Language);
        end else begin
          // check if MDX - DBF language id's match
          if (PMdxHdr(Header)^.Language = 0) or (PMdxHdr(Header)^.Language = DbfLangId) then
            FCollation := GetCollationTable(DbfLangId)
          else
            localeError := leTableIndexMismatch;
        end;
        // don't overwrite previous error
        if (FCollation = UNKNOWN_COLLATION) and (localeError = leNone) then
          localeError := leUnknown;
      end else begin
        // dbase III always binary?
        FCollation := BINARY_COLLATION;
      end;
      // check if selected locale is available, binary is always available...
      if (localeError <> leNone) and (FCollation <> BINARY_COLLATION) then
      begin
        if LCIDList.IndexOf(Pointer(FCollation)) < 0 then
          localeError := leNotAvailable;
      end;
      // check if locale error detected
      if localeError <> leNone then
      begin
        // provide solution, well, solution...
        localeSolution := lsNotOpen;
        // call error handler
        if Assigned(FOnLocaleError) then
          FOnLocaleError(localeError, localeSolution);
        // act to solution
        case localeSolution of
          lsNotOpen: FForceClose := true;
          lsNoEdit: FForceReadOnly := true;
        else
          { lsBinary }
          FCollation := BINARY_COLLATION;
        end;
      end;
      // now read info
      if not ForceClose then
        ReadIndexes;
    end;
    // default to update all
    UpdateMode := umAll;
    // flag open
    FOpened := true;
  end;
end;

procedure TIndexFile.Close;
var
  I: Integer;
begin
  if FOpened then
  begin
    // save headers
    Flush;

    // remove parser reference
    FCurrentParser := nil;

    // free roots
    if FIndexVersion >= xBaseIV then
    begin
      for I := 0 to MaxIndexes - 1 do
      begin
        FreeMemAndNil(FIndexHeaders[I]);
        FreeAndNil(FParsers[I]);
        FreeAndNil(FRoots[I]);
      end;
    end else begin
      FreeAndNil(FRoot);
    end;

    // free mem
    FMdxTag.Free;
    FTempMdxTag.Free;

    // close physical file
    CloseFile;

    // not opened any more
    FOpened := false;
  end;
end;

procedure TIndexFile.ClearRoots;
  //
  // *) assumes FIndexVersion >= xBaseIV
  //
var
  I, prevIndex: Integer;
begin
  prevIndex := FSelectedIndex;
  for I := 0 to MaxIndexes - 1 do
  begin
    SelectIndexVars(I);
    if FRoot <> nil then
    begin
      // clear this entry
      ClearIndex;
      FLeaves[I] := FRoots[I];
    end;
  end;
  // reselect previously selected index
  SelectIndexVars(prevIndex);
  // deselect index
end;

procedure WriteDBFileName(Header: PMdxHdr; HdrFileName: string);
var
  HdrFileExt: string;
  lPos, lenFileName: integer;
begin
  HdrFileName := ExtractFileName(HdrFileName);
  HdrFileExt := ExtractFileExt(HdrFileName);
  if Length(HdrFileExt) > 0 then
  begin
    lPos := System.Pos(HdrFileExt, HdrFileName);
    if lPos > 0 then
      SetLength(HdrFileName, lPos - 1);
  end;
  if Length(HdrFileName) > 15 then
    SetLength(HdrFileName, 15);
  lenFileName := Length(HdrFileName);
  Move(PChar(HdrFileName)^, PMdxHdr(Header)^.FileName[0], lenFileName);
  FillChar(PMdxHdr(Header)^.FileName[lenFileName], 15-lenFileName, 0);
end;

procedure TIndexFile.Clear;
var
  year, month, day: Word;
  pos, prevSelIndex, pageno: Integer;
  DbfLangId: Byte;
begin
  // flush cache to prevent reading corrupted data
  Flush;
  // completely erase index
  if FIndexVersion >= xBaseIV then
  begin
    DecodeDate(Now, year, month, day);
    if FIndexVersion = xBaseVII then
      PMdxHdr(Header)^.MdxVersion := 3
    else  
      PMdxHdr(Header)^.MdxVersion := 2;
    PMdxHdr(Header)^.Year := year - 1900;
    PMdxHdr(Header)^.Month := month;
    PMdxHdr(Header)^.Day := day;
    WriteDBFileName(PMdxHdr(Header), FileName);
    PMdxHdr(Header)^.BlockSize := SwapWordLE(2);
    PMdxHdr(Header)^.BlockAdder := SwapWordLE(1024);
    PMdxHdr(Header)^.ProdFlag := 1;
    PMdxHdr(Header)^.NumTags := 48;
    PMdxHdr(Header)^.TagSize := 32;
    PMdxHdr(Header)^.Dummy2 := 0;
    PMdxHdr(Header)^.Language := GetDbfLanguageID;
    PMdxHdr(Header)^.NumPages := SwapIntLE(HeaderSize div PageSize);  // = 4
    TouchHeader(Header);
    PMdxHdr(Header)^.TagFlag := 1;
    // use locale id of parent
    DbfLangId := GetDbfLanguageId;
    if DbfLangId = 0 then
      FCollation := BINARY_COLLATION
    else
      FCollation := GetCollationTable(DbfLangId);
    // write index headers
    prevSelIndex := FSelectedIndex;
    for pos := 0 to SwapWordLE(PMdxHdr(Header)^.TagsUsed) - 1 do
    begin
      SelectIndexVars(pos);
      pageno := GetNewPageNo;
      FMdxTag.HeaderPageNo := SwapIntLE(pageno);
      WriteRecord(pageno, FIndexHeader);
    end;
    // reselect previously selected index
    SelectIndexVars(prevSelIndex);
    // file header done (tags are included in file header)
    WriteFileHeader;
    // clear roots
    ClearRoots;
    // init vars
    FTagSize := 32;
    FTagOffset := 544;
    // clear entries
    RecordCount := SwapIntLE(PMdxHdr(Header)^.NumPages);
  end else begin
    // clear single index entry
    ClearIndex;
    RecordCount := SwapIntLE(PIndexHdr(FIndexHeader)^.NumPages);
  end;
end;

procedure TIndexFile.ClearIndex;
var
  prevHeaderLocked: Integer;
  needHeaderLock: Boolean;
begin
  // flush cache to prevent reading corrupted data
  Flush;
  // modifying header: lock page
  needHeaderLock := FHeaderLocked <> 0;
  prevHeaderLocked := FHeaderLocked;
  if needHeaderLock then
  begin
    LockPage(0, true);
    FHeaderLocked := 0;
  end;
  // initially, we have 1 page: header
  PIndexHdr(FIndexHeader)^.NumPages := SwapIntLE(HeaderSize div PageSize);
  // clear memory of root
  FRoot.Clear;
  // get new page for root
  FRoot.GetNewPage;
  // store new root page
  PIndexHdr(FIndexHeader)^.RootPage := SwapIntLE(FRoot.PageNo);
{$ifdef TDBF_UPDATE_FIRSTLAST_NODE}
  PIndexHdr(FIndexHeader)^.FirstNode := SwapIntLE(FRoot.PageNo);
{$endif}
  // update leaf pointers
  FLeaves[FSelectedIndex] := FRoot;
  FLeaf := FRoot;
  // write new header
  WriteHeader;
  FRoot.Modified;
  FRoot.WritePage;
  // done updating: unlock header
  if needHeaderLock then
  begin
    UnlockPage(0);
    FHeaderLocked := prevHeaderLocked;
  end;
end;

procedure TIndexFile.CalcKeyProperties;
  // given KeyLen, this func calcs KeyRecLen and NumEntries
begin
  // now adjust keylen to align on DWORD boundaries
  PIndexHdr(FIndexHeader)^.KeyRecLen := SwapWordLE((SwapWordLE(
    PIndexHdr(FIndexHeader)^.KeyLen) + FEntryHeaderSize + 3) and not 3);
  PIndexHdr(FIndexHeader)^.NumKeys := SwapWordLE((RecordSize - FPageHeaderSize) div 
    SwapWordLE(PIndexHdr(FIndexHeader)^.KeyRecLen));
end;

function TIndexFile.GetName: string;
begin
  // get suitable name of index: if tag name defined use that otherwise filename
  if FIndexVersion >= xBaseIV then
    Result := FIndexName
  else
    Result := FileName;
end;

procedure TIndexFile.CreateIndex(FieldDesc, TagName: string; Options: TIndexOptions);
var
  tagNo: Integer;
  fieldType: Char;
  TempParser: TDbfIndexParser;
begin
  // check if we have exclusive access to table
  TDbfFile(FDbfFile).CheckExclusiveAccess;
  // parse index expression; if it cannot be parsed, why bother making index?
  TempParser := TDbfIndexParser.Create(FDbfFile);
  try
    TempParser.ParseExpression(FieldDesc);
    // check if result type is correct
    fieldType := 'C';
    case TempParser.ResultType of
      etString: ; { default set above to suppress delphi warning }
      etInteger, etLargeInt, etFloat: fieldType := 'N';
    else
      raise EDbfError.Create(STRING_INVALID_INDEX_TYPE);
    end;
  finally
    TempParser.Free;
  end;
  // select empty index
  if FIndexVersion >= xBaseIV then
  begin
    // get next entry no
    tagNo := SwapWordLE(PMdxHdr(Header)^.TagsUsed);
    // check if too many indexes