disqlite3_full_text_search_form_main.pas

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

{ This example project shows how to realize a full text search (FTS) utility
  with DISQLite3.

  The application includes both indexing and searching of *.pas or *.txt
  documents using the internal DISQLite3 full text search.

  To experience full text search you first need build the full text search
  index. Specify the path, extension, and the FTS module and click Index to
  add files to the full text index.

  After indexing, searching is immediately available, even if the application
  is restarted. Simply enter the search term and press 'Enter' to run the query.

  This demo uses the Demo.db3 database to store the full text index.

  Visit the DISQLite3 Internet site for latest information and updates:

    http://www.yunqa.de/delphi/

  Copyright (c) 2005-2007 Ralf Junker, The Delphi Inspiration <[e-mail]>

------------------------------------------------------------------------------ }

unit DISQLite3_Full_Text_Search_Form_Main;

{$I DI.inc}
{$I DISQLite3.inc}

interface

uses
  Classes, Controls, Forms, StdCtrls, ComCtrls, ExtCtrls,

  DISQLite3Database;

type
  TOffsetInfo = record
    o: Integer; // Offset
    l: Integer; // Length
  end;
  TOffsetInfoArray = array of TOffsetInfo;

  TfrmFTS = class(TForm)
    pnlIndex: TPanel;
    edtIndexPath: TEdit;
    btnIndex: TButton;
    lblIndexPath: TLabel;
    btnIndexPathSelect: TButton;
    cbxRecurse: TCheckBox;
    cbxStemming: TCheckBox;
    pnlSearch: TPanel;
    lblSearchExpression: TLabel;
    edtSearch: TEdit;
    btnSearch: TButton;
    pnlIndexCaption: TPanel;
    pnlSearchCaption: TPanel;
    pnlResults: TPanel;
    lbxResults: TListBox;
    memoContents: TMemo;
    StatusBar: TStatusBar;
    Splitter1: TSplitter;
    cbxModules: TComboBox;
    lblModule: TLabel;
    cbxExtensions: TComboBox;
    pnlSearchResult: TPanel;
    cbxWordWrap: TCheckBox;
    btnNext: TButton;
    btnPrevious: TButton;
    btnFirst: TButton;
    btnLast: TButton;
    procedure btnIndexPathSelectClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnIndexClick(Sender: TObject);
    procedure btnSearchClick(Sender: TObject);
    procedure edtSearchKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure lbxResultsClick(Sender: TObject);
    procedure cbxWordWrapClick(Sender: TObject);
    procedure btnNextClick(Sender: TObject);
    procedure btnPreviousClick(Sender: TObject);
    procedure btnFirstClick(Sender: TObject);
    procedure btnLastClick(Sender: TObject);
    procedure memoContents_KeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  private
    FDb: TDISQLite3Database;
    FCurrentContentID: Int64;
    FCurrentOffsets: TOffsetInfoArray;
    FCurrentOffsetIdx: Integer;
    FCurrentSearch: WideString;
    procedure CreateDatabase;
    procedure CloseDatabase;
    function HighlightCurrent: Boolean;
    procedure SetStatus(
      const StrOne, StrTwo, StrThree, StrFour: AnsiString;
      const UpdateOne: Boolean = True;
      const UpdateTwo: Boolean = True;
      const UpdateThree: Boolean = True;
      const UpdateFour: Boolean = True);
  public
    procedure AddFiles(aDir: AnsiString; const ARecurse: Boolean; const AStemming: Boolean);
    procedure EnableControls(const AValue: Boolean);
    function HighlightFirst: Boolean;
    function HighlightLast: Boolean;
    function HighlightNext: Boolean;
    function HighlightPrevious: Boolean;
    procedure SearchFiles(const ASearch: WideString);
    procedure ShowContents(const FileID: Integer);
  end;

var
  frmFTS: TfrmFTS;

const
  APP_TITLE = 'DISQLite3' + {$IFDEF DISQLite3_Personal} ' Personal' + {$ENDIF} ': Full Text Search Demo';

implementation

uses
  Windows, Messages, SysUtils, FileCtrl, Dialogs,

  DISQLite3Api;

{$R *.dfm}

const
  DATABASE_NAME = 'FTS.db3';
  FTS_TABLE = 'FTS';

  //------------------------------------------------------------------------------
  // Basic database functions
  //------------------------------------------------------------------------------

procedure TfrmFTS.CreateDatabase;
begin
  FDb := TDISQLite3Database.Create(nil);
  FDb.DatabaseName := DATABASE_NAME;
  try
    FDb.Open; // Exception here means: Database does not yet exist, create new one below!
  except
    FDb.CreateDatabase;
    { Do not use the old file format. The new one supports descending indexes,
      is more compact creates smaller databases. }
    FDb.Execute16('PRAGMA legacy_file_format=OFF;');
  end;
  {$IFDEF SQLITE_ENABLE_FTS1}sqlite3_check(sqlite3Fts1Init(FDb.Handle), FDb.Handle); {$ENDIF}
  {$IFDEF SQLITE_ENABLE_FTS2}sqlite3_check(sqlite3Fts2Init(FDb.Handle), FDb.Handle); {$ENDIF}
end;

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

procedure TfrmFTS.CloseDatabase;
begin
  FDb.Free;
end;

//------------------------------------------------------------------------------
// Full Text index and search functions
//------------------------------------------------------------------------------

procedure TfrmFTS.AddFiles(
  aDir: AnsiString;
  const ARecurse: Boolean;
  const AStemming: Boolean);
var
  StmtContent, StmtFiles: TDISQLite3Statement;
  Extension: AnsiString;
  TC: Cardinal;
  TotalFiles, TotalSize: Int64;

  function KiloByteText(const ABytes: Int64): AnsiString;
  begin
    Result := IntToStr((ABytes + 1023) div 1024) + ' KB';
  end;

  function GetTickCountDiff: Cardinal;
  begin
    Result := GetTickCount - TC;
    if Result = 0 then
      Result := 1;
  end;

  { Loads a file into a string. }
  function ReadString(const FileName: AnsiString; var s: AnsiString): Boolean;
  var
    FileHandle: THandle;
    FileSize, NumberOfBytesRead: DWORD;
  begin
    FileHandle := CreateFileA(PAnsiChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_SEQUENTIAL_SCAN, 0);
    Result := FileHandle <> INVALID_HANDLE_VALUE;
    if Result then
      begin
        FileSize := GetFileSize(FileHandle, nil);
        Result := FileSize <> $FFFFFFFF;
        if Result then
          begin
            SetString(s, nil, FileSize);
            Result := ReadFile(FileHandle, Pointer(s)^, FileSize, NumberOfBytesRead, nil) and (FileSize = NumberOfBytesRead);
            if not Result then
              SetLength(s, NumberOfBytesRead);
          end;
        Result := CloseHandle(FileHandle) and Result;
      end;
  end;

  { Scans a directory (recursively) and adds matches to the database. }
  procedure InternalAdd(const aDir: AnsiString);
  var
    FN: AnsiString;
    s: AnsiString;
    SR: TSearchRec;
  begin
    if FindFirst(aDir + Extension, faAnyFile, SR) = 0 then
      begin
        repeat
          FN := aDir + SR.Name;

          if ReadString(FN, s) then
            begin
              Inc(TotalFiles); Inc(TotalSize, Length(s));
              SetStatus(
                IntToStr(TotalFiles) + ' Files',
                KiloByteText(TotalSize),
                KiloByteText(TotalSize * 1000 div GetTickCountDiff) + ' / sec',
                FN);

              StmtContent.Bind_Str16(1, s);
              StmtContent.Step;
              StmtContent.Reset;

              StmtFiles.Bind_Int64(1, FDb.LastInsertRowID);
              StmtFiles.Bind_Str16(2, FN);
              StmtFiles.Step;
              StmtFiles.Reset;
            end;
        until FindNext(SR) <> 0;
        FindClose(SR);
      end;

    if ARecurse and (FindFirst(aDir + '*', faDirectory, SR) = 0) then
      begin
        repeat
          if (SR.Name <> '.') and (SR.Name <> '..') then
            InternalAdd(aDir + SR.Name + '\');
        until FindNext(SR) <> 0;
        FindClose(SR);
      end;
  end;

  {$IFNDEF COMPILER_6_UP}
  { Mimic function not available before Delphi 6. }
  function IncludeTrailingPathDelimiter(const s: AnsiString): AnsiString;
  begin
    Result := s;
    if (Result = '') or (Result[Length(Result)] <> '\') then
      Result := Result + '\';
  end;
  {$ENDIF !COMPILER_5_UP}

var
  FtsModule: WideString;
begin
  EnableControls(False);
  try
    lbxResults.Clear;
    memoContents.Clear;

    {$IFDEF SQLITE_OMIT_PAGER_PRAGMAS}
    ShowMessage(
      '"PRAGMA synchronous=off;" is not available in DISQLite3 Personal.' +
      #13#10#13#10 +
      'With the default synchronous=full, the database will pause at critical ' +
      'moments to make sure that data has actually been written to the disk ' +
      'surface before continuing. This is very safe, but makes indexing slower.' +
      #13#10#13#10 +
      '"PRAGMA synchronous=off;" is available in the Full version of DISQLite3.' +
      #13#10#13#10 +
      'With synchronous=off, the database continues without pausing as soon as ' +
      'it has handed data off to the operating system. This is a less safe if ' +
      'the operating system crashes or the computer loses power, but indexing ' +
      'is as much as 50 times faster with synchronous=off.' +
      #13#10#13#10 +
      'Only indexing is affected by the synchronous state. Searching is ' +
      'equally fast in DISQLite3 Peraonal and the Full version.');
    {$ELSE SQLITE_OMIT_PAGER_PRAGMA}
    FDb.Execute16('PRAGMA synchronous=off;'); // For speed!
    {$ENDIF SQLITE_OMIT_PAGER_PRAGMA}

    SetStatus('', '', '', 'Deleting old contents ...');

    { Drop all tables related to FTS. }

    FDb.Execute16('DROP TABLE IF EXISTS "' + FTS_TABLE + '";');

    {$IFDEF SQLITE_ENABLE_FTS1}
    FDb.Execute16('DROP TABLE IF EXISTS "' + FTS_TABLE + '_Content";');
    FDb.Execute16('DROP TABLE IF EXISTS "' + FTS_TABLE + '_Term";'); // FTS1
    {$ENDIF}

    {$IFDEF SQLITE_ENABLE_FTS2}
    FDb.Execute16('DROP TABLE IF EXISTS "' + FTS_TABLE + '_Content";');
    FDb.Execute16('DROP TABLE IF EXISTS "' + FTS_TABLE + '_SegDir";'); // FTS2
    FDb.Execute16('DROP TABLE IF EXISTS "' + FTS_TABLE + '_Segments";'); // FTS2
    {$ENDIF}

    FDb.Execute16('DROP TABLE IF EXISTS "' + FTS_TABLE + '_Files";');

    { Create brand new FTS demo tables:
        * FTS:       stores the file's contents and word index
        * FTS_Files: stores the names of the files indexed }

    SetStatus('', '', '', 'Creating new tables ...');

    FtsModule := cbxModules.Text;
    if AStemming then
      { If stemming is enabled, use the "Porter" stemming tokenizer. The Porter
        stemmer implements English language stemming so that run finds runs,
        running, etc. }
      FDb.Execute16('CREATE VIRTUAL TABLE "' + FTS_TABLE + '" USING ' + FtsModule + ' (Content, Tokenize Porter)')
    else
      { Without stemming, just use the standard tokenizer. }
      FDb.Execute16('CREATE VIRTUAL TABLE "' + FTS_TABLE + '" USING ' + FtsModule + ' (Content)');

    FDb.Execute16('CREATE TABLE "' + FTS_TABLE + '_Files" ("FileID" INTEGER PRIMARY KEY, "FileName" TEXT);');

    TC := GetTickCount;

    FDb.StartTransaction; // For speed!
    try
      { Prepare insertion statements for fastest indexing performance. }
      StmtContent := FDb.Prepare16('INSERT INTO "' + FTS_TABLE + '" ("Content") VALUES (?);');
      StmtFiles := FDb.Prepare16('INSERT INTO "' + FTS_TABLE + '_Files" ("FileID", "FileName") VALUES (?,?);');
      try
        aDir := ExpandFileName(aDir);
        aDir := IncludeTrailingPathDelimiter(aDir);
        Extension := cbxExtensions.Text;

        TotalFiles := 0; TotalSize := 0;
        { Finally scan the directory and add files (recursively). }
        InternalAdd(aDir);
      finally
        StmtFiles.Free;
        StmtContent.Free;
      end;

      SetStatus('', '', '', 'Committing changes ...', False, False, False);

      FDb.Commit;

      SetStatus(
        IntToStr(TotalFiles) + ' Files',
        KiloByteText(TotalSize),
        KiloByteText(TotalSize * 1000 div GetTickCountDiff) + ' / sec',
        'Indexing done');
    except
      { In case of errors, rollback changes and raise the error. }
      // SetStatus('', '', '', 'Indexing Error - rolling back changes');
      FDb.Rollback;
      // SetStatus('', '', '', 'Indexing Error - changes rolled back');
      raise;
    end;
  finally
    EnableControls(True);
  end;
end;

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

procedure TfrmFTS.SearchFiles(const ASearch: WideString);
var
  Stmt: TDISQLite3Statement;
  TC: Cardinal;
begin
  EnableControls(False);
  try
    FCurrentSearch := ASearch;
    lbxResults.Clear;
    memoContents.Clear;
    SetLength(FCurrentOffsets, 0);
    FCurrentOffsetIdx := -1;

    TC := GetTickCount;

    try
      { Prepare the full text search statement. }
      Stmt := FDb.Prepare16(
        'SELECT FileName, FileID FROM ' + FTS_TABLE + ', ' + FTS_TABLE + '_Files ' +
        'WHERE ' + FTS_TABLE + '.RowID = ' + FTS_TABLE + '_Files.FileID AND ' +
        FTS_TABLE + ' MATCH ?;');
    except
      on e: ESQLite3 do
        begin
          MessageDlg(e.Message + #13#10#13#10 + 'Did you already run the indexer which sets up the required tables?', mtError, [mbOK], 0);
          Exit;
        end;
      else
        raise;
    end;

    try
      lbxResults.Items.BeginUpdate;
      Stmt.Bind_Str16(1, ASearch);