bgramultifiletype.pas

{ ***************************************************************************
 *                                                                          *
 *  This file is part of BGRABitmap library which is distributed under the  *
 *  modified LGPL.                                                          *
 *                                                                          *
 *  See the file COPYING.modifiedLGPL.txt, included in this distribution,   *
 *  for details about the copyright.                                        *
 *                                                                          *
 *  This program is distributed in the hope that it will be useful,         *
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of          *
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                    *
 *                                                                          *
 ************************* BGRABitmap library  ******************************

 - Drawing routines with transparency and antialiasing with Lazarus.
   Offers also various transforms.
 - These routines allow to manipulate 32bit images in BGRA format or RGBA
   format (depending on the platform).
 - This code is under modified LGPL (see COPYING.modifiedLGPL.txt).
   This means that you can link this library inside your programs for any purpose.
   Only the included part of the code must remain LGPL.

 - If you make some improvements to this library, please notify here:
   http://www.lazarus.freepascal.org/index.php/topic,12037.0.html

   ********************* Contact : Circular at operamail.com *******************


   ******************************* CONTRIBUTOR(S) ******************************
   - Edivando S. Santos Brasil | mailedivando@gmail.com
     (Compatibility with FPC ($Mode objfpc/delphi) and delphi VCL 11/2018)

   ***************************** END CONTRIBUTOR(S) *****************************}


Unit BGRAMultiFileType;

{$i bgrabitmap.inc}{$H+}
{$IFDEF FPC}
{$MODESWITCH ADVANCEDRECORDS}
{$ENDIF}

interface

uses
  Classes, SysUtils, BGRATypes,{$IFNDEF FPC}Types, GraphType, BGRAGraphics,{$ENDIF} {$IFDEF OBJ}fgl{$ELSE}generics.collections{$ENDIF};

type

  { TEntryFilename }

  TEntryFilename = record
  private
    FExtension: utf8string;
    FName: utf8string;
    function GetFilename: utf8string;
    function GetIsEmpty: boolean;
    procedure SetExtension(AValue: utf8string);
    procedure SetFilename(AValue: utf8string);
    procedure SetName(AValue: utf8string);
  public
    class operator {$IFDEF OBJ} = {$ELSE} Equal {$ENDIF}(const AValue1,AValue2: TEntryFilename): boolean;
    property Filename: utf8string read GetFilename write SetFilename;
    property Name: utf8string read FName write SetName;
    property Extension: utf8string read FExtension write SetExtension;
    property IsEmpty: boolean read GetIsEmpty;
  end;

function EntryFilename(AName,AExtension: string): TEntryFilename; overload;
function EntryFilename(AFilename: string): TEntryFilename; overload;

type
  TMultiFileContainer = class;

  { TMultiFileEntry }

  TMultiFileEntry = class
  protected
    FContainer: TMultiFileContainer;
    function GetName: utf8string; virtual; abstract;
    procedure SetName(AValue: utf8string); virtual; abstract;
    function GetFileSize: BGRAInt64; virtual;
    function GetExtension: utf8string; virtual;
  public
    constructor Create(AContainer: TMultiFileContainer);
    function CopyTo({%H-}ADestination: TStream): BGRAInt64; virtual;
    property Name: utf8string read GetName write SetName;
    property Extension: utf8string read GetExtension;
    property FileSize: BGRAInt64 read GetFileSize;
    property Container: TMultiFileContainer read FContainer;
  end;

  TMultiFileEntryList = {$IFDEF OBJ}specialize TFPGList{$ELSE}TList{$ENDIF}<TMultiFileEntry>;

  { TMultiFileContainer }

  TMultiFileContainer = class
  private
    FEntries: TMultiFileEntryList;
  protected
    procedure Init; virtual;
    function AddEntry(AEntry: TMultiFileEntry; AIndex: integer = -1): integer;
    function GetCount: integer;
    function GetEntry(AIndex: integer): TMultiFileEntry;
    function CreateEntry(AName: utf8string; AExtension: utf8string; AContent: TStream): TMultiFileEntry; virtual; abstract;
    function GetRawString(AIndex: integer): RawByteString;
    function GetRawStringByFilename(AFilename: string): RawByteString;
    procedure SetRawString(AIndex: integer; AValue: RawByteString);
    procedure SetRawStringByFilename(AFilename: string; AValue: RawByteString);
  public
    constructor Create; overload;
    constructor Create(AFilename: utf8string); overload;
    constructor Create(AStream: TStream); overload;
    constructor Create(AStream: TStream; AStartPos: BGRAInt64); overload;
    function Add(AName: utf8string; AExtension: utf8string; AContent: TStream; AOverwrite: boolean = false; AOwnStream: boolean = true): integer; overload;
    function Add(AName: utf8string; AExtension: utf8string; AContent: RawByteString; AOverwrite: boolean = false): integer; overload;
    function Add(AFilename: TEntryFilename; AContent: TStream; AOverwrite: boolean = false; AOwnStream: boolean = true): integer; overload;
    function Add(AFilename: TEntryFilename; AContent: RawByteString; AOverwrite: boolean = false): integer; overload;
    procedure Clear; virtual;
    destructor Destroy; override;
    procedure LoadFromFile(AFilename: utf8string);
    procedure LoadFromStream(AStream: TStream); virtual; abstract;
    procedure SaveToFile(AFilename: utf8string);
    procedure SaveToStream(ADestination: TStream); virtual; abstract;
    procedure Remove(AEntry: TMultiFileEntry); virtual;
    procedure Delete(AIndex: integer); overload; virtual;
    function Delete(AName: utf8string; AExtension: utf8string; ACaseSensitive: boolean = True): boolean; overload;
    function Delete(AFilename: TEntryFilename; ACaseSensitive: boolean = True): boolean; overload;
    function IndexOf(AEntry: TMultiFileEntry): integer; overload;
    function IndexOf(AName: utf8string; AExtenstion: utf8string; ACaseSensitive: boolean = True): integer; overload; virtual;
    function IndexOf(AFilename: TEntryFilename; ACaseSensitive: boolean = True): integer; overload;
    property Count: integer read GetCount;
    property Entry[AIndex: integer]: TMultiFileEntry read GetEntry;
    property RawString[AIndex: integer]: RawByteString read GetRawString write SetRawString;
    property RawStringByFilename[AFilename: string]: RawByteString read GetRawStringByFilename write SetRawStringByFilename;
  end;

implementation

uses BGRAUTF8, strutils;

{ TEntryFilename }

function TEntryFilename.GetFilename: utf8string;
begin
  if Extension = '' then
    result := Name
  else
    result := Name+'.'+Extension;
end;

function TEntryFilename.GetIsEmpty: boolean;
begin
  result := (FName='') and (FExtension = '');
end;

procedure TEntryFilename.SetExtension(AValue: utf8string);
var
  i: Integer;
begin
  if FExtension=AValue then Exit;
  for i := 1 to length(AValue) do
    if AValue[i] in ['.','/'] then
      raise Exception.Create('Invalid extension');
  FExtension:=AValue;
end;

procedure TEntryFilename.SetFilename(AValue: utf8string);
var
  idxDot: SizeInt;
begin                        //#
  idxDot := {$IFDEF FPC}RPos{$ELSE}Pos{$ENDIF}('.',AValue);
  if idxDot = 0 then
  begin
    Name := AValue;
    Extension := '';
  end
  else
  begin
    Name := copy(AValue,1,idxDot-1);
    Extension := copy(AValue,idxDot+1,length(AValue)-idxDot);
  end;
end;

procedure TEntryFilename.SetName(AValue: utf8string);
var
  i: Integer;
begin
  if FName=AValue then Exit;
  for i := 1 to length(AValue) do
    if AValue[i] = '/' then
      raise Exception.Create('Invalid name');
  FName:=AValue;
end;

function EntryFilename(AName, AExtension: string): TEntryFilename;
begin
  result.Name := AName;
  result.Extension:= AExtension;
end;

function EntryFilename(AFilename: string): TEntryFilename;
begin
  result.Filename:= AFilename;
end;

class operator TEntryFilename.{$IFDEF OBJ} = {$ELSE} Equal {$ENDIF}(const AValue1, AValue2: TEntryFilename): boolean;
begin
  result := (AValue1.Name = AValue2.Name) and (AValue1.Extension = AValue2.Extension);
end;

{ TMultiFileEntry }

function TMultiFileEntry.GetFileSize: BGRAInt64;
begin
  result := 0;
end;

function TMultiFileEntry.GetExtension: utf8string;
begin
  result := '';
end;

constructor TMultiFileEntry.Create(AContainer: TMultiFileContainer);
begin
  FContainer := AContainer;
end;

function TMultiFileEntry.CopyTo(ADestination: TStream): BGRAInt64;
begin
  result := 0;
end;

{ TMultiFileContainer }

function TMultiFileContainer.GetCount: integer;
begin
  if Assigned(FEntries) then
    result := FEntries.Count
  else
    result := 0;
end;

function TMultiFileContainer.GetEntry(AIndex: integer): TMultiFileEntry;
begin
  result := FEntries[AIndex];
end;

function TMultiFileContainer.GetRawString(AIndex: integer): RawByteString;
var s: TStringStream;
begin
  s := TStringStream.Create('');
  try
    Entry[AIndex].CopyTo(s);
    result := s.DataString;
  finally
    s.Free;
  end;
end;

function TMultiFileContainer.GetRawStringByFilename(AFilename: string
  ): RawByteString;
var
  idx: Integer;
begin
  idx := IndexOf(EntryFilename(AFilename));
  if idx = -1 then
    result := ''
  else
    result := GetRawString(idx);
end;

procedure TMultiFileContainer.SetRawString(AIndex: integer;
  AValue: RawByteString);
begin
  with Entry[AIndex] do
    Add(Name, Extension, AValue, true);
end;

procedure TMultiFileContainer.SetRawStringByFilename(AFilename: string;
  AValue: RawByteString);
var
  f: TEntryFilename;
begin
  f := EntryFilename(AFilename);
  Add(f.Name,f.Extension,AValue,true);
end;

procedure TMultiFileContainer.Init;
begin
  FEntries := TMultiFileEntryList.Create;
end;

function TMultiFileContainer.AddEntry(AEntry: TMultiFileEntry; AIndex: integer): integer;
begin
  if not Assigned(FEntries) then
    raise exception.Create('Entry list not created');
  if (AIndex >= 0) and (AIndex < FEntries.Count) then
  begin
    FEntries.Insert(AIndex, AEntry);
    result := AIndex;
  end
  else
    result := FEntries.Add(AEntry);
end;

constructor TMultiFileContainer.Create;
begin
  Init;
end;

constructor TMultiFileContainer.Create(AFilename: utf8string);
begin
  Init;
  LoadFromFile(AFilename);
end;

constructor TMultiFileContainer.Create(AStream: TStream);
begin
  Init;
  LoadFromStream(AStream);
end;

constructor TMultiFileContainer.Create(AStream: TStream; AStartPos: BGRAInt64);
begin
  Init;
  AStream.Position := AStartPos;
  LoadFromStream(AStream);
end;

function TMultiFileContainer.Add(AName: utf8string; AExtension: utf8string;
  AContent: TStream; AOverwrite: boolean; AOwnStream: boolean): integer;
var
  index: Integer;
  newEntry: TMultiFileEntry;
  contentCopy: TMemoryStream;
begin
  index := IndexOf(AName,AExtension);
  if index <> -1 then
  begin
    if AOverwrite then
      Delete(index)
    else
      raise Exception.Create('Duplicate entry');
  end;
  if not AOwnStream then
  begin
    AContent.Position:= 0;
    contentCopy := TMemoryStream.Create;
    contentCopy.CopyFrom(AContent, AContent.Size);
    newEntry := CreateEntry(AName, AExtension, contentCopy);
  end else
    newEntry := CreateEntry(AName, AExtension, AContent);
  if Assigned(newEntry) then
    result := AddEntry(newEntry, index)
  else
    raise exception.Create('Unable to create entry');
end;

function TMultiFileContainer.Add(AName: utf8string; AExtension: utf8string;
  AContent: RawByteString; AOverwrite: boolean): integer;
var stream: TMemoryStream;
begin
  stream := TMemoryStream.Create;
  stream.Write(AContent[1],length(AContent));
  result := Add(AName,AExtension,stream,AOverwrite);
end;

function TMultiFileContainer.Add(AFilename: TEntryFilename; AContent: TStream;
  AOverwrite: boolean; AOwnStream: boolean): integer;
begin
  result := Add(AFilename.Name,AFilename.Extension, AContent, AOverwrite, AOwnStream);
end;

function TMultiFileContainer.Add(AFilename: TEntryFilename;
  AContent: RawByteString; AOverwrite: boolean): integer;
begin
  result := Add(AFilename.Name,AFilename.Extension, AContent, AOverwrite);
end;

destructor TMultiFileContainer.Destroy;
begin
  Clear;
  FreeAndNil(FEntries);
  inherited Destroy;
end;

procedure TMultiFileContainer.LoadFromFile(AFilename: utf8string);
var stream: TFileStream;
begin
  stream := TFileStream.Create(Utf8ToAnsi(AFilename), fmOpenRead);
  LoadFromStream(stream);
  stream.Free;
end;

procedure TMultiFileContainer.SaveToFile(AFilename: utf8string);
var stream: TFileStream;
begin
  stream := TFileStream.Create(Utf8ToAnsi(AFilename), fmCreate);
  SaveToStream(stream);
  stream.Free;
end;

procedure TMultiFileContainer.Remove(AEntry: TMultiFileEntry);
var
  index: Integer;
begin
  index := IndexOf(AEntry);
  if index = -1 then
    raise exception.Create('Entry not found');
  Delete(index);
end;

procedure TMultiFileContainer.Delete(AIndex: integer);
begin
  if (AIndex >= 0) and (AIndex < Count) then
  begin
    Entry[AIndex].Free;
    FEntries.Delete(AIndex);
  end else
    raise ERangeError.Create('Index out of bounds');
end;

function TMultiFileContainer.Delete(AName: utf8string; AExtension: utf8string;
  ACaseSensitive: boolean): boolean;
var
  index: Integer;
begin
  index := IndexOf(AName, AExtension, ACaseSensitive);
  if index = -1 then
    result := false
  else
  begin
    Delete(index);
    result := true;
  end;
end;

function TMultiFileContainer.Delete(AFilename: TEntryFilename;
  ACaseSensitive: boolean): boolean;
begin
  result := Delete(AFilename.Name,AFilename.Extension,ACaseSensitive);
end;

function TMultiFileContainer.IndexOf(AEntry: TMultiFileEntry): integer;
begin
  result := FEntries.IndexOf(AEntry);
end;

function TMultiFileContainer.IndexOf(AName: utf8string; AExtenstion: utf8string; ACaseSensitive: boolean): integer;
var
  i: Integer;
begin
  if ACaseSensitive then
  begin
    for i := 0 to Count-1 do
      if (Entry[i].Name = AName) and (UTF8CompareText(Entry[i].Extension,AExtenstion) = 0) then
      begin
        result := i;
        exit;
      end;
  end else
    for i := 0 to Count-1 do
      if (UTF8CompareText(Entry[i].Name,AName) = 0) and (UTF8CompareText(Entry[i].Extension,AExtenstion) = 0) then
      begin
        result := i;
        exit;
      end;
  result := -1;
end;

function TMultiFileContainer.IndexOf(AFilename: TEntryFilename;
  ACaseSensitive: boolean): integer;
begin
  result := IndexOf(AFilename.Name,AFilename.Extension,ACaseSensitive);
end;

procedure TMultiFileContainer.Clear;
var
  i: Integer;
begin
  for i := 0 to FEntries.Count-1 do
    FEntries.Items[i].Free;
  FEntries.Clear;
end;

end.