////////////////////////////////////////////////////////////////////////////////
//
//  ****************************************************************************
//  * Unit Name : GSStorage
//  * Purpose   : Обертк?на?структурированны?хранилищем данных (Com Storage)
//  * Author    : Александ?Багель
//  * Copyright : Цент?Гран?2001 - 2005 ?
//  * Version   : 1.34
//  ****************************************************************************
//

unit EM.GSStorage;

interface

uses
  WinApi.Windows, Classes, WinApi.ActiveX, AxCtrls, SysUtils, WinAPi.ShlObj;

const
  CLRF = #13#10;

type
  TStatStgEx = record
    pwcsName: String[30];
    dwType: Longint;
  end;

  TStatStgArray = array of TStatStgEx;
  TGSStorageEnum = packed record
    Count: Cardinal;
    ElementEnum: TStatStgArray;
  end;

  GSCustomStorageException = class(Exception);
  TGSStorageCursors = class;
  TGSCustomStorage = class;
  TGSStorage = class;

  TGSStorageCursor = class(TCollectionItem)
  private
    FLockCount: Integer;
    FID: ShortString;
    FStorageInterface: IStorage;
    FSubStorage: TGSStorageCursors;
    FMode: Longint;
    FOwner: TGSCustomStorage;
    FParent: TGSStorageCursor;
    procedure SetParam(const AOwner: TGSCustomStorage;
      AParent: TGSStorageCursor);
    function GetPath: String;
    function GetLock: Boolean;
    function GetLockCount: Integer;
    procedure Lock;
    procedure UnLock;
    property Locked: Boolean read GetLock;
    {$IFDEF CLASS_INSTANCE}
      class procedure AddInstance;
      class procedure ReleaseInstance;
    {$ENDIF}
  protected
    procedure Garbage;
    function ExistsObject(const AName: String; const AType: Longint;
      var Exists: Boolean): Boolean;
    function GetName: String;
  public
    {$IFDEF CLASS_INSTANCE}
      class function NumOfInstances: Integer;
    {$ENDIF}
    function Backward(var ACursor: TGSStorageCursor): Boolean;
    constructor Create(Collection: TCollection); override;
    function CreateStream(const AName: String): HRESULT;
    function CreateStorage(const AName: String;
      var ACursor: TGSStorageCursor): HRESULT;
    function Copy(const AName: String;
      const ACursor: TGSStorageCursor): HRESULT;
    function DeleteStream(const AName: String): HRESULT;
    function DeleteStorage(const AName: String): HRESULT;
    destructor Destroy; override;
    function Enumerate(var AData: TGSStorageEnum): HRESULT;
    procedure FreeMemAfterEnum(var AData: TGSStorageEnum);
    function FlushBuffer: HRESULT;
    function MoveTo(const AName: String;
      const ACursor: TGSStorageCursor): HRESULT;
    function OpenStorage(const AName: String;
      var ACursor: TGSStorageCursor; Verify: Boolean = True): HRESULT;
    function StreamExists(const AName: String): Boolean;
    function StorageExists(const AName: String): Boolean;
//    function ReadStream(const AName: String;
//      var AStream: TStream; Verify: Boolean = True): HRESULT;
    function ReadStream(const AName: String;
      AStream: TStream; Verify: Boolean = True): HRESULT;
    function Rename(const AName, ANewName: String): HRESULT;
    function WriteStream(const AName: String; const AStream: TMemoryStream): HRESULT;
    procedure Release;
    property Path: String read GetPath;
    property Storages: TGSStorageCursors read FSubStorage;
  end;

  TGSStorageCursors = class(TCollection)
  private
    function GetItem(Index: Integer): TGSStorageCursor;
    procedure SetItem(Index: Integer; const Value: TGSStorageCursor);
    function Add: TGSStorageCursor;
    {$IFDEF CLASS_INSTANCE}
      class procedure AddInstance;
      class procedure ReleaseInstance;
    {$ENDIF}
  protected
    function FindStorageByName(
      const AName: String; var Index: Cardinal): Boolean;
  public
    {$IFDEF CLASS_INSTANCE}
      class function NumOfInstances: Integer;
    {$ENDIF}
    constructor Create;
    destructor Destroy; override;
    property Items[Index: Integer]: TGSStorageCursor read GetItem write SetItem; default;
  end;

  TGSCustomStorage = class(TPersistent)
  private
    FRootStorage: TGSStorageCursor;
    FMode: Longint;
    FFileName: String;
    FCanCreate: Boolean;
    function GetActive: Boolean;
    {$IFDEF CLASS_INSTANCE}
      class procedure AddInstance;
      class procedure ReleaseInstance;
    {$ENDIF}
  protected
    function OpenFileEx(const AFileName: String;
      const CanCreate: Boolean; const AMode: LongInt;
      var ACursor: TGSStorageCursor): HRESULT;
    procedure Garbage;
    class function ClassSupport(const AFileName: String; Change: Boolean): HRESULT;
  public
    {$IFDEF CLASS_INSTANCE}
      class function NumOfInstances: Integer;
      constructor Create;
    {$ENDIF}
    destructor Destroy; override;
    function CreateCursor: TGSStorageCursor;
    function ForceStorage(APath: String; var ACursor: TGSStorageCursor): HRESULT;
    function OpenFileReadOnly(const AFileName: String;
      var ACursor: TGSStorageCursor): HRESULT;
    function OpenFile(const AFileName: String;
      const CanCreate: Boolean; var ACursor: TGSStorageCursor): HRESULT;
    function OpenStorage(APath: String; var ACursor: TGSStorageCursor): HRESULT;
    procedure CloseFile;
    function IsBussy: Boolean;
    function ReConnect(var AStorage: TGSStorage;
      var ACursor: TGSStorageCursor): HRESULT;
    class function Compress(const AFileName: String): HRESULT;
    class function IsStgValidBinaryFmt(const AFileName: String): HRESULT;
    property Active: Boolean read GetActive;
  end;

  TGSStorage = class(TGSCustomStorage);

 { TGInfoStorage = class(TGSCustomStorage)
  public
    function WriteInteger
  end; }

implementation

uses Variants, System.Win.ComObj;

{$IFDEF CLASS_INSTANCE}
var
  TGSCustomStorage_Instance: Integer = 0;
  TGSStorageCursor_Instance: Integer = 0;
  TGSStorageCursors_Instance: Integer = 0;
{$ENDIF}

{ TGSStorage }

//  Закрытие всех дочерних Storage
// =============================================================================
procedure TGSCustomStorage.CloseFile;
begin
  if Assigned(FRootStorage) then
  begin
    FreeAndNil(FRootStorage);
    {$IFDEF CREATE_FREE_LOG}
      CreateFreeLog(False, 'TGSCustomStorage.FRootStorage');
    {$ENDIF}
  end;
end;

function TGSCustomStorage.CreateCursor: TGSStorageCursor;
begin
  if FRootStorage = nil then
  begin
    Result := nil;
    Exit;
  end;
  Result := FRootStorage;
end;

destructor TGSCustomStorage.Destroy;
begin
  if Assigned(FRootStorage) then
    FRootStorage.Free;
  {$IFDEF CREATE_FREE_LOG}
    CreateFreeLog(False, 'TGSCustomStorage.FRootStorage');
  {$ENDIF}

  {$IFDEF CLASS_INSTANCE}
    ReleaseInstance;
  {$ENDIF}
  inherited;
end;


function TGSCustomStorage.IsBussy: Boolean;
var
  LocCount: Integer;
begin
  LocCount := 0;
  Inc(LocCount, FRootStorage.GetLockCount);
  Result := LocCount > 1;
end;


function TGSCustomStorage.ReConnect(var AStorage: TGSStorage;
  var ACursor: TGSStorageCursor): HRESULT;
begin
  AStorage.CloseFile;
  Result := AStorage.OpenFileEx(FFileName, FCanCreate, FMode, ACursor);
end;


//  Аналог ForceDirectory
// =============================================================================
function TGSCustomStorage.ForceStorage(APath: String;
  var ACursor: TGSStorageCursor): HRESULT;
var
  S: TStringList;
  I: Integer;
begin
  Result := S_FALSE;
  if APath = '' then
    raise Exception.Create(SysErrorMessage(ERROR_INVALID_PARAMETER));
  S := TStringList.Create;
  try
    ACursor := FRootStorage;
    if ACursor.GetName + '\' <> Copy(APath, 1, Length(ACursor.GetName) + 1) then
    begin
      Result := ERROR_PATH_NOT_FOUND;
      Exit;
    end;
    Delete(APath, 1, Length(ACursor.GetName) + 1);
    S.Text := StringReplace(APath, '\', CLRF, [rfReplaceAll]);
    for I := 0 to S.Count - 1 do
    begin
      if ACursor.StorageExists(S.Strings[I]) then
        Result := ACursor.OpenStorage(S.Strings[I], ACursor)
      else
        Result := ACursor.CreateStorage(S.Strings[I], ACursor);
      if Result <> S_OK then
      begin
        FRootStorage.Garbage;
        Exit;
      end;
    end;
  finally
    S.Free;
  end;
end;      

procedure TGSCustomStorage.Garbage;
begin
  if FRootStorage <> nil then
    FRootStorage.Garbage;
end;


//  открытие хранилищ?(?перезапись?ил?не?
// =============================================================================
function TGSCustomStorage.OpenFile(const AFileName: String;
  const CanCreate: Boolean; var ACursor: TGSStorageCursor): HRESULT;
begin
  Result := OpenFileEx(AFileName, CanCreate,
    STGM_READWRITE or STGM_SHARE_EXCLUSIVE, ACursor);
end;


//  Реализац? открыт? файл?
// =============================================================================
function TGSCustomStorage.OpenFileEx(const AFileName: String;
  const CanCreate: Boolean; const AMode: LongInt;
  var ACursor: TGSStorageCursor): HRESULT;
begin
  FMode := AMode;
  FCanCreate := CanCreate;
  FFileName := AFileName;
  CloseFile;
  FRootStorage := TGSStorageCursor.Create(nil);
  {$IFDEF CREATE_FREE_LOG}
    CreateFreeLog(True, 'TGSCustomStorage.FRootStorage');
  {$ENDIF}
  if CanCreate then
  begin
    ACursor := FRootStorage;
    ACursor.SetParam(Self, nil);
    Result := StgCreateDocfile(StringToOleStr(AFileName), FMode or STGM_CREATE, 0,
      ACursor.FStorageInterface);
    {$IFDEF CREATE_FREE_LOG}
      CreateFreeLog(True, 'TGSCustomStorage.ACursor.FStorageInterface = ' + IntToStr(Integer(ACursor.FStorageInterface)));
    {$ENDIF}
    ACursor.Lock;
  end
  else
  begin
    if not FileExists(AFileName) then
    begin
      Result := ERROR_FILE_NOT_FOUND;
      Exit;
    end;
    Result := StgIsStorageFile(StringToOleStr(AFileName));
    if Result <> S_OK then Exit;
    ACursor := FRootStorage;
    ACursor.SetParam(Self, nil);
    Result := StgOpenStorage(StringToOleStr(AFileName),
      nil, FMode, nil, 0, ACursor.FStorageInterface);
    {$IFDEF CREATE_FREE_LOG}
      CreateFreeLog(True, 'TGSCustomStorage.ACursor.FStorageInterface = ' + IntToStr(Integer(ACursor.FStorageInterface)));
    {$ENDIF}      
    ACursor.Lock;
  end;
end;


function TGSCustomStorage.OpenStorage(APath: String;
  var ACursor: TGSStorageCursor): HRESULT;
var
  S: TStringList;
  I: Integer;
begin
  Result := S_FALSE;
  if APath = '' then
    raise Exception.Create(SysErrorMessage(ERROR_INVALID_PARAMETER));
  S := TStringList.Create;
  try
    ACursor := FRootStorage;
    if APath[Length(APath)] <> '\' then APath := APath + '\';
    if ACursor.GetName + '\' <> Copy(APath, 1, Length(ACursor.GetName) + 1) then
    begin
      Result := ERROR_PATH_NOT_FOUND;
      Exit;
    end;
    Delete(APath, 1, Length(ACursor.GetName) + 1);
    S.Text := StringReplace(APath, '\', CLRF, [rfReplaceAll]);
    for I := 0 to S.Count - 1 do
      if ACursor.StorageExists(S.Strings[I]) then
      begin
        if ACursor.OpenStorage(S.Strings[I], ACursor) <> S_OK then Exit
      end
      else
        raise Exception.Create(SysErrorMessage(ERROR_PATH_NOT_FOUND));
    Result := S_OK;
  finally
    S.Free;
  end;
end;


//  Открытие хранилищ??режиме чтен?
// =============================================================================
function TGSCustomStorage.OpenFileReadOnly(
  const AFileName: String; var ACursor: TGSStorageCursor): HRESULT;
begin
  Result := OpenFileEx(AFileName, False, STGM_READ or STGM_SHARE_EXCLUSIVE,
    ACursor);
end;

{ TGSStorageCursors }

function TGSStorageCursors.Add: TGSStorageCursor;
begin
  Result := TGSStorageCursor(inherited Add);
end;

{$IFDEF CLASS_INSTANCE}
class procedure TGSStorageCursors.AddInstance;
begin
  Inc(TGSStorageCursors_Instance);
end;
{$ENDIF}

constructor TGSStorageCursors.Create;
begin
  inherited Create(TGSStorageCursor);
  {$IFDEF CLASS_INSTANCE}
    AddInstance;
  {$ENDIF}
end;

destructor TGSStorageCursors.Destroy;
begin
  {$IFDEF CLASS_INSTANCE}
    ReleaseInstance;
  {$ENDIF}
  inherited;
end;


//  Поис?открытог?Storage по имен?
// =============================================================================
function TGSStorageCursors.FindStorageByName(
  const AName: String; var Index: Cardinal): Boolean;
var
  I: Cardinal;
begin
  Result := False;
  Index := 0;
  if Count = 0 then Exit;
  for I := 0 to Count - 1 do
    if Items[I].GetName = AName then
    begin
      Result := True;
      Index := I;
      Break;
    end;
end;

function TGSStorageCursors.GetItem(Index: Integer): TGSStorageCursor;
begin
  Result := TGSStorageCursor(inherited GetItem(Index));
end;

{$IFDEF CLASS_INSTANCE}
class function TGSStorageCursors.NumOfInstances: Integer;
begin
  Result := TGSStorageCursors_Instance;
end;

class procedure TGSStorageCursors.ReleaseInstance;
begin
  Dec(TGSStorageCursors_Instance);
end;
{$ENDIF}

procedure TGSStorageCursors.SetItem(Index: Integer;
  const Value: TGSStorageCursor);
begin
  inherited SetItem(Index, Value);
end;

{ TGSStorageCursor }

{$IFDEF CLASS_INSTANCE}
class procedure TGSStorageCursor.AddInstance;
begin
  Inc(TGSStorageCursor_Instance);
end;
{$ENDIF}

//
// =============================================================================
function TGSStorageCursor.Backward(var ACursor: TGSStorageCursor): Boolean;
begin
  Result := FParent <> nil;
  if Result then
  begin
    UnLock;
    ACursor := FParent;
    ACursor.Lock;
    if not Locked then
      Self.Free;
  end;
end;

function TGSStorageCursor.Copy(const AName: String;
  const ACursor: TGSStorageCursor): HRESULT;
begin
  if ACursor = nil then
    raise EComponentError.Create('TGSStorageCursor.Copy() >> "ACursor = nil"');//SysErrorMessage(E_INVALIDARG));
  if FStorageInterface = nil then
    raise EComponentError.Create('TGSStorageCursor.Copy() >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED));
  //Result := FStorageInterface.CopyTo(0, nil, nil, ACursor.FStorageInterface);
  Result := FStorageInterface.MoveElementTo(StringToOleStr(AName),
    ACursor.FStorageInterface, StringToOleStr(AName), STGMOVE_COPY);
end;

constructor TGSStorageCursor.Create(Collection: TCollection);
var
  ID: TGUID;
begin
  inherited;
  {$IFDEF CLASS_INSTANCE}
    AddInstance;
  {$ENDIF}
  FSubStorage := TGSStorageCursors.Create;
  (*{$IFDEF CREATE_FREE_LOG}
    CreateFreeLog(True, 'TGSStorageCursor - конструкто?);
    CreateFreeLog(True, 'TGSStorageCursor.ACursor.FSubStorage');
  {$ENDIF}*)
  FLockCount := 0;
  if CreateGUID(ID) <> S_OK then
    raise EComponentError.Create('TGSStorageCursor.Create() >> "CreateGUID(ID) <> S_OK"');//SysErrorMessage(E_UNEXPECTED));
  FID := GUIDToString(ID);
end;

function TGSStorageCursor.CreateStorage(const AName: String;
  var ACursor: TGSStorageCursor): HRESULT;
var
  Index: Cardinal;
begin
{  if ACursor = nil then
    raise EComponentError.Create(SysErrorMessage(E_INVALIDARG));}
  if FSubStorage.FindStorageByName(AName, Index) then
  begin
    Result := ERROR_ALREADY_EXISTS;
    Exit;
  end;
  ACursor := FSubStorage.Add;
  ACursor.SetParam(FOwner, Self);
  Result := FStorageInterface.CreateStorage(StringToOleStr(AName),
    FMode, 0, 0, ACursor.FStorageInterface);
  {$IFDEF CREATE_FREE_LOG}
    CreateFreeLog(True, 'TGSStorageCursor.ACursor.FStorageInterface = ' + IntToStr(Integer(ACursor.FStorageInterface)));
  {$ENDIF}
  ACursor.Lock;
end;

function TGSStorageCursor.CreateStream(const AName: String): HRESULT;
var
  TmpStream:IStream;
begin
  if FStorageInterface = nil then
    raise EComponentError.Create('TGSStorageCursor.CreateStream( >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED));
  Result := FStorageInterface.CreateStream(StringToOleStr(AName),
    FMode, 0, 0, TmpStream);
  TmpStream := nil;
end;

function TGSStorageCursor.DeleteStorage(const AName: String): HRESULT;
var
  Index: Cardinal;
begin
  if FStorageInterface = nil then
    raise EComponentError.Create('TGSStorageCursor.DeleteStorage() >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED));
  if FSubStorage.FindStorageByName(AName, Index) then
  begin
    { TODO : Думать - нужнал?ту?блокировка? }
    {if FSubStorage.Items[Index].Locked then
     raise EComponentError.Create(SysErrorMessage(ERROR_ACCESS_DENIED)); }
    FSubStorage.Delete(Index);
  end;
  Result := FStorageInterface.DestroyElement(StringToOleStr(AName));
end;

function TGSStorageCursor.DeleteStream(const AName: String): HRESULT;
begin
  if FStorageInterface = nil then
    raise EComponentError.Create('TGSStorageCursor.DeleteStream() >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED));
  Result := FStorageInterface.DestroyElement(StringToOleStr(AName));
end;

destructor TGSStorageCursor.Destroy;
begin
  {$IFDEF CREATE_FREE_LOG}
    //CreateFreeLog(False, 'TGSStorageCursor - деструктор');
    //CreateFreeLog(False, 'TGSStorageCursor.ACursor.FSubStorage');
    CreateFreeLog(False, 'TGSStorageCursor.FStorageInterface = ' + IntToStr(Integer(FStorageInterface)));
  {$ENDIF}
  FStorageInterface := nil;
  FreeAndNil(FSubStorage);
  {$IFDEF CLASS_INSTANCE}
    ReleaseInstance;
  {$ENDIF}
  inherited;
end;

function TGSStorageCursor.Enumerate(var AData: TGSStorageEnum): HRESULT;
var
  Enum: IEnumStatStg;
  TmpElement: TStatStg;
  ShellMalloc: IMalloc;
  Fetched: Int64;
begin
  if (CoGetMalloc(1, ShellMalloc) <> S_OK) or (ShellMalloc = nil) then
    raise EComponentError.Create('CoGetMalloc failed.');
  if FStorageInterface = nil then
    raise EComponentError.Create('TGSStorageCursor.Enumerate() >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED));
  Result := FStorageInterface.EnumElements(0, nil, 0, Enum);
  if Result = S_OK then
  begin
    AData.Count := 0;
    ZeroMemory(@AData, SizeOf(AData));
    Fetched := 1;
    while Fetched > 0 do
      if Enum.Next(1, TmpElement, @Fetched) = S_OK then
        if ShellMalloc.DidAlloc(TmpElement.pwcsName) = 1 then
        begin
          Inc(AData.Count);
          SetLength(AData.ElementEnum, AData.Count);
          AData.ElementEnum[AData.Count - 1].pwcsName := String(TmpElement.pwcsName);
          ShellMalloc.Free(TmpElement.pwcsName);
          AData.ElementEnum[AData.Count - 1].dwType := TmpElement.dwType;
        end;
  end;
  Enum := nil;
end;

function TGSStorageCursor.ExistsObject(const AName: String; const AType: Longint;
  var Exists: Boolean): Boolean;
var
  I: Integer;
  Data: TGSStorageEnum;
begin
  Data.Count := 0;
  Result := Enumerate(Data) = S_OK;
  try
    Exists := False;
    if Result then
      if Data.Count > 0 then
        for I := 0 to Data.Count - 1 do
        begin
          if Data.ElementEnum[I].pwcsName = AName then
          begin
            Exists := Data.ElementEnum[I].dwType = AType;
            Exit;
          end;
        end;
  finally
    //FreeMemAfterEnum(Data);
  end;
end;

function TGSStorageCursor.FlushBuffer: HRESULT;
begin
  Result := FStorageInterface.Commit(STGC_DEFAULT);
end;

procedure TGSStorageCursor.FreeMemAfterEnum(var AData: TGSStorageEnum);
{var
  I: Integer;}
begin
//  for I := 0 to AData.Count - 1 do
//    FreeMem(AData.ElementEnum[I].pwcsName);
  AData.Count := 0;
  SetLength(AData.ElementEnum, 0);
end;

procedure TGSStorageCursor.Garbage;
var
  I: Integer;
begin
  if FSubStorage = nil then Exit;
  if FSubStorage.Count > 0 then
    for I := 0 to FSubStorage.Count - 1 do
    begin
      FSubStorage.Items[I].Garbage;
      if not FSubStorage.Items[I].Locked then
        FSubStorage.Items[I].Free;
    end;
end;

function TGSStorageCursor.GetLock: Boolean;
var
  I: Integer;
begin
  Result := FLockCount > 0;
  if not Result then
    if FSubStorage.Count > 0 then
      for I := 0 to FSubStorage.Count - 1 do
        if FSubStorage.Items[I].Locked then
        begin
          Result := True;
          Break;
        end;
end;

function TGSStorageCursor.GetLockCount: Integer;
var
  I: Integer;
begin
  Result := FLockCount;
  if FSubStorage.Count > 0 then
    for I := 0 to FSubStorage.Count - 1 do
      Inc(Result, FSubStorage.Items[I].GetLockCount);
end;

function TGSStorageCursor.GetName: String;
var
  Error: HRESULT;
  StatStg: TStatStg;
  ShellMalloc: IMalloc;
begin
  Result := '';
  if (CoGetMalloc(1, ShellMalloc) <> S_OK) or (ShellMalloc = nil) then
    raise EComponentError.Create('CoGetMalloc failed.');
  if FStorageInterface = nil then
    raise EComponentError.Create('TGSStorageCursor.GetName() >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED));
  Error := FStorageInterface.Stat(StatStg, STATFLAG_DEFAULT);
  if Error <> S_OK then
    raise Exception.Create('TGSStorageCursor.GetName() >> "Error <> S_OK"');//SysErrorMessage(Error));
  if ShellMalloc.DidAlloc(StatStg.pwcsName) = 1 then
  begin
    Result := String(StatStg.pwcsName);
    ShellMalloc.Free(StatStg.pwcsName);
  end;
end;

function TGSStorageCursor.GetPath: String;
begin
  if FParent = nil then
    Result := GetName
  else
    Result := FParent.GetPath + '\' + GetName;
end;

procedure TGSStorageCursor.Lock;
begin
  Inc(FLockCount);
end;

function TGSStorageCursor.MoveTo(const AName: String;
  const ACursor: TGSStorageCursor): HRESULT;
var
  Index: Cardinal;
begin
  if ACursor = nil then
    raise EComponentError.Create('TGSStorageCursor.MoveTo() >> "ACursor = nil"');//SysErrorMessage(E_INVALIDARG));
  if FStorageInterface = nil then
    raise EComponentError.Create('TGSStorageCursor.MoveTo() >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED));
  if FSubStorage.FindStorageByName(AName, Index) then
    Result := E_ACCESSDENIED
  else
    Result := FStorageInterface.MoveElementTo(StringToOleStr(AName),
        ACursor.FStorageInterface, StringToOleStr(AName), STGMOVE_MOVE);
end;

{$IFDEF CLASS_INSTANCE}
class function TGSStorageCursor.NumOfInstances: Integer;
begin
  Result := TGSStorageCursor_Instance;
end;
{$ENDIF}

function TGSStorageCursor.OpenStorage(const AName: String;
  var ACursor: TGSStorageCursor; Verify: Boolean = True): HRESULT;
var
  Index: Cardinal;
begin
  //if ACursor = nil then
    //raise EComponentError.Create(SysErrorMessage(E_INVALIDARG));
  if fSubStorage.FindStorageByName(AName, Index) then
  begin
    Result := S_OK;
    ACursor := FSubStorage.Items[Index];
    ACursor.Lock;
    Exit;
  end;

  if Verify then
    if not StorageExists(AName) then
      raise EComponentError.Create(SysErrorMessage(ERROR_PATH_NOT_FOUND));

  if ACursor <> nil then
    if ACursor.FID = FID then UnLock;

  ACursor := FSubStorage.Add;
  ACursor.SetParam(FOwner, Self);

  Result := FStorageInterface.OpenStorage(StringToOleStr(AName),
    nil, FMode, nil, 0, ACursor.FStorageInterface);
  {$IFDEF CREATE_FREE_LOG}
    CreateFreeLog(True, 'TGSCustomStorage.ACursor.FStorageInterface = ' + IntToStr(Integer(ACursor.FStorageInterface)));
  {$ENDIF}
  ACursor.Lock; 
end;

// ?данной функци?проверять = если результа?не S_OK то смотреть AStream <> nil
//function TGSStorageCursor.ReadStream(const AName: String;
//  var AStream: TStream; Verify: Boolean = True): HRESULT;

// ЅєЖ®ёІА» АМ ЗФјцїЎј­ »эјєЗПБц ѕК°Ф јцБ¤ 18_1123 15:53:21 sunk
function TGSStorageCursor.ReadStream(const AName: String;
  AStream: TStream; Verify: Boolean = True): HRESULT;
var
  TmpStream:IStream;
  OS:TOleStream;
  Buff: array of Byte;
  I, Err: Integer;

  procedure DoReadAnything;
  begin
    { DONE : Возможна утечка па?ти, та?ка?AStream уж?буде?создан!!! }
    // Ха?сами проверяют


    // Попытк?вытащить хоть чт?нибудь...
    SetLength(Buff, OS.Size);
    Err := 0;
    I := 0;
    OS.Position := 0;
    while I < OS.Size do
    try
      OS.Read(Buff[I - Err], 1);
      Inc(I);
    except
      Break;
    end;
    AStream.Write(Buff[0], I);
  end;

begin
//  AStream := nil;
  if FStorageInterface = nil then
    raise EComponentError.Create('TGSStorageCursor.ReadStream() >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED));
  if Verify then
  begin
    if StreamExists(AName) then
      Result := FStorageInterface.OpenStream(StringToOleStr(AName),
        nil, FMode, 0, TmpStream)
    else
      raise EComponentError.Create('TGSStorageCursor.ReadStream() >> "StreamExists(AName) = false"');//SysErrorMessage(ERROR_PATH_NOT_FOUND));
  end
  else
    Result := FStorageInterface.OpenStream(StringToOleStr(AName),
      nil, FMode, 0, TmpStream);
  if Result = S_OK then
  begin
//    AStream := TMemoryStream.Create;
    AStream.Position := 0;
    OS := TOleStream.Create(TmpStream);
    try
      OS.Position := 0;
      try
        AStream.CopyFrom(OS, OS.Size);
      except
        on E: EOleException do
        begin
          Result := E.ErrorCode;
          DoReadAnything;
          Exit;
        end;
        on E: Exception do
        begin
          Result := S_FALSE;
          DoReadAnything;
        end;
      end;
      AStream.Position := 0;
    finally
      OS.Free;
      TmpStream := nil;
    end;
  end;
end;

procedure TGSStorageCursor.Release;
begin
  if FID = FOwner.FRootStorage.FID then Exit;
  Free;
  FOwner.Garbage;
end;

{$IFDEF CLASS_INSTANCE}
class procedure TGSStorageCursor.ReleaseInstance;
begin
  Dec(TGSStorageCursor_Instance);
end;
{$ENDIF}

function TGSStorageCursor.Rename(const AName, ANewName: String): HRESULT;
begin
  if FStorageInterface = nil then
    raise EComponentError.Create('TGSStorageCursor.Rename() >> "FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED));
  Garbage;
  Result := FStorageInterface.RenameElement(StringToOleStr(AName),
    StringToOleStr(ANewName));
end;

procedure TGSStorageCursor.SetParam(const AOwner: TGSCustomStorage;
  AParent: TGSStorageCursor);
begin
  FMode := AOwner.FMode;
  FOwner := AOwner;
  FParent := AParent;
end;

function TGSStorageCursor.StorageExists(const AName: String): Boolean;
var
  Exists: Boolean;
begin
  Result := False;
  if ExistsObject(AName, STGTY_STORAGE, Exists) then
    Result := Exists;
end;

function TGSStorageCursor.StreamExists(const AName: String): Boolean;
var
  Exists: Boolean;
begin
  Result := False;
  if ExistsObject(AName, STGTY_STREAM, Exists) then
    Result := Exists;
end;

procedure TGSStorageCursor.UnLock;
begin
  Dec(FLockCount);
end;

function TGSStorageCursor.WriteStream(const AName: String;
  const AStream: TMemoryStream): HRESULT;
var
  TmpStream:IStream;
  OS:TOleStream;
begin
  if FStorageInterface = nil then
    raise EComponentError.Create('TGSStorageCursor.WriteStream() >> " FStorageInterface = nil"');//SysErrorMessage(E_UNEXPECTED));
  if StreamExists(AName) then
    Result := FStorageInterface.OpenStream(StringToOleStr(AName),
      nil, FMode, 0, TmpStream)
  else
  begin
    // Правим глюк когд?стри?присутствует но ег?не?пр?енумерации
    // Тупо создае?ег? если не создал? - удаляем ?опять создае?
    Result := FStorageInterface.CreateStream(StringToOleStr(AName),
      FMode, 0, 0, TmpStream);
    if Result <> S_OK then
    begin
      FStorageInterface.DestroyElement(StringToOleStr(AName));
      Result := FStorageInterface.CreateStream(StringToOleStr(AName),
        FMode, 0, 0, TmpStream);
    end;
  end;
  if Result = S_OK then
  begin
    { TODO : ?TmpStream удалять нужн? }
    OS := TOleStream.Create(TmpStream);
    try
      AStream.Position := 0;
      OS.CopyFrom(AStream, AStream.Size);
    finally
      OS.Free;
      TmpStream := nil;
    end;
  end;
end;

class function TGSCustomStorage.Compress(const AFileName: String): HRESULT;
begin
  Result := ClassSupport(AFileName, True);
end;

class function TGSCustomStorage.IsStgValidBinaryFmt(
  const AFileName: String): HRESULT;
begin
  Result := ClassSupport(AFileName, False);
end;

class function TGSCustomStorage.ClassSupport(const AFileName: String;
  Change: Boolean): HRESULT;
var
  Src, Dest: IStorage;
begin
  Result := S_FALSE;
  if not FileExists(AFileName) then Exit;
  Result := StgOpenStorage(StringToOleStr(AFileName), nil,
    STGM_READ or STGM_SHARE_EXCLUSIVE, nil, 0, Src);
  if Result = S_OK then
  try
    Result :=  StgCreateDocfile(StringToOleStr(String(AFileName) + '~'),
      STGM_READWRITE or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, Dest);
    if Result = S_OK then
    try
      Result := Src.CopyTo(0, nil, nil, Dest);
    finally
      Dest := nil;
    end;
  finally
    Src := nil;
    if Result = S_OK then
    begin
      if Change then
      begin
        if Result = S_OK then
          if not DeleteFile(AFileName) then
            Result := S_FALSE
          else
            RenameFile(AFileName + '~', AFileName);
      end else begin
        if Result = S_OK then
          if not DeleteFile(AFileName + '~') then
            Result := S_FALSE
      end;
    end else
      DeleteFile(AFileName + '~'); // »иБ¦ ГЯ°Ў 18_0726 15:11:38 sunk
  end;
end;

function TGSCustomStorage.GetActive: Boolean;
begin
  Result := FRootStorage.FStorageInterface <> nil;
end;

{$IFDEF CLASS_INSTANCE}
class procedure TGSCustomStorage.AddInstance;
begin
  Inc(TGSCustomStorage_Instance);
end;

constructor TGSCustomStorage.Create;
begin
  AddInstance;
end;

class function TGSCustomStorage.NumOfInstances: Integer;
begin
  Result := TGSCustomStorage_Instance;
end;

class procedure TGSCustomStorage.ReleaseInstance;
begin
  Dec(TGSCustomStorage_Instance);
end;
{$ENDIF}

{$IFDEF CLASS_INSTANCE}

initialization

finalization

  if TGSCustomStorage_Instance > 0 then
    raise GSCustomStorageException.Create(Format('%d instances of TGSCustomStorage active', [TGSCustomStorage_Instance]));

  if TGSStorageCursor_Instance > 0 then
    raise GSCustomStorageException.Create(Format('%d instances of TGSStorageCursor active', [TGSStorageCursor_Instance]));

  if TGSStorageCursors_Instance > 0 then
    raise GSCustomStorageException.Create(Format('%d instances of TGSStorageCursors active', [TGSStorageCursors_Instance]));

{$ENDIF}

end.