bgralazresource.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 BGRALazResource;

{$i bgrabitmap.inc}{$H+}

interface

uses
  Classes, SysUtils, {$IFNDEF FPC}Types, GraphType, BGRAGraphics,{$ENDIF}BGRATypes, BGRAMultiFileType;

type
  { TLazResourceEntry }

  TLazResourceEntry = class(TMultiFileEntry)
  private
    procedure Serialize(ADestination: TStream);
  protected
    FName: utf8string;
    FValueType: utf8string;
    FContent: TStream;
    function GetName: utf8string; override;
    procedure SetName(AValue: utf8string); override;
    function GetExtension: utf8string; override;
    function GetFileSize: BGRAInt64; override;
  public
    constructor Create(AContainer: TMultiFileContainer; AName: utf8string; AValueType: utf8string; AContent: TStream);
    destructor Destroy; override;
    function CopyTo(ADestination: TStream): BGRAInt64; override;
  end;

  { TFormDataEntry }

  TFormDataEntry = class(TLazResourceEntry)
  protected
    FTextContent: TStream;
    procedure RequireTextContent;
    function GetExtension: utf8string; override;
    function GetFileSize: BGRAInt64; override;
  public
    constructor Create(AContainer: TMultiFileContainer; AName: utf8string; ABinaryContent: TStream);
    destructor Destroy; override;
    function CopyTo(ADestination: TStream): BGRAInt64; override;
  end;

  { TLazResourceContainer }

  TLazResourceContainer = class(TMultiFileContainer)
  protected
    function CreateEntry(AName: utf8string; AExtension: utf8string; AContent: TStream): TMultiFileEntry; override;
  public
    procedure LoadFromStream(AStream: TStream); override;
    procedure SaveToStream(ADestination: TStream); override;
  end;

implementation

uses {$IFDEF FPC}LResources,{$ENDIF} BGRAUTF8;

{ TFormDataEntry }

procedure TFormDataEntry.RequireTextContent;
begin
  if FTextContent = nil then
  begin
    FTextContent:= TMemoryStream.Create;
    FContent.Position:= 0;
    {$IFDEF FPC}//#
    LRSObjectBinaryToText(FContent, FTextContent);
    {$ENDIF}
  end;
end;

function TFormDataEntry.GetExtension: utf8string;
begin
  {$IFDEF FPC}
  Result:= 'lfm';
  {$ELSE}
  Result:= 'dfm';
  {$ENDIF}
end;

function TFormDataEntry.GetFileSize: BGRAInt64;
begin
  RequireTextContent;
  Result:= FTextContent.Size;
end;

constructor TFormDataEntry.Create(AContainer: TMultiFileContainer;
  AName: utf8string; ABinaryContent: TStream);
begin
  inherited Create(AContainer,AName,'FORMDATA',ABinaryContent);
end;

destructor TFormDataEntry.Destroy;
begin
  FreeAndNil(FTextContent);
  inherited Destroy;
end;

function TFormDataEntry.CopyTo(ADestination: TStream): BGRAInt64;
begin
  RequireTextContent;
  if FTextContent.Size = 0 then
    result := 0
  else
  begin
    FTextContent.Position:= 0;
    result := ADestination.CopyFrom(FTextContent,FTextContent.Size);
  end;
end;

{ TLazResourceEntry }

procedure TLazResourceEntry.Serialize(ADestination: TStream);
begin
  FContent.Position := 0;
  {$IFDEF FPC}//#
  BinaryToLazarusResourceCode(FContent, ADestination, Name, FValueType);
  {$ENDIF}
end;

function TLazResourceEntry.GetName: utf8string;
begin
  Result:= FName;
end;

procedure TLazResourceEntry.SetName(AValue: utf8string);
begin
  if AValue = FName then exit;
  if Container.IndexOf(AVAlue, Extension) <> -1 then
    raise Exception.Create('Name is already used for this extension');
  FName := AValue;
end;

function TLazResourceEntry.GetExtension: utf8string;
begin
  Result:= FValueType;
end;

function TLazResourceEntry.GetFileSize: BGRAInt64;
begin
  Result:= FContent.Size;
end;

destructor TLazResourceEntry.Destroy;
begin
  FreeAndNil(FContent);
  inherited Destroy;
end;

constructor TLazResourceEntry.Create(AContainer: TMultiFileContainer; AName: utf8string; AValueType: utf8string;
  AContent: TStream);
begin
  inherited Create(AContainer);
  FName := AName;
  FValueType := UTF8UpperCase(AValueType);
  FContent := AContent;
end;

function TLazResourceEntry.CopyTo(ADestination: TStream): BGRAInt64;
begin
  if FContent.Size = 0 then
    result := 0
  else
  begin
    FContent.Position:= 0;
    result := ADestination.CopyFrom(FContent, FContent.Size);
  end;
end;

{ TLazResourceContainer }

procedure TLazResourceContainer.LoadFromStream(AStream: TStream);
const
  entryStart = 'LazarusResources.Add(';
  entryEnd = ');';
  whiteSpace = [' ',#9,#10,#13,#26];
var
  fileContent: String;
  filePos : integer;

  procedure SkipWhitespace;
  begin
    while (filePos <= length(fileContent)) and (fileContent[filePos] in whiteSpace) do inc(filePos);
  end;

  procedure SkipComma;
  begin
    SkipWhitespace;
    if (filePos <= length(fileContent)) and (fileContent[filePos] = ',') then
      inc(filePos)
    else
      raise Exception.Create('Comma expected');
  end;

  function ParseString(ignoreCommas: boolean): TStream;
  var
    expectPlus: boolean;

    procedure AppendChar(c: {$IFDEF FPC}Char{$ELSE}AnsiChar{$ENDIF});
    begin
      result.WriteByte(ord(c));
    end;

    function ParseNumber: integer;
    var numberStart, errPos: integer;
      s: String;
    begin
      numberStart:= filePos;
      if (filePos <= length(fileContent)) and (fileContent[filePos] = '$') then
      begin
        inc(filePos);
        while (filePos <= length(fileContent)) and (fileContent[filePos] in['0'..'9','a'..'f','A'..'F']) do inc(filePos);
      end else
      begin
        while (filePos <= length(fileContent)) and (fileContent[filePos] in['0'..'9']) do inc(filePos);
      end;
      s := copy(fileContent,numberStart,filePos-numberStart);
      val(s, result, errPos);
      if errPos <> 0 then
        raise exception.Create('Invalid number "' + s + '"');
    end;

    function ParseStringPart: boolean;
    var charCode: integer;
    begin
      SkipWhitespace;
      if filePos <= length(fileContent) then
      begin
        if expectPlus then
          if fileContent[filePos] <> '+' then
          begin
            result := false;
            expectPlus := false;
            exit;
          end else
          inc(filePos);

        case fileContent[filePos] of
        '+': raise exception.Create('Unexpected "+"');
        '''': begin
            inc(filePos);
            while (filePos <= length(fileContent)) do
            begin
              if fileContent[filePos] = '''' then
              begin
                inc(filePos);
                if (filePos <= length(fileContent)) and (fileContent[filePos] = '''') then
                begin
                  AppendChar('''');
                  inc(filePos);
                end
                else break;
              end else
              if fileContent[filePos] in[#10,#13] then
                raise Exception.Create('Unexpected end of line')
              else
              begin
                AppendChar({$IFDEF FPC}Char{$ELSE}AnsiChar{$ENDIF}(fileContent[filePos]));
                inc(filePos);
              end;
            end;
            if (filePos <= length(fileContent)) and (fileContent[filePos] = '#') then
              expectPlus := false
            else
              expectPlus := true;
            result := true;
          end;
        '#': begin
            inc(filePos);
            charCode := ParseNumber;
            if (charCode < 0) or (charCode > 255) then
              raise exception.Create('Character code out of bounds');
            AppendChar({$IFDEF FPC}Char{$ELSE}AnsiChar{$ENDIF}(chr(charCode)));
            if (filePos <= length(fileContent)) and (fileContent[filePos] in['#','''']) then
              expectPlus := false
            else
              expectPlus := true;
            result := true;
          end;
         else
         begin
           result := false;
           expectPlus := false;
         end;
         end;
      end
       else
       begin
         result := false;
         expectPlus := false;
       end;
    end;

  begin
    result := TMemoryStream.Create;
    expectPlus := false;
    if not ParseStringPart then raise exception.Create('Expecting string');
    repeat
      if ignoreCommas then
      begin
        SkipWhitespace;
        if (filePos <= length(fileContent)) and (fileContent[filePos] = ',') then
        begin
          inc(filePos);
          expectPlus := false;
        end;
      end;
    until not ParseStringPart;
  end;

  procedure ReadContent;
  var
    bytesRead: integer;
  begin
    setlength(fileContent,AStream.Size-AStream.Position);
    bytesRead := AStream.Read(fileContent[1],length(fileContent));
    setlength(fileContent, bytesRead);
    filePos := 1;
  end;

  function StreamToUTF8String(AStream: TStream): utf8String;
  begin
    setlength(result, AStream.Size);
    AStream.Position := 0;
    AStream.Read(result[1], length(result));
    AStream.Free;
  end;

var
  entryName: utf8string;
  entryType: utf8string;
  entryContent: TStream;
  inArray: boolean;

begin
  Clear;
  ReadContent;
  while filePos <= length(fileContent) do
  begin
    if (upcase(fileContent[filePos]) = upcase(entryStart[1])) and
      (CompareText(copy(fileContent,filePos,length(entryStart)),entryStart)=0) then
    begin
      inc(filePos, length(entryStart));
      entryName := StreamToUTF8String(ParseString(false));
      SkipComma;
      entryType := StreamToUTF8String(ParseString(false));
      SkipComma;

      SkipWhitespace;
      if (filePos <= length(fileContent)) and (fileContent[filePos] = '[') then
      begin
        inArray := true;
        inc(filePos);
      end else
        inArray := false;
      entryContent := ParseString(inArray);
      SkipWhitespace;
      if inArray then
      begin
        if (filePos <= length(fileContent)) and (fileContent[filePos] = ']') then
          inc(filePos)
        else
          raise exception.Create('Expecting "]"');
      end;

      if entryType = 'FORMDATA' then
        AddEntry(TFormDataEntry.Create(self,entryName,entryContent))
      else
        AddEntry(TLazResourceEntry.Create(self,entryName,entryType,entryContent));

      if (filePos+length(entryEnd)-1 <= length(fileContent)) and (CompareText(copy(fileContent,filePos,length(entryEnd)),entryEnd)=0) then
        inc(filePos,length(entryEnd))
      else
        raise exception.Create('Expecting "'+entryEnd+'"');
    end else
    if fileContent[filePos] in whiteSpace then
      inc(filePos)
    else
      raise exception.Create('Unexpected character "'+fileContent[filePos]+'"');
  end;
end;

function TLazResourceContainer.CreateEntry(AName: utf8string; AExtension: utf8string;
  AContent: TStream): TMultiFileEntry;
var
  binContent: TMemoryStream;
begin
  if UTF8CompareText(AExtension,'lfm')=0 then
  begin
    binContent := TMemoryStream.Create;
    try
      AContent.Position:= 0;
      {$IFDEF FPC}//#
      LRSObjectTextToBinary(AContent, binContent);
      {$ENDIF}
      result := TFormDataEntry.Create(self,AName,binContent);
    except
      on ex:Exception do
      begin
        binContent.Free;
        result := nil;
      end;
    end;
    AContent.Free;
  end
  else
    result := TLazResourceEntry.Create(self,AName,UTF8UpperCase(AExtension),AContent);
end;

procedure TLazResourceContainer.SaveToStream(ADestination: TStream);
var
  i: Integer;
begin
  for i := 0 to Count-1 do
    TLazResourceEntry(Entry[i]).Serialize(ADestination);
end;

end.