text:
{
  Classes to represent resource data.
}
unit PE.Resources;

interface

uses
  System.Classes,
  System.Generics.Collections,
  System.SysUtils,

  PE.Common,
  PE.Types.Resources;

type
  { Nodes }

  TResourceTreeNode = class;
  TResourceTreeBranchNode = class;

  // Return False to stop traversing or True to continue.
  TResourceTraverseMethod = function(Node: TResourceTreeNode): boolean of object;

  // Base node.
  TResourceTreeNode = class
  private
    // Either ID or Name.
    FId: uint32;
    FName: UnicodeString;
    procedure SetId(const Value: uint32); inline;
    procedure SetName(const Value: UnicodeString);inline;
  public
    Parent: TResourceTreeBranchNode;

    procedure Traverse(TraverseMethod: TResourceTraverseMethod); inline;

    // Check if node is named. Otherwise it's ID.
    function IsNamed: boolean; inline;

    function IsBranch: boolean; inline;
    function IsLeaf: boolean; inline;

    // Find resource by Name or Id.
    function FindByName(const Name: string): TResourceTreeNode; inline;
    function FindByID(Id: uint32): TResourceTreeNode; inline;

    // By Name/Id.
    function FindNode(Node: TResourceTreeNode): TResourceTreeNode;

    // Find either by name or by id.
    function FindByNameOrId(const Name: string; Id: uint32): TResourceTreeNode;

    function GetNameOrId: string;

    function GetPath: string;

    property Id: uint32 read FId write SetId;
    property Name: UnicodeString read FName write SetName;
  end;

  TResourceTreeNodes = TObjectList<TResourceTreeNode>;

  // Leaf node (data).
  TResourceTreeLeafNode = class(TResourceTreeNode)
  private
    FDataRVA: TRVA; // RVA of data in original image.
    FCodepage: uint32;
    FData: TMemoryStream;
    FOriginalDataSize: uint32;
    FValidSize: boolean;
    function GetDataSize: uint32; inline;
  public
    constructor Create;
    constructor CreateFromRVA(PE: TPEImageObject; DataRVA: TRVA; DataSize: uint32; CodePage: uint32);
    constructor CreateFromEntry(PE: TPEImageObject; const Entry: TResourceDataEntry);
    constructor CreateFromStream(Stream: TStream; Pos: UInt64 = 0; Size: UInt64 = 0);

    destructor Destroy; override;

    procedure UpdateData(Buffer: PByte; Size: uint32);

    property Data: TMemoryStream read FData;
    property DataRVA: TRVA read FDataRVA;
    property DataSize: uint32 read GetDataSize;
    property CodePage: uint32 read FCodepage write FCodepage;

    // Original Size is set when node created.
    // For example it is size of parsed leaf node data. But if executable is
    // packed and not all raw size available or modified then OriginalSize is
    // not equal to DataSize (DataSize = 0).
    property OriginalDataSize: uint32 read FOriginalDataSize;

    // Leaf can be invalid if data size in parsed header doesn't match actual
    // size that can be read from section. For example if executable is packed.
    // See OriginalSize for parsed size of data.
    // By default created leaf is valid.
    // Valid size doesn't mean content is also valid, i.e. in right format.
    // For example it can be RT_BITMAP resource but contain non-bitmap info.
    property ValidSize: boolean read FValidSize;
  end;

  // Branch node.
  TResourceTreeBranchNode = class(TResourceTreeNode)
  private
    // 5.9.2. Resource Directory Entries
    // ...
    // All the Name entries precede all the ID entries for the table.
    // All entries for the table are sorted in ascending order:
    // Name entries by case-insensitive string and the ID entries by numeric value.
    FChildren: TResourceTreeNodes;
  public
    Characteristics: uint32;
    TimeDateStamp: uint32;
    MajorVersion: uint16;
    MinorVersion: uint16;

    constructor Create();
    destructor Destroy; override;

    // Get either Name or Id as string.
    function GetSafeName: string; inline;

    // Add node to children. Result is added node.
    function Add(Node: TResourceTreeNode): TResourceTreeNode;
    function AddNewBranch: TResourceTreeBranchNode;
    function AddNewLeaf: TResourceTreeLeafNode;

    // Remove node.
    procedure Remove(Node: TResourceTreeNode; RemoveSelfIfNoChildren: boolean = False);

    property Children: TResourceTreeNodes read FChildren;
  end;

  { Tree }

  TResourceTree = class
  protected
    FRoot: TResourceTreeBranchNode;
    procedure CreateDummyRoot;
  public
    constructor Create;
    destructor Destroy; override;

    // Clear all nodes.
    procedure Clear;

    property Root: TResourceTreeBranchNode read FRoot;
  end;

implementation

uses
  PE.Image;

function TreeNodeCompareLess(const A, B: TResourceTreeNode): boolean;
var
  NamedA, NamedB: boolean;
  n1, n2: string;
begin
  NamedA := A.IsNamed;
  NamedB := B.IsNamed;
  if NamedA and NamedB then // Compare named.
  begin
    n1 := UpperCase(A.Name);
    n2 := UpperCase(B.Name);
    exit(CompareStr(n1, n2) < 0);
  end;
  if (not NamedA) and (not NamedB) then // Compare by ID.
    Result := A.Id < B.Id
  else // Compare Named vs ID (named must go first).
    Result := NamedA and (not NamedB);
end;

{ TResourceTreeNode }

function TResourceTreeBranchNode.Add(Node: TResourceTreeNode): TResourceTreeNode;
begin
  Result := Node;
  if Assigned(Node) then
  begin
    Node.Parent := Self;
    FChildren.Add(Node);
  end;
end;

function TResourceTreeBranchNode.AddNewBranch: TResourceTreeBranchNode;
begin
  Result := TResourceTreeBranchNode.Create;
  Add(Result);
end;

function TResourceTreeBranchNode.AddNewLeaf: TResourceTreeLeafNode;
begin
  Result := TResourceTreeLeafNode.Create;
  Add(Result);
end;

constructor TResourceTreeBranchNode.Create();
begin
  inherited;
  FChildren := TResourceTreeNodes.Create(True);
end;

procedure TResourceTreeBranchNode.Remove(Node: TResourceTreeNode; RemoveSelfIfNoChildren: boolean);
begin
  FChildren.Remove(Node);
  if RemoveSelfIfNoChildren and (Self.FChildren.Count = 0) and Assigned(Parent) then
    Self.Parent.Remove(Self, True);
end;

destructor TResourceTreeBranchNode.Destroy;
begin
  FChildren.Free;
  inherited;
end;

function TResourceTreeBranchNode.GetSafeName: string;
begin
  if IsNamed then
    Result := name
  else
    Result := Format('#%d', [Id])
end;

{ TResourceTreeNode }

function TResourceTreeNode.FindByName(const Name: string): TResourceTreeNode;
begin
  Result := FindByNameOrId(Name, 0);
end;

function TResourceTreeNode.FindByID(Id: uint32): TResourceTreeNode;
begin
  Result := FindByNameOrId('', Id);
end;

function TResourceTreeNode.FindByNameOrId(const Name: string; Id: uint32): TResourceTreeNode;
var
  tmp: TResourceTreeNode;
begin
  Result := nil;

  if not IsBranch then
    exit;

  for tmp in TResourceTreeBranchNode(Self).FChildren do
  begin
    if (tmp.Name <> '') then
    begin
      if tmp.Name = Name then
        exit(tmp);
    end
    else
    begin
      if tmp.Id = Id then
        exit(tmp);
    end;
  end;
end;

function TResourceTreeNode.FindNode(Node: TResourceTreeNode): TResourceTreeNode;
var
  tmp: TResourceTreeNode;
begin
  Result := nil;
  if not IsBranch then
    exit;

  for tmp in TResourceTreeBranchNode(Self).FChildren do
  begin
    if tmp = node then
      exit(tmp);
  end;
end;

function TResourceTreeNode.GetNameOrId: string;
begin
  if FName <> '' then
    Result := FName
  else
    Result := Format('#%d', [FId]);
end;

function TResourceTreeNode.GetPath: string;
var
  Cur: TResourceTreeNode;
  Separator: string;
begin
  Cur := Self;

  if Cur.IsLeaf then
  begin
    Result := Format('(%d)', [TResourceTreeLeafNode(Cur).FCodepage]);
  end;

  // All parent nodes are branches.
  // Go up excluding root node.
  while (Cur.Parent <> nil) and (Cur.Parent.Parent <> nil) do
  begin
    // Leaf node don't need PathDelim.
    if Cur = Self then
      Separator := ''
    else
      Separator := PathDelim;
    Result := Format('%s%s%s', [TResourceTreeBranchNode(Cur.Parent).GetSafeName,
      Separator, Result]);
    Cur := Cur.Parent;
  end;
end;

function TResourceTreeNode.IsBranch: boolean;
begin
  Result := (Self is TResourceTreeBranchNode);
end;

function TResourceTreeNode.IsLeaf: boolean;
begin
  Result := (Self is TResourceTreeLeafNode);
end;

function TResourceTreeNode.IsNamed: boolean;
begin
  Result := Name <> '';
end;

procedure TResourceTreeNode.SetId(const Value: uint32);
begin
  FId := Value;
  FName := '';
end;

procedure TResourceTreeNode.SetName(const Value: UnicodeString);
begin
  FId := 0;
  FName := Value;
end;

procedure TResourceTreeNode.Traverse(TraverseMethod: TResourceTraverseMethod);
const
  WANT_MORE_NODES = True;
var
  n: TResourceTreeNode;
begin
  if Assigned(TraverseMethod) and (Assigned(Self)) then
  begin
    // Visit node.
    if TraverseMethod(Self) = WANT_MORE_NODES then
    begin
      // If branch, visit children.
      if Self.IsBranch then
        for n in TResourceTreeBranchNode(Self).FChildren do
          n.Traverse(TraverseMethod)
    end;
  end;
end;

{ TResourceTree }

procedure TResourceTree.Clear;
begin
  FRoot.Free; // To destroy all children.
  CreateDummyRoot;
end;

constructor TResourceTree.Create;
begin
  inherited;
  CreateDummyRoot;
end;

procedure TResourceTree.CreateDummyRoot;
begin
  FRoot := TResourceTreeBranchNode.Create;
end;

destructor TResourceTree.Destroy;
begin
  FRoot.Free;
  inherited;
end;

{ TResourceTreeLeafNode }

constructor TResourceTreeLeafNode.Create;
begin
  inherited Create;
  FValidSize := True; // valid by default
  FData := TMemoryStream.Create;
end;

constructor TResourceTreeLeafNode.CreateFromRVA(PE: TPEImageObject;
  DataRVA: TRVA; DataSize: uint32; CodePage: uint32);
begin
  Create;

  FDataRVA := DataRVA;
  FCodepage := CodePage;
  FOriginalDataSize := DataSize;

  // Copy data from image.
  if DataSize <> 0 then
  begin
    // Check if we can't read whole raw size then this section either packed or
    // spoiled and mark it as invalid without reading any data.
    if not TPEImage(PE).RegionExistsRaw(DataRVA, DataSize) then
    begin
      FValidSize := False;
    end
    else
    begin
      // Otherwise leaf is valid and contain whole size.
      // Though it's not guaranteed that data is in right format anyway :)
      FData.Size := DataSize;
      TPEImage(PE).SaveRegionToStream(FData, DataRVA, DataSize);
    end;
  end;
end;

constructor TResourceTreeLeafNode.CreateFromStream(
  Stream: TStream;
  Pos, Size: UInt64);
begin
  Create;

  Stream.Position := Pos;

  if Size = 0 then
    Size := Stream.Size - Pos;

  FOriginalDataSize := Size;

  FData.CopyFrom(Stream, Size);
end;

constructor TResourceTreeLeafNode.CreateFromEntry(
  PE: TPEImageObject;
  const Entry: TResourceDataEntry);
begin
  CreateFromRVA(PE, Entry.DataRVA, Entry.Size, Entry.CodePage);
end;

destructor TResourceTreeLeafNode.Destroy;
begin
  FData.Free;
  inherited;
end;

function TResourceTreeLeafNode.GetDataSize: uint32;
begin
  Result := FData.Size;
end;

procedure TResourceTreeLeafNode.UpdateData(Buffer: PByte; Size: uint32);
begin
  if (Buffer = nil) or (Size = 0) then
  begin
    FData.Clear;
    exit;
  end;
  FData.Size := Size;
  Move(Buffer^, FData.Memory^, Size);
end;

end.


text:
{
  Generic Red-Black Tree
}

unit grbtree;

interface

uses
  System.SysUtils,
  System.Generics.Defaults,
  System.Generics.Collections;

Type
  TNodeKind = (NODE_RED, NODE_BLACK);

  TRBTree<T> = class(TEnumerable<T>)

    { Public Types }

  public type

    TCompareLessFunc = reference to function(const A, B: T): Boolean;

    TRBNodePtr = ^TRBNode;
    PRBNodePtr = ^TRBNodePtr;

    TRBNode = record
      K: T;                            // key
      Left, Right, Parent: TRBNodePtr; // <, >, ^
      Kind: TNodeKind;                 // node kind
    end;
  private type

    { Enumerator }

    TRBTreeEnumerator = class(TEnumerator<T>)
    private
      FRBTree: TRBTree<T>;
      FCurrentPtr: TRBNodePtr;
      function GetCurrent: T;
    protected
      function DoGetCurrent: T; override;
      function DoMoveNext: Boolean; override;
    public
      constructor Create(ARBTree: TRBTree<T>);
      property Current: T read GetCurrent;
      function MoveNext: Boolean;
    end;

  private
  var
    // Cache (1 item).
    FUseCache: Boolean;
    FCacheRec: TRBNodePtr;
    procedure InvalidateCache; inline;
    function IsCacheValid: Boolean; inline;
    function FindInCache(const Key: T; out Node: TRBNodePtr): Boolean; // inline;
    procedure UpdateCache(const Key: T; Node: TRBNodePtr); // inline;
  private
    FRoot, FFirst, FLast: TRBNodePtr;
    FCompare: TCompareLessFunc;
    FCount: Integer;

    FOnNotify: TCollectionNotifyEvent<T>;

    procedure RotateLeft(var x: TRBNodePtr);
    procedure RotateRight(var x: TRBNodePtr);
    function Minimum(var x: TRBNodePtr): TRBNodePtr;
    function Maximum(var x: TRBNodePtr): TRBNodePtr;
    procedure QuickErase(x: TRBNodePtr);
    procedure SetUseCache(const Value: Boolean);
  protected
    function DoGetEnumerator: TEnumerator<T>; override;
    procedure Notify(const Item: T; Action: TCollectionNotification); virtual;
    procedure ClearQuick;
    procedure ClearFull;

    function DoCompareLess(const A, B: T): Boolean; virtual;
  public
    constructor Create(Less: TCompareLessFunc);
    destructor Destroy(); override;

    procedure Clear; virtual;

    function Exists(const Key: T): Boolean; inline; // deprecated;
    function ContainsKey(const Key: T): Boolean; inline;

    function Find(const Key: T): TRBNodePtr;

    // Find first item lesser than Key (or nil if none).
    function FindLesser(const Key: T): TRBNodePtr;

    // Find first item gereater or equal to Key.
    function FindGreaterOrEqual(const Key: T): TRBNodePtr;

    // If Cur item found, result is True.
    function FindEx(const Key: T; out Prev, Cur, Next: TRBNodePtr): Boolean; overload;
    function FindEx(const Key: T; Prev, Cur, Next: PRBNodePtr): Boolean; overload;

    // Add new item or return existing.
    function Add(const Key: T; SendNotification: Boolean = True): TRBNodePtr; virtual;

    // Delete old key and add new key.
    function Replace(const OldKey, NewKey: T): TRBNodePtr;

    // Delete
    procedure Delete(z: TRBNodePtr; SendNotification: Boolean = True); overload; virtual;

    // Return True if item was found and removed.
    function Remove(const Key: T; SendNotification: Boolean = True): Boolean;

    function Next(var x: TRBNodePtr): Boolean;
    function Prev(var x: TRBNodePtr): Boolean;

    function GetNext(x: TRBNodePtr): TRBNodePtr; inline;
    function GetPrev(x: TRBNodePtr): TRBNodePtr; inline;

    { Properites }
    property Count: Integer read FCount;
    property Root: TRBNodePtr read FRoot;
    property First: TRBNodePtr read FFirst;
    property Last: TRBNodePtr read FLast;

    property OnNotify: TCollectionNotifyEvent<T> read FOnNotify write FOnNotify;

    property UseCache: Boolean read FUseCache write SetUseCache;
  end;

implementation

constructor TRBTree<T>.Create(Less: TCompareLessFunc);
begin
  inherited Create;
  FCount := 0;
  FCompare := Less;
  FRoot := nil;
  FFirst := nil;
  FLast := nil;
  FUseCache := True;
end;

function TRBTree<T>.Remove(const Key: T; SendNotification: Boolean): Boolean;
var
  z: TRBNodePtr;
begin
  InvalidateCache;
  z := Find(Key);
  if not Assigned(z) then
    Exit(False);
  Delete(z, SendNotification);
  Exit(True);
end;

destructor TRBTree<T>.Destroy();
begin
  ClearFull;
  inherited;
end;

function TRBTree<T>.DoCompareLess(const A, B: T): Boolean;
begin
  if @FCompare = nil then
    raise Exception.Create('Need comparer function')
  else
    Result := FCompare(A, B);
end;

function TRBTree<T>.DoGetEnumerator: TEnumerator<T>;
begin
  Result := TRBTreeEnumerator.Create(self);
end;

function TRBTree<T>.Exists(const Key: T): Boolean;
begin
  Result := Find(Key) <> nil;
end;

procedure TRBTree<T>.QuickErase(x: TRBNodePtr);
begin
  if x^.Left <> nil then
    QuickErase(x^.Left);
  if x^.Right <> nil then
    QuickErase(x^.Right);

  Notify(x^.K, cnRemoved);
  FreeMem(x);
end;

procedure TRBTree<T>.Clear;
begin
  InvalidateCache;
  ClearFull;
end;

function TRBTree<T>.IsCacheValid: Boolean;
begin
  Result := FCacheRec <> nil;
end;

procedure TRBTree<T>.InvalidateCache;
begin
  FCacheRec := nil;
end;

procedure TRBTree<T>.ClearFull;
begin
  InvalidateCache;
  while FCount <> 0 do
    Delete(First);
end;

procedure TRBTree<T>.ClearQuick;
begin
  InvalidateCache;
  if FRoot <> nil then
  begin
    QuickErase(FRoot);
    FRoot := nil;
  end;
  FFirst := nil;
  FLast := nil;
  FCount := 0;
end;

function TRBTree<T>.ContainsKey(const Key: T): Boolean;
begin
  Result := Exists(Key);
end;

function TRBTree<T>.Find(const Key: T): TRBNodePtr;
begin
  // Try cache.
  if FindInCache(Key, Result) then
    Exit;

  // Normal search.
  Result := FRoot;
  while Result <> nil do
  begin
    if DoCompareLess(Result^.K, Key) then
      Result := Result^.Right
    else if DoCompareLess(Key, Result^.K) then
      Result := Result^.Left
    else
    begin
      // If item found, update cache.
      UpdateCache(Key, Result);
      break;
    end;
  end;
end;

function TRBTree<T>.FindLesser(const Key: T): TRBNodePtr;
var
  Cur: TRBNodePtr;
begin
  Result := nil;
  Cur := FRoot;
  while Cur <> nil do
    if FCompare(Cur^.K, Key) then
    begin
      Result := Cur;
      Cur := Cur^.Right;
    end
    else
      Cur := Cur^.Left;
end;

function TRBTree<T>.FindGreaterOrEqual(const Key: T): TRBNodePtr;
var
  Cur: TRBNodePtr;
begin
  Result := nil;
  Cur := FRoot;
  while Cur <> nil do
    if not FCompare(Cur^.K, Key) then
    begin
      Result := Cur;
      Cur := Cur^.Left;
    end
    else
      Cur := Cur^.Right;
end;

function TRBTree<T>.FindInCache(const Key: T; out Node: TRBNodePtr): Boolean;
begin
  if FUseCache and IsCacheValid then
    if (not DoCompareLess(Key, FCacheRec^.K)) and
      (not DoCompareLess(FCacheRec^.K, Key)) then
    begin
      Node := FCacheRec;
      Exit(True);
    end;
  Exit(False);
end;

function TRBTree<T>.FindEx(const Key: T; Prev, Cur, Next: PRBNodePtr): Boolean;
var
  tPrev, tCur, tNext: TRBNodePtr;
begin
  tCur := FRoot;
  tPrev := nil;
  tNext := nil;
  Result := False;

  while tCur <> nil do
  begin
    if DoCompareLess(tCur^.K, Key) then
    begin
      tPrev := tCur;
      tCur := tCur^.Right;
    end
    else if DoCompareLess(Key, tCur^.K) then
    begin
      tNext := tCur;
      tCur := tCur^.Left;
    end
    else // Found.
    begin
      // Skip if not needed.
      if Prev <> nil then
        tPrev := GetPrev(tCur);
      if Next <> nil then
        tNext := GetNext(tCur);
      Result := True;
      break;
    end;
  end;

  // Store results.
  if Prev <> nil then
    Prev^ := tPrev;
  if Cur <> nil then
    Cur^ := tCur;
  if Next <> nil then
    Next^ := tNext;
end;

function TRBTree<T>.FindEx(const Key: T; out Prev, Cur, Next: TRBNodePtr): Boolean;
begin
  Result := False;
  Cur := FRoot;
  Prev := nil;
  Next := nil;
  while Cur <> nil do
  begin
    if DoCompareLess(Cur^.K, Key) then
    begin
      Prev := Cur;
      Cur := Cur^.Right;
    end
    else if DoCompareLess(Key, Cur^.K) then
    begin
      Next := Cur;
      Cur := Cur^.Left;
    end
    else
    begin
      Prev := GetPrev(Cur);
      Next := GetNext(Cur);
      Result := True;
      break; // Found.
    end;
  end;
end;

function TRBTree<T>.GetNext(x: TRBNodePtr): TRBNodePtr;
begin
  Result := x;
  if x <> nil then
    Next(Result);
end;

function TRBTree<T>.GetPrev(x: TRBNodePtr): TRBNodePtr;
begin
  Result := x;
  if x <> nil then
    Prev(Result);
end;

procedure TRBTree<T>.RotateLeft(var x: TRBNodePtr);
var
  y: TRBNodePtr;
begin
  y := x^.Right;
  x^.Right := y^.Left;
  if (y^.Left <> nil) then
    y^.Left^.Parent := x;
  y^.Parent := x^.Parent;
  if (x = FRoot) then
    FRoot := y
  else if (x = x^.Parent^.Left) then
    x^.Parent^.Left := y
  else
    x^.Parent^.Right := y;
  y^.Left := x;
  x^.Parent := y;
end;

procedure TRBTree<T>.RotateRight(var x: TRBNodePtr);
var
  y: TRBNodePtr;
begin
  y := x^.Left;
  x^.Left := y^.Right;
  if (y^.Right <> nil) then
    y^.Right^.Parent := x;
  y^.Parent := x^.Parent;
  if (x = FRoot) then
    FRoot := y
  else if (x = x^.Parent^.Right) then
    x^.Parent^.Right := y
  else
    x^.Parent^.Left := y;
  y^.Right := x;
  x^.Parent := y;
end;

procedure TRBTree<T>.SetUseCache(const Value: Boolean);
begin
  FUseCache := Value;
  InvalidateCache;
end;

procedure TRBTree<T>.UpdateCache(const Key: T; Node: TRBNodePtr);
begin
  if FUseCache then
  begin
    FCacheRec := Node;
  end;
end;

function TRBTree<T>.Minimum(var x: TRBNodePtr): TRBNodePtr;
begin
  Result := x;
  while (Result^.Left <> nil) do
    Result := Result^.Left;
end;

function TRBTree<T>.Maximum(var x: TRBNodePtr): TRBNodePtr;
begin
  Result := x;
  while (Result^.Right <> nil) do
    Result := Result^.Right;
end;

function TRBTree<T>.Add(const Key: T; SendNotification: Boolean = True): TRBNodePtr;
var
  x, y, z, zpp: TRBNodePtr;
begin
  InvalidateCache;

  z := AllocMem(sizeof(TRBNode));

  z^.K := Key;
  z^.Kind := NODE_RED;

  Result := z;

  if (FFirst = nil) or (DoCompareLess(Key, FFirst^.K)) then
    FFirst := z;

  if (FLast = nil) or (DoCompareLess(FLast^.K, Key)) then
    FLast := z;

  y := nil;
  x := FRoot;
  while (x <> nil) do
  begin
    y := x;
    if DoCompareLess(Key, x^.K) then
      x := x^.Left
    else if DoCompareLess(x^.K, Key) then
      x := x^.Right
    else
    begin
      // Already exists.
      // Destroy newly created item.
      // Notify(z^.K, cnRemoved);
      FreeMem(z);
      raise Exception.Create('Duplicate key.');
      Exit;
    end;
  end;

  z^.Parent := y;
  if (y = nil) then
    FRoot := z
  else if (DoCompareLess(Key, y^.K)) then
    y^.Left := z
  else
    y^.Right := z;

  // Rebalance
  while ((z <> FRoot) and (z^.Parent^.Kind = NODE_RED)) do
  begin
    zpp := z^.Parent^.Parent;
    if (z^.Parent = zpp^.Left) then
    begin
      y := zpp^.Right;
      if ((y <> nil) and (y^.Kind = NODE_RED)) then
      begin
        z^.Parent^.Kind := NODE_BLACK;
        y^.Kind := NODE_BLACK;
        zpp^.Kind := NODE_RED;
        z := zpp;
      end
      else
      begin
        if (z = z^.Parent^.Right) then
        begin
          z := z^.Parent;
          RotateLeft(z);
        end;
        z^.Parent^.Kind := NODE_BLACK;
        zpp^.Kind := NODE_RED;
        RotateRight(zpp);
      end;
    end
    else
    begin
      y := zpp^.Left;
      if ((y <> nil) and (y^.Kind = NODE_RED)) then
      begin
        z^.Parent^.Kind := NODE_BLACK;
        y^.Kind := NODE_BLACK;
        zpp^.Kind := NODE_RED;
        z := zpp;
      end
      else
      begin
        if (z = z^.Parent^.Left) then
        begin
          z := z^.Parent;
          RotateRight(z);
        end;
        z^.Parent^.Kind := NODE_BLACK;
        zpp^.Kind := NODE_RED;
        RotateLeft(zpp);
      end;
    end;
  end;
  FRoot^.Kind := NODE_BLACK;

  inc(FCount);

  if SendNotification then
    Notify(Result^.K, cnAdded);
end;

procedure TRBTree<T>.Delete(z: TRBNodePtr; SendNotification: Boolean);
var
  w, x, y, x_parent: TRBNodePtr;
  tmpcol: TNodeKind;
  OldKey: T;
begin
  InvalidateCache;

  if SendNotification then
    OldKey := z^.K; // store it for notification in the end

  z^.K := Default (T); // finalize key
{$REGION 'delete'}
  y := z;
  x := nil;
  x_parent := nil;

  if (y^.Left = nil) then
    x := y^.Right
  else
  begin
    if (y^.Right = nil) then
      x := y^.Left
    else
    begin
      y := y^.Right;
      while (y^.Left <> nil) do
        y := y^.Left;
      x := y^.Right;
    end;
  end;

  if (y <> z) then
  begin
    z^.Left^.Parent := y;
    y^.Left := z^.Left;
    if (y <> z^.Right) then
    begin
      x_parent := y^.Parent;
      if (x <> nil) then
        x^.Parent := y^.Parent;
      y^.Parent^.Left := x;
      y^.Right := z^.Right;
      z^.Right^.Parent := y;
    end
    else
      x_parent := y;
    if (FRoot = z) then
      FRoot := y
    else if (z^.Parent^.Left = z) then
      z^.Parent^.Left := y
    else
      z^.Parent^.Right := y;
    y^.Parent := z^.Parent;
    tmpcol := y^.Kind;
    y^.Kind := z^.Kind;
    z^.Kind := tmpcol;
    y := z;
  end
  else
  begin { y = z }
    x_parent := y^.Parent;
    if (x <> nil) then
      x^.Parent := y^.Parent;
    if (FRoot = z) then
      FRoot := x
    else
    begin
      if (z^.Parent^.Left = z) then
        z^.Parent^.Left := x
      else
        z^.Parent^.Right := x;
    end;
    if (FFirst = z) then
    begin
      if (z^.Right = nil) then
        FFirst := z^.Parent
      else
        FFirst := Minimum(x);
    end;
    if (FLast = z) then
    begin
      if (z^.Left = nil) then
        FLast := z^.Parent
      else { x = z^.left }
        FLast := Maximum(x);
    end;
  end;
{$ENDREGION 'delete'}
{$REGION 'rebalance'}
  // Rebalance tree
  if (y^.Kind = NODE_BLACK) then
  begin
    while ((x <> FRoot) and ((x = nil) or (x^.Kind = NODE_BLACK))) do
    begin
      if (x = x_parent^.Left) then
      begin
        w := x_parent^.Right;
        if (w^.Kind = NODE_RED) then
        begin
          w^.Kind := NODE_BLACK;
          x_parent^.Kind := NODE_RED;
          RotateLeft(x_parent);
          w := x_parent^.Right;
        end;
        if (((w^.Left = nil) or
          (w^.Left^.Kind = NODE_BLACK)) and
          ((w^.Right = nil) or
          (w^.Right^.Kind = NODE_BLACK))) then
        begin
          w^.Kind := NODE_RED;
          x := x_parent;
          x_parent := x_parent^.Parent;
        end
        else
        begin
          if ((w^.Right = nil) or (w^.Right^.Kind = NODE_BLACK)) then
          begin
            w^.Left^.Kind := NODE_BLACK;
            w^.Kind := NODE_RED;
            RotateRight(w);
            w := x_parent^.Right;
          end;
          w^.Kind := x_parent^.Kind;
          x_parent^.Kind := NODE_BLACK;
          if (w^.Right <> nil) then
            w^.Right^.Kind := NODE_BLACK;
          RotateLeft(x_parent);
          x := FRoot; { break; }
        end
      end
      else
      begin
        w := x_parent^.Left;
        if (w^.Kind = NODE_RED) then
        begin
          w^.Kind := NODE_BLACK;
          x_parent^.Kind := NODE_RED;
          RotateRight(x_parent);
          w := x_parent^.Left;
        end;
        if (((w^.Right = nil) or
          (w^.Right^.Kind = NODE_BLACK)) and
          ((w^.Left = nil) or
          (w^.Left^.Kind = NODE_BLACK))) then
        begin
          w^.Kind := NODE_RED;
          x := x_parent;
          x_parent := x_parent^.Parent;
        end
        else
        begin
          if ((w^.Left = nil) or (w^.Left^.Kind = NODE_BLACK)) then
          begin
            w^.Right^.Kind := NODE_BLACK;
            w^.Kind := NODE_RED;
            RotateLeft(w);
            w := x_parent^.Left;
          end;
          w^.Kind := x_parent^.Kind;
          x_parent^.Kind := NODE_BLACK;
          if (w^.Left <> nil) then
            w^.Left^.Kind := NODE_BLACK;
          RotateRight(x_parent);
          x := FRoot;
        end;
      end;
    end;
    if (x <> nil) then
      x^.Kind := NODE_BLACK;
  end;
{$ENDREGION 'rebalance'}
  dec(FCount);

  if SendNotification then
    Notify(OldKey, cnRemoved);

  FreeMem(y);
end;

function TRBTree<T>.Next(var x: TRBNodePtr): Boolean;
var
  y: TRBNodePtr;
begin
  if x = Last then
  begin
    x := nil;
    Exit(False);
  end;

  if (x^.Right <> nil) then
  begin
    x := x^.Right;
    while (x^.Left <> nil) do
      x := x^.Left;
  end
  else
  begin
    y := x^.Parent;
    while (x = y^.Right) do
    begin
      x := y;
      y := y^.Parent;
    end;
    if (x^.Right <> y) then
      x := y;
  end;
  Exit(True);
end;

procedure TRBTree<T>.Notify(const Item: T; Action: TCollectionNotification);
begin
  if Assigned(FOnNotify) then
    FOnNotify(self, Item, Action);
end;

function TRBTree<T>.Prev(var x: TRBNodePtr): Boolean;
var
  y: TRBNodePtr;
begin
  if x = First then
  begin
    x := nil;
    Exit(False);
  end;
  if (x^.Left <> nil) then
  begin
    y := x^.Left;
    while (y^.Right <> nil) do
      y := y^.Right;
    x := y;
  end
  else
  begin
    y := x^.Parent;
    while (x = y^.Left) do
    begin
      x := y;
      y := y^.Parent;
    end;
    x := y;
  end;
  Exit(True);
end;

function TRBTree<T>.Replace(const OldKey, NewKey: T): TRBNodePtr;
begin
  InvalidateCache;
  Remove(OldKey);
  Result := Add(NewKey);
end;

{ TRBTree<T>.TValueEnumerator }

constructor TRBTree<T>.TRBTreeEnumerator.Create(ARBTree: TRBTree<T>);
begin
  inherited Create;
  FCurrentPtr := nil;
  FRBTree := ARBTree;
end;

function TRBTree<T>.TRBTreeEnumerator.DoGetCurrent: T;
begin
  Result := GetCurrent;
end;

function TRBTree<T>.TRBTreeEnumerator.DoMoveNext: Boolean;
begin
  Result := MoveNext;
end;

function TRBTree<T>.TRBTreeEnumerator.GetCurrent: T;
begin
  Result := FCurrentPtr^.K;
end;

function TRBTree<T>.TRBTreeEnumerator.MoveNext: Boolean;
begin
  if not Assigned(FCurrentPtr) then
  begin
    FCurrentPtr := FRBTree.First;
    Exit(Assigned(FCurrentPtr));
  end
  else if (FCurrentPtr <> FRBTree.Last) then
  begin
    FRBTree.Next(FCurrentPtr);
    Exit(True);
  end;
  Exit(False);
end;

end.

repo_name: vdisasm/pe-image-for-delphi

repo_language: Pascal

mime_type: text/plain


text:
unit PE.Imports.Func;

interface

uses
  System.Generics.Collections,
  System.SysUtils,
  PE.Common;

type
  TPEImportFunction = class
  public
    Ordinal: uint16;
    Name: String;
    procedure Clear; inline;
    constructor CreateEmpty;
    constructor Create(const Name: String; Ordinal: uint16 = 0);
  end;

  TPEImportFunctionDelayed = class(TPEImportFunction)
  public
  end;

  TPEImportFunctions = TObjectList<TPEImportFunction>;

implementation

{ TImportFunction }

procedure TPEImportFunction.Clear;
begin
  self.Ordinal := 0;
  self.Name := '';
end;

constructor TPEImportFunction.Create(const Name: String; Ordinal: uint16);
begin
  self.Name := Name;
  self.Ordinal := Ordinal;
end;

constructor TPEImportFunction.CreateEmpty;
begin
end;

end.


text:
(*
  .pdata section parser
*)
unit PE.Parser.PData;

interface

uses
  PE.Image,
  PE.Section,
  PE.Sections,
  PE.Types.FileHeader,
  PE.Types.Sections;

{ http://msdn.microsoft.com/en-us/library/ms864326.aspx }

type
  PDATA_EH = packed record
    // OS Versions: Windows CE .NET 4.0 and later.
    // Header: no public definition.
    pHandler: uint32;     // Address of the exception handler for the function.
    pHandlerData: uint32; // Address of the exception handler data record for the function.
  end;

  { 5.5. The .pdata Section }

type
  { 32-bit MIPS images }
  TPDATA_MIPS32 = packed record
    // The VA of the corresponding function.
    BeginAddress: uint32;

    // The VA of the end of the function.
    EndAddress: uint32;

    // The pointer to the exception handler to be executed.
    ExceptionHandler: uint32;

    // The pointer to additional information to be passed to the handler.
    HandlerData: uint32;

    // The VA of the end of the function’s prolog.
    PrologEndAddress: uint32;
  end;

  PPDATA_MIPS32 = ^TPDATA_MIPS32;

  { ARM, PowerPC, SH3 and SH4 Windows CE platforms }
  TPDATA_ARM = packed record
  strict private
    _BeginAddress: uint32;
    _DATA: uint32;
  public
    // The VA of the corresponding function.
    function BeginAddress: uint32; inline;

    // 8 bit: The number of instructions in the function’s prolog.
    function PrologLength: uint8; inline;

    // 22 bit: The number of instructions in the function.
    function FunctionLength: uint32; inline;

    // 1 bit: If set, the function consists of 32-bit instructions.
    // If clear, the function consists of 16-bit instructions.
    function Is32Bit: boolean; inline;

    // 1 bit: If set, an exception handler exists for the function.
    // Otherwise, no exception handler exists.
    function IsExceptionFlag: boolean; inline;

    function IsEmpty: boolean; inline;

  end;

  PPDATA_ARM = ^TPDATA_ARM;

  { For x64 and Itanium platforms }
  TPDATA_x64 = packed record
    BeginAddress: uint32;      // The RVA of the corresponding function.
    EndAddress: uint32;        // The RVA of the end of the function.
    UnwindInformation: uint32; // The RVA of the unwind information.
  end;

  PPDATA_x64 = ^TPDATA_x64;

  { For the ARMv7 platform }
  TPDATA_ARMv7 = packed record
    // The RVA of the corresponding function.
    BeginAddress: uint32;

    // The RVA of the unwind information, including function length.
    // If the low 2 bits are non-zero, then this word represents a compacted
    // inline form of the unwind information, including function length.
    UnwindInformation: uint32;
  end;

  PPDATA_ARMv7 = ^TPDATA_ARMv7;

type
  TPDATAType = (pdata_NONE, pdata_MIPS32, pdata_ARM, pdata_x64, pdata_ARMv7);

  TPDATAItem = record
    function IsEmpty: boolean; inline;
    procedure Clear; inline;
  public
    case TPDATAType of
      pdata_NONE:
        (BeginAddress: uint32); // common field, can be RVA or VA
      pdata_MIPS32:
        (MIPS32: TPDATA_MIPS32);
      pdata_ARM:
        (ARM: TPDATA_ARM);
      pdata_x64:
        (x64: TPDATA_x64);
      pdata_ARMv7:
        (ARMv7: TPDATA_ARMv7);
  end;

type
  TPDATAItems = array of TPDATAItem;

  // Parses .PDATA section (if exists) and returns count of elements found
function ParsePDATA(PE: TPEImage; out &Type: TPDATAType; out Items: TPDATAItems): integer;

implementation

{ TPDATA_ARM }

function TPDATA_ARM.BeginAddress: uint32;
begin
  result := _BeginAddress;
end;

function TPDATA_ARM.FunctionLength: uint32;
begin
  result := (_DATA shr 8) and ((1 shl 22) - 1);
end;

function TPDATA_ARM.Is32Bit: boolean;
begin
  result := _DATA and (1 shl 30) <> 0;
end;

function TPDATA_ARM.IsEmpty: boolean;
begin
  result := (_BeginAddress = 0) or (_DATA = 0);
end;

function TPDATA_ARM.IsExceptionFlag: boolean;
begin
  result := _DATA and (1 shl 31) <> 0;
end;

function TPDATA_ARM.PrologLength: uint8;
begin
  result := byte(_DATA);
end;

{ ParsePDATA }

function ParsePDATA(PE: TPEImage; out &Type: TPDATAType; out Items: TPDATAItems): integer;
var
  sec: TPESection;
  i, Cnt, Size, Actual: uint32;
begin
  SetLength(Items, 0);

  Size := 0;
  &Type := pdata_NONE;

  sec := PE.Sections.FindByName('.pdata');

  if
    (sec <> nil) and
    (sec.RawSize > 0) and
    ((sec.flags and IMAGE_SCN_CNT_INITIALIZED_DATA) <> 0) and
    ((sec.flags and IMAGE_SCN_MEM_READ) <> 0) and
    (PE.SeekRVA(sec.RVA)) then
  begin
    // Load.
    case PE.FileHeader^.Machine of
      IMAGE_FILE_MACHINE_ARM, IMAGE_FILE_MACHINE_THUMB:
        begin
          Size := sizeof(TPDATA_ARM);
          &Type := pdata_ARM;
        end;
      IMAGE_FILE_MACHINE_AMD64:
        begin
          Size := sizeof(TPDATA_x64);
          &Type := pdata_x64;
        end;
    end;

    if &Type <> pdata_NONE then
    begin
      Cnt := sec.VirtualSize div Size;
      Actual := 0;
      SetLength(Items, Cnt); // pre-allocate
      if Cnt <> 0 then
      begin
        for i := 0 to Cnt - 1 do
        begin
          if (not PE.ReadEx(@Items[i], Size)) or (Items[i].IsEmpty) then
            break;
          inc(Actual);
        end;
      end;
      if Actual <> Cnt then
        SetLength(Items, Actual); // trim
    end;
  end;

  result := Length(Items);
end;

{ TPDATAItem }

procedure TPDATAItem.Clear;
begin
  FillChar(self, sizeof(self), 0);
end;

function TPDATAItem.IsEmpty: boolean;
begin
  result := self.BeginAddress = 0;
end;

end.


text:
unit PE.Image;

interface

uses
  System.Classes,
  System.SysUtils,
  System.Generics.Collections,

  PE.Common,
  PE.Headers,
  PE.DataDirectories,

  PE.Msg,
  PE.Utils,

  PE.Image.Defaults,
  PE.Image.Saving,

  PE.Types,
  PE.Types.DOSHeader,
  PE.Types.Directories,
  PE.Types.FileHeader,
  PE.Types.NTHeaders,
  PE.Types.Sections,
  PE.Types.Relocations,
  PE.Types.Imports,
  PE.Types.Export,

  PE.ExportSym,

  PE.TLS,
  PE.Section,
  PE.Sections,
  PE.Imports,
  PE.Resources,

  PE.Parser.Headers,
  PE.Parser.Export,
  PE.Parser.Import,
  PE.Parser.ImportDelayed,
  PE.Parser.Relocs,
  PE.Parser.TLS,
  PE.Parser.Resources,

  PE.COFF,
  PE.COFF.Types,

  PE.MemoryStream,
  PE.ProcessModuleStream,

  PE.ParserCallbacks;

type

  { TPEImage }

  TPEImage = class
  private
    FImageKind: TPEImageKind;
    FParseStages: TParserFlags;
    FParseCallbacks: IPEParserCallbacks;
    FOptions: TParserOptions;

    // Used only for loading from mapped image. Nil for disk images.
    FPEMemoryStream: TPEMemoryStream;

    FFileName: string;
    FFileSize: UInt64;
    FDefaults: TPEDefaults;
    FImageBitSize: byte;  // 32/64
    FImageWordSize: byte; // 4/8

    FCOFF: TCOFF;

    FDosHeader: TImageDOSHeader; // DOS header.
    FLFANew: uint32;             // Address of new header next after DOS.
    FDosBlock: TBytes;           // Bytes between DOS header and next header.
    FSecHdrGap: TBytes;          // Gap after section headers.

    FFileHeader: TImageFileHeader;
    FOptionalHeader: TPEOptionalHeader;

    FSections: TPESections;
    FRelocs: TRelocs;
    FImports: TPEImport;        // of TPEImportFunction
    FImportsDelayed: TPEImport; // of TPEImportFunctionDelayed
    FExports: TPEExportSyms;
    FExportedName: String;
    FTLS: TTLS;
    FResourceTree: TResourceTree;
    FOverlay: TOverlay;

    FParsers: array [TParserFlag] of TPEParserClass;
    FMsg: TMsgMgr;
    FDataDirectories: TDataDirectories;
  private
    // Used for read/write.
    FCurrentSec: TPESection; // Current section.
    FPositionRVA: TRVA;      // Current RVA.
    FCurrentOfs: uint32;     // Current offset in section.

    procedure SetPositionRVA(const Value: TRVA);

    procedure SetPositionVA(const Value: TVA);
    function GetPositionVA: TVA;

    function ReadWrite(Buffer: Pointer; Count: cardinal; Read: boolean): uint32;
  private
    // Add new section to have range of addresses for image header.
    procedure LoadingAddHeaderAsASection(Stream: TStream);
  private

    { Notifiers }
    procedure DoReadError;

    { Parsers }
    procedure InitParsers;

    { Base loading }
    function LoadSectionHeaders(AStream: TStream): boolean;
    function LoadSectionData(AStream: TStream): UInt16;

    // Replace /%num% to name from COFF string table.
    procedure ResolveSectionNames;

    function GetImageBase: TRVA; inline;
    procedure SetImageBase(Value: TRVA); inline;

    function GetSizeOfImage: UInt64; inline;
    procedure SetSizeOfImage(Value: UInt64); inline;

    function EntryPointRVAGet: TRVA; inline;
    procedure EntryPointRVASet(Value: TRVA); inline;

    function FileAlignmentGet: uint32; inline;
    procedure FileAlignmentSet(const Value: uint32); inline;

    function SectionAlignmentGet: uint32; inline;
    procedure SectionAlignmentSet(const Value: uint32); inline;

    function GetFileHeader: PImageFileHeader; inline;
    function GetImageDOSHeader: PImageDOSHeader; inline;
    function GetOptionalHeader: PPEOptionalHeader; inline;

    function GetIsDll: boolean;
    procedure SetIsDll(const Value: boolean);

  protected

    // If image is disk-based, result is created TFileStream.
    // If it's memory mapped, result is opened memory stream.
    function SourceStreamGet(Mode: word): TStream;

    // If image is disk-based, stream is freed.
    // If it's memory mapped, nothing happens.
    procedure SourceStreamFree(Stream: TStream);

  public

    // Create without message proc.
    constructor Create(); overload;

    // Create with message proc.
    constructor Create(AMsgProc: TMsgProc); overload;

    destructor Destroy; override;

    // Check if stream at offset Ofs is MZ/PE image.
    // Result is False if either failed to make check or it's not valid image.
    class function IsPE(AStream: TStream; Ofs: UInt64 = 0): boolean; overload; static;

    // Check if file is PE.
    class function IsPE(const FileName: string): boolean; overload; static;

    // Check if image is 32/64 bit.
    function Is32bit: boolean; inline;
    function Is64bit: boolean; inline;

    // Get image bitness. 32/64 or 0 if unknown.
    function GetImageBits: UInt16; inline;
    procedure SetImageBits(Value: UInt16);

    { PE Streaming }

    // Seek RVA or VA and return True on success.
    function SeekRVA(RVA: TRVA): boolean;
    function SeekVA(VA: TVA): boolean;

    // Read Count bytes from current RVA/VA position to Buffer and
    // return number of bytes read.
    // It cannot read past end of section.
    function Read(Buffer: Pointer; Count: cardinal): uint32; overload;
    function Read(var Buffer; Count: cardinal): uint32; overload; inline;

    // Read Count bytes to Buffer and return True if all bytes were read.
    function ReadEx(Buffer: Pointer; Count: cardinal): boolean; overload; inline;
    function ReadEx(var Buffer; Size: cardinal): boolean; overload; inline;

    // Read 1/2/4/8-sized word.
    // If WordSize is 0 size native to image is used (4 for PE32, 8 for PE64).
    function ReadWord(WordSize: byte = 0): UInt64;

    // Try to read 1/2/4/8-sized word.
    // Result shows if all bytes are read.
    function ReadWordEx(WordSize: byte; OutValue: PUInt64): boolean;

    // Skip Count bytes.
    procedure Skip(Count: integer);

    // Read 1-byte 0-terminated string.
    function ReadAnsiString: String;

    // MaxLen: 0 - no limit
    function ReadAnsiStringLen(MaxLen: integer; out Len: integer; out Str: string): boolean;

    // Read 2-byte UTF-16 string with length prefix (2 bytes).
    function ReadUnicodeStringLenPfx2: String;

    // Reading values.
    // todo: these functions should be Endianness-aware.
    function ReadUInt8: UInt8; overload; inline;
    function ReadUInt16: UInt16; overload; inline;
    function ReadUInt32: uint32; overload; inline;
    function ReadUInt64: UInt64; overload; inline;
    function ReadUIntPE: UInt64; overload; inline; // 64/32 depending on PE format.

    function ReadUInt8(OutData: PUInt8): boolean; overload; inline;
    function ReadUInt16(OutData: PUInt16): boolean; overload; inline;
    function ReadUInt32(OutData: PUInt32): boolean; overload; inline;
    function ReadUInt64(OutData: PUInt64): boolean; overload; inline;
    function ReadUIntPE(OutData: PUInt64): boolean; overload; inline; // 64/32 depending on PE format.

    // Write Count bytes from Buffer to current position.
    function Write(Buffer: Pointer; Count: cardinal): uint32; overload;
    function Write(const Buffer; Count: cardinal): uint32; overload;

    function WriteEx(Buffer: Pointer; Count: cardinal): boolean; overload; inline;
    function WriteEx(const Buffer; Count: cardinal): boolean; overload; inline;

    { Address conversions }

    // Check if RVA exists.
    function RVAExists(RVA: TRVA): boolean;

    // Convert RVA to memory pointer.
    function RVAToMem(RVA: TRVA): Pointer;

    // Convert RVA to file offset. OutOfs can be nil.
    function RVAToOfs(RVA: TRVA; OutOfs: PDword): boolean;

    // Find Section by RVA. OutSec can be nil.
    function RVAToSec(RVA: TRVA; OutSec: PPESection): boolean;

    // Convert RVA to VA.
    function RVAToVA(RVA: TRVA): TVA; inline;

    // Check if VA exists.
    function VAExists(VA: TRVA): boolean;

    // Convert VA to memory pointer.
    function VAToMem(VA: TVA): Pointer; inline;

    // Convert VA to file offset. OutOfs can be nil.
    function VAToOfs(VA: TVA; OutOfs: PDword): boolean; inline;

    // Find Section by VA. OutSec can be nil.
    function VAToSec(VA: TRVA; OutSec: PPESection): boolean;

    // Convert VA to RVA.
    // Make sure VA is >= ImageBase.
    function VAToRVA(VA: TVA): TRVA; inline;

    // Check if RVA/VA belongs to image.
    function ContainsRVA(RVA: TRVA): boolean; inline;
    function ContainsVA(VA: TVA): boolean; inline;

    { Image }

    // Clear image.
    procedure Clear;

    // Calculate not aligned size of headers.
    function CalcHeadersSizeNotAligned: uint32; inline;

    // Calculate valid aligned size of image.
    function CalcVirtualSizeOfImage: UInt64; inline;

    // Calc raw size of image (w/o overlay), or 0 if failed.
    // Can be used if image loaded from stream and exact image size is unknown.
    // Though we still don't know overlay size.
    function CalcRawSizeOfImage: UInt64; inline;

    // Calc offset of section headers.
    function CalcSecHdrOfs: TFileOffset;

    // Calc offset of section headers end.
    function CalcSecHdrEndOfs: TFileOffset;

    // Calc size of optional header w/o directories.
    function CalcSizeOfPureOptionalHeader: uint32;

    // Set aligned SizeOfHeaders.
    procedure FixSizeOfHeaders; inline;

    // Set valid size of image.
    procedure FixSizeOfImage; inline;

    { Loading }

    // Load image from stream.
    function LoadFromStream(AStream: TStream;
      AParseStages: TParserFlags = DEFAULT_PARSER_FLAGS;
      ImageKind: TPEImageKind = PEIMAGE_KIND_DISK): boolean;

    // Load image from file.
    function LoadFromFile(const AFileName: string;
      AParseStages: TParserFlags = DEFAULT_PARSER_FLAGS): boolean;

    // Load PE image from image in memory of current process.
    // Won't help if image in memory has spoiled headers.
    function LoadFromMappedImage(const AFileName: string;
      AParseStages: TParserFlags = DEFAULT_PARSER_FLAGS): boolean; overload;
    function LoadFromMappedImage(ModuleBase: NativeUInt;
      AParseStages: TParserFlags = DEFAULT_PARSER_FLAGS): boolean; overload;

    // Load PE image from running process.
    // Address defines module to load.
    function LoadFromProcessImage(ProcessId: DWORD; Address: NativeUInt;
      AParseStages: TParserFlags = DEFAULT_PARSER_FLAGS): boolean;

    { Saving }

    // Save image to stream.
    function SaveToStream(AStream: TStream): boolean;

    // Save image to file.
    function SaveToFile(const AFileName: string): boolean;

    { Sections }

    // Get last section containing raw offset and size.
    // Get nil if no good section found.
    function GetLastSectionWithValidRawData: TPESection;

    { Overlay }

    // Get overlay record pointer.
    function GetOverlay: POverlay;

    // Save overlay to file. It can be either appended to existing file or new
    // file will be created.
    function SaveOverlayToFile(const AFileName: string; Append: boolean = false): boolean;

    // Remove overlay from current image file.
    function RemoveOverlay: boolean;

    // Set overlay for current image file from file data of AFileName file.
    // If Offset and Size are 0, then whole file is appended.
    function LoadOverlayFromFile(const AFileName: string;
      Offset: UInt64 = 0; Size: UInt64 = 0): boolean; overload;

    { Writing to external stream }

    // Write RVA to stream (32/64 bit sized depending on image).
    function StreamWriteRVA(AStream: TStream; RVA: TRVA): boolean;

    { Dump }

    // Save memory region to stream/file (in section boundary).
    // Result is number of bytes written.
    // If trying to save more bytes than section contains it will save until
    // section end.
    // AStream can be nil if you want just check how many bytes can be saved.
    // todo: maybe also add cross-section dumps.
    function SaveRegionToStream(AStream: TStream; RVA: TRVA; Size: uint32): uint32;
    function SaveRegionToFile(const AFileName: string; RVA: TRVA; Size: uint32): uint32;

    // Load data from Stream at Offset to memory. RVA and Size must define region
    // that completely fit into some section. If region is larger than file or
    // section it is truncated.
    // ReadSize is optional param to get number of bytes read.
    function LoadRegionFromStream(AStream: TStream; Offset: UInt64; RVA: TRVA; Size: uint32; ReadSize: PUInt32 = nil): boolean;
    function LoadRegionFromFile(const AFileName: string; Offset: UInt64; RVA: TRVA; Size: uint32; ReadSize: PUInt32 = nil): boolean;

    { Regions }

    procedure RegionRemove(RVA: TRVA; Size: uint32);

    // Check if region belongs to some section and has enough raw/virtual size.
    function RegionExistsRaw(RVA: TRVA; RawSize: uint32): boolean;
    function RegionExistsVirtual(RVA: TRVA; VirtSize: uint32): boolean;

    { Properties }

    property Msg: TMsgMgr read FMsg;

    property Defaults: TPEDefaults read FDefaults;

    property ImageBitSize: byte read FImageBitSize;
    property ImageWordSize: byte read FImageWordSize;

    property ParseCallbacks: IPEParserCallbacks read FParseCallbacks write FParseCallbacks;

    // Current read/write position.
    property PositionRVA: TRVA read FPositionRVA write SetPositionRVA;
    property PositionVA: TVA read GetPositionVA write SetPositionVA;

    property ImageKind: TPEImageKind read FImageKind;
    property FileName: string read FFileName;

    // Offset of NT headers, used building new image.
    property LFANew: uint32 read FLFANew write FLFANew;
    property DosBlock: TBytes read FDosBlock;
    property SecHdrGap: TBytes read FSecHdrGap;

    // Headers.
    property DOSHeader: PImageDOSHeader read GetImageDOSHeader;
    property FileHeader: PImageFileHeader read GetFileHeader;
    property OptionalHeader: PPEOptionalHeader read GetOptionalHeader;

    // Directories.
    property DataDirectories: TDataDirectories read FDataDirectories;

    // Image sections.
    property Sections: TPESections read FSections;

    // Relocations.
    property Relocs: TRelocs read FRelocs;

    // Import items.
    property Imports: TPEImport read FImports;
    property ImportsDelayed: TPEImport read FImportsDelayed;

    // Export items.
    property ExportSyms: TPEExportSyms read FExports;

    // Image exported name.
    property ExportedName: String read FExportedName write FExportedName;

    // Thread Local Storage items.
    property TLS: TTLS read FTLS;

    // Resource items.
    property ResourceTree: TResourceTree read FResourceTree;

    property ImageBase: TRVA read GetImageBase write SetImageBase;
    property SizeOfImage: UInt64 read GetSizeOfImage write SetSizeOfImage;

    // 32/64
    property ImageBits: UInt16 read GetImageBits write SetImageBits;

    property EntryPointRVA: TRVA read EntryPointRVAGet write EntryPointRVASet;
    property FileAlignment: uint32 read FileAlignmentGet write FileAlignmentSet;
    property SectionAlignment: uint32 read SectionAlignmentGet write SectionAlignmentSet;

    property IsDLL: boolean read GetIsDll write SetIsDll;

    property Options: TParserOptions read FOptions write FOptions;
  end;

implementation

const
  VM_PAGE_SIZE = $1000; // 4 KB page

  { TPEImage }

function TPEImage.EntryPointRVAGet: TRVA;
begin
  Result := FOptionalHeader.AddressOfEntryPoint;
end;

procedure TPEImage.EntryPointRVASet(Value: TRVA);
begin
  FOptionalHeader.AddressOfEntryPoint := Value;
end;

function TPEImage.GetImageBase: TRVA;
begin
  Result := FOptionalHeader.ImageBase;
end;

procedure TPEImage.SetImageBase(Value: TRVA);
begin
  FOptionalHeader.ImageBase := Value;
end;

function TPEImage.GetSizeOfImage: UInt64;
begin
  Result := FOptionalHeader.SizeOfImage;
end;

procedure TPEImage.SetSizeOfImage(Value: UInt64);
begin
  FOptionalHeader.SizeOfImage := Value;
end;

function TPEImage.StreamWriteRVA(AStream: TStream; RVA: TRVA): boolean;
var
  rva32: uint32;
  rva64: UInt64;
begin
  if Is32bit then
  begin
    rva32 := RVA;
    Result := AStream.Write(rva32, 4) = 4;
    exit;
  end;
  if Is64bit then
  begin
    rva64 := RVA;
    Result := AStream.Write(rva64, 8) = 8;
    exit;
  end;
  exit(false);
end;

constructor TPEImage.Create;
begin
  Create(nil);
end;

constructor TPEImage.Create(AMsgProc: TMsgProc);
begin
  FOptions := DEFAULT_OPTIONS;
  FMsg := TMsgMgr.Create(AMsgProc);
  FDefaults := TPEDefaults.Create(self);

  FDataDirectories := TDataDirectories.Create(self);

  FSections := TPESections.Create(self);

  FRelocs := TRelocs.Create;

  FImports := TPEImport.Create;
  FImportsDelayed := TPEImport.Create;

  FExports := TPEExportSyms.Create;

  FTLS := TTLS.Create;

  FResourceTree := TResourceTree.Create;

  FCOFF := TCOFF.Create(self);

  InitParsers;

  FDefaults.SetAll;
end;

procedure TPEImage.Clear;
begin
  if FImageKind = PEIMAGE_KIND_MEMORY then
    raise Exception.Create('Can''t clear mapped in-memory image.');

  FLFANew := 0;
  SetLength(FDosBlock, 0);
  SetLength(FSecHdrGap, 0);

  FCOFF.Clear;
  FDataDirectories.Clear;
  FSections.Clear;
  FImports.Clear;
  FImportsDelayed.Clear;
  FExports.Clear;
  FTLS.Clear;
  FResourceTree.Clear;
end;

function TPEImage.ContainsRVA(RVA: TRVA): boolean;
begin
  if FSections.Count = 0 then
    raise Exception.Create('Image contains no sections.');
  Result := (RVA >= FSections.First.RVA) and (RVA < FSections.Last.GetEndRVA);
end;

function TPEImage.ContainsVA(VA: TVA): boolean;
begin
  Result := (VA >= ImageBase) and ContainsRVA(VAToRVA(VA));
end;

destructor TPEImage.Destroy;
begin
  FPEMemoryStream.Free;
  FResourceTree.Free;
  FTLS.Free;
  FExports.Free;
  FImports.Free;
  FImportsDelayed.Free;
  FRelocs.Free;
  FSections.Free;
  FDataDirectories.Free;
  FCOFF.Free;
  inherited Destroy;
end;

procedure TPEImage.DoReadError;
begin
  raise Exception.Create('Read Error.');
end;

function TPEImage.SaveRegionToStream(AStream: TStream; RVA: TRVA; Size: uint32): uint32;
const
  BUFSIZE = 8192;
var
  Sec: TPESection;
  Ofs, TmpSize: uint32;
  pCur: PByte;
begin
  if not RVAToSec(RVA, @Sec) then
    exit(0);

  Ofs := RVA - Sec.RVA; // offset to read from

  // If end position is over section end then override size to read until end
  // of section.
  if Ofs + Size > Sec.GetAllocatedSize then
    Size := Sec.GetAllocatedSize - Ofs;

  Result := Size;

  if Assigned(AStream) then
  begin
    pCur := Sec.Mem + Ofs; // memory to read from

    while Size <> 0 do
    begin
      if Size >= BUFSIZE then
        TmpSize := BUFSIZE
      else
        TmpSize := Size;
      AStream.Write(pCur^, TmpSize);
      inc(pCur, TmpSize);
      dec(Size, TmpSize);
    end;
  end;
end;

function TPEImage.SaveRegionToFile(const AFileName: string; RVA: TRVA; Size: uint32): uint32;
var
  fs: TFileStream;
begin
  fs := TFileStream.Create(AFileName, fmCreate);
  try
    Result := SaveRegionToStream(fs, RVA, Size);
  finally
    fs.Free;
  end;
end;

function TPEImage.LoadRegionFromStream(AStream: TStream; Offset: UInt64; RVA: TRVA; Size: uint32; ReadSize: PUInt32): boolean;
var
  Sec: TPESection;
  p: PByte;
  ActualSize: uint32;
begin
  if Size = 0 then
    exit(true);
  if Offset >= AStream.Size then
    exit(false);
  if (Offset + Size) > AStream.Size then
    Size := AStream.Size - Offset;
  if not RVAToSec(RVA, @Sec) then
    exit(false);
  if (RVA + Size) > Sec.GetEndRVA then
    Size := Sec.GetEndRVA - RVA;

  AStream.Position := Offset;

  p := Sec.Mem + (RVA - Sec.RVA);
  ActualSize := AStream.Read(p^, Size);

  if Assigned(ReadSize) then
    ReadSize^ := ActualSize;

  exit(true);
end;

function TPEImage.LoadRegionFromFile(const AFileName: string; Offset: UInt64; RVA: TRVA; Size: uint32; ReadSize: PUInt32): boolean;
var
  fs: TFileStream;
begin
  fs := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
  try
    Result := LoadRegionFromStream(fs, Offset, RVA, Size, ReadSize);
  finally
    fs.Free;
  end;
end;

procedure TPEImage.InitParsers;
begin
  FParsers[PF_EXPORT] := TPEExportParser;
  FParsers[PF_IMPORT] := TPEImportParser;
  FParsers[PF_IMPORT_DELAYED] := TPEImportDelayedParser;
  FParsers[PF_RELOCS] := TPERelocParser;
  FParsers[PF_TLS] := TPETLSParser;
  FParsers[PF_RESOURCES] := TPEResourcesParser;
end;

function TPEImage.CalcHeadersSizeNotAligned: uint32;
begin
  Result := CalcSecHdrEndOfs;
end;

procedure TPEImage.FixSizeOfHeaders;
begin
  FOptionalHeader.SizeOfHeaders :=
    AlignUp(CalcHeadersSizeNotAligned, FileAlignment);
end;

function TPEImage.CalcVirtualSizeOfImage: UInt64;
begin
  with FSections do
  begin
    if Count <> 0 then
      Result := AlignUp(Last.RVA + Last.VirtualSize, SectionAlignment)
    else
      Result := AlignUp(CalcHeadersSizeNotAligned, SectionAlignment);
  end;
end;

function TPEImage.CalcRawSizeOfImage: UInt64;
var
  Last: TPESection;
begin
  Last := GetLastSectionWithValidRawData;
  if (Last <> nil) then
    Result := Last.GetEndRawOffset
  else
    Result := 0;
end;

procedure TPEImage.FixSizeOfImage;
begin
  SizeOfImage := CalcVirtualSizeOfImage;
end;

function TPEImage.CalcSecHdrOfs: TFileOffset;
var
  SizeOfPureOptionalHeader: uint32;
begin
  SizeOfPureOptionalHeader := CalcSizeOfPureOptionalHeader();
  Result :=
    FLFANew +
    4 +
    SizeOf(TImageFileHeader) +
    SizeOfPureOptionalHeader +
    FDataDirectories.Count * SizeOf(TImageDataDirectory);
end;

function TPEImage.CalcSecHdrEndOfs: TFileOffset;
begin
  Result := CalcSecHdrOfs + FSections.Count * SizeOf(TImageSectionHeader);
end;

function TPEImage.CalcSizeOfPureOptionalHeader: uint32;
begin
  Result := FOptionalHeader.CalcSize(ImageBits);
end;

function TPEImage.GetFileHeader: PImageFileHeader;
begin
  Result := @self.FFileHeader;
end;

function TPEImage.LoadSectionHeaders(AStream: TStream): boolean;
var
  Sec: TPESection;
  i: integer;
  sh: TImageSectionHeader;
  NumberOfSections: UInt16;
  SizeOfHeader, SizeOfHeaderMapped: uint32;
  HeaderList: TList<TImageSectionHeader>;
  VSizeToBeMapped: uint32;
  CorrectRawDataPositions: integer;
  StreamSize: UInt64;
  SecNameOldHex: string;
begin
  NumberOfSections := FFileHeader.NumberOfSections;

  // Header comes from offset: 0 to SizeOfHeader
  SizeOfHeader := CalcHeadersSizeNotAligned;
  SizeOfHeaderMapped := AlignUp(SizeOfHeader, VM_PAGE_SIZE);

  FSections.Clear; // it clears FFileHeader.NumberOfSections

  if NumberOfSections = 0 then
  begin
    Msg.Write(SCategorySections, 'There are no sections in the image');
    exit(true);
  end;

  HeaderList := TList<TImageSectionHeader>.Create;
  try
    // -------------------------------------------------------------------------
    // Load section headers.
    CorrectRawDataPositions := 0;
    StreamSize := AStream.Size;
    for i := 1 to NumberOfSections do
    begin
      if not StreamRead(AStream, sh, SizeOf(sh)) then
        break;

      if (sh.SizeOfRawData = 0) or (sh.PointerToRawData < AStream.Size) then
      begin
        inc(CorrectRawDataPositions);
        HeaderList.Add(sh);
      end
      else
        Msg.Write(SCategorySections, 'Raw data is outside of stream (0x%x>0x%x). Skipped.', [sh.PointerToRawData, StreamSize]);
    end;

    if CorrectRawDataPositions = 0 then
    begin
      Msg.Write(SCategorySections, 'No good raw data positions found.');
      exit(false);
    end
    else if CorrectRawDataPositions <> NumberOfSections then
    begin
      Msg.Write(SCategorySections, '%d of %d sections contain correct raw data positions.', [CorrectRawDataPositions, NumberOfSections]);
    end;

    // -------------------------------------------------------------------------
    // Check section count.
    if HeaderList.Count <> NumberOfSections then
      FMsg.Write(SCategorySections, 'Found %d of %d section headers.', [HeaderList.Count, NumberOfSections]);

    // -------------------------------------------------------------------------
    for i := 0 to HeaderList.Count - 1 do
    begin
      sh := HeaderList[i];

      if sh.SizeOfRawData <> 0 then
      begin
        // If section data points into header.
        if (sh.PointerToRawData < SizeOfHeader) then
        begin
          Msg.Write(SCategorySections, 'Section # %d is inside of headers', [i]);

          // Headers are always loaded at image base with
          // RawSize = SizeOfHeaders
          // VirtualSize = SizeOfHeaderMapped

          // Override section header.
          sh.PointerToRawData := 0;
          sh.SizeOfRawData := Min(sh.SizeOfRawData, FFileSize, SizeOfHeaderMapped);
          sh.VirtualSize := SizeOfHeaderMapped;
        end;
      end;

      if (sh.VirtualSize = 0) and (sh.SizeOfRawData = 0) then
      begin
        Msg.Write(SCategorySections, 'Section # %d has vsize and rsize = 0, skipping it', [i]);
        continue;
      end;

      if (sh.SizeOfRawData > sh.VirtualSize) then
      begin
        // Correct virtual size to be sure all raw data will be loaded.
        VSizeToBeMapped := AlignUp(sh.VirtualSize, VM_PAGE_SIZE);
        sh.VirtualSize := PE.Utils.Min(sh.SizeOfRawData, VSizeToBeMapped);
      end;

      {
        * Raw size can be 0
        * Virtual size can't be 0 as it won't be mapped
      }

      if sh.VirtualSize = 0 then
      begin
        Msg.Write(SCategorySections, 'Section # %d has vsize = 0', [i]);
        if PO_SECTION_VSIZE_FALLBACK in FOptions then
        begin
          sh.VirtualSize := AlignUp(sh.SizeOfRawData, SectionAlignment);
        end
        else
        begin
          Msg.Write(SCategorySections, 'Option to fallback to RSize isn''t included, skipping');
          continue;
        end;
      end;

      Sec := TPESection.Create(sh, nil, @FMsg);

      if Sec.Name.IsEmpty or (not IsAlphaNumericString(Sec.Name)) then
      begin
        if PO_SECTION_AUTORENAME_NON_ALPHANUMERIC in FOptions then
        begin
          SecNameOldHex := Sec.NameAsHex;
          Sec.Name := format('sec_%4.4x', [i]);
          Msg.Write(SCategorySections, 'Section name can be garbage (hex: %s). Overriding to %s', [SecNameOldHex, Sec.Name]);
        end;
      end;

      FSections.Add(Sec); // changes FFileHeader.NumberOfSections
    end;
  finally
    HeaderList.Free;
  end;

  exit(true);
end;

function TPEImage.LoadSectionData(AStream: TStream): UInt16;
var
  i: integer;
  Sec: TPESection;
begin
  Result := 0;
  // todo: check if section overlaps existing sections.
  for i := 0 to FSections.Count - 1 do
  begin
    Sec := FSections[i];

    // Process only normal sections.
    // Section like "image header" is skipped.
    if Sec.ClassType = TPESection then
    begin
      if FImageKind = PEIMAGE_KIND_DISK then
      begin
        if Sec.LoadDataFromStream(AStream) then
          inc(Result);
      end
      else
      begin
        if Sec.LoadDataFromStreamEx(AStream, Sec.RVA, Sec.VirtualSize) then
          inc(Result);
      end;
    end;
  end;
end;

procedure TPEImage.ResolveSectionNames;
var
  StringOfs, err: integer;
  Sec: TPESection;
  t: string;
begin
  for Sec in FSections do
  begin
    if Sec.Name.StartsWith('/') then
    begin
      val(Sec.Name.Substring(1), StringOfs, err);
      if (err = 0) and (FCOFF.GetString(StringOfs, t)) and (not t.IsEmpty) then
        Sec.Name := t; // long name from COFF strings
    end;
  end;
end;

function TPEImage.Is32bit: boolean;
begin
  Result := FOptionalHeader.Magic = PE_MAGIC_PE32;
end;

function TPEImage.Is64bit: boolean;
begin
  Result := FOptionalHeader.Magic = PE_MAGIC_PE32PLUS;
end;

class function TPEImage.IsPE(const FileName: string): boolean;
var
  Stream: TFileStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    Result := TPEImage.IsPE(Stream);
  finally
    Stream.Free;
  end;
end;

class function TPEImage.IsPE(AStream: TStream; Ofs: UInt64): boolean;
var
  dos: TImageDOSHeader;
  peSig: TNTSignature;
begin
  if not StreamSeek(AStream, Ofs) then
    exit(false);

  if StreamRead(AStream, dos, SizeOf(dos)) then
    if dos.e_magic.IsMZ then
    begin
      Ofs := Ofs + dos.e_lfanew;
      if Ofs >= AStream.Size then
        exit(false);
      if StreamSeek(AStream, Ofs) then
        if StreamRead(AStream, peSig, SizeOf(peSig)) then
          exit(peSig.IsPE00);
    end;
  exit(false);
end;

function TPEImage.GetImageBits: UInt16;
begin
  Result := FImageBitSize;
end;

function TPEImage.GetImageDOSHeader: PImageDOSHeader;
begin
  Result := @self.FDosHeader;
end;

procedure TPEImage.SetImageBits(Value: UInt16);
begin
  case Value of
    32:
      FOptionalHeader.Magic := PE_MAGIC_PE32;
    64:
      FOptionalHeader.Magic := PE_MAGIC_PE32PLUS;
  else
    begin
      FOptionalHeader.Magic := 0;
      raise Exception.Create('Value unsupported.');
    end;
  end;
  FImageBitSize := Value;
  FImageWordSize := Value div 8;
end;

procedure TPEImage.SetPositionRVA(const Value: TRVA);
begin
  if not SeekRVA(Value) then
    raise Exception.CreateFmt('Invalid RVA position (0x%x)', [Value]);
end;

procedure TPEImage.SetPositionVA(const Value: TVA);
begin
  SetPositionRVA(VAToRVA(Value));
end;

function TPEImage.GetPositionVA: TVA;
begin
  Result := RVAToVA(FPositionRVA);
end;

function TPEImage.GetIsDll: boolean;
begin
  Result := (FFileHeader.Characteristics and IMAGE_FILE_DLL) <> 0;
end;

procedure TPEImage.SetIsDll(const Value: boolean);
begin
  if Value then
    FFileHeader.Characteristics := FFileHeader.Characteristics or IMAGE_FILE_DLL
  else
    FFileHeader.Characteristics := FFileHeader.Characteristics and (not IMAGE_FILE_DLL);
end;

function TPEImage.FileAlignmentGet: uint32;
begin
  Result := FOptionalHeader.FileAlignment;
end;

procedure TPEImage.FileAlignmentSet(const Value: uint32);
begin
  FOptionalHeader.FileAlignment := Value;
end;

function TPEImage.SectionAlignmentGet: uint32;
begin
  Result := FOptionalHeader.SectionAlignment;
end;

procedure TPEImage.SectionAlignmentSet(const Value: uint32);
begin
  FOptionalHeader.SectionAlignment := Value;
end;

function TPEImage.SeekRVA(RVA: TRVA): boolean;
begin
  // Section.
  if not RVAToSec(RVA, @FCurrentSec) then
    exit(false);

  // RVA/Offset.
  FPositionRVA := RVA;
  FCurrentOfs := FPositionRVA - FCurrentSec.RVA;

  exit(true);
end;

function TPEImage.SeekVA(VA: TVA): boolean;
begin
  Result := (VA >= ImageBase) and SeekRVA(VAToRVA(VA));
end;

procedure TPEImage.Skip(Count: integer);
begin
  inc(FPositionRVA, Count);
end;

procedure TPEImage.SourceStreamFree(Stream: TStream);
begin
  if FImageKind = PEIMAGE_KIND_DISK then
    Stream.Free;
end;

function TPEImage.SourceStreamGet(Mode: word): TStream;
begin
  if FImageKind = PEIMAGE_KIND_DISK then
    Result := TFileStream.Create(FFileName, Mode)
  else
    Result := FPEMemoryStream;
end;

function TPEImage.ReadWord(WordSize: byte): UInt64;
begin
  if not ReadWordEx(WordSize, @Result) then
    raise Exception.Create('Read error');
end;

function TPEImage.ReadWordEx(WordSize: byte; OutValue: PUInt64): boolean;
var
  tmp: UInt64;
begin
  case WordSize of
    0:
      WordSize := FImageWordSize;
    1, 2, 4, 8:
      ; // allowed size
  else
    raise Exception.Create('Unsupported word size for ReadWord');
  end;

  tmp := 0;
  Result := ReadEx(tmp, WordSize);

  if Assigned(OutValue) then
    OutValue^ := tmp;
end;

procedure TPEImage.RegionRemove(RVA: TRVA; Size: uint32);
begin
  // Currently it's just placeholder.
  // Mark memory as free.
  FSections.FillMemory(RVA, Size, $CC);
end;

function TPEImage.RegionExistsRaw(RVA: TRVA; RawSize: uint32): boolean;
var
  Sec: TPESection;
  Ofs: uint32;
begin
  if not RVAToSec(RVA, @Sec) then
    exit(false);
  Ofs := RVA - Sec.RVA;
  Result := Ofs + RawSize <= Sec.RawSize;
end;

function TPEImage.RegionExistsVirtual(RVA: TRVA; VirtSize: uint32): boolean;
var
  Sec: TPESection;
  Ofs: uint32;
begin
  if not RVAToSec(RVA, @Sec) then
    exit(false);
  Ofs := RVA - Sec.RVA;
  Result := Ofs + VirtSize <= Sec.VirtualSize;
end;

function TPEImage.ReadWrite(Buffer: Pointer; Count: cardinal; Read: boolean): uint32;
begin
  // If count is 0 or no valid position was set we cannot do anything.
  if (Count = 0) or (not Assigned(FCurrentSec)) then
    exit(0);

  // Check how many bytes we can process.
  Result := Min(Count, FCurrentSec.AllocatedSize - FCurrentOfs);
  if Result = 0 then
    exit;

  if Assigned(Buffer) then
  begin
    if Read then
      Move(FCurrentSec.Mem[FCurrentOfs], Buffer^, Result)
    else
      Move(Buffer^, FCurrentSec.Mem[FCurrentOfs], Result);
  end;

  // Move next.
  inc(FPositionRVA, Result);
  inc(FCurrentOfs, Result);
end;

function TPEImage.Read(Buffer: Pointer; Count: cardinal): uint32;
begin
  Result := ReadWrite(Buffer, Count, true);
end;

function TPEImage.Read(var Buffer; Count: cardinal): uint32;
begin
  Result := Read(@Buffer, Count);
end;

function TPEImage.ReadEx(Buffer: Pointer; Count: cardinal): boolean;
begin
  Result := Read(Buffer, Count) = Count;
end;

function TPEImage.ReadEx(var Buffer; Size: cardinal): boolean;
begin
  Result := ReadEx(@Buffer, Size);
end;

function TPEImage.ReadAnsiString: string;
var
  Len: integer;
begin
  if not ReadAnsiStringLen(0, Len, Result) then
    Result := '';
end;

function TPEImage.ReadAnsiStringLen(MaxLen: integer; out Len: integer; out Str: string): boolean;
var
  available: uint32;
  pBegin, pCur, pEnd: PAnsiChar;
begin
  Len := 0;
  Str := '';
  Result := false;

  if not Assigned(FCurrentSec) then
    exit;

  available := FCurrentSec.AllocatedSize - FCurrentOfs;

  if (MaxLen <> 0) and (MaxLen < available) then
    available := MaxLen;

  pBegin := @FCurrentSec.Mem[FCurrentOfs];
  pCur := pBegin;
  pEnd := pBegin + available;
  while pCur < pEnd do
  begin
    if pCur^ = #0 then
    begin
      Result := true;
      break;
    end;
    inc(pCur);
  end;

  Len := pCur - pBegin;

  if Result then
  begin
    // String.
    Str := string(pBegin);

    // Include null at end.
    inc(Len);

    // Move current position.
    inc(FPositionRVA, Len);
    inc(FCurrentOfs, Len);
  end;
end;

function TPEImage.ReadUnicodeStringLenPfx2: string;
var
  Size: uint32;
  Bytes: TBytes;
begin
  // Check if there is at least 2 bytes for length.
  if Assigned(FCurrentSec) and (FCurrentOfs + 2 <= FCurrentSec.AllocatedSize) then
  begin
    Size := ReadUInt16 * 2;
    if Size <> 0 then
    begin
      // Check if there is enough space to read string.
      if FCurrentOfs + Size <= FCurrentSec.AllocatedSize then
      begin
        SetLength(Bytes, Size);
        Read(Bytes[0], Size);
        Result := TEncoding.Unicode.GetString(Bytes);
        exit;
      end;
    end;
  end;
  exit('');
end;

function TPEImage.ReadUInt8: UInt8;
begin
  if not ReadUInt8(@Result) then
    DoReadError;
end;

function TPEImage.ReadUInt16: UInt16;
begin
  if not ReadUInt16(@Result) then
    DoReadError;
end;

function TPEImage.ReadUInt32: uint32;
begin
  if not ReadUInt32(@Result) then
    DoReadError;
end;

function TPEImage.ReadUInt64: UInt64;
begin
  if not ReadUInt64(@Result) then
    DoReadError;
end;

function TPEImage.ReadUIntPE: UInt64;
begin
  if not ReadUIntPE(@Result) then
    DoReadError;
end;

function TPEImage.ReadUInt8(OutData: PUInt8): boolean;
begin
  Result := ReadEx(OutData, 1);
end;

function TPEImage.ReadUInt16(OutData: PUInt16): boolean;
begin
  Result := ReadEx(OutData, 2);
end;

function TPEImage.ReadUInt32(OutData: PUInt32): boolean;
begin
  Result := ReadEx(OutData, 4);
end;

function TPEImage.ReadUInt64(OutData: PUInt64): boolean;
begin
  Result := ReadEx(OutData, 8);
end;

function TPEImage.ReadUIntPE(OutData: PUInt64): boolean;
begin
  if OutData <> nil then
    OutData^ := 0;

  case ImageBits of
    32:
      Result := ReadEx(OutData, 4);
    64:
      Result := ReadEx(OutData, 8);
  else
    begin
      DoReadError;
      Result := false; // compiler friendly
    end;
  end;
end;

function TPEImage.Write(Buffer: Pointer; Count: cardinal): uint32;
begin
  Result := ReadWrite(Buffer, Count, false);
end;

function TPEImage.Write(const Buffer; Count: cardinal): uint32;
begin
  Result := Write(@Buffer, Count);
end;

function TPEImage.WriteEx(Buffer: Pointer; Count: cardinal): boolean;
begin
  Result := Write(Buffer, Count) = Count;
end;

function TPEImage.WriteEx(const Buffer; Count: cardinal): boolean;
begin
  Result := Write(@Buffer, Count) = Count;
end;

function TPEImage.RVAToMem(RVA: TRVA): Pointer;
var
  Ofs: integer;
  s: TPESection;
begin
  if RVAToSec(RVA, @s) and (s.Mem <> nil) then
  begin
    Ofs := RVA - s.RVA;
    exit(@s.Mem[Ofs]);
  end;
  exit(nil);
end;

function TPEImage.RVAExists(RVA: TRVA): boolean;
begin
  Result := RVAToSec(RVA, nil);
end;

function TPEImage.RVAToOfs(RVA: TRVA; OutOfs: PDword): boolean;
begin
  Result := FSections.RVAToOfs(RVA, OutOfs);
end;

function TPEImage.RVAToSec(RVA: TRVA; OutSec: PPESection): boolean;
begin
  Result := FSections.RVAToSec(RVA, OutSec);
end;

function TPEImage.RVAToVA(RVA: TRVA): UInt64;
begin
  Result := RVA + FOptionalHeader.ImageBase;
end;

function TPEImage.VAExists(VA: TRVA): boolean;
begin
  Result := (VA >= ImageBase) and RVAToSec(VAToRVA(VA), nil);
end;

function TPEImage.VAToMem(VA: TVA): Pointer;
begin
  Result := RVAToMem(VAToRVA(VA));
end;

function TPEImage.VAToOfs(VA: TVA; OutOfs: PDword): boolean;
begin
  Result := (VA >= ImageBase) and RVAToOfs(VAToRVA(VA), OutOfs);
end;

function TPEImage.VAToSec(VA: TRVA; OutSec: PPESection): boolean;
begin
  Result := (VA >= ImageBase) and RVAToSec(VAToRVA(VA), OutSec);
end;

function TPEImage.VAToRVA(VA: TVA): TRVA;
begin
  if VA >= FOptionalHeader.ImageBase then
    Result := VA - FOptionalHeader.ImageBase
  else
    raise Exception.Create('VAToRVA: VA argument must be >= ImageBase.');
end;

function TPEImage.LoadFromFile(const AFileName: string;
  AParseStages: TParserFlags): boolean;
var
  fs: TFileStream;
begin
  if not FileExists(AFileName) then
  begin
    FMsg.Write(SCategoryLoadFromFile, 'File not found.');
    exit(false);
  end;

  fs := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
  try
    FFileName := AFileName;
    fs.Position := 0;
    Result := LoadFromStream(fs, AParseStages);
  finally
    fs.Free;
  end;
end;

function TPEImage.LoadFromMappedImage(const AFileName: string;
  AParseStages: TParserFlags): boolean;
begin
  FPEMemoryStream := TPEMemoryStream.Create(AFileName);
  Result := LoadFromStream(FPEMemoryStream, AParseStages, PEIMAGE_KIND_MEMORY);
end;

function TPEImage.LoadFromMappedImage(ModuleBase: NativeUInt;
  AParseStages: TParserFlags): boolean;
begin
  FPEMemoryStream := TPEMemoryStream.Create(ModuleBase);
  Result := LoadFromStream(FPEMemoryStream, AParseStages, PEIMAGE_KIND_MEMORY);
end;

function TPEImage.LoadFromProcessImage(ProcessId: DWORD; Address: NativeUInt;
  AParseStages: TParserFlags): boolean;
var
  Stream: TProcessModuleStream;
begin
  Stream := TProcessModuleStream.CreateFromPidAndAddress(ProcessId, Address);
  try
    Result := LoadFromStream(Stream, AParseStages, PEIMAGE_KIND_MEMORY);
  finally
    Stream.Free;
  end;
end;

function TPEImage.LoadFromStream(AStream: TStream; AParseStages: TParserFlags;
  ImageKind: TPEImageKind): boolean;
const
  PE_HEADER_ALIGN = 4;
var
  OptHdrOfs, DataDirOfs, SecHdrOfs, SecHdrEndOfs, SecDataOfs: TFileOffset;
  SecHdrGapSize: integer;
  OptHdrSizeRead: int32; // w/o directories
  Stage: TParserFlag;
  Parser: TPEParser;
  Signature: TNTSignature;
  DOSBlockSize: uint32;
begin
  Result := false;

  FImageKind := ImageKind;
  FFileSize := AStream.Size;
  FParseStages := AParseStages;

  // DOS header.
  if not LoadDosHeader(AStream, FDosHeader) then
  begin
    Msg.Write(SCategoryDOSHeader, 'No DOS header found.');
    exit;
  end;

  if (FDosHeader.e_lfanew = 0) then
  begin
    Msg.Write(SCategoryDOSHeader, 'This is probably 16-bit executable.');
    exit;
  end;

  // Check PE ofs < 256 MB (see RtlImageNtHeaderEx)
  if (FDosHeader.e_lfanew >= 256 * 1024 * 1024) then
  begin
    Msg.Write(SCategoryDOSHeader, 'e_lfanew >= 256 MB');
    exit;
  end;

  if (FDosHeader.e_lfanew mod PE_HEADER_ALIGN) <> 0 then
  begin
    Msg.Write(SCategoryDOSHeader, 'PE header is not properly aligned.');
    exit;
  end;

  if (FDosHeader.e_lfanew < SizeOf(TImageDOSHeader)) then
  begin
    Msg.Write(SCategoryDOSHeader, 'e_lfanew points into itself (0x%x)', [FDosHeader.e_lfanew]);
  end;

  // Check if e_lfanew is ok
  if not StreamSeek(AStream, FDosHeader.e_lfanew) then
    exit; // e_lfanew is wrong

  // @ e_lfanew

  // Store offset of NT headers.
  FLFANew := FDosHeader.e_lfanew;

  // Read DOS Block
  self.FDosBlock := nil;
  if FDosHeader.e_lfanew > SizeOf(FDosHeader) then
  begin
    DOSBlockSize := FDosHeader.e_lfanew - SizeOf(FDosHeader);
    SetLength(self.FDosBlock, DOSBlockSize);
    if (DOSBlockSize <> 0) then
      if StreamSeek(AStream, SizeOf(FDosHeader)) then
      begin
        if not StreamRead(AStream, self.FDosBlock[0], DOSBlockSize) then
          SetLength(self.FDosBlock, 0);
      end;
  end;

  // Go back to new header.
  if not StreamSeek(AStream, FDosHeader.e_lfanew) then
    exit; // e_lfanew is wrong

  // Load signature.
  if not StreamRead(AStream, Signature, SizeOf(Signature)) then
    exit;

  // Check signature.
  if not Signature.IsPE00 then
    exit; // not PE file

  // Load File Header.
  if not LoadFileHeader(AStream, FFileHeader) then
    exit; // File Header failed.

  // Get offsets of Optional Header and Section Headers.
  OptHdrOfs := AStream.Position;
  SecHdrOfs := OptHdrOfs + FFileHeader.SizeOfOptionalHeader;
  SecHdrEndOfs := SecHdrOfs + SizeOf(TImageSectionHeader) * FFileHeader.NumberOfSections;

  // Read opt.hdr. magic to know if image is 32 or 64 bit.
  AStream.Position := OptHdrOfs;
  if not StreamPeek(AStream, FOptionalHeader.Magic, SizeOf(FOptionalHeader.Magic)) then
    exit;

  // Set some helper fields.
  case FOptionalHeader.Magic of
    PE_MAGIC_PE32:
      begin
        FImageBitSize := 32;
        FImageWordSize := 4;
      end;
    PE_MAGIC_PE32PLUS:
      begin
        FImageBitSize := 64;
        FImageWordSize := 8;
      end
  else
    raise Exception.Create('Image type is unknown.');
  end;

  // Safe read optional header.
  OptHdrSizeRead := FOptionalHeader.ReadFromStream(AStream, FImageBitSize, -1);

  // Can't read more bytes then available.
  if OptHdrSizeRead > FFileHeader.SizeOfOptionalHeader then
    raise Exception.Create('Read size of opt. header > FileHeader.SizeOfOptionalHeader');

  DataDirOfs := AStream.Position;

  // Load Section Headers.
  AStream.Position := SecHdrOfs;
  if not LoadSectionHeaders(AStream) then
    exit;

  // Add header as a section.
  // LoadingAddHeaderAsASection(AStream);

  // Read data directories.
  if OptHdrSizeRead <> 0 then
  begin
    AStream.Position := DataDirOfs;

    FDataDirectories.LoadDirectoriesFromStream(AStream, Msg,
      FOptionalHeader.NumberOfRvaAndSizes,              // declared count
      FFileHeader.SizeOfOptionalHeader - OptHdrSizeRead // bytes left in optional header
      );
  end;

  // Mapped image can't have overlay, so correct total size.
  if FImageKind = PEIMAGE_KIND_MEMORY then
    FFileSize := CalcRawSizeOfImage;

  // Read COFF.
  FCOFF.LoadFromStream(AStream);

  // Convert /%num% section names to long names if possible.
  ResolveSectionNames;

  // Read Gap after Section Header.
  if FSections.Count <> 0 then
  begin
    SecDataOfs := FSections.First.RawOffset;
    if SecDataOfs >= SecHdrEndOfs then
    begin
      SecHdrGapSize := SecDataOfs - SecHdrEndOfs;
      SetLength(self.FSecHdrGap, SecHdrGapSize);
      if SecHdrGapSize <> 0 then
      begin
        AStream.Position := SecHdrEndOfs;
        AStream.Read(self.FSecHdrGap[0], SecHdrGapSize);
      end;
    end;
  end;

  Result := true;

  // Load section data.
  LoadSectionData(AStream);

  // Now base headers loaded.
  // Define regions loaded before.

  // Execute parsers.
  if AParseStages <> [] then
  begin
    for Stage in AParseStages do
      if Assigned(FParsers[Stage]) then
      begin
        Parser := FParsers[Stage].Create(self);
        try
          case Parser.Parse of
            PR_ERROR:
              Msg.Write('[%s] Parser returned error.', [Parser.ToString]);
            PR_SUSPICIOUS:
              Msg.Write('[%s] Parser returned status SUSPICIOUS.',
                [Parser.ToString]);
          end;
        finally
          Parser.Free;
        end;
      end;
  end;
end;

procedure TPEImage.LoadingAddHeaderAsASection(Stream: TStream);
var
  sh: TImageSectionHeader;
  Sec: TPESection;
  oldPos: int64;
begin
  oldPos := Stream.Position;
  try
    sh.Clear;
    sh.Name := 'header';
    sh.SizeOfRawData := FOptionalHeader.SizeOfHeaders;
    sh.VirtualSize := AlignUp(FOptionalHeader.SizeOfHeaders, FOptionalHeader.SectionAlignment);

    Sec := TPESection(TPESectionImageHeader.Create(sh, nil));

    FSections.Insert(0, Sec);

    Stream.Position := 0;
    Stream.Read(Sec.Mem^, sh.SizeOfRawData);
  finally
    Stream.Position := oldPos;
  end;
end;

function TPEImage.SaveToStream(AStream: TStream): boolean;
begin
  Result := PE.Image.Saving.SaveImageToStream(self, AStream);
end;

function TPEImage.SaveToFile(const AFileName: string): boolean;
var
  fs: TFileStream;
begin
  fs := TFileStream.Create(AFileName, fmCreate);
  try
    Result := SaveToStream(fs);
  finally
    fs.Free;
  end;
end;

function TPEImage.GetOptionalHeader: PPEOptionalHeader;
begin
  Result := @self.FOptionalHeader;
end;

function TPEImage.GetOverlay: POverlay;
var
  lastSec: TPESection;
begin
  lastSec := GetLastSectionWithValidRawData;

  if (lastSec <> nil) then
  begin
    FOverlay.Offset := lastSec.GetEndRawOffset; // overlay offset

    // Check overlay offet present in file.
    if FOverlay.Offset < FFileSize then
    begin
      FOverlay.Size := FFileSize - FOverlay.Offset;
      exit(@FOverlay);
    end;
  end;

  exit(nil);
end;

function TPEImage.GetLastSectionWithValidRawData: TPESection;
var
  i: integer;
begin
  for i := FSections.Count - 1 downto 0 do
    if (FSections[i].RawOffset <> 0) and (FSections[i].RawSize <> 0) then
      exit(FSections[i]);
  exit(nil);
end;

function TPEImage.SaveOverlayToFile(const AFileName: string;
  Append: boolean = false): boolean;
var
  src, dst: TStream;
  ovr: POverlay;
begin
  Result := false;

  ovr := GetOverlay;
  if Assigned(ovr) then
  begin
    // If no overlay, we're done.
    if ovr^.Size = 0 then
      exit(true);
    try
      src := SourceStreamGet(fmOpenRead or fmShareDenyWrite);

      if Append and FileExists(AFileName) then
      begin
        dst := TFileStream.Create(AFileName, fmOpenReadWrite or fmShareDenyWrite);
        dst.Seek(0, soFromEnd);
      end
      else
        dst := TFileStream.Create(AFileName, fmCreate);

      try
        src.Seek(ovr^.Offset, TSeekOrigin.soBeginning);
        dst.CopyFrom(src, ovr^.Size);
        Result := true;
      finally
        SourceStreamFree(src);
        dst.Free;
      end;
    except
    end;
  end;
end;

function TPEImage.RemoveOverlay: boolean;
var
  ovr: POverlay;
  fs: TFileStream;
begin
  Result := false;

  if FImageKind = PEIMAGE_KIND_MEMORY then
  begin
    FMsg.Write('Can''t remove overlay from mapped image.');
    exit;
  end;

  ovr := GetOverlay;
  if (ovr <> nil) and (ovr^.Size <> 0) then
  begin
    try
      fs := TFileStream.Create(FFileName, fmOpenWrite or fmShareDenyWrite);
      try
        fs.Size := fs.Size - ovr^.Size; // Trim file.
        self.FFileSize := fs.Size;      // Update filesize.
        Result := true;
      finally
        fs.Free;
      end;
    except
    end;
  end;
end;

function TPEImage.LoadOverlayFromFile(const AFileName: string; Offset,
  Size: UInt64): boolean;
var
  ovr: POverlay;
  fs: TFileStream;
  src: TStream;
  newImgSize: uint32;
begin
  Result := false;

  if FImageKind = PEIMAGE_KIND_MEMORY then
  begin
    FMsg.Write('Can''t append overlay to mapped image.');
    exit;
  end;

  fs := TFileStream.Create(FFileName, fmOpenWrite or fmShareDenyWrite);
  src := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
  try
    if (Offset = 0) and (Size = 0) then
      Size := src.Size;
    if Size <> 0 then
    begin
      if (Offset + Size) > src.Size then
        exit(false);
      src.Position := Offset;

      ovr := GetOverlay;
      if (ovr <> nil) and (ovr^.Size <> 0) then
        fs.Size := fs.Size - ovr^.Size // Trim file.
      else
      begin
        newImgSize := CalcRawSizeOfImage();
        fs.Size := newImgSize;
      end;

      fs.Position := fs.Size;

      fs.CopyFrom(src, Size);

      self.FFileSize := fs.Size; // Update filesize.
    end;
    Result := true;
  finally
    src.Free;
    fs.Free;
  end;
end;

end.


text:
{
  Generic Key-Value Map class. Items are ordered by Key.
}

unit gmap;

interface

uses
  System.Generics.Collections,
  System.SysUtils,
  grbtree;

type
  TMap<TKey, TValue> = class(TEnumerable < TPair < TKey, TValue >> )
  public type
    TCompareLess = reference to function(const A, B: TKey): boolean;
  private const
    SKeyDoesNotExist = 'Key does not exist.';
  private type
    TItem = record
      Pair: TPair<TKey, TValue>;
      Owner: TMap<TKey, TValue>;
      constructor Create(const K: TKey; const V: TValue;
        const Owner: TMap<TKey, TValue>);
    end;

    TItemTree = TRBTree<TItem>;

    TPairEnumerator = class(TEnumerator < TPair < TKey, TValue >> )
    private
      FMap: TMap<TKey, TValue>;
      FNode: TItemTree.TRBNodePtr;
    protected
      function DoGetCurrent: TPair<TKey, TValue>; override;
      function DoMoveNext: boolean; override;
    public
      constructor Create(const Map: TMap<TKey, TValue>);
    end;

    TKeyEnumerator = class(TEnumerator<TKey>)
    private
      FPairEnum: TPairEnumerator;
    protected
      function DoGetCurrent: TKey; override;
      function DoMoveNext: boolean; override;
    public
      constructor Create(const Map: TMap<TKey, TValue>);
      destructor Destroy; override;
    end;

    TValueEnumerator = class(TEnumerator<TValue>)
    private
      FPairEnum: TPairEnumerator;
    protected
      function DoGetCurrent: TValue; override;
      function DoMoveNext: boolean; override;
    public
      constructor Create(const Map: TMap<TKey, TValue>);
      destructor Destroy; override;
    end;

    TKeyCollection = class(TEnumerable<TKey>)
    private
      FMap: TMap<TKey, TValue>;
    protected
      function DoGetEnumerator: TEnumerator<TKey>; override;
    public
      constructor Create(Map: TMap<TKey, TValue>);
    end;

    TValueCollection = class(TEnumerable<TValue>)
    private
      FMap: TMap<TKey, TValue>;
    protected
      function DoGetEnumerator: TEnumerator<TValue>; override;
    public
      constructor Create(Map: TMap<TKey, TValue>);
    end;

  private
    FKeyComparer: TCompareLess;
    FItems: TItemTree;
    FOnKeyNotify: TCollectionNotifyEvent<TKey>;
    FOnValueNotify: TCollectionNotifyEvent<TValue>;
    FKeyCollection: TKeyCollection;
    FValueCollection: TValueCollection;
    class function CompareItem(const A, B: TItem): boolean; static; inline;

    // Add new Key-Value pair or update existing Key with Value.
    procedure &Set(const Key: TKey; const Value: TValue);

    // Get Value by key.
    function Get(const Key: TKey): TValue;

    // Find node of item in RBTRree.
    function FindNodePtr(const Key: TKey): TItemTree.TRBNodePtr; inline;

    function GetCount: integer; inline;

    procedure ItemTreeNotify(Sender: TObject; const Item: TItem;
      Action: TCollectionNotification);

    function GetKeys: TKeyCollection;
    function GetValues: TValueCollection;
  protected
    function DoGetEnumerator: TEnumerator<TPair<TKey, TValue>>; override;
  public
    constructor Create(const Comparer: TCompareLess);
    destructor Destroy; override;

    // Add new item.
    procedure Add(const Key: TKey; const Value: TValue); inline;
    procedure Clear; inline;
    function ContainsKey(const Key: TKey): boolean; inline;
    function TryGetValue(const Key: TKey; out Value: TValue): boolean;
    function TryGetKeyAndValue(const Key: TKey; out OutKey: TKey; out OutValue: TValue): boolean;
    procedure Remove(const Key: TKey);

    function FirstKey: TKey; inline;
    function FirstValue: TValue; inline;

    function LastKey: TKey; inline;
    function LastValue: TValue; inline;

    property Items[const Key: TKey]: TValue read Get write &Set; default;
    property Keys: TKeyCollection read GetKeys;
    property Values: TValueCollection read GetValues;
    property Count: integer read GetCount;
    property OnKeyNotify: TCollectionNotifyEvent<TKey> read FOnKeyNotify write FOnKeyNotify;
    property OnValueNotify: TCollectionNotifyEvent<TValue> read FOnValueNotify write FOnValueNotify;
  end;

implementation

{ TMap<TKey, TValue> }

procedure TMap<TKey, TValue>.Add(const Key: TKey; const Value: TValue);
begin
  FItems.Add(TItem.Create(Key, Value, self));
end;

procedure TMap<TKey, TValue>.Clear;
begin
  FItems.Clear;
end;

class function TMap<TKey, TValue>.CompareItem(const A, B: TItem): boolean;
begin
  Result := A.Owner.FKeyComparer(A.Pair.Key, B.Pair.Key);
end;

constructor TMap<TKey, TValue>.Create(const Comparer: TCompareLess);
begin
  inherited Create;
  FKeyComparer := Comparer;
  FItems := TItemTree.Create(CompareItem);
  FItems.OnNotify := ItemTreeNotify;
end;

destructor TMap<TKey, TValue>.Destroy;
begin
  FKeyCollection.Free;
  FValueCollection.Free;
  FItems.Free;
  inherited;
end;

function TMap<TKey, TValue>.DoGetEnumerator: TEnumerator<TPair<TKey, TValue>>;
begin
  Result := TPairEnumerator.Create(self);
end;

function TMap<TKey, TValue>.FindNodePtr(const Key: TKey): TItemTree.TRBNodePtr;
begin
  Result := FItems.Find(TItem.Create(Key, Default (TValue), self));
end;

function TMap<TKey, TValue>.FirstKey: TKey;
begin
  Result := FItems.First.K.Pair.Key;
end;

function TMap<TKey, TValue>.FirstValue: TValue;
begin
  Result := FItems.First.K.Pair.Value;
end;

function TMap<TKey, TValue>.LastKey: TKey;
begin
  Result := FItems.Last.K.Pair.Key;
end;

function TMap<TKey, TValue>.LastValue: TValue;
begin
  Result := FItems.Last.K.Pair.Value;
end;

function TMap<TKey, TValue>.Get(const Key: TKey): TValue;
var
  Ptr: TItemTree.TRBNodePtr;
begin
  Ptr := FindNodePtr(Key);
  if Assigned(Ptr) then
    Result := Ptr^.K.Pair.Value
  else
    raise Exception.Create(SKeyDoesNotExist);
end;

function TMap<TKey, TValue>.GetCount: integer;
begin
  Result := FItems.Count;
end;

function TMap<TKey, TValue>.GetKeys: TKeyCollection;
begin
  if FKeyCollection = nil then
    FKeyCollection := TKeyCollection.Create(self);
  Result := FKeyCollection;
end;

function TMap<TKey, TValue>.GetValues: TValueCollection;
begin
  if FValueCollection = nil then
    FValueCollection := TValueCollection.Create(self);
  Result := FValueCollection;
end;

procedure TMap<TKey, TValue>.ItemTreeNotify(Sender: TObject; const Item: TItem;
  Action: TCollectionNotification);
begin
  if Assigned(FOnKeyNotify) then
    FOnKeyNotify(self, Item.Pair.Key, Action);
  if Assigned(FOnValueNotify) then
    FOnValueNotify(self, Item.Pair.Value, Action);
end;

procedure TMap<TKey, TValue>.Remove(const Key: TKey);
var
  Ptr: TItemTree.TRBNodePtr;
begin
  Ptr := FindNodePtr(Key);
  if Assigned(Ptr) then
    FItems.Delete(Ptr);
end;

procedure TMap<TKey, TValue>.&Set(const Key: TKey; const Value: TValue);
var
  Ptr: TItemTree.TRBNodePtr;
begin
  Ptr := FindNodePtr(Key);
  if Assigned(Ptr) then
    Ptr^.K.Pair.Value := Value
  else
    Add(Key, Value);
end;

function TMap<TKey, TValue>.ContainsKey(const Key: TKey): boolean;
begin
  Result := FindNodePtr(Key) <> nil;
end;

function TMap<TKey, TValue>.TryGetValue(const Key: TKey; out Value: TValue): boolean;
var
  Ptr: TItemTree.TRBNodePtr;
begin
  Ptr := FindNodePtr(Key);
  if Assigned(Ptr) then
  begin
    Value := Ptr^.K.Pair.Value;
    exit(true);
  end;
  Value := Default (TValue);
  exit(false);
end;

function TMap<TKey, TValue>.TryGetKeyAndValue(const Key: TKey; out OutKey: TKey; out OutValue: TValue): boolean;
var
  Ptr: TItemTree.TRBNodePtr;
begin
  Ptr := FindNodePtr(Key);
  if Assigned(Ptr) then
  begin
    OutKey := Ptr^.K.Pair.Key;
    OutValue := Ptr^.K.Pair.Value;
    exit(true);
  end;
  OutKey := Default (TKey);
  OutValue := Default (TValue);
  exit(false);
end;

{ TMap<TKey, TValue>.TItem }

constructor TMap<TKey, TValue>.TItem.Create(const K: TKey; const V: TValue;
  const Owner: TMap<TKey, TValue>);
begin
  self.Pair.Key := K;
  self.Pair.Value := V;
  self.Owner := Owner;
end;

{ TMap<TKey, TValue>.TPairEnumerator }

constructor TMap<TKey, TValue>.TPairEnumerator.Create(
  const Map: TMap<TKey, TValue>);
begin
  FMap := Map;
  FNode := nil;
end;

function TMap<TKey, TValue>.TPairEnumerator.DoGetCurrent: TPair<TKey, TValue>;
begin
  Result := FNode^.K.Pair;
end;

function TMap<TKey, TValue>.TPairEnumerator.DoMoveNext: boolean;
begin
  if FNode = nil then
  begin
    FNode := FMap.FItems.First;
    exit(FNode <> nil);
  end;
  Result := FMap.FItems.Next(FNode);
end;

{ TMap<TKey, TValue>.TKeyCollection }

constructor TMap<TKey, TValue>.TKeyCollection.Create(Map: TMap<TKey, TValue>);
begin
  FMap := Map;
end;

function TMap<TKey, TValue>.TKeyCollection.DoGetEnumerator: TEnumerator<TKey>;
begin
  Result := TKeyEnumerator.Create(FMap);
end;

{ TMap<TKey, TValue>.TValueCollection }

constructor TMap<TKey, TValue>.TValueCollection.Create(Map: TMap<TKey, TValue>);
begin
  FMap := Map;
end;

function TMap<TKey, TValue>.TValueCollection.DoGetEnumerator: TEnumerator<TValue>;
begin
  Result := TValueEnumerator.Create(FMap);
end;

{ TMap<TKey, TValue>.TKeyEnumerator }

constructor TMap<TKey, TValue>.TKeyEnumerator.Create(
  const Map: TMap<TKey, TValue>);
begin
  FPairEnum := TPairEnumerator.Create(Map);
end;

destructor TMap<TKey, TValue>.TKeyEnumerator.Destroy;
begin
  FPairEnum.Free;
  inherited;
end;

function TMap<TKey, TValue>.TKeyEnumerator.DoGetCurrent: TKey;
begin
  Result := FPairEnum.DoGetCurrent.Key;
end;

function TMap<TKey, TValue>.TKeyEnumerator.DoMoveNext: boolean;
begin
  Result := FPairEnum.DoMoveNext;
end;

{ TMap<TKey, TValue>.TValueEnumerator }

constructor TMap<TKey, TValue>.TValueEnumerator.Create(const Map: TMap<TKey, TValue>);
begin
  FPairEnum := TPairEnumerator.Create(Map);
end;

destructor TMap<TKey, TValue>.TValueEnumerator.Destroy;
begin
  FPairEnum.Free;
  inherited;
end;

function TMap<TKey, TValue>.TValueEnumerator.DoGetCurrent: TValue;
begin
  Result := FPairEnum.DoGetCurrent.Value;
end;

function TMap<TKey, TValue>.TValueEnumerator.DoMoveNext: boolean;
begin
  Result := FPairEnum.DoMoveNext;
end;

end.


text:
unit PE.Resources.Extract;

interface

uses
  PE.Common,
  PE.Resources;

// Extract raw resource data from Root node and save it to Dir folder.
// If Root is nil, the main root is taken.
// Result is number of resources extracted.
function ExtractRawResources(Img: TPEImageObject; const Dir: string;
  Root: TResourceTreeNode = nil): integer;

implementation

uses
  System.IOUtils,
  System.SysUtils,
  PE.Image;

type

  { TExtractor }

  TExtractor = class
  private
    FImg: TPEImage;
    FDir: string;
    FCount: integer;
    function Callback(Node: TResourceTreeNode): boolean;
  public
    function Extract(Img: TPEImage; const Dir: string; Root: TResourceTreeNode): integer;
  end;

function TExtractor.Callback(Node: TResourceTreeNode): boolean;
var
  Leaf: TResourceTreeLeafNode;
  FileName: string;
  Path: string;
begin
  if Node.IsLeaf then
  begin
    Leaf := Node as TResourceTreeLeafNode;
    // Make filename and path.
    FileName := Format('%s\%s', [FDir, Leaf.GetPath]);
    Path := ExtractFilePath(FileName);
    // Create path and save file.
    TDirectory.CreateDirectory(Path);
    Leaf.Data.SaveToFile(FileName);
    inc(FCount);
  end;
  Result := True; // continue
end;

function ExtractRawResources(Img: TPEImageObject; const Dir: string; Root: TResourceTreeNode = nil): integer;
var
  Extractor: TExtractor;
begin
  Extractor := TExtractor.Create;
  try
    Result := Extractor.Extract(Img as TPEImage,
      ExcludeTrailingPathDelimiter(Dir), Root);
  finally
    Extractor.Free;
  end;
end;

function TExtractor.Extract(Img: TPEImage; const Dir: string;
  Root: TResourceTreeNode): integer;
begin
  FImg := Img;
  FDir := Dir;
  FCount := 0;
  if Root = nil then
    Root := Img.ResourceTree.Root;
  if Root = nil then
    Exit(0);
  TDirectory.CreateDirectory(Dir);
  Img.ResourceTree.Root.Traverse(Callback);
  Exit(FCount);
end;

end.


text:
unit NullStream;

interface

uses
  System.Classes,
  System.SysUtils;

type
  TNullStream = class(TStream)
  private
    FPosition: int64;
    FSize: int64;
  protected
    procedure SetSize(NewSize: Integer); override;
  public
    function Seek(const Offset: int64; Origin: TSeekOrigin): int64; override;
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
  end;

implementation

{ TNullStream }

procedure TNullStream.SetSize(NewSize: Integer);
begin
  FSize := NewSize;
end;

function TNullStream.Seek(const Offset: int64; Origin: TSeekOrigin): int64;
begin
  case Origin of
    soBeginning:
      FPosition := Offset;
    soCurrent:
      Inc(FPosition, Offset);
    soEnd:
      FPosition := FSize + Offset;
  end;
  Result := FPosition;
end;

function TNullStream.Read(var Buffer; Count: Integer): Longint;
begin
  raise Exception.Create('Null stream cannot read');
end;

function TNullStream.Write(const Buffer; Count: Integer): Longint;
var
  pos: int64;
begin
  if (FPosition >= 0) and (Count >= 0) then
  begin
    pos := FPosition + Count;
    if pos > FSize then
      FSize := pos;
    FPosition := pos;
    exit(Count);
  end;
  exit(0);
end;

end.


text:
unit PE.RTTI;

interface

uses
  System.Classes;

type
  TRecordFieldDesc = record
    Flags: uint32;
    FieldName: PChar;
  end;

  PRecordFieldDesc = ^TRecordFieldDesc;

  // TRttiReadFunc must return:
  // - OutFieldSize: size of field.
  // - OutReadSize size to read into field.
  TRttiFieldResolveProc = procedure(Desc: PRecordFieldDesc;
    OutFieldSize, OutReadWriteSize: PInteger; ud: pointer);

  TRttiOperation = (RttiRead, RttiWrite, RttiCalcSize);

  // MaxSize: -1 means no limit.
function RTTI_Process(Stream: TStream; Op: TRttiOperation; Buf: PByte;
  FieldDesc: PRecordFieldDesc; FieldDescCnt: integer; MaxSize: integer;
  ResolveProc: TRttiFieldResolveProc; ud: pointer): uint32;

implementation

{$IFDEF DIAG}

uses
  System.SysUtils;

procedure DbgLogData(Desc: PRecordFieldDesc; Stream: TStream;
  FieldSize: integer; IOSize: integer);
begin
  writeln(Format('"%s" @ %x FieldSize: %x IOSize: %x',
    [Desc.FieldName, Stream.Position, FieldSize, IOSize]));
end;
{$ENDIF}

function RTTI_Process;
var
  i: integer;
  FieldSize, ReadWriteSize, tmp: integer;
begin
  Result := 0;

  if (Buf = nil) or (FieldDesc = nil) or (FieldDescCnt = 0) or (MaxSize = 0)
  then
    exit;

  for i := 0 to FieldDescCnt - 1 do
  begin
    ResolveProc(FieldDesc, @FieldSize, @ReadWriteSize, ud);

{$IFDEF DIAG}
    DbgLogData(FieldDesc, Stream, FieldSize, ReadWriteSize);
{$ENDIF}
    if ReadWriteSize <> 0 then
    begin
      case Op of
        RttiRead:
          begin
            if ReadWriteSize < FieldSize then
              FillChar(Buf^, FieldSize, 0);
            tmp := Stream.Read(Buf^, ReadWriteSize);
          end;
        RttiWrite:
          tmp := Stream.Write(Buf^, ReadWriteSize);
        RttiCalcSize:
          tmp := ReadWriteSize;
      else
        tmp := ReadWriteSize;
      end;

      if tmp <> ReadWriteSize then
        break; // read error
{$IFDEF DIAG}
      case tmp of
        1:
          writeln(Format('= %x', [PByte(Buf)^]));
        2:
          writeln(Format('= %x', [PWord(Buf)^]));
        4:
          writeln(Format('= %x', [PCardinal(Buf)^]));
        8:
          writeln(Format('= %x', [PUint64(Buf)^]));
      end;
{$ENDIF}
    end;

    inc(Result, ReadWriteSize);
    inc(Buf, FieldSize);
    inc(FieldDesc);

{$WARN COMPARING_SIGNED_UNSIGNED OFF}
    if (MaxSize <> -1) and (Result >= MaxSize) then
      break;
{$WARN COMPARING_SIGNED_UNSIGNED ON}
  end;

end;

end.