structuredstorage.pas

Structured Storage Library in Delphi With source

unit StructuredStorage;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

Author:       Jay Hallett
Description:  TStructuredStorage
Creation:     April 13, 1999
Version:      1.02
Support:      None

Notes:
  The TStructuredStorage object is a Delphi friendly wrapper around the
  IStorage COM object.  This object can be used to create structured
  storage files that can contain other storages and streams of data within
  the single file.

  Non-root storages and streams MUST be openned with STGM_SHARE_EXCLUSIVE
  access due to the OLE support of the IStream interface.

  Streams MUST be openned in DIRECT mode.  The OLE implimentation does not
  support transacted streams as of this version.

  If a root storage is open in direct mode, then STGM_SHARE_EXCLUSIVE must
  be specified.  If a root storage is open in transacted mode, then any
  of the share mode specifiers can be used.

  Failing to specify the STGM_SHARE_EXCLUSIVE or STGM_SHARE_DENY_WRITE when
  openning a root storage will cause a snapshot of the storage to be taken.
  If the file is large, this snapshot could be very time consuming.


Updates:
     April 13, 1999 - v1.00  Initial Creation
     April 14, 1999 - v1.01  Added FindFirst/FindNext/FindClose
     April 19, 1999 - v1.02  Added SetElementTimes
  November 18, 2005 - v1.02  Added use of StgCreateStorageEx and
                             StgOpenStorageEx

 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

interface

uses Windows, Messages, SysUtils, Classes, ActiveX;

Const
  ssROOT_TRANSACTED  = STGM_TRANSACTED or STGM_READWRITE or STGM_SHARE_DENY_NONE;
  ssROOT_DIRECT      = STGM_DIRECT or STGM_READWRITE or STGM_SHARE_EXCLUSIVE;
  ssSTOR_TRANSACTED  = STGM_TRANSACTED or STGM_READWRITE or STGM_SHARE_EXCLUSIVE;
  ssSTOR_DIRECT      = STGM_DIRECT or STGM_READWRITE or STGM_SHARE_EXCLUSIVE;
  ssSTRM_DIRECT      = STGM_DIRECT or STGM_READWRITE or STGM_SHARE_EXCLUSIVE;

type
  //** Forward Declarations
  TStorageInfo = class;
  TStorageFind = class;
  TStorageStream = class;
  TStructuredStorage = class;

  //** Storage Enumeration Types
  TStorageType = (stStorage, stStream, stLockBytes, stProperty, stUnknown);
  TStorageFindSet = set of TStorageType;

  //** TStructuredStorage Object
  TStructuredStorage = class(TObject)
  public
    constructor Create;
    constructor CreateFromInterface(Storage: IStorage);
    destructor Destroy; override;
  private
    FStorage:  IStorage;
    procedure VerifyRootStorage;
  public
    //** Root Storage Controls
    procedure CreateRootStorage(FileName: String; Mode: Integer);
    procedure OpenRootStorage(FileName: String; Mode: Integer);
    procedure OpenTemporaryRootStorage(Mode: Integer);

    //** Storage & Stream Controls
    function  CreateStorage(StorageName: String; Mode: Integer): TStructuredStorage;
    function  OpenStorage(StorageName: String; Mode: Integer): TStructuredStorage;
    function  OpenTemporaryStorage(Mode: Integer): TStructuredStorage;
    function  CreateStream(StreamName: String; Mode: Integer): TStorageStream;
    function  OpenStream(StreamName: String; Mode: Integer): TStorageStream;

    //** Element Management Functions
    procedure CopyElementTo(ElementName: String; Storage: TStructuredStorage; NewElementName: String);
    procedure MoveElementTo(ElementName: String; Storage: TStructuredStorage; NewElementName: String);
    procedure DestroyElement(ElementName: String);
    procedure RenameElement(OldElementName, NewElementName: String);
    procedure SetElementTimes(ElementName: String; CreateTime, AccessTime, ModTime: TDateTime);

    //** Storage Transaction Functions
    procedure CommitIfCurrent;
    procedure CommitByForce;
    procedure CommitEx(Mode: Integer);
    procedure Revert;

    //** Identification Functions
    function  FindFirst(FindType: TStorageFindSet; var Search: TStorageFind): Boolean;
    function  FindNext(Search: TStorageFind): Boolean;
    procedure FindClose(Search: TStorageFind);
    procedure FindAllByType(FindType: TStorageFindSet; List: TStrings);
    function  IsStreamPresent(StreamName: String): Boolean;
    function  IsStoragePresent(StorageName: String): Boolean;
  end;

  //** TStorageStream Delphi Streaming Object
  TStorageStream = class(TStream)
  public
    constructor CreateFromInterface(Stream: IStream);
    destructor Destroy; override;
  private
    FStream:  IStream;
  public
    //** Stream Read/Write Assist Functions
    procedure WriteString(const Value: String);
    procedure WriteInteger(const Value: Integer);
    procedure WriteBoolean(const Value: Boolean);
    procedure WriteStringList(Value: TStrings);
    function  ReadString: String;
    function  ReadInteger: Integer;
    function  ReadBoolean: Boolean;
    procedure ReadStringList(Value: TStrings);

    //** Stream File Assist Functions
    procedure LoadFromFile(const FileName: String);
    procedure SaveToFile(const FileName: String);

    //** TStream Abstract Overrides
    procedure SetSize(NewSize: Longint); override;
    function Read(var Buffer; Count: Longint): Longint;  override;
    function Write(const Buffer; Count: Longint): Longint;  override;
    function Seek(Offset: Longint; Origin: Word): Longint;  override;
  end;

  //** Storage Information Object
  TStorageInfo = class(TObject)
  private
    FName:          String;
    FSize:          Integer;
    FStorageType:   TStorageType;
    FCreated:       TDateTime;
    FLastModified:  TDateTime;
    FLastAccessed:  TDateTime;
  public
    property Name:          String        Read FName          Write FName;
    property Size:          Integer       Read FSize          Write FSize;
    property StorageType:   TStorageType  Read FStorageType   Write FStorageType;
    property Created:       TDateTime     Read FCreated       Write FCreated;
    property LastModified:  TDateTime     Read FLastModified  Write FLastModified;
    property LastAccessed:  TDateTime     Read FLastAccessed  Write FLastAccessed;
  end;

  //** TStorageFind Object
  TStorageFind = class(TStorageInfo)
  public
    constructor Create(FindSet: TStorageFindSet; Enum: IEnumSTATSTG);
    destructor Destroy; override;
  private
    FFindSet:       TStorageFindSet;
    FEnumerator:    IEnumSTATSTG;
  protected
    function NextFromInterface: Boolean;
  end;


  //** Structed Storage Exception Object
  EStructuredStorage = class(Exception);

  //** Utility Functions
  function  IsFileStorage(const FileName: String): Boolean;
  procedure CheckHRESULT(Code: HRESULT; Subst: String);
  function  GetStorageType(dwType: DWORD): TStorageType;
  function  UTCFileTimeToDateTime(const ft: TFileTime): TDateTime;
  function  DateTimeToUTCFileTime(const dt: TDateTime): TFileTime;

implementation

Const
  IID_IStorage: TGUID = '{0000000B-0000-0000-C000-000000000046}';
  SSVER_NAME          = 'TSS-VersionInfo';
  SSVERSION           = 'TStructedStorage v1.02';


//****************************************************
//** Exception Messages                     (English)
//****************************************************
Const
  SSEX_NOTSTRUCTEDSTORAGE = '(%s):' + #13 + 'Specified file is not a Structed Storage file.';
  SSEX_NOTCORRECTVERSION  = '(%s):' + #13 + 'Specified file is not the correct version.';
  SSEX_NOCURRENTSTORAGE   = 'Error:  No Root Storage Object has been openned.';
  SSEX_MUSTBEEXCLUSIVE    = 'Error:  Non-Root Storages & Streams must be opened with EXCLUSIVE access.';
  SSEX_MUSTBEDIRECT       = 'Error:  Streams must be opened in direct access mode.';
  SSEX_CORRUPTEDVERSION   = 'Error:  Version information has become corrupted.';


//****************************************************
//** Use Enhanced(EX) STG Storage API
//****************************************************
function StgCreateStorageEx(const pwcsName: POleStr; grfMode: DWORD;
  stgMft: DWORD; grfAttrs: DWORD; pStgOptions: Pointer;
  reserved2: Pointer; riid: PGUID; out stgOpen: IStorage): HResult; stdcall;
  external 'ole32.dll' name 'StgCreateStorageEx';

function StgOpenStorageEx (const pwcsName: POleStr; grfMode: LongInt;
  stgfmt: DWORD; grfAttrs: DWORD; pStgOptions: Pointer;
  reserved2: Pointer; riid: PGUID; out stgOpen: IStorage): HResult; stdcall;
  external 'ole32.dll' name 'StgOpenStorageEx';


//****************************************************
//** TStructedStorage Constructor & Destructors
//****************************************************
constructor TStructuredStorage.Create;
begin
  inherited Create;

  //** Null Storage Object
  FStorage := nil;
end;

constructor TStructuredStorage.CreateFromInterface(Storage: IStorage);
begin
  inherited Create;

  //** Assign Storage Object
  FStorage := Storage;
end;

destructor TStructuredStorage.Destroy;
begin
  //** Release the Storage Object if it is Assigned
  if (FStorage <> nil) then begin
    FStorage := nil;
  end;

  inherited Destroy;
end;


//****************************************************
//** Private Functions & Procedures
//****************************************************
procedure TStructuredStorage.VerifyRootStorage;
begin
  //** Verify the current IStorage Object
  if (FStorage = nil) then begin
    Raise EStructuredStorage.Create(SSEX_NOCURRENTSTORAGE);
  end;
end;


//****************************************************
//** Public Functions & Procedures
//****************************************************
procedure TStructuredStorage.CreateRootStorage(FileName: String; Mode: Integer);
var
  WideName:  Array[0..MAX_PATH] of WideChar;
  pWideName: PWideChar;
  Stream:    TStorageStream;
begin
  //** Create the Root Storage
  pWideName := nil;
  if (Length(FileName) > 0) then begin
    pWideName := StringToWideChar(FileName, @WideName[0], Sizeof(WideName) div Sizeof(WideChar));
  end;
  CheckHRESULT(StgCreateStorageEx(pWideName, Mode or STGM_CREATE, 0, 0, nil, nil, @IID_IStorage, FStorage), FileName);

  //** Create the Version Stream
  Try
    Stream := Self.CreateStream(SSVER_NAME, ssSTRM_DIRECT);
    Stream.WriteString(SSVERSION);
    Stream.Free;

    //** Commit the Storage
    Self.CommitByForce;
  Except
    FStorage := nil;
    Raise;
  End;
end;

procedure TStructuredStorage.OpenRootStorage(FileName: String; Mode: Integer);
var
  WideName:  Array[0..MAX_PATH] of WideChar;
  pWideName: PWideChar;
  szVersion: String;
  Stream:    TStorageStream;
begin
  //** Verify File Exists
  if NOT (IsFileStorage(FileName)) then begin
    Raise EStructuredStorage.CreateFmt(SSEX_NOTSTRUCTEDSTORAGE, [FileName]);
  end;

  //** Open the Root Storage Object
  pWideName := StringToWideChar(FileName, @WideName[0], Sizeof(WideName) div Sizeof(WideChar));
  CheckHRESULT(StgOpenStorageEx(pWideName, Mode, 0, 0, nil, nil, @IID_IStorage, FStorage), FileName);

  //** Verify the Version Stream
  Try
    if (Self.IsStreamPresent(SSVER_NAME)) then begin
      Stream := Self.OpenStream(SSVER_NAME, ssSTRM_DIRECT);

      //** Verify the Stream size in case of corruption
      if (Stream.Size > Length(SSVERSION) + 10) then begin
        Raise EStructuredStorage.CreateFmt(SSEX_CORRUPTEDVERSION, [Stream.Size]);
      end;

      szVersion := Stream.ReadString;
      Stream.Free;
      if (szVersion <> SSVERSION) then begin
        Raise EStructuredStorage.CreateFmt(SSEX_NOTCORRECTVERSION, [FileName]);
      end;
    end else begin
      Raise EStructuredStorage.CreateFmt(SSEX_NOTCORRECTVERSION, [FileName]);
    end;
  Except
    FStorage := nil;
    Raise;
  End;
end;

procedure TStructuredStorage.OpenTemporaryRootStorage(Mode: Integer);
begin
  Self.CreateRootStorage(EmptyStr, Mode or STGM_DELETEONRELEASE);
end;

function TStructuredStorage.CreateStorage(StorageName: String; Mode: Integer): TStructuredStorage;
var
  WideName:  Array[0..MAX_PATH] of WideChar;
  pWideName: PWideChar;
  Storage:   IStorage;
begin
  //** Verify the Root Storage object
  VerifyRootStorage;

  //** Create the Sub-Storage Object
  pWideName := nil;
  if (Length(StorageName) > 0) then begin
    pWideName := StringToWideChar(StorageName, @WideName[0], Sizeof(WideName) div Sizeof(WideChar));
  end;
  CheckHRESULT(FStorage.CreateStorage(pWideName, Mode or STGM_CREATE, 0, 0, Storage), StorageName);

  //** Create the TStructuredStorage Wrapper
  Result := TStructuredStorage.CreateFromInterface(Storage);
end;

function TStructuredStorage.OpenStorage(StorageName: String; Mode: Integer): TStructuredStorage;
var
  WideName:  Array[0..MAX_PATH] of WideChar;
  pWideName: PWideChar;
  Storage:   IStorage;
begin
  //** Verify the Root Storage object
  VerifyRootStorage;

  //** Non-Root Storages & Streams must be exclusive access.
  if NOT ((STGM_SHARE_EXCLUSIVE AND Mode) = STGM_SHARE_EXCLUSIVE)  then begin
    Raise EStructuredStorage.Create(SSEX_MUSTBEEXCLUSIVE);
  end;

  //** Create the Sub-Storage Object
  pWideName := StringToWideChar(StorageName, @WideName[0], Sizeof(WideName) div Sizeof(WideChar));
  CheckHRESULT(FStorage.OpenStorage(pWideName, nil, Mode, nil, 0, Storage), StorageName);

  //** Create the TStructuredStorage Wrapper
  Result := TStructuredStorage.CreateFromInterface(Storage);
end;

function TStructuredStorage.OpenTemporaryStorage(Mode: Integer): TStructuredStorage;
begin
  Result := CreateStorage(EmptyStr, Mode or STGM_DELETEONRELEASE);
end;

function TStructuredStorage.CreateStream(StreamName: String; Mode: Integer): TStorageStream;
var
  WideName:  Array[0..MAX_PATH] of WideChar;
  pWideName: PWideChar;
  Stream:    IStream;
begin
  //** Verify the Root Storage object
  VerifyRootStorage;

  //** Non-Root Storages & Streams must be exclusive access.
  //** Streams must have direct access.
  if NOT ((STGM_SHARE_EXCLUSIVE AND Mode) = STGM_SHARE_EXCLUSIVE)  then begin
    Raise EStructuredStorage.Create(SSEX_MUSTBEEXCLUSIVE);
  end;
  if NOT ((STGM_DIRECT AND Mode) = STGM_DIRECT)  then begin
    Raise EStructuredStorage.Create(SSEX_MUSTBEDIRECT);
  end;

  //** Create the Stream Object
  pWideName := nil;
  if (Length(StreamName) > 0) then begin
    pWideName := StringToWideChar(StreamName, @WideName[0], Sizeof(WideName) div Sizeof(WideChar));
  end;
  CheckHRESULT(FStorage.CreateStream(pWideName, Mode, 0, 0, Stream), StreamName);

  //** Create the TStorageStream Wrapper
  Result := TStorageStream.CreateFromInterface(Stream);
end;

function TStructuredStorage.OpenStream(StreamName: String; Mode: Integer): TStorageStream;
var
  WideName:  Array[0..MAX_PATH] of WideChar;
  pWideName: PWideChar;
  Stream:    IStream;
begin
  //** Verify the Root Storage object
  VerifyRootStorage;

  //** Non-Root Storages & Streams must be exclusive access.
  //** Streams must have direct access.
  if NOT ((STGM_SHARE_EXCLUSIVE AND Mode) = STGM_SHARE_EXCLUSIVE)  then begin
    Raise EStructuredStorage.Create(SSEX_MUSTBEEXCLUSIVE);
  end;
  if NOT ((STGM_DIRECT AND Mode) = STGM_DIRECT)  then begin
    Raise EStructuredStorage.Create(SSEX_MUSTBEDIRECT);
  end;

  //** Create the Stream Object
  pWideName := StringToWideChar(StreamName, @WideName[0], Sizeof(WideName) div Sizeof(WideChar));
  CheckHRESULT(FStorage.OpenStream(pWideName, nil, Mode, 0, Stream), StreamName);

  //** Create the TStorageStream Wrapper
  Result := TStorageStream.CreateFromInterface(Stream);
end;

procedure TStructuredStorage.CopyElementTo(ElementName: String; Storage: TStructuredStorage; NewElementName: String);
var
  WideName, DestWideName:   Array[0..MAX_PATH] of WideChar;
  pWideName, pDestWideName: PWideChar;
begin
  //** Verify the Root Storage object
  VerifyRootStorage;

  //** Copy the Element to the Destination (IStorage)
  pWideName := StringToWideChar(ElementName, @WideName[0], Sizeof(WideName) div Sizeof(WideChar));
  pDestWideName := StringToWideChar(NewElementName, @DestWideName[0], Sizeof(DestWideName) div Sizeof(WideChar));
  CheckHRESULT(FStorage.MoveElementTo(pWideName, Storage.FStorage, pDestWideName, STGMOVE_COPY), ElementName);
end;

procedure TStructuredStorage.MoveElementTo(ElementName: String; Storage: TStructuredStorage; NewElementName: String);
var
  WideName, DestWideName:   Array[0..MAX_PATH] of WideChar;
  pWideName, pDestWideName: PWideChar;
begin
  //** Verify the Root Storage object
  VerifyRootStorage;

  //** Copy the Element to the Destination (IStorage)
  pWideName := StringToWideChar(ElementName, @WideName[0], Sizeof(WideName) div Sizeof(WideChar));
  pDestWideName := StringToWideChar(NewElementName, @DestWideName[0], Sizeof(DestWideName) div Sizeof(WideChar));
  CheckHRESULT(FStorage.MoveElementTo(pWideName, Storage.FStorage, pDestWideName, STGMOVE_MOVE), ElementName);
end;

procedure TStructuredStorage.DestroyElement(ElementName: String);
var
  WideName:  Array[0..MAX_PATH] of WideChar;
  pWideName: PWideChar;
begin
  //** Verify the Root Storage object
  VerifyRootStorage;

  //** Destroy the Element
  pWideName := StringToWideChar(ElementName, @WideName[0], Sizeof(WideName) div Sizeof(WideChar));
  CheckHRESULT(FStorage.DestroyElement(pWideName), ElementName);
end;