{ Main database access unit for the DISQLite3 Drive Catalog example.

  This unit supports both the DISQLite3 Standard and Personal editions.
  However, full Unicode support is not available with DISQLite3 Personal.

  Visit the DISQLite3 Internet site for latest information and updates:

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

  Copyright (c) 2005-2009 Ralf Junker, The Delphi Inspiration <delphi@yunqa.de>

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

unit DISQLite3_Drive_Catalog_DB;

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

interface

uses
  DISystemCompat, Types, Windows,
  DISQLite3Cache, DISQLite3Api, DISQLite3Database;

type
  TDriveCatalogDB = class;

  //------------------------------------------------------------------------------
  // TFileCache class
  //------------------------------------------------------------------------------

  { Stores node information for the FileTree. }
  TFileData = record
    Name: String;
    Size: Int64;
    Time: Double;
    Attri: Integer;
    IconIdx: Integer;
    Parent: Int64;
  end;
  PFileData = ^TFileData;

  { A common cache shared by all trees accessing the Files table. }
  TFileCache = class(TDIAbstractSQLite3Cache)
  protected
    procedure DoInitializeItem(const AItem: Pointer); override;
    procedure DoFinalizeItem(const AItem: Pointer); override;
  end;

  //------------------------------------------------------------------------------
  // TDriveCatalogStatement
  //------------------------------------------------------------------------------

  { }
  TDriveCatalogStatement = class(TDISQLite3Statement)
  public

    { Binds a FileTime structure as a Julian date. }
    procedure Bind_FileTime(
      const AParamIdx: Integer;
      const AFileTime: TFileTime);

  end;

  //------------------------------------------------------------------------------
  // TDriveCatalogDB
  //------------------------------------------------------------------------------

  { Callback function triggered during indexing. }
  TAddVolumeProgressCallback = procedure(
    const AFolder: String;
    var AAbort: Boolean) of object;

  { }
  TDriveCatalogDB = class(TDISQLite3Database)
  private
    FFileCache: TFileCache;
    { Prepared statement for frequently used query. }
    FStmt: TDISQLite3Statement;

  protected

    procedure DoAfterConnect; override;

    procedure DoAfterCreateDatabase; override;

    procedure DoBeforeDisconnect; override;

    procedure DoInitDatabase; override;

    function GetStatementClass: TDISQLite3StatementClass; override;

  public

    { Adds a new drive. Returns the new drive's ID. }
    function AddVolume(
      const AName: string;
      const ARootFolder: string;
      const ACallback: TAddVolumeProgressCallback): Int64;

    { Recursively deletes file / folder with AID.
      Returns the ParentID of the deleted file / folder. }
    function Delete(const AID: Int64): Int64;

    { }
    function GetFileData(const AID: Int64): PFileData;

    { }
    function GetVolumeFullPath(AID: Int64; out AVolume, AFullPath: UnicodeString): Boolean;

    { Returns the full path to AID as an array of IDs. }
    function GetIdPath(AID: Int64): TInt64DynArray;

    { }
    procedure Invalidate; overload;

    { }
    procedure Invalidate(const AID: Integer); overload;

    { Updates the name of the record. }
    procedure UpdateName(const AID: Int64; const AName: String);

  end;

  { }
  TInt64Rec = packed record
    case Boolean of
      False: (i64: Int64);
      True: (Lo, Hi: Cardinal);
  end;

  { Returns a string representation of the file attributes. }
function FileAttributesToString(const AFileAttributes: Integer): String;

{ Obtains the current system date and time. The result is a Julian Date
  in Coordinated Universal Time (UTC) format. }
function GetSystemTimeAsJulianDate: TDIJulianDate;

{ Returns a string representation for the given Julian date and time.
  AJulianDate is expected to be in UTC format. The result string
  will be corrected to local time. }
function JulianDateToDateTimeString(AJulianDate: TDIJulianDate): string;

{ Converts a Julian date to a TSystemTime record. }
function JulianDateToSystemTime(const AJulianDate: TDIJulianDate): TSystemTime;

{ Convertes a TSystemTime record to a Julian date. }
function SystemTimeToJulianDate(const ASystemTime: TSystemTime): TDIJulianDate;

const
  DIALOG_DATABASE_DEFAULTEXT = 'db3';
  DIALOG_DATABASE_FILTER = 'SQLite3 Database (*.db3)|*.db3|Any file (*.*)|*.*';

  { Our volume mark as a file attribute. }
  FILE_ATTRIBUTE_VOLUME = 1 shl 31;

  { If the icon index is not yet known. }
  ICON_INDEX_UNKNOWN = -2;

  TYPE_FILE = 0;
  TYPE_FOLDER = 1;
  TYPE_VOLUME = 2;

implementation

uses
  ShellAPI, SysUtils, Classes, RTLConsts
  {$IFNDEF DISQLite3_Personal}, DISQLite3Collations{$ENDIF};

//------------------------------------------------------------------------------
// TFileCache class
//------------------------------------------------------------------------------

procedure TFileCache.DoFinalizeItem(const AItem: Pointer);
begin
  Finalize(PFileData(AItem)^);
end;

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

procedure TFileCache.DoInitializeItem(const AItem: Pointer);
begin
  Initialize(PFileData(AItem)^);
end;

//------------------------------------------------------------------------------
// TDriveCatalogStatement class
//------------------------------------------------------------------------------

procedure TDriveCatalogStatement.Bind_FileTime(
  const AParamIdx: Integer;
  const AFileTime: TFileTime);
begin
  Bind_Double(AParamIdx, FileTimeToJulianDate(AFileTime));
end;

//------------------------------------------------------------------------------
// TDriveCatalogDB class
//------------------------------------------------------------------------------

function TDriveCatalogDB.AddVolume(
  const AName: string;
  const ARootFolder: string;
  const ACallback: TAddVolumeProgressCallback): Int64;
var
  Stmt_Insert: TDriveCatalogStatement;
  Stmt_Update_Size: TDISQLite3Statement;
  Abort: Boolean;

  function AddFolder(
    const AFolderName: String;
    const AParentID: Int64): Int64; // Returns total size of added files.
  var
    FD: TWin32FindData;
    h: THandle;
    NewFolderID: Int64;
    NewFolderSize: Int64;
    Size: TInt64Rec;
    s: string;
  begin
    Result := 0;

    if Assigned(ACallback) then
      begin
        ACallback(AFolderName, Abort);
        if Abort then Exit;
      end;

    h := FindFirstFile(PChar(AFolderName + '*'), FD);
    if h <> INVALID_HANDLE_VALUE then
      begin
        repeat
          if FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = 0 then
            begin
              { Add a file. }
              if FD.dwFileAttributes and FILE_ATTRIBUTE_TEMPORARY = 0 then
                begin
                  Stmt_Insert.Bind_Str16(1, FD.cFileName); // Name
                  Stmt_Insert.Bind_Int64(2, AParentID); // Parent
                  Stmt_Insert.Bind_Int(3, TYPE_FILE); // Type: File
                  Size.Hi := FD.nFileSizeHigh; Size.Lo := FD.nFileSizeLow;
                  Stmt_Insert.Bind_Int64(4, Size.i64); // Size
                  Inc(Result, Size.i64);
                  Stmt_Insert.Bind_FileTime(5, FD.ftLastWriteTime); // Time
                  Stmt_Insert.Bind_Int(6, FD.dwFileAttributes); // Attributes
                  Stmt_Insert.StepAndReset;
                end;
            end
          else
            if (FD.cFileName[0] <> '.') or not (
              (FD.cFileName[1] = #0) or
              (FD.cFileName[1] = '.') and
              (FD.cFileName[2] = #0)) then
              begin
                { Add a folder recursively. }
                s := FD.cFileName;
                Stmt_Insert.Bind_Str16(1, s); // Name
                Stmt_Insert.Bind_Int64(2, AParentID); // Parent
                Stmt_Insert.Bind_Int(3, TYPE_FOLDER); // Type: Folder
                // Size: is updated below.
                Stmt_Insert.Bind_FileTime(5, FD.ftLastWriteTime);
                Stmt_Insert.Bind_Int(6, FD.dwFileAttributes); // Attributes
                Stmt_Insert.StepAndReset;

                NewFolderID := LastInsertRowID;
                NewFolderSize := AddFolder(AFolderName + s + '\', NewFolderID);
                { Set size to total file size of all children. }
                Stmt_Update_Size.Bind_Int64(1, NewFolderSize);
                Stmt_Update_Size.Bind_Int64(2, NewFolderID);
                Stmt_Update_Size.StepAndReset;

                Inc(Result, NewFolderSize);
              end;
        until not FindNextFile(h, FD);
        Windows.FindClose(h);
      end;
  end;

var
  FN: String;
  Size: Int64;
begin
  StartTransaction;
  try
    Abort := False;

    Stmt_Insert := Prepare(
      'INSERT INTO"Files"("Name","Parent","Type","Size","Time","Attr")VALUES(?,?,?,?,?,?);')
      as TDriveCatalogStatement;
    Stmt_Update_Size := Prepare(
      'UPDATE "Files" SET "Size"=? WHERE "ID"=?;');

    try
      { Add the root with the catalog's name. }
      Stmt_Insert.Bind_Str16(1, AName);
      Stmt_Insert.Bind_Int64(2, 0);
      Stmt_Insert.Bind_Int(3, TYPE_VOLUME); // Mark as Volume.
      // Size: is updated below.
      Stmt_Insert.Bind_Double(5, GetSystemTimeAsJulianDate); // Time the volume was added.
      Stmt_Insert.Bind_Int(6, FILE_ATTRIBUTE_VOLUME); // Set the folder attribute.

      Stmt_Insert.StepAndReset;
      Result := LastInsertRowID;

      { Add the catalog's folders recursively. }
      FN := IncludeTrailingPathDelimiter(ARootFolder);
      Size := AddFolder(FN, Result);

      { Update the catalog's total file size. }
      Stmt_Update_Size.Bind_Int64(1, Size);
      Stmt_Update_Size.Bind_Int64(2, Result);
      Stmt_Update_Size.StepAndReset;
    finally
      Stmt_Update_Size.Free;
      Stmt_Insert.Free;
    end;

    if Abort then
      Rollback
    else
      Commit;
  except
    Rollback;
    raise;
  end;
end;

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

function TDriveCatalogDB.Delete(const AID: Int64): Int64;
var
  Stmt_Delete, Stmt_DeleteChildFiles, Stmt_SelectChildFolder: TDISQLite3Statement;

  { This procedure is called recursively. }
  procedure DeleteChildren(const AParentID: Int64);
  var
    ID: Int64;
  begin
    { Delete all child files first. }
    Stmt_DeleteChildFiles.Bind_Int64(1, AParentID);
    Stmt_DeleteChildFiles.StepAndReset;

    { Look for remaining child folders and delete them recursively. }
    repeat
      Stmt_SelectChildFolder.Bind_Int64(1, AParentID);
      if Stmt_SelectChildFolder.Step = SQLITE_ROW then
        begin
          { Get ID of child folder ... }
          ID := Stmt_SelectChildFolder.Column_Int64(0);
          Stmt_SelectChildFolder.Reset;
          { ... delete it ... }
          Stmt_Delete.Bind_Int64(1, ID);
          Stmt_Delete.StepAndReset;
          { ... and finally delete its children. }
          DeleteChildren(ID);
        end
      else
        begin
          Stmt_SelectChildFolder.Reset;
          Break;
        end;
    until False;
  end;

var
  ParentID, Size: Int64;
  Stmt, Stmt_SelectParent, Stmt_UpdateSize: TDISQLite3Statement;
begin
  { First delete all children. }

  Stmt_Delete := Prepare('DELETE FROM "Files" WHERE "ID"=?;');
  Stmt_DeleteChildFiles := Prepare('DELETE FROM "Files" WHERE "Type"=0 AND "Parent"=?;');
  Stmt_SelectChildFolder := Prepare('SELECT "ID" FROM "Files" WHERE "Type"=1 AND "Parent"=?;');
  try
    DeleteChildren(AID);
  finally
    Stmt_SelectChildFolder.Free;
    Stmt_DeleteChildFiles.Free;
    Stmt_Delete.Free;
  end;

  { Retrieve ParentID and Size of record to delete. }

  Stmt := Prepare('SELECT "Parent", "Size" FROM "Files" WHERE "ID"=?;');
  try
    Stmt.Bind_Int64(1, AID);
    if Stmt.Step = SQLITE_ROW then
      begin
        Result := Stmt.Column_Int64(0);
        Size := Stmt.Column_Int64(1);
      end
    else
      begin
        Result := -1;
        Size := 0;
      end;
  finally
    Stmt.Free;
  end;

  if Result = -1 then Exit;

  { Delete the record itself. }

  Stmt := Prepare('DELETE FROM "Files" WHERE "ID"=?;');
  try
    Stmt.Bind_Int64(1, AID);
    Stmt.Step;
  finally
    Stmt.Free;
  end;

  { Propagate the size change to the parent records. }

  ParentID := Result;
  Stmt_UpdateSize := Prepare('UPDATE "Files" SET "Size"="Size"-? WHERE "ID"=?;');
  Stmt_SelectParent := Prepare('SELECT "Parent" FROM "Files" WHERE "ID"=?;');
  try
    repeat
      Stmt_UpdateSize.Bind_Int64(1, Size);
      Stmt_UpdateSize.Bind_Int64(2, ParentID);
      Stmt_UpdateSize.StepAndReset;

      Stmt_SelectParent.Bind_Int64(1, ParentID);
      if Stmt_SelectParent.Step = SQLITE_ROW then
        begin
          ParentID := Stmt_SelectParent.Column_Int64(0);
          Stmt_SelectParent.Reset;
        end
      else
        begin
          Break;
        end;
    until False;
  finally
    Stmt_SelectParent.Free;
    Stmt_UpdateSize.Free;
  end;
end;

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

procedure TDriveCatalogDB.DoAfterConnect;
begin
  FFileCache := TFileCache.Create(SizeOf(TFileData), 7681); // 7681 is the first prime > (5120 * 1.5)
  FFileCache.MaxCount := 5120;

  FStmt := Prepare('SELECT "Name", "Size", "Time", "Attr", "Parent" FROM "Files" WHERE "ID"=?;');

  inherited;
end;

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

procedure TDriveCatalogDB.DoAfterCreateDatabase;
begin
  Execute(
    'PRAGMA legacy_file_format=OFF;');

  Execute(
    'CREATE TABLE "Files" (' +
    'ID Integer PRIMARY KEY,' + // Unique identifier.
    'Name Text,' + // Name of the volume, folder or file.
    'Parent Integer,' + // Identifier of parent of 0 if no parent.
    'Type Integer,' + // One of the TYPE_... constants.
    'Size Integer,' + // Size in bytes.
    'Time Double,' + // Date and Time in UTC JulianDate form when the file was last written to.
    'Attr Integer,' + // Attributes (DOS, as in WIN32_FIND_DATA), or NULL.
    'Desc Text,' + // Optional Description.
    'Hash Integer);'); // Optional CRC32 value of the file.

  Execute(
    'CREATE INDEX "Files_Parent_Type" ON "Files" ("Parent","Type");');

  inherited;
end;

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

procedure TDriveCatalogDB.DoBeforeDisconnect;
begin
  FStmt.Free;
  FFileCache.Free;

  inherited;
end;

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

procedure TDriveCatalogDB.DoInitDatabase;
begin
  {$IFNDEF DISQLite3_Personal}
  Check(sqlite3_create_collation(Handle, 'NOCASE', SQLITE_UTF16LE, nil, SQLite3_Compare_User_NoCase_UTF16LE));
  {$ENDIF !DISQLite3_Personal}
end;

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

function TDriveCatalogDB.GetStatementClass: TDISQLite3StatementClass;
begin
  Result := TDriveCatalogStatement;
end;

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

function TDriveCatalogDB.GetVolumeFullPath(AID: Int64; out AVolume, AFullPath: UnicodeString): Boolean;
var
  FileData: PFileData;
  s: String;
begin
  FileData := GetFileData(AID);
  Result := Assigned(FileData);
  if Result then
    begin
      AVolume := '';
      AFullPath := '';
      repeat
        s := FileData^.Name;
        AID := FileData^.Parent;
        if AID <> 0 then
          begin
            Insert(s, AFullPath, 1);
            Insert('\', AFullPath, 1);
          end
        else
          begin
            AVolume := s;
            Break;
          end;
        FileData := GetFileData(AID);
      until not Assigned(FileData);
    end;
end;

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

function TDriveCatalogDB.GetFileData(const AID: Int64): PFileData;
var
  Info: TShFileInfo;
begin
  Result := FFileCache.GetItem(AID);
  if not Assigned(Result) then
    begin
      Result := FFileCache.AddItem(AID);
      FStmt.Bind_Int64(1, AID);
      try
        if FStmt.Step = SQLITE_ROW then
          begin
            Result^.Name := FStmt.Column_Str16(0);
            Result^.Size := FStmt.Column_Int64(1);
            Result^.Time := FStmt.Column_Double(2);
            Result^.Attri := FStmt.Column_Int(3);
            Result^.Parent := FStmt.Column_Int64(4);

            { Is this a file (not a volume or a folder), then get the system icon index. }
            if Result^.Attri and (FILE_ATTRIBUTE_VOLUME or FILE_ATTRIBUTE_DIRECTORY) = 0 then
              if SHGetFileInfo(PChar(Result^.Name), FILE_ATTRIBUTE_NORMAL, Info, SizeOf(Info),
                SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX or SHGFI_SMALLICON) <> 0 then
                Result^.IconIdx := Info.iIcon
              else
                Result^.IconIdx := -1;
          end;
      finally
        FStmt.Reset;
      end;
    end;
end;

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

function TDriveCatalogDB.GetIdPath(AID: Int64): TInt64DynArray;
var
  l, s: Integer;
  FileData: PFileData;
  Temp: Int64;
begin
  l := 1;
  SetLength(Result, l);
  Result[0] := AID;

  repeat
    FileData := GetFileData(AID);
    if Assigned(FileData) then
      begin
        AID := FileData^.Parent;
        if AID = 0 then Break;

        Inc(l);
        SetLength(Result, l);
        Result[l - 1] := AID;
      end
    else
      Break;
  until False;

  { Revert. }
  if l > 1 then
    begin
      s := 0;
      Dec(l);
      repeat
        Temp := Result[l];
        Result[l] := Result[s];
        Result[s] := Temp;
        Inc(s); Dec(l);
      until s > l;
    end;
end;

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

procedure TDriveCatalogDB.Invalidate;
begin
  FFileCache.Invalidate;
end;

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

procedure TDriveCatalogDB.Invalidate(const AID: Integer);
begin
  FFileCache.InvalidateItem(AID);
end;

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

procedure TDriveCatalogDB.UpdateName(const AID: Int64; const AName: String);
var
  Stmt: TDISQLite3Statement;
begin
  Stmt := Prepare('UPDATE "Files" SET "Name"=? WHERE "ID"=?;');
  try
    Stmt.Bind_Str16(1, AName);
    Stmt.Bind_Int64(2, AID);
    Stmt.Step;
    Invalidate(AID);
  finally
    Stmt.Free;
  end;
end;

//------------------------------------------------------------------------------
// Utility Routines
//------------------------------------------------------------------------------

function FileAttributesToString(const AFileAttributes: Integer): String;
begin
  if AFileAttributes and FILE_ATTRIBUTE_TEMPORARY <> 0 then
    Result := Result + 'T';
  if AFileAttributes and FILE_ATTRIBUTE_SYSTEM <> 0 then
    Result := Result + 'S';
  if AFileAttributes and FILE_ATTRIBUTE_READONLY <> 0 then
    Result := Result + 'R';
  if AFileAttributes and FILE_ATTRIBUTE_HIDDEN <> 0 then
    Result := Result + 'H';
  if AFileAttributes and FILE_ATTRIBUTE_ARCHIVE <> 0 then
    Result := Result + 'A';
end;

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

function GetSystemTimeAsJulianDate: TDIJulianDate;
var
  ft: TFileTime;
begin
  GetSystemTimeAsFileTime(ft);
  Result := FileTimeToJulianDate(ft);
end;

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

function JulianDateToDateTimeString(AJulianDate: TDIJulianDate): string;
var
  Date, Time: string;
  l: Integer;
  ft: TFileTime;
  st: TSystemTime;
begin
  FileTimeToLocalFileTime(JulianDateToFileTime(AJulianDate), ft);
  FileTimeToSystemTime(ft, st);

  { Get the date string. }
  l := GetDateFormat(LOCALE_USER_DEFAULT, 0, @st, nil, nil, 0);
  SetString(Date, nil, l - 1);
  GetDateFormat(LOCALE_USER_DEFAULT, 0, @st, nil, Pointer(Date), l);

  { Get the time string. }
  l := GetTimeFormat(LOCALE_USER_DEFAULT, 0, @st, nil, nil, 0);
  SetString(Time, nil, l - 1);
  GetTimeFormat(LOCALE_USER_DEFAULT, 0, @st, nil, Pointer(Time), l);

  Result := Date + #$20 + Time;
end;

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

function JulianDateToSystemTime(const AJulianDate: TDIJulianDate): TSystemTime;
var
  Year, Month, Day, Hour, Minute, Second: Integer;
begin
  DISQLite3Api.JulianDateToYmd(AJulianDate, Year, Month, Day);
  Result.wYear := Year;
  Result.wMonth := Month;
  Result.wDayOfWeek := Trunc(AJulianDate + 1.5) mod 7;
  Result.wDay := Day;

  DISQLite3Api.JulianDateToHms(AJulianDate, Hour, Minute, Second);
  Result.wHour := Hour;
  Result.wMinute := Minute;
  Result.wSecond := Second;
  Result.wMilliSeconds := 0;
end;

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

function SystemTimeToJulianDate(const ASystemTime: TSystemTime): TDIJulianDate;
begin
  with ASystemTime do Result :=
    DISQLite3Api.YmdToJulianDate(wYear, wMonth, wDay) +
      DISQLite3Api.HmsToJulianDate(wHour, wMinute, wSecond);
end;

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

end.

