disqlite3_full_text_search_form_main.pas

来自「DELPHI 访问SQLITE3 数据库的VCL控件」· PAS 代码 · 共 803 行 · 第 1/2 页

      while Stmt.Step = SQLITE_ROW do
        begin
          { Iterate over all match results and add the files' names
            and their IDs to the listbox. }
          lbxResults.Items.AddObject(
            Stmt.Column_Str16(0), // The FileName
            TObject(Stmt.Column_Int(1)) // The FileID
            );
        end;

    finally
      lbxResults.Items.EndUpdate;
      Stmt.Free;
    end;

    SetStatus(
      IntToStr(lbxResults.Items.Count) + ' Found',
      IntToStr(GetTickCount - TC) + ' ms',
      '', '');

    lbxResults.ItemIndex := 0;
    lbxResultsClick(nil);
  finally
    EnableControls(True);
  end;
end;

//------------------------------------------------------------------------------

{ Converts an Offset string to an array of TOffsetInfo. Takes care to convert
  UTF-8 byte positions to WideString character indexes. Therfore, the
  corresponding Content string must be passed as well. }
function DecodeOffsets(const Offsets: AnsiString; const Content: WideString): TOffsetInfoArray;
var
  OffsetsPtr: PAnsiChar; OffsetsLen: Integer;

  { Skips whitespace and converts digits to integer.
    -1 is returned on error or end of Offsets srting. }
  function ReadNext: Integer;
  begin
    while (OffsetsLen > 0) and (OffsetsPtr^ = #32) do
      begin
        Inc(OffsetsPtr);
        Dec(OffsetsLen);
      end;

    if (OffsetsLen > 0) and (OffsetsPtr^ in ['0'..'9']) then
      begin
        Result := 0;
        repeat
          Result := Result * 10;
          Inc(Result, Ord(OffsetsPtr^) - Ord('0'));
          Inc(OffsetsPtr);
          Dec(OffsetsLen);
        until (OffsetsLen <= 0) or not (OffsetsPtr^ in ['0'..'9'])
      end
    else
      Result := -1;
  end;

var
  ContentPtr: PWideChar; ContentLen: Integer;
  i, CharLength, CharOffset, LastMatchOffset, MatchDelta, MatchOffset, MatchLength: Integer;
begin
  // Determine number of offsets and allocate result array accordingly.
  i := 0;
  OffsetsPtr := PAnsiChar(Offsets); OffsetsLen := Length(Offsets);
  while ReadNext >= 0 do
    Inc(i);
  SetLength(Result, i div 4);

  ContentPtr := PWideChar(Content); ContentLen := Length(Content);
  OffsetsPtr := PAnsiChar(Offsets); OffsetsLen := Length(Offsets);
  i := 0; CharOffset := 0; LastMatchOffset := 0;

  repeat
    if ReadNext < 0 then Break; // Skip index of the column containing the match.
    if ReadNext < 0 then Break; // Skip term in the query expression which was matched.

    MatchOffset := ReadNext;
    if MatchOffset < 0 then Break;

    MatchLength := ReadNext;
    if MatchLength < 0 then Break;

    MatchDelta := MatchOffset - LastMatchOffset;
    LastMatchOffset := MatchOffset + MatchLength;

    { Convert UTF-8 byte offset to character offset. }
    while (ContentLen > 0) and (MatchDelta > 0) do
      begin
        case Ord(ContentPtr^) of
          $0000..$007F: Dec(MatchDelta);
          $0080..$07FF: Dec(MatchDelta, 2);
          else
            Dec(MatchDelta, 3);
        end;
        Inc(CharOffset);
        Inc(ContentPtr); Dec(ContentLen);
      end;
    Result[i].o := CharOffset;

    { Convert UTF-8 byte length to character length. }
    CharLength := 0;
    while (ContentLen > 0) and (MatchLength > 0) do
      begin
        case Ord(ContentPtr^) of
          $0000..$007F: Dec(MatchLength);
          $0080..$07FF: Dec(MatchLength, 2);
          else
            Dec(MatchLength, 3);
        end;
        Inc(CharLength);
        Inc(ContentPtr); Dec(ContentLen);
      end;
    Result[i].l := CharLength;

    Inc(CharOffset, CharLength);
    Inc(i);
  until False;
end;

//------------------------------------------------------------------------------

{ Show the document contents of a particular match and initialize the
  highlighting array to quickly navigate between the document's matches. }
procedure TfrmFTS.ShowContents(const FileID: Integer);
var
  Content: WideString;
  Stmt: TDISQLite3Statement;
begin
  EnableControls(False);
  try
    FCurrentContentID := FileID;

    Stmt := FDb.Prepare16(
      'SELECT Content, Offsets (' + FTS_TABLE + ') FROM ' + FTS_TABLE + ' ' +
      'WHERE +RowID = ? AND Content Match (?);');
    try
      Stmt.Bind_Int(1, FileID);
      Stmt.Bind_Str16(2, FCurrentSearch);
      if Stmt.Step = SQLITE_ROW then
        begin
          Content := Stmt.Column_Str16(0);
          memoContents.Text := Content;
          { Load match offsets into array. }
          FCurrentOffsets := DecodeOffsets(Stmt.Column_Str(1), Content);
          SetStatus('', '', '', IntToStr(Length(FCurrentOffsets)) + ' hits in document', False, False, False);
          FCurrentOffsetIdx := -1;
        end
    finally
      Stmt.Free;
    end;

    HighlightFirst;
  finally
    EnableControls(True);
  end;
end;

//------------------------------------------------------------------------------

function TfrmFTS.HighlightCurrent: Boolean;
begin
  if FCurrentOffsetIdx < 0
    then FCurrentOffsetIdx := 0;
  if FCurrentOffsetIdx >= Length(FCurrentOffsets) then
    FCurrentOffsetIdx := Length(FCurrentOffsets) - 1;

  Result := (FCurrentOffsetIdx >= 0);
  if Result then
    with FCurrentOffsets[FCurrentOffsetIdx] do
      begin
        memoContents.SelStart := o;
        memoContents.SelLength := l;
        SetStatus('', '', 'hit ' + IntToStr(FCurrentOffsetIdx + 1), '', False, False, True, False);
      end;
end;

//------------------------------------------------------------------------------

function TfrmFTS.HighlightFirst: Boolean;
begin
  FCurrentOffsetIdx := 0;
  Result := HighlightCurrent;
end;

//------------------------------------------------------------------------------

function TfrmFTS.HighlightLast: Boolean;
begin
  FCurrentOffsetIdx := Length(FCurrentOffsets) - 1;
  Result := HighlightCurrent;
end;

//------------------------------------------------------------------------------

function TfrmFTS.HighlightNext: Boolean;
begin
  Inc(FCurrentOffsetIdx);
  Result := HighlightCurrent;
end;

//------------------------------------------------------------------------------

function TfrmFTS.HighlightPrevious: Boolean;
begin
  Dec(FCurrentOffsetIdx);
  Result := HighlightCurrent;
end;

//------------------------------------------------------------------------------

procedure TfrmFTS.EnableControls(const AValue: Boolean);
begin
  btnIndex.Enabled := AValue;
  btnSearch.Enabled := AValue;

  btnFirst.Enabled := AValue;
  btnPrevious.Enabled := AValue;
  btnNext.Enabled := AValue;
  btnLast.Enabled := AValue;
end;

//------------------------------------------------------------------------------

procedure TfrmFTS.SetStatus(
  const StrOne, StrTwo, StrThree, StrFour: AnsiString;
  const UpdateOne: Boolean = True;
  const UpdateTwo: Boolean = True;
  const UpdateThree: Boolean = True;
  const UpdateFour: Boolean = True);
begin
  with StatusBar.Panels do
    begin
      if UpdateOne then Items[0].Text := StrOne;
      if UpdateTwo then Items[1].Text := StrTwo;
      if UpdateThree then Items[2].Text := StrThree;
      if UpdateFour then Items[3].Text := StrFour;
    end;
  Application.ProcessMessages;
end;

//------------------------------------------------------------------------------
// Form and Control events
//------------------------------------------------------------------------------

procedure TfrmFTS.FormCreate(Sender: TObject);
begin
  Caption := APP_TITLE;

  Constraints.MinHeight := Height;
  Constraints.MinWidth := Width;

  edtIndexPath.Text := ExpandFileName('..');

  with cbxExtensions, Items do
    begin
      Add('*.pas');
      Add('*.htm');
      Add('*.txt');
      ItemIndex := 0;
    end;

  with cbxModules, Items do
    begin
      {$IFDEF SQLITE_ENABLE_FTS1}Add('FTS1'); {$ENDIF}
      {$IFDEF SQLITE_ENABLE_FTS2}Add('FTS2'); {$ENDIF}
      ItemIndex := 0;
    end;

  cbxWordWrap.Checked := memoContents.WordWrap;

  {$IFDEF COMPILER_7_UP}
  { Starting with Delphi 7, a new TPanel.ParentBackground property defaults
    to True which suppresses out color settings. } 
  pnlIndexCaption.ParentBackground := False;
  pnlSearchCaption.ParentBackground := False;
  {$ENDIF COMPLIER_7_UP}

  CreateDatabase;
end;

//------------------------------------------------------------------------------

procedure TfrmFTS.FormDestroy(Sender: TObject);
begin
  CloseDatabase;
end;

//------------------------------------------------------------------------------

procedure TfrmFTS.btnIndexPathSelectClick(Sender: TObject);
var
  s: AnsiString;
begin
  s := edtIndexPath.Text;
  if Selectdirectory('Select Directory', '', s) then
    edtIndexPath.Text := s;
end;

//------------------------------------------------------------------------------

procedure TfrmFTS.btnIndexClick(Sender: TObject);
begin
  AddFiles(edtIndexPath.Text, cbxRecurse.Checked, cbxStemming.Checked);
end;

//------------------------------------------------------------------------------

procedure TfrmFTS.btnSearchClick(Sender: TObject);
begin
  SearchFiles(edtSearch.Text);
end;

//------------------------------------------------------------------------------

procedure TfrmFTS.edtSearchKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  case Key of
    VK_RETURN:
      SearchFiles(edtSearch.Text);
    VK_UP, VK_DOWN:
      begin
        SendMessage(lbxResults.Handle, WM_KEYDOWN, Key, 0);
        Key := 0;
      end;
    Ord('A'):
      if ssCtrl in Shift then
        edtSearch.SelectAll;
  end;
end;

//------------------------------------------------------------------------------

procedure TfrmFTS.lbxResultsClick(Sender: TObject);
var
  i: Integer;
begin
  i := lbxResults.ItemIndex;
  if i >= 0 then
    ShowContents(Integer(lbxResults.Items.Objects[i]));
end;

//------------------------------------------------------------------------------

procedure TfrmFTS.cbxWordWrapClick(Sender: TObject);
var
  b: Boolean;
begin
  b := cbxWordWrap.Checked;
  with memoContents do
    begin
      WordWrap := b;
      if b then
        ScrollBars := ssVertical
      else
        ScrollBars := ssBoth;
    end;
end;

//------------------------------------------------------------------------------

procedure TfrmFTS.btnNextClick(Sender: TObject);
begin
  HighlightNext;
end;

//------------------------------------------------------------------------------

procedure TfrmFTS.btnPreviousClick(Sender: TObject);
begin
  HighlightPrevious;
end;

//------------------------------------------------------------------------------

procedure TfrmFTS.btnFirstClick(Sender: TObject);
begin
  HighlightFirst;
end;

//------------------------------------------------------------------------------

procedure TfrmFTS.btnLastClick(Sender: TObject);
begin
  HighlightLast;
end;

//------------------------------------------------------------------------------

procedure TfrmFTS.memoContents_KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if (ssCtrl in Shift) and (Key = Ord('A')) then
    memoContents.SelectAll;
end;

end.