text:
unit PE.Build.Resource;

interface

uses
  System.Classes,
  PE.Build.Common,
  PE.Common,
  PE.Resources,
  PE.Types.Resources;

type
  TRsrcBuilder = class(TDirectoryBuilder)
  private
    // Sizes.
    FSizeOfResourceTables: UInt32;
    FSizeOfDataDesc: UInt32;
    FSizeOfNames: UInt32;
    FSizeOfData: UInt32;
    procedure ClearSizes; inline;
    function CalcSizesCallback(Node: TResourceTreeNode): boolean;
    procedure CalcSizes; inline;
  private
    // Offsets.
    FOfsTables: UInt32;
    FOfsDataDesc: UInt32;
    FOfsNames: UInt32;
    FOfsData: UInt32;
    FOfsEnd: UInt32;
    procedure CalcOffsets;
  private
    FBaseRVA: TRVA;
    FStream: TStream;
    // Write name. Result is position of written name.
    function WriteName(const Name: UnicodeString): UInt32;
    // Write table and update offsets. Result is offset where table was written.
    function WriteBranchNode(Root: TResourceTreeBranchNode): UInt32;
    // Write leaf data and return offset where it was written.
    function WriteLeafData(Node: TResourceTreeLeafNode): UInt32;
    // Write leaf node and return offset where it was written.
    function WriteLeafNode(Node: TResourceTreeLeafNode): UInt32;
  public
    procedure Build(DirRVA: TRVA; Stream: TStream); override;
    class function GetDefaultSectionFlags: Cardinal; override;
    class function GetDefaultSectionName: string; override;
    class function NeedRebuildingIfRVAChanged: boolean; override;
  end;

implementation

uses
  // Expand
  PE.Image,
  //
  PE.Utils;

procedure TRsrcBuilder.Build(DirRVA: TRVA; Stream: TStream);
var
  Root: TResourceTreeBranchNode;
begin
  FBaseRVA := DirRVA;
  CalcSizes;
  CalcOffsets;

  Root := FPE.ResourceTree.Root;

  // If there's no items at root exit.
  if Root.Children.Count = 0 then
    exit;

  // Setup stream.
  FStream := Stream;
  FStream.Size := FOfsEnd;
  // Build nodes starting from root.
  WriteBranchNode(Root);
end;

procedure TRsrcBuilder.CalcSizes;
begin
  ClearSizes;
  FPE.ResourceTree.Root.Traverse(CalcSizesCallback);
end;

function TRsrcBuilder.CalcSizesCallback(Node: TResourceTreeNode): boolean;
var
  Leaf: TResourceTreeLeafNode;
  Branch: TResourceTreeBranchNode;
begin
  if Node.IsLeaf then
  begin
    Leaf := Node as TResourceTreeLeafNode;
    inc(FSizeOfDataDesc, SizeOf(TResourceDataEntry));
    inc(FSizeOfData, Leaf.DataSize);
  end
  else
  begin
    Branch := Node as TResourceTreeBranchNode;
    inc(FSizeOfResourceTables, SizeOf(TResourceDirectoryTable));
    inc(FSizeOfResourceTables, SizeOf(TResourceDirectoryEntry) * Branch.Children.Count);
    if Branch.Name <> '' then
    begin
      inc(FSizeOfNames, 2 + SizeOf(WideChar) * Length(Branch.Name));
    end;
  end;
  Result := True;
end;

procedure TRsrcBuilder.ClearSizes;
begin
  FSizeOfResourceTables := 0;
  FSizeOfDataDesc := 0;
  FSizeOfNames := 0;
  FSizeOfData := 0;
end;

class function TRsrcBuilder.GetDefaultSectionFlags: Cardinal;
begin
  Result := $40000040; // readable + initialized data
end;

class function TRsrcBuilder.GetDefaultSectionName: string;
begin
  Result := '.rsrc';
end;

class function TRsrcBuilder.NeedRebuildingIfRVAChanged: boolean;
begin
  Result := True;
end;

function TRsrcBuilder.WriteLeafData(Node: TResourceTreeLeafNode): UInt32;
var
  Pos: UInt32;
begin
  Result := FOfsData;
  if Node.Data.Size <> 0 then
  begin
    Pos := FStream.Position;
    FStream.Position := FOfsData;
    Node.Data.Position := 0;
    FStream.CopyFrom(Node.Data, Node.Data.Size);
    inc(FOfsData, Node.Data.Size);
    FStream.Position := Pos;
  end;
end;

function TRsrcBuilder.WriteLeafNode(Node: TResourceTreeLeafNode): UInt32;
var
  DataEntry: TResourceDataEntry;
  Pos: UInt32;
begin
  Result := FOfsDataDesc;
  Pos := FStream.Position;
  FStream.Position := FOfsDataDesc; // store pos
  // Write data and make data desc.
  DataEntry.DataRVA := WriteLeafData(Node) + FBaseRVA;
  DataEntry.Size := Node.DataSize;
  DataEntry.Codepage := Node.Codepage;
  DataEntry.Reserved := 0;
  // Write data.
  FStream.Write(DataEntry, SizeOf(DataEntry));
  inc(FOfsDataDesc, SizeOf(DataEntry));
  FStream.Position := Pos; // restore pos
end;

function TRsrcBuilder.WriteBranchNode(Root: TResourceTreeBranchNode): UInt32;
type
  TSimpleEntry = packed record
    IdOrNameOfs: UInt32;
    ChildOfs: UInt32;
  end;

  PSimpleEntry = ^TSimpleEntry;
var
  Table: TResourceDirectoryTable;
  Node: TResourceTreeNode;
  Entries: array of TSimpleEntry;
  Entry: PSimpleEntry;
  Pos: UInt32;
begin
  if Root.Children.Count = 0 then
    exit(0);

  Pos := FStream.Position;

  Result := FOfsTables;

  // Prepare table.
  Table.Characteristics := Root.Characteristics;
  Table.TimeDateStamp := Root.TimeDateStamp;
  Table.MajorVersion := Root.MajorVersion;
  Table.MinorVersion := Root.MinorVersion;

  Table.NumberOfNameEntries := 0;
  Table.NumberOfIDEntries := 0;

  for Node in Root.Children do
    if Node.IsNamed then
      inc(Table.NumberOfNameEntries)
    else
      inc(Table.NumberOfIDEntries);

  // Write table.
  FStream.Position := FOfsTables;
  FStream.Write(Table, SizeOf(Table));
  // Update FOfsTables.
  inc(FOfsTables, SizeOf(TResourceDirectoryTable));
  inc(FOfsTables, SizeOf(TResourceDirectoryEntry) * Root.Children.Count);
  // Entries.

  // Prepare entries.
  SetLength(Entries, Root.Children.Count);
  Entry := @Entries[0];

  for Node in Root.Children do
  begin
    // Set Id or Name.
    if Node.IsNamed then
      Entry.IdOrNameOfs := WriteName(Node.Name) or $80000000 // Named
    else
      Entry.IdOrNameOfs := Node.Id; // ID
    // Set child offset.
    if Node.IsLeaf then
      Entry.ChildOfs := WriteLeafNode(TResourceTreeLeafNode(Node))
    else
      Entry.ChildOfs := WriteBranchNode(TResourceTreeBranchNode(Node)) or $80000000;
    // Next entry.
    inc(Entry);
  end;
  // Write entries.
  FStream.Write(Entries[0], Length(Entries) * SizeOf(Entries[0]));
  FStream.Position := Pos; // resotre pos
end;

function TRsrcBuilder.WriteName(const Name: UnicodeString): UInt32;
var
  Len: word;
  Pos: UInt32;
begin
  // Align offset up 2 bytes.
  if (FOfsNames mod 2) <> 0 then
    inc(FOfsNames);
  Pos := FStream.Position; // store pos
  Result := FOfsNames;
  FStream.Position := FOfsNames;
  Len := Length(Name);
  FStream.Write(Len, 2);
  FStream.Write(Name[1], Length(Name) * SizeOf(Name[1]));
  FOfsNames := FStream.Position;
  FStream.Position := Pos; // restore pos
end;

procedure TRsrcBuilder.CalcOffsets;
var
  MachineWord: Byte;
begin
  MachineWord := FPE.GetImageBits div 8;
  FOfsTables := 0;
  FOfsDataDesc := FOfsTables + FSizeOfResourceTables;
  FOfsNames := FOfsDataDesc + FSizeOfDataDesc;
  FOfsData := AlignUp(FOfsNames + FSizeOfNames, MachineWord);
  FOfsEnd := FOfsData + FSizeOfData;
end;

end.


text:
unit PE.Types.Relocations;

interface

uses
{$IFDEF DEBUG}
  System.SysUtils,
{$ENDIF}
  System.Generics.Collections,
  PE.Common,
  gRBTree;

{$I 'PE.Types.Relocations.inc'} // Include constants.

type

  { TBaseRelocationBlock }

  TBaseRelocationBlock = packed record
    // The image base plus the page RVA is added to each offset
    // to create the VA where the base relocation must be applied.
    PageRVA: UInt32;

    // The total number of bytes in the base relocation block, including the
    // Page RVA and Block Size fields and the Type/Offset fields that follow.
    BlockSize: UInt32;

    // Get count of relocation elements (entries).
    function Count: integer; {$IFNDEF DEBUG} inline; {$ENDIF}
    // Check if this block's size:0 or rva:0.
    function IsEmpty: Boolean; inline;
  end;

  { TBaseRelocationEntry }

  TBaseRelocationEntry = packed record
    raw: uint16;
    function GetOffset: uint16;
    function GetType: byte;
  end;

  { TReloc }

  TReloc = packed record
    RVA: uint64;    // relocatable rva
    &Type: integer; // see 5.6.2. Base Relocation Types (IMAGE_REL_BASED_...)
  end;

  PReloc = ^TReloc;

  { TRelocs }

  TRelocTree = TRBTree<TReloc>;

  TRelocs = class
  private
    FItems: TRelocTree;
    // Find relocation. Result is pointer to relocation otherwise it's nil.
    function FindReloc(RVA: TRVA): PReloc; overload;
  public
    constructor Create;
    destructor Destroy; override;

    procedure Clear;

    function Count: integer;

    function Find(RVA: TRVA; out Reloc: TReloc): Boolean;

    // Add non-existing item, or update existing item.
    procedure Put(const Value: TReloc); overload;
    procedure Put(RVA: TRVA; &Type: integer); overload;

    // Result is True if reloc was found and removed.
    function Remove(RVA: TRVA): Boolean;

    property Items: TRelocTree read FItems;
  end;

implementation

uses
  PE.Utils;

{ TBaseRelocationBlock }

function TBaseRelocationBlock.Count: integer;
begin
{$IFDEF DEBUG}
  if BlockSize < SizeOf(TBaseRelocationBlock) then
    raise Exception.Create('Relocation block is too small.');
{$ENDIF}
  result := (BlockSize - SizeOf(TBaseRelocationBlock)) div SizeOf(TBaseRelocationEntry);
end;

function TBaseRelocationBlock.IsEmpty: Boolean;
begin
  result := (PageRVA = 0) or (BlockSize = 0);
end;

{ TBaseRelocationEntry }

function TBaseRelocationEntry.GetOffset: uint16;
begin
  result := raw and $0FFF;
end;

function TBaseRelocationEntry.GetType: byte;
begin
  result := raw shr 12;
end;

{ TRelocs }

procedure TRelocs.Put(const Value: TReloc);
var
  p: PReloc;
begin
  p := FindReloc(Value.RVA);
  // If item exists, modify it.
  if p <> nil then
    // This will modify type, rva will stay same.
    // If we'll modify rva, tree will be corrupted.
    p^ := Value
  else
    // If not yet exists, add it.
    FItems.Add(Value);
end;

function TRelocs.Remove(RVA: TRVA): Boolean;
var
  r: TReloc;
begin
  r.RVA := RVA;
  r.&Type := 0; // don't care
  result := FItems.Remove(r);
end;

procedure TRelocs.Clear;
begin
  FItems.Clear;
end;

function TRelocs.Count: integer;
begin
  result := FItems.Count;
end;

constructor TRelocs.Create;
begin
  FItems := TRelocTree.Create(
    function(const A, B: TReloc): Boolean
    begin
      result := A.RVA < B.RVA;
    end);
end;

destructor TRelocs.Destroy;
begin
  FItems.Free;
  inherited;
end;

function TRelocs.Find(RVA: TRVA; out Reloc: TReloc): Boolean;
var
  r: TReloc;
  p: TRelocTree.TRBNodePtr;
begin
  r.RVA := RVA;
  r.&Type := 0; // don't care
  p := FItems.Find(r);
  if p = nil then
    Exit(False);
  Reloc := p^.K;
  Exit(True);
end;

function TRelocs.FindReloc(RVA: TRVA): PReloc;
var
  r: TReloc;
  p: TRelocTree.TRBNodePtr;
begin
  r.RVA := RVA;
  r.&Type := 0; // don't care
  p := FItems.Find(r);
  if p = nil then
    Exit(nil);
  Exit(@p^.K);
end;

procedure TRelocs.Put(RVA: TRVA; &Type: integer);
var
  r: TReloc;
begin
  r.RVA := RVA;
  r.&Type := &Type;
  Put(r);
end;

end.

repo_name: vdisasm/pe-image-for-delphi

repo_language: Pascal

mime_type: text/plain


text:
unit PE.Build.Import;

interface

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

  PE.Common,
  PE.Section,
  PE.Build.Common,
  PE.Utils;

type
  TImportBuilder = class(TDirectoryBuilder)
  public
    // Modified after Build called.
    BuiltIatRVA: TRVA;
    BuiltIatSize: uint32;
    procedure Build(DirRVA: TRVA; Stream: TStream); override;
    class function GetDefaultSectionFlags: Cardinal; override;
    class function GetDefaultSectionName: string; override;
    class function NeedRebuildingIfRVAChanged: Boolean; override;
  end;

implementation

uses
  // Expand
  PE.Image,
  PE.Types.FileHeader,
  //
  PE.Imports,
  PE.Imports.Lib,
  PE.Imports.Func,
  PE.Types.Imports;

{
  *  Import directory layout
  *
  *  IDT.
  *  For each library
  *    Import Descriptor
  *  Null Import Descriptor
  *
  *  Name pointers.
  *  For each library
  *    For each function
  *      Pointer to function hint/name or ordinal
  *    Null pointer
  *
  *  IAT.
  *  For each library
  *    For each function
  *      Function address
  *    Null address
  *
  *  Names.
  *  For each library
  *    Library name
  *    ** align 2 **
  *    For each function
  *      Hint: uint16
  *      Function name: variable length
}
procedure WriteStringAligned2(Stream: TStream; const s: string);
const
  null: byte = 0;
var
  bytes: TBytes;
begin
  bytes := TEncoding.ANSI.GetBytes(s);
  StreamWrite(Stream, bytes[0], length(bytes));
  StreamWrite(Stream, null, 1);
  if Stream.Position mod 2 <> 0 then
    StreamWrite(Stream, null, 1);
end;

procedure WriteIDT(
  Stream: TStream;
  var ofs_idt: uint32;
  const idt: TImportDirectoryTable);
begin
  Stream.Position := ofs_idt;
  StreamWrite(Stream, idt, sizeof(idt));
  inc(ofs_idt, sizeof(idt));
end;

procedure WriteNullIDT(Stream: TStream; var ofs_idt: uint32);
var
  idt: TImportDirectoryTable;
begin
  idt.Clear;
  WriteIDT(Stream, ofs_idt, idt);
end;

// Write library name and set idt name pointer, update name pointer offset.
procedure WriteLibraryName(
  Stream: TStream;
  Lib: TPEImportLibrary;
  DirRVA: TRVA;
  var ofs_names: uint32;
  var idt: TImportDirectoryTable);
begin
  // library name
  idt.NameRVA := DirRVA + ofs_names;
  Stream.Position := ofs_names;
  WriteStringAligned2(Stream, Lib.Name);
  ofs_names := Stream.Position;
end;

function MakeOrdinalRVA(ordinal: uint16; wordsize: byte): TRVA; inline;
begin
  if wordsize = 4 then
    result := $80000000 or ordinal
  else
    result := $8000000000000000 or ordinal;
end;

procedure WriteFunctionNamesOrOrdinalsAndIat(
  Stream: TStream;
  Lib: TPEImportLibrary;
  DirRVA: TRVA;
  var ofs_names: uint32;
  var ofs_name_pointers: uint32;
  var ofs_iat: uint32;
  var idt: TImportDirectoryTable;
  wordsize: byte);
var
  hint: uint16;
  fn: TPEImportFunction;
  rva_hint_name: TRVA;
begin
  if Lib.Functions.Count = 0 then
    exit;

  idt.ImportLookupTableRVA := DirRVA + ofs_name_pointers;

  if (not Lib.Original) then
  begin
    idt.ImportAddressTable := DirRVA + ofs_iat;

    // Update IAT in library.
    Lib.IatRva := idt.ImportAddressTable;
  end
  else
  begin
    idt.ImportAddressTable := Lib.IatRva;
  end;

  hint := 0;
  for fn in Lib.Functions do
  begin
    // Write name.
    if not fn.Name.IsEmpty then
    begin
      // If imported by name.
      rva_hint_name := DirRVA + ofs_names;
      Stream.Position := ofs_names;
      StreamWrite(Stream, hint, sizeof(hint));
      WriteStringAligned2(Stream, fn.Name);
      ofs_names := Stream.Position;
    end
    else
    begin
      // If imported by ordinal.
      rva_hint_name := MakeOrdinalRVA(fn.ordinal, wordsize);
    end;

    // Write name pointer.
    Stream.Position := ofs_name_pointers;
    StreamWrite(Stream, rva_hint_name, wordsize);
    inc(ofs_name_pointers, wordsize);

    // Write IAT item.
    Stream.Position := ofs_iat;
    StreamWrite(Stream, rva_hint_name, wordsize);
    inc(ofs_iat, wordsize);
  end;

  rva_hint_name := 0;

  // Write null name pointer.
  Stream.Position := ofs_name_pointers;
  StreamWrite(Stream, rva_hint_name, wordsize);
  ofs_name_pointers := Stream.Position;

  // Write null IAT item.
  Stream.Position := ofs_iat;
  StreamWrite(Stream, rva_hint_name, wordsize);
  inc(ofs_iat, wordsize);
end;

procedure TImportBuilder.Build(DirRVA: TRVA; Stream: TStream);
var
  idt: TImportDirectoryTable;
  Lib: TPEImportLibrary;
  elements: uint32;
var
  ofs_idt: uint32;
  ofs_name_pointers: uint32;
  ofs_iat, ofs_iat_0: uint32;
  ofs_names: uint32;
begin
  BuiltIatRVA := 0;
  BuiltIatSize := 0;

  if FPE.Imports.Libs.Count = 0 then
    exit;

  // Calculate initial offsets.
  elements := 0;
  for Lib in FPE.Imports.Libs do
    inc(elements, Lib.Functions.Count + 1);

  ofs_idt := 0;
  ofs_name_pointers := sizeof(idt) * (FPE.Imports.Libs.Count + 1);
  ofs_iat := ofs_name_pointers + elements * (FPE.ImageWordSize);
  ofs_iat_0 := ofs_iat;
  ofs_names := ofs_name_pointers + 2 * elements * (FPE.ImageWordSize);

  // Write.
  for Lib in FPE.Imports.Libs do
  begin
    idt.Clear;
    WriteLibraryName(Stream, Lib, DirRVA, ofs_names, idt);
    WriteFunctionNamesOrOrdinalsAndIat(Stream, Lib, DirRVA,
      ofs_names, ofs_name_pointers, ofs_iat, idt, FPE.ImageWordSize);
    WriteIDT(Stream, ofs_idt, idt);
  end;
  WriteNullIDT(Stream, ofs_idt);

  self.BuiltIatRVA := DirRVA + ofs_iat_0;
  self.BuiltIatSize := ofs_iat - ofs_iat_0;
end;

class function TImportBuilder.GetDefaultSectionFlags: Cardinal;
begin
  result := $C0000040;
end;

class function TImportBuilder.GetDefaultSectionName: string;
begin
  result := '.idata';
end;

class function TImportBuilder.NeedRebuildingIfRVAChanged: Boolean;
begin
  result := True;
end;

end.


text:
unit PE.Parser.TLS;

interface

uses
  System.SysUtils,

  PE.Common,
  PE.Types,
  PE.Types.Directories,
  PE.Types.TLS,
  PE.TLS;

type
  TPETLSParser = class(TPEParser)
  public
    function Parse: TParserResult; override;
  end;

implementation

uses
  PE.Image;

{ TPETLSParser }

function TPETLSParser.Parse: TParserResult;
var
  PE: TPEImage;
var
  Dir: TImageDataDirectory;
  TLSDir: TTLSDirectory;
  AddressofCallbacks: TVA;
  CurRVA, CallbackVA: uint64;
  bRead: boolean;
begin
  PE := TPEImage(FPE);

  if not PE.DataDirectories.Get(DDIR_TLS, @Dir) then
    exit(PR_OK);
  if Dir.IsEmpty then
    exit(PR_OK);

  if not PE.SeekRVA(Dir.VirtualAddress) then
  begin
    PE.Msg.Write(SCategoryTLS, 'Incorrect directory RVA.');
    exit(PR_ERROR);
  end;

  case PE.ImageBits of
    32:
      begin
        bRead := PE.ReadEx(TLSDir.tls32, SizeOf(TLSDir.tls32));
        AddressofCallbacks := TLSDir.tls32.AddressofCallbacks;
      end;
    64:
      begin
        bRead := PE.ReadEx(TLSDir.tls64, SizeOf(TLSDir.tls64));
        AddressofCallbacks := TLSDir.tls64.AddressofCallbacks;
      end;
  else
    exit(PR_ERROR);
  end;

  if not bRead then
  begin
    PE.Msg.Write(SCategoryTLS, 'Failed to read directory.');
    exit(PR_ERROR);
  end;

  // Assign dir.
  PE.TLS.Dir := TLSDir;

  // Try to read callback addresses if available.

  // It's ok if there's no callbacks.
  if AddressofCallbacks = 0 then
    exit(PR_OK);

  if not PE.SeekVA(AddressofCallbacks) then
  begin
    PE.Msg.Write(SCategoryTLS, 'Incorrect address of callbacks.');
    exit(PR_OK);
  end;

  while True do
  begin
    CurRVA := PE.PositionRVA;

    // Try to read callback address.
    if not PE.ReadWordEx(0, @CallbackVA) then
    begin
      PE.Msg.Write(SCategoryTLS, 'Failed to read callback address at RVA: 0x%x. Probably malformed data.', [CurRVA]);
      break;
    end;

    // Is it terminator?
    if CallbackVA = 0 then
      break;

    // Does the address exist?
    if not PE.VAExists(CallbackVA) then
    begin
      PE.Msg.Write(SCategoryTLS, 'Bad callback address (0x%x) at RVA: 0x%x', [CallbackVA, CurRVA]);
      break;
    end;

    // Add existing address.
    PE.TLS.CallbackRVAs.Add(PE.VAToRVA(CallbackVA))
  end;

  exit(PR_OK);
end;

end.


text:
{
  Unit to manipulate resources in Windows oriented way.

  It means 3 resource levels:
  - Type (RT_...)
  - Name
  - Language
}
unit PE.Resources.Windows;

interface

uses
  System.Classes,
  PE.Image,
  PE.Resources,
  PE.Resources.VersionInfo;

{ Values for Windows PE. }

type
  RSRCID = UInt32;

const
  // The following are the predefined resource types.
  // http://msdn.microsoft.com/en-us/library/windows/desktop/ms648009(v=vs.85).aspx

  RT_CURSOR       = RSRCID(1);                      // Hardware-dependent cursor resource.
  RT_BITMAP       = RSRCID(2);                      // Bitmap resource.
  RT_ICON         = RSRCID(3);                      // Hardware-dependent icon resource.
  RT_MENU         = RSRCID(4);                      // Menu resource.
  RT_DIALOG       = RSRCID(5);                      // Dialog box.
  RT_STRING       = RSRCID(6);                      // String-table entry.
  RT_FONTDIR      = RSRCID(7);                      // Font directory resource.
  RT_FONT         = RSRCID(8);                      // Font resource.
  RT_ACCELERATOR  = RSRCID(9);                      // Accelerator table.
  RT_RCDATA       = RSRCID(10);                     // Application-defined resource (raw data).
  RT_MESSAGETABLE = RSRCID(11);                     // Message-table entry.
  RT_GROUP_CURSOR = RSRCID(UInt32(RT_CURSOR) + 11); // Hardware-independent cursor resource.
  RT_GROUP_ICON   = RSRCID(UInt32(RT_ICON) + 11);   // Hardware-independent icon resource.
  RT_VERSION      = RSRCID(16);                     // Version resource.
  RT_DLGINCLUDE   = RSRCID(17);                     // Allows a resource editing tool to associate a string with an .rc file.
  RT_PLUGPLAY     = RSRCID(19);                     // Plug and Play resource.
  RT_VXD          = RSRCID(20);                     // VXD.
  RT_ANICURSOR    = RSRCID(21);                     // Animated cursor.
  RT_ANIICON      = RSRCID(22);                     // Animated icon.
  RT_HTML         = RSRCID(23);                     // HTML resource.
  RT_MANIFEST     = RSRCID(24);                     // Side-by-Side Assembly Manifest.

  RT_NAMES: array [0 .. 24] of string = (
    '#0',              // 0
    'RT_CURSOR',       // 1
    'RT_BITMAP',       // 2
    'RT_ICON',         // 3
    'RT_MENU',         // 4
    'RT_DIALOG',       // 5
    'RT_STRING',       // 6
    'RT_FONTDIR',      // 7
    'RT_FONT',         // 8
    'RT_ACCELERATOR',  // 9
    'RT_RCDATA',       // 10
    'RT_MESSAGETABLE', // 11
    'RT_GROUP_CURSOR', // 12
    '#13',             // 13
    'RT_GROUP_ICON',   // 14
    '#15',             // 15
    'RT_VERSION',      // 16
    'RT_DLGINCLUDE',   // 17
    '#18',             // 18
    'RT_PLUGPLAY',     // 19
    'RT_VXD',          // 20
    'RT_ANICURSOR',    // 21
    'RT_ANIICON',      // 22
    'RT_HTML',         // 23
    'RT_MANIFEST'      // 24
    );

type
  TWindowsResourceTree = class
  private
    function FindResourceInternal(lpType, lpName: PChar; Language: word; Depth: cardinal): TResourceTreeNode;
  protected
    FResourceTree: TResourceTree;
  public
    constructor Create(ResourceTree: TResourceTree);

    // Find Type-Name-Language leaf.
    function FindResource(lpType, lpName: PChar; Language: word): TResourceTreeLeafNode; overload;
    // Find Type-Name branch.
    function FindResource(lpType, lpName: PChar): TResourceTreeBranchNode; overload;
    // Find Type branch.
    function FindResource(lpType: PChar): TResourceTreeBranchNode; overload;

    // Update resource by full path.
    // lpType, lpName: if <= $FFFF it's ID otherwise it point to Name string.
    // If (lpData=nil) and (cbData=0) then resource is deleted.
    procedure UpdateResource(lpType, lpName: PChar; Language: word;
      lpData: PByte; cbData: UInt32);

    function RemoveResource(lpType, lpName: PChar; Language: word): boolean;
  end;

function IsIntResource(lpszType: PChar): boolean; inline;
function GetIntResource(lpszType: PChar): word; inline;
function MakeIntResource(wInteger: uint16): PChar; inline;

// See Windows GetFileVersionInfo function.
// Find RT_VERSION raw data or nil if failed.
// Don't Free returned stream because it's part of ResourceTree.
function PeGetFileVersionInfo(img: TPEImage): TMemoryStream;

function PeVerQueryValueFixed(stream: TStream; out value: VS_FIXEDFILEINFO): boolean;

implementation

uses
  System.SysUtils;

function IsIntResource(lpszType: PChar): boolean; inline;
begin
  Result := NativeUInt(lpszType) shr 16 = 0;
end;

function GetIntResource(lpszType: PChar): word; // inline;
begin
  Result := NativeUInt(lpszType) and $FFFF;
end;

function MakeIntResource(wInteger: uint16): PChar;
begin
  Result := PChar(wInteger);
end;

constructor TWindowsResourceTree.Create(ResourceTree: TResourceTree);
begin
  FResourceTree := ResourceTree;
end;

// Find or create node.
// IsBranch: Is fetched node must be branch (or leaf).
// lpName: Name or ID (intresource)
function FetchNode(
  Parent: TResourceTreeBranchNode;
  IsBranch: boolean;
  CreateIfNotExists: boolean;
  lpName: PChar): TResourceTreeNode;
var
  bIntRsrc: boolean;
begin
  bIntRsrc := IsIntResource(lpName);
  // Check if node with such Name/Id already exists.
  if bIntRsrc then
    Result := Parent.FindByID(GetIntResource(lpName))
  else
    Result := Parent.FindByName(lpName);
  // If not exists, create it.
  if Result = nil then
  begin
    if CreateIfNotExists then
    begin
      // Create sub-node.
      if IsBranch then
        Result := Parent.AddNewBranch
      else
        Result := Parent.AddNewLeaf;
      // Set Id/Name
      if bIntRsrc then
        Result.Id := GetIntResource(lpName)
      else
        Result.Name := lpName;
    end;
  end
  else
  // If exists, check if branch/leaf.
  begin
    if not(Result.IsBranch = IsBranch) then
      raise Exception.Create('Node type mismatch.');
  end;
end;

function TWindowsResourceTree.RemoveResource(lpType, lpName: PChar; Language: word): boolean;
var
  n: TResourceTreeNode;
begin
  n := FindResourceInternal(lpType, lpName, Language, 2);
  if not assigned(n) then
    exit(false);

  n.Parent.Remove(n);
  exit(true);
end;

function TWindowsResourceTree.FindResource(lpType, lpName: PChar; Language: word): TResourceTreeLeafNode;
begin
  Result := TResourceTreeLeafNode(FindResourceInternal(lpType, lpName, Language, 2));
end;

function TWindowsResourceTree.FindResource(lpType, lpName: PChar):
  TResourceTreeBranchNode;
begin
  Result := TResourceTreeBranchNode(FindResourceInternal(lpType, lpName, 0, 1));
end;

function TWindowsResourceTree.FindResource(lpType: PChar): TResourceTreeBranchNode;
begin
  Result := TResourceTreeBranchNode(FindResourceInternal(lpType, nil, 0, 0));
end;

function TWindowsResourceTree.FindResourceInternal(lpType, lpName: PChar;
  Language: word; Depth: cardinal): TResourceTreeNode;
const
  IsBranches: array [0 .. 2] of boolean = (true, true, false);
var
  i: integer;
  n: TResourceTreeNode;
  val: PChar;
begin
  if Depth > 2 then
    Depth := 2;
  n := FResourceTree.Root;
  val := nil; // compiler friendly
  for i := 0 to Depth do
  begin
    case i of
      0:
        val := lpType;
      1:
        val := lpName;
      2:
        val := PChar(Language);
    end;
    n := FetchNode(TResourceTreeBranchNode(n), IsBranches[i], false, val);
    if n = nil then
      exit(nil);
  end;
  Result := n;
end;

procedure TWindowsResourceTree.UpdateResource(lpType, lpName: PChar;
  Language: word; lpData: PByte; cbData: UInt32);
var
  nRoot, nType, nName: TResourceTreeBranchNode;
  nLang: TResourceTreeLeafNode;
begin
  if (lpData = nil) and (cbData = 0) then
  begin
    RemoveResource(lpType, lpName, Language);
    exit;
  end;
  nRoot := FResourceTree.Root;
  nType := FetchNode(nRoot, true, true, lpType) as TResourceTreeBranchNode;
  nName := FetchNode(nType, true, true, lpName) as TResourceTreeBranchNode;
  nLang := FetchNode(nName, false, true, PChar(Language)) as TResourceTreeLeafNode;
  nLang.UpdateData(lpData, cbData);
end;

function PeGetFileVersionInfo(img: TPEImage): TMemoryStream;
var
  rt: TWindowsResourceTree;
  versionBranch: TResourceTreeBranchNode;
  versionLeaf: TResourceTreeLeafNode;
begin
  rt := TWindowsResourceTree.Create(img.ResourceTree);
  try
    versionBranch := rt.FindResource(MakeIntResource(RT_VERSION));
    if assigned(versionBranch) and versionBranch.IsBranch and (versionBranch.Children.Count > 0) then
    begin
      versionBranch := TResourceTreeBranchNode(versionBranch.Children.First);
      if assigned(versionBranch) and versionBranch.IsBranch and (versionBranch.Children.Count > 0) then
      begin
        versionLeaf := TResourceTreeLeafNode(versionBranch.Children.First);
        if assigned(versionLeaf) and versionLeaf.IsLeaf then
        begin
          exit(versionLeaf.Data);
        end;
      end;
    end;
    exit(nil);
  finally
    rt.Free;
  end;
end;

function PeVerQueryValueFixed(stream: TStream; out value: VS_FIXEDFILEINFO): boolean;
var
  verInfo: TPEVersionInfo;
  block: TBlock;
begin
  verInfo := TPEVersionInfo.Create;
  try
    verInfo.LoadFromStream(stream);

    if assigned(verInfo.Root) then
      for block in verInfo.Root.Children do
        if block.ClassType = TBlockVersionInfo then
        begin
          value := TBlockVersionInfo(block).FixedInfo;
          exit(true);
        end;

    exit(false);
  finally
    verInfo.Free;
  end;
end;

end.


text:
unit PE.COFF.Types;

interface

type
  // 4.4.1. Symbol Name Representation

  TCOFFSymbolTableName = packed record
    case byte of
      0:
        (ShortName: array [0 .. 7] of AnsiChar);
      1:
        (u: record Zeroes, Offset: uint32; end);
  end;

  // 4.4. COFF Symbol Table

  TCOFFSymbolTable = packed record

    Name: TCOFFSymbolTableName;

    // The value that is associated with the symbol. The interpretation of this
    // field depends on SectionNumber and StorageClass. A typical meaning is
    // the relocatable address.
    Value: uint32;

    // The signed integer that identifies the section, using a one-based index
    // into the section table. Some values have special meaning, as defined in
    // section 5.4.2, “Section Number Values.”
    SectionNumber: int16;

    // A number that represents type. Microsoft tools set this field to 0x20
    // (function) or 0x0 (not a function). For more information, see section
    // 5.4.3, “Type Representation.”
    &Type: uint16;

    // An enumerated value that represents storage class. For more information,
    // see section 5.4.4, “Storage Class.”
    StorageClass: uint8;

    // The number of auxiliary symbol table entries that follow this record.
    NumberOfAuxSymbols: uint8;

  end;

  // 4.4.2. Section Number Values

const
  // The symbol record is not yet assigned a section. A value of zero indicates
  // that a reference to an external symbol is defined elsewhere. A value of
  // non-zero is a common symbol with a size that is specified by the value.
  IMAGE_SYM_UNDEFINED = 0;

  // The symbol has an absolute (non-relocatable) value and is not an address.
  IMAGE_SYM_ABSOLUTE = -1;

  // The symbol provides general type or debugging information but does not
  // correspond to a section. Microsoft tools use this setting along with .file
  // records (storage class FILE).
  IMAGE_SYM_DEBUG = -2;

  // ... also other info

implementation

end.


text:
unit PE.Sections;

interface

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

  PE.Common,
  PE.Types.Sections,
  PE.Section;

type
  TPESections = class(TList<TPESection>)
  private
    FPE: TObject;
    procedure ItemNotify(Sender: TObject; const Item: TPESection;
      Action: TCollectionNotification);
  public
    constructor Create(APEImage: TObject);

    function Add(const Sec: TPESection): TPESection;
    procedure Clear;

    // Change section Raw and Virtual size.
    // Virtual size is aligned to section alignment.
    procedure Resize(Sec: TPESection; NewSize: UInt32);

    function CalcNextSectionRVA: TRVA;

    // Create new section but don't add it.
    // See AddNew for list of parameters.
    function CreateNew(const AName: String; ASize, AFlags: UInt32;
      Mem: pointer; ForceVA: TVA = 0): TPESection;

    // Add new named section.
    // If Mem <> nil, data from Mem will be copied to newly allocated block.
    // If Mem = nil, block will be allocated and filled with 0s.
    // Normally Virtual Address of section is calculated to come after previous
    // section (aligned). But if ForceVA is not 0 it is used instead of
    // calculation.
    function AddNew(const AName: String; ASize, AFlags: UInt32;
      Mem: pointer; ForceVA: TVA = 0): TPESection;

    // Add new section using raw data from file.
    function AddNewFromFile(const AFileName: string; const AName: String;
      AFlags: UInt32; ForceVA: TVA = 0): TPESection;

    function SizeOfAllHeaders: UInt32; inline;

    function RVAToOfs(RVA: TRVA; OutOfs: PDword): boolean;
    function RVAToSec(RVA: TRVA; OutSec: PPESection): boolean;

    function FindByName(const AName: String; IgnoreCase: boolean = True): TPESection;

    // Fill section memory with specified byte and return number of bytes
    // actually written.
    function FillMemory(RVA: TRVA; Size: UInt32; FillByte: Byte = 0): UInt32;

    // WholeSizeOrNothing: either write Size bytes or write nothing.
    function FillMemoryEx(RVA: TRVA; Size: UInt32; WholeSizeOrNothing: boolean;
      FillByte: Byte = 0): UInt32;
  end;

implementation

uses
  // Expand
  PE.Types.FileHeader,
  //
  PE.Image,
  PE.Utils;

{ TPESections }

function TPESections.Add(const Sec: TPESection): TPESection;
begin
  inherited Add(Sec);
  Result := Sec;
end;

function TPESections.CreateNew(const AName: String; ASize, AFlags: UInt32;
  Mem: pointer; ForceVA: TVA): TPESection;
var
  PE: TPEImage;
  sh: TImageSectionHeader;
begin
  PE := TPEImage(FPE);

  sh.Clear;
  sh.Name := AName;
  sh.VirtualSize := AlignUp(ASize, PE.SectionAlignment);

  if ForceVA = 0 then
    sh.RVA := CalcNextSectionRVA
  else
    sh.RVA := ForceVA;

  sh.SizeOfRawData := ASize;
  // sh.PointerToRawData will be calculated later during image saving.
  sh.Flags := AFlags;

  Result := TPESection.Create(sh, Mem);
end;

function TPESections.AddNew(const AName: String; ASize, AFlags: UInt32;
  Mem: pointer; ForceVA: TVA): TPESection;
begin
  Result := CreateNew(AName, ASize, AFlags, Mem, ForceVA);
  Add(Result);
end;

function TPESections.AddNewFromFile(const AFileName: string;
  const AName: String; AFlags: UInt32; ForceVA: TVA): TPESection;
var
  ms: TMemoryStream;
begin
  ms := TMemoryStream.Create;
  try
    ms.LoadFromFile(AFileName);
    Result := AddNew(AName, ms.Size, AFlags, ms.Memory, ForceVA);
  finally
    ms.Free;
  end;
end;

function TPESections.CalcNextSectionRVA: TRVA;
var
  PE: TPEImage;
begin
  PE := TPEImage(FPE);
  if Count = 0 then
    Result := AlignUp(PE.CalcHeadersSizeNotAligned, PE.SectionAlignment)
  else
    Result := AlignUp(Last.RVA + Last.VirtualSize, PE.SectionAlignment);
end;

procedure TPESections.Clear;
begin
  inherited Clear;
  TPEImage(FPE).FileHeader^.NumberOfSections := 0;
end;

constructor TPESections.Create(APEImage: TObject);
begin
  inherited Create;
  FPE := APEImage;
  self.OnNotify := ItemNotify;
end;

function TPESections.FillMemory(RVA: TRVA; Size: UInt32;
  FillByte: Byte): UInt32;
begin
  Result := FillMemoryEx(RVA, Size, False, FillByte);
end;

function TPESections.FillMemoryEx(RVA: TRVA; Size: UInt32;
  WholeSizeOrNothing: boolean; FillByte: Byte): UInt32;
var
  Sec: TPESection;
  Ofs, CanWrite: UInt32;
  p: PByte;
begin
  if not RVAToSec(RVA, @Sec) then
    Exit(0);
  Ofs := RVA - Sec.RVA;                   // offset of RVA in section
  CanWrite := Sec.GetAllocatedSize - Ofs; // max we can write before section end
  if CanWrite < Size then
  begin
    if WholeSizeOrNothing then
      Exit(0); //
    Result := CanWrite;
  end
  else
    Result := Size;
  p := Sec.Mem + Ofs;
  System.FillChar(p^, Result, FillByte);
end;

function TPESections.FindByName(const AName: String; IgnoreCase: boolean): TPESection;
var
  a, b: string;
begin
  if IgnoreCase then
    a := AName.ToLower
  else
    a := AName;
  for Result in self do
  begin
    if IgnoreCase then
      b := Result.Name.ToLower
    else
      b := Result.Name;
    if a = b then
      Exit;
  end;
  Exit(nil);
end;

procedure TPESections.ItemNotify(Sender: TObject; const Item: TPESection;
  Action: TCollectionNotification);
begin
  case Action of
    cnAdded:
      inc(TPEImage(FPE).FileHeader^.NumberOfSections);
    cnRemoved:
      begin
        dec(TPEImage(FPE).FileHeader^.NumberOfSections);
        if Item <> nil then
          Item.Free;
      end;
    cnExtracted:
      dec(TPEImage(FPE).FileHeader^.NumberOfSections);
  end;
end;

procedure TPESections.Resize(Sec: TPESection; NewSize: UInt32);
var
  NewVirtualSize: UInt32;
  LastRVA: TRVA;
begin
  // Last section can be changed freely, other sections must be checked.
  if Sec <> self.Last then
  begin
    if NewSize = 0 then
    begin
      Remove(Sec);
    end
    else
    begin
      // Get new size and rva for this section.
      NewVirtualSize := AlignUp(NewSize, TPEImage(FPE).SectionAlignment);
      LastRVA := Sec.RVA + NewVirtualSize - 1;
      // Check if new section end would be already occupied.
      if RVAToSec(LastRVA, nil) then
        raise Exception.Create('Cannot resize section: size is too big');
    end;
  end;
  Sec.Resize(NewSize);
end;

function TPESections.RVAToOfs(RVA: TRVA; OutOfs: PDword): boolean;
var
  Sec: TPESection;
begin
  for Sec in self do
  begin
    if Sec.ContainRVA(RVA) then
    begin
      if Assigned(OutOfs) then
        OutOfs^ := (RVA - Sec.RVA) + Sec.RawOffset;
      Exit(True);
    end;
  end;
  Exit(False);
end;

function TPESections.RVAToSec(RVA: TRVA; OutSec: PPESection): boolean;
var
  Sec: TPESection;
begin
  for Sec in self do
    if Sec.ContainRVA(RVA) then
    begin
      if OutSec <> nil then
        OutSec^ := Sec;
      Exit(True);
    end;
  Result := False;
end;

function TPESections.SizeOfAllHeaders: UInt32;
begin
  Result := Count * sizeof(TImageSectionHeader)
end;

end.


text:
program AllUnits;

uses
  PE.Build.Common in 'PE.Build.Common.pas',
  PE.Build.Export in 'PE.Build.Export.pas',
  PE.Build.Import in 'PE.Build.Import.pas',
  PE.Build in 'PE.Build.pas',
  PE.Build.Relocs in 'PE.Build.Relocs.pas',
  PE.Build.Resource in 'PE.Build.Resource.pas',
  PE.COFF in 'PE.COFF.pas',
  PE.COFF.Types in 'PE.COFF.Types.pas',
  PE.Common in 'PE.Common.pas',
  PE.DataDirectories in 'PE.DataDirectories.pas',
  PE.ExportSym in 'PE.ExportSym.pas',
  PE.FileHeaderToStr in 'PE.FileHeaderToStr.pas',
  PE.Headers in 'PE.Headers.pas',
  PE.Image.Defaults in 'PE.Image.Defaults.pas',
  PE.Image in 'PE.Image.pas',
  PE.Image.Saving in 'PE.Image.Saving.pas',
  PE.Image.x86 in 'PE.Image.x86.pas',
  PE.Imports in 'PE.Imports.pas',
  PE.MemoryStream in 'PE.MemoryStream.pas',
  PE.Msg in 'PE.Msg.pas',
  PE.Parser.Export in 'PE.Parser.Export.pas',
  PE.Parser.Headers in 'PE.Parser.Headers.pas',
  PE.Parser.Import in 'PE.Parser.Import.pas',
  PE.Parser.PData in 'PE.Parser.PData.pas',
  PE.Parser.Relocs in 'PE.Parser.Relocs.pas',
  PE.Parser.Resources in 'PE.Parser.Resources.pas',
  PE.Parser.TLS in 'PE.Parser.TLS.pas',
  PE.Resources.Extract in 'PE.Resources.Extract.pas',
  PE.Resources in 'PE.Resources.pas',
  PE.Resources.Windows in 'PE.Resources.Windows.pas',
  PE.RTTI in 'PE.RTTI.pas',
  PE.Section in 'PE.Section.pas',
  PE.Sections in 'PE.Sections.pas',
  PE.TLS in 'PE.TLS.pas',
  PE.Types.Directories in 'PE.Types.Directories.pas',
  PE.Types.DOSHeader in 'PE.Types.DOSHeader.pas',
  PE.Types.Export in 'PE.Types.Export.pas',
  PE.Types.FileHeader in 'PE.Types.FileHeader.pas',
  PE.Types.Imports in 'PE.Types.Imports.pas',
  PE.Types.NTHeaders in 'PE.Types.NTHeaders.pas',
  PE.Types.OptionalHeader in 'PE.Types.OptionalHeader.pas',
  PE.Types in 'PE.Types.pas',
  PE.Types.Relocations in 'PE.Types.Relocations.pas',
  PE.Types.Resources in 'PE.Types.Resources.pas',
  PE.Types.Sections in 'PE.Types.Sections.pas',
  PE.Types.TLS in 'PE.Types.TLS.pas',
  PE.Utils in 'PE.Utils.pas',
  PE.ExecutableLoader in 'PE.ExecutableLoader.pas',
  PE.ParserCallbacks in 'PE.ParserCallbacks.pas',
  PE.Types.ImportsDelayed in 'PE.Types.ImportsDelayed.pas',
  PE.Parser.ImportDelayed in 'PE.Parser.ImportDelayed.pas',
  NullStream in 'NullStream.pas',
  PE.Imports.Func in 'PE.Imports.Func.pas',
  PE.Imports.Lib in 'PE.Imports.Lib.pas';

begin
end.


text:
{$WARN COMBINING_SIGNED_UNSIGNED OFF}
unit PE.Image.Saving;

interface

uses
  System.Classes,
  System.SysUtils;

// If SavingModifiedImage is True some fields like header size and image size
// are recalculated and updated. If it's False it's assumed image is already
// built (or just loaded) and only headers writing done.
function SaveHeaders(APE: TObject; AStream: TStream; SavingModifiedImage: boolean): boolean;

function SaveImageToStream(APE: TObject; AStream: TStream): boolean;

implementation

uses
  // To expand.
  PE.Headers,
  PE.Common,
  PE.DataDirectories,
  //
  PE.Types.DOSHeader,
  PE.Types.FileHeader,
  PE.Types.NTHeaders,
  PE.Types.OptionalHeader,
  PE.Types.Directories,
  PE.Types.Sections,
  PE.Image,
  PE.Section,
  PE.Sections,
  PE.Utils,

  PE.Build.Export;

{ DOS }

function DoDosHdr(PE: TPEImage; AStream: TStream): boolean;
var
  h: PImageDOSHeader;
  DosBlockSize: integer;
begin
  h := PE.DOSHeader;
  h^.e_magic.SetMZ;
  h^.e_lfanew := PE.LFANew;

  // Write DOS header.
  Result := StreamWrite(AStream, h^, SizeOf(h^));

  // Write DOS block.
  DosBlockSize := Length(PE.DosBlock);
  if DosBlockSize <> 0 then
    StreamWrite(AStream, PE.DosBlock[0], DosBlockSize);
end;

{ NT }

function DoFileHdr(PE: TPEImage; AStream: TStream): boolean;
begin
  if StreamWrite(AStream, PE00_SIGNATURE, SizeOf(PE00_SIGNATURE)) then
    if StreamWrite(AStream, PE.FileHeader^, SizeOf(PE.FileHeader^)) then
      exit(true);
  exit(false);
end;

{ Optional }

function DoOptHdrAndDirs(PE: TPEImage; AStream: TStream): boolean;
var
  OptHdrSize: integer;
  DDirSize: integer;
begin
  // Update # of dirs.
  PE.OptionalHeader.NumberOfRvaAndSizes := PE.DataDirectories.Count;
  // Write optional header.
  OptHdrSize := PE.OptionalHeader.WriteToStream(AStream, PE.ImageBits, -1);
  // Write dirs.
  DDirSize := PE.DataDirectories.SaveDirectoriesToStream(AStream);
  // Update size of opt. hdr.
  PE.FileHeader.SizeOfOptionalHeader := OptHdrSize + DDirSize;

  Result := PE.FileHeader.SizeOfOptionalHeader <> 0;
end;

{ Sec Hdr }

procedure FillSecHdrRawOfs(PE: TPEImage; ofsSecHdr: uint32);
var
  sec: TPESection;
  ofs: uint64;
begin
  ofs := ofsSecHdr + PE.Sections.Count * SizeOf(TImageSectionHeader);
  for sec in PE.Sections do
  begin
    // Process only TPESection.
    if sec.ClassType <> TPESection then
      continue;

    ofs := AlignUp(ofs, PE.FileAlignment);
    sec.RawOffset := ofs;
    inc(ofs, sec.RawSize);
  end;
end;

function DoSecHdr(PE: TPEImage; AStream: TStream): boolean;
var
  Sec: TPESection;
  h: TImageSectionHeader;
begin
  for Sec in PE.Sections do
  begin
    // Process only TPESection.
    if sec.ClassType <> TPESection then
      continue;

    h := Sec.ImageSectionHeader;
    if not StreamWrite(AStream, h, SizeOf(h)) then
      exit(False);
  end;
  exit(true);
end;

function DoSecHdrGap(PE: TPEImage; AStream: TStream): boolean;
var
  size: integer;
begin
  size := Length(PE.SecHdrGap);
  if size <> 0 then
    if not StreamWrite(AStream, PE.SecHdrGap[0], size) then
      exit(False);
  exit(true);
end;

procedure DoSecData(PE: TPEImage; AStream: TStream);
var
  sec: TPESection;
  SizeToWrite: uint32;
  PaddingSize: uint32;
begin
  for sec in PE.Sections do
  begin
    // Process only TPESection.
    if sec.ClassType <> TPESection then
      continue;

    StreamSeekWithPadding(AStream, sec.RawOffset);

    if sec.RawSize > sec.VirtualSize then
    begin
      SizeToWrite := sec.VirtualSize;
      PaddingSize := sec.RawSize - sec.VirtualSize;
    end
    else
    begin
      SizeToWrite := sec.RawSize;
      PaddingSize := 0;
    end;

    AStream.Write(sec.Mem^, SizeToWrite);
    WritePattern(AStream, PaddingSize, nil, 0);
  end;
end;

function SaveHeaders(APE: TObject; AStream: TStream; SavingModifiedImage: boolean): boolean;
var
  PE: TPEImage;
  ofsFileHdr, ofsSecHdr: uint32;
begin
  Result := False;

  PE := TPEImage(APE);

  // save dos
  if not DoDosHdr(PE, AStream) then
    exit;

  ofsFileHdr := PE.LFANew;

  // skip file header now
  if not StreamSeek(AStream, ofsFileHdr + SizeOf(TImageFileHeader) + 4) then
    exit;

  if SavingModifiedImage then
  begin
    // update size of image header
    PE.FixSizeOfImage;

    // update size of headers
    PE.FixSizeOfHeaders;
  end;

  // save optional
  if not DoOptHdrAndDirs(PE, AStream) then
    exit;

  ofsSecHdr := AStream.Position;

  // now write file header
  if not StreamSeek(AStream, ofsFileHdr) then
    exit;
  if not DoFileHdr(PE, AStream) then
    exit;

  // go back to sec hdr
  if not StreamSeek(AStream, ofsSecHdr) then
    exit;

  if SavingModifiedImage then
  begin
    // Fill RawData offsets for Section Headers.
    FillSecHdrRawOfs(PE, ofsSecHdr);
  end;

  // write sec hdr
  if not DoSecHdr(PE, AStream) then
    exit;

  exit(true);
end;

function SaveImageToStream(APE: TObject; AStream: TStream): boolean;
var
  PE: TPEImage;
begin
  Result := False;

  PE := TPEImage(APE);

  // Ensure we have all needed values set.
  PE.Defaults.SetAll;

  if not SaveHeaders(PE, AStream, true) then
    exit;

  // write sec hdr gap
  DoSecHdrGap(PE, AStream);

  // write sec data
  DoSecData(PE, AStream);

  Result := true;
end;

end.


text:
{
  This is unit to parse PEID signature base text file.
}
unit PE.ID;

interface

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

  PE.Common,
  PE.Image,
  PE.Section,
  PE.Search;

type
  TPEIDSignature = record
  public
    Text: string;
    Pattern: TBytes;
    Mask: TBytes;
  end;

  TPEIDSignatureList = TList<TPEIDSignature>;

  { Class which contain PEID signatures. }
  TPEIDSignatures = class
  private
    FSigsEpOnly: TPEIDSignatureList;
    FSigsAnywhere: TPEIDSignatureList;
  public
    constructor Create;
    destructor Destroy; override;

    property SigsEpOnly: TPEIDSignatureList read FSigsEpOnly;
    property SigsAnywhere: TPEIDSignatureList read FSigsAnywhere;
  end;

  {
    Try to load signatures.
    Returns nil if failed or created class on success.
  }
function PeidLoadSignatures(const SigFileName: string): TPEIDSignatures;

{
  Scan section at RVA for Signatures and return Found signature names.
}
procedure PeidScanSection(
  PE: TPEImage;
  RVA: TRVA;
  Signatures: TPEIDSignatureList;
  Found: TStringList);

procedure PeidScan(
  PE: TPEImage;
  Signatures: TPEIDSignatures;
  Found: TStringList);

implementation

{ For string like "key = value" return value }
function GetStrPairValue(const Line: string): string;
var
  a: integer;
begin
  a := Line.IndexOf('=');
  if a < 0 then
    result := ''
  else
    result := Line.Substring(a + 1).Trim;
end;

function PeidLoadSignatures(const SigFileName: string): TPEIDSignatures;
var
  sl: TStringList;
  i: integer;
  Line, PatternText: string;
  sig: TPEIDSignature;
  EntryPointOnly: Boolean;
begin
  result := nil;

  if not FileExists(SigFileName) then
    exit;

  { Do so simple parsing by loading into string list and parsing each line. }
  sl := TStringList.Create;
  try
    sl.LoadFromFile(SigFileName);
    i := 0;
    while i < sl.count do
    begin
      Line := sl[i];

      { Skip empty lines and comments }
      if Line.IsEmpty or Line.StartsWith(';') then
      begin
        inc(i);
        continue;
      end;

      { Expect signature text like [Some text] }
      if Line.StartsWith('[') and Line.EndsWith(']') then
      begin
        { This is 3-line signature descriptor. Check if we have 3 lines. }
        if i + 3 > sl.count then
        begin
          break;
        end;

        { Check format of next 2 lines }
        if
          (not sl[i + 1].StartsWith('signature = ')) or
          (not sl[i + 2].StartsWith('ep_only = ')) then
        begin
          break;
        end;

        { Check pattern format is correct and get fields. }
        PatternText := GetStrPairValue(sl[i + 1]);

        if not StringToPattern(PatternText, sig.Pattern, sig.Mask) then
        begin
          break;
        end;

        sig.Text := Line.Substring(1, Line.Length - 2);

        EntryPointOnly := GetStrPairValue(sl[i + 2]).ToLower = 'true';

        { Got at least one signature, add it to list }
        if not Assigned(result) then
          result := TPEIDSignatures.Create;

        if EntryPointOnly then
          result.FSigsEpOnly.Add(sig)
        else
          result.FSigsAnywhere.Add(sig);

        inc(i, 3);
      end;
    end;

    if Assigned(result) then
    begin
      result.FSigsEpOnly.TrimExcess;
      result.FSigsAnywhere.TrimExcess;
    end;
  finally
    sl.Free;
  end;
end;

procedure PeidScanSection(
  PE: TPEImage;
  RVA: TRVA;
  Signatures: TPEIDSignatureList;
  Found: TStringList);
var
  sec: TPESection;
  sig: TPEIDSignature;
  offset: uint32;
begin
  if not PE.RVAToSec(RVA, @sec) then
    exit;

  for sig in Signatures do
  begin
    offset := RVA - sec.RVA;
    if SearchBytes(sec, sig.Pattern, sig.Mask, offset, 0) then
    begin
      Found.Add(sig.Text);
    end;
  end;
end;

procedure PeidScan(
  PE: TPEImage;
  Signatures: TPEIDSignatures;
  Found: TStringList);
var
  sec: TPESection;
  sig: TPEIDSignature;
  offset: uint32;
begin
  if PE.Sections.count = 0 then
    exit;

  { First try EPOnly signatures }
  PeidScanSection(PE, PE.EntryPointRVA, Signatures.SigsEpOnly, Found);

  sec := PE.Sections.First;

  for sig in Signatures.SigsAnywhere do
  begin
    offset := 0;
    while SearchBytes(sec, sig.Pattern, sig.Mask, offset, 1) do
    begin
      inc(offset);
      Found.Add(sig.Text);
    end;
  end;
end;

{ TPEIDSignatures }

constructor TPEIDSignatures.Create;
begin
  inherited Create;
  FSigsEpOnly := TPEIDSignatureList.Create;
  FSigsAnywhere := TPEIDSignatureList.Create;
end;

destructor TPEIDSignatures.Destroy;
begin
  FSigsEpOnly.Free;
  FSigsAnywhere.Free;
  inherited;
end;

end.


text:
unit PE.Types.DOSHeader;

interface

type
  TDOSMagic = packed record
  public
    function IsMZ: boolean; inline;
    procedure SetMZ; inline;
  public
    case integer of
      0:
        (chars: array [0 .. 1] of AnsiChar);
  end;

type
  TImageDOSHeader = packed record
    e_magic: TDOSMagic;               // Magic number.
    e_cblp: uint16;                   // Bytes on last page of file.
    e_cp: uint16;                     // Pages in file.
    e_crlc: uint16;                   // Relocations.
    e_cparhdr: uint16;                // Size of header in paragraphs.
    e_minalloc: uint16;               // Minimum extra paragraphs needed.
    e_maxalloc: uint16;               // Maximum extra paragraphs needed.
    e_ss: uint16;                     // Initial (relative) SS value.
    e_sp: uint16;                     // Initial SP value.
    e_csum: uint16;                   // Checksum.
    e_ip: uint16;                     // Initial IP value.
    e_cs: uint16;                     // Initial (relative) CS value.
    e_lfarlc: uint16;                 // File address of relocation table.
    e_ovno: uint16;                   // Overlay number.
    e_res: array [0 .. 3] of uint16;  // Reserved words.
    e_oemid: uint16;                  // OEM identifier (for e_oeminfo).
    e_oeminfo: uint16;                // OEM information; e_oemid specific.
    e_res2: array [0 .. 9] of uint16; // Reserved words.
    e_lfanew: uint32;                 // File address of new exe header.
  end;

  PImageDOSHeader = ^TImageDOSHeader;

const
  DOSSTUB: packed array [0 .. 56] of byte = ($0E, $1F, $BA, $0E, $00, $B4, $09,
    $CD, $21, $B8, $01, $4C, $CD, $21, $54, $68, $69, $73, $20, $70, $72, $6F,
    $67, $72, $61, $6D, $20, $63, $61, $6E, $6E, $6F, $74, $20, $62, $65, $20,
    $72, $75, $6E, $20, $69, $6E, $20, $44, $4F, $53, $20, $6D, $6F, $64, $65,
    $2E, $0D, $0D, $0A, $24);

implementation

{ TDOSMagic }

function TDOSMagic.IsMZ: boolean;
begin
  result := self.chars = 'MZ';
end;

procedure TDOSMagic.SetMZ;
begin
  self.chars[0] := 'M';
  self.chars[1] := 'Z';
end;

end.


text:
{
  Building export table to stream.
  This stream can be later saved to section or replace old export table.

  todo: clear old export data
}

{$WARN COMBINING_SIGNED_UNSIGNED OFF}

unit PE.Build.Export;

interface

uses
  System.Classes,

  PE.Build.Common,
  PE.Common,
  PE.Utils;

type
  TExportBuilder = class(TDirectoryBuilder)
  public
    procedure Build(DirRVA: UInt64; Stream: TStream); override;
    class function GetDefaultSectionFlags: Cardinal; override;
    class function GetDefaultSectionName: string; override;
    class function NeedRebuildingIfRVAChanged: Boolean; override;
  end;

implementation

uses
  System.Generics.Defaults,
  System.Generics.Collections,
  System.SysUtils,
  PE.ExportSym,
  PE.Types.Export;

type
  TSym = record
    sym: TPEExportSym;
    nameRVA: TRVA;
  end;

  TSyms = TList<TSym>;

  { TExportBuilder }

procedure TExportBuilder.Build(DirRVA: UInt64; Stream: TStream);
var
  i: integer;
  ExpDir: TImageExportDirectory;
  ofs_SymRVAs: uint32;  // sym rvas offsets
  ofs_NameRVAs: uint32; // name rva offsets
  ofs_NameOrds: uint32; // name ordinals
  ofs_LibName: uint32;  // offset of address of names
  sym: TPEExportSym;
  rva32: uint32;
  RVAs: packed array of uint32;
  minIndex, maxIndex: word;
var
  nSyms: TSyms;
  nSym: TSym;
  ordinal: word;
begin
  nSyms := TSyms.Create;

  try
    // Collect named items.
    // Find min and max index.
    maxIndex := 0;
    if FPE.ExportSyms.Count = 0 then
      minIndex := 1
    else
      minIndex := $FFFF;

    for sym in FPE.ExportSyms.Items do
    begin
      nSym.sym := sym;
      nSym.nameRVA := 0;
      nSyms.Add(nSym);

      if sym.ordinal > maxIndex then
        maxIndex := sym.ordinal;
      if sym.ordinal < minIndex then
        minIndex := sym.ordinal;
    end;

    // Create RVAs.
    if maxIndex <> 0 then
    begin
      SetLength(RVAs, maxIndex);
      for i := 0 to FPE.ExportSyms.Count - 1 do
      begin
        sym := FPE.ExportSyms.Items[i];
        if sym.ordinal <> 0 then
          RVAs[sym.ordinal - minIndex] := sym.RVA;
      end;
    end;

    // Calc offsets.
    ofs_SymRVAs := SizeOf(ExpDir);
    ofs_NameRVAs := ofs_SymRVAs + Length(RVAs) * SizeOf(rva32);
    ofs_NameOrds := ofs_NameRVAs + nSyms.Count * SizeOf(rva32);
    ofs_LibName := ofs_NameOrds + nSyms.Count * SizeOf(ordinal);

    // Initial seek.
    Stream.Size := ofs_LibName;
    Stream.Position := ofs_LibName;

    // Write exported name.
    if FPE.ExportedName <> '' then
      StreamWriteStringA(Stream, FPE.ExportedName);

    // Sort nSyms by names (lexicographical order) to allow binary searches.
    nSyms.Sort(TComparer<TSym>.Construct(
      function(const a, b: TSym): integer
      begin
        Result := CompareStr(a.sym.Name, b.sym.Name)
      end
      ));

    // Write names.
    for i := 0 to nSyms.Count - 1 do
    begin
      nSym := nSyms[i];
      nSym.nameRVA := DirRVA + Stream.Position;
      nSyms[i] := nSym;
      StreamWriteStringA(Stream, nSym.sym.Name);
    end;

    // Write forwarder names.
    for i := 0 to nSyms.Count - 1 do
    begin
      nSym := nSyms[i];
      if nSym.sym.Forwarder then
      begin
        RVAs[nSym.sym.ordinal - minIndex] := DirRVA + Stream.Position;
        StreamWriteStringA(Stream, nSym.sym.ForwarderName);
      end;
    end;

    // Fill export dir.
    ExpDir.ExportFlags := 0;
    ExpDir.TimeDateStamp := 0;
    ExpDir.MajorVersion := 0;
    ExpDir.MinorVersion := 0;
    if FPE.ExportedName <> '' then
      ExpDir.nameRVA := DirRVA + ofs_LibName
    else
      ExpDir.nameRVA := 0;
    ExpDir.OrdinalBase := minIndex;
    ExpDir.AddressTableEntries := Length(RVAs);
    ExpDir.NumberOfNamePointers := nSyms.Count;
    ExpDir.ExportAddressTableRVA := DirRVA + ofs_SymRVAs;
    ExpDir.NamePointerRVA := DirRVA + ofs_NameRVAs;
    ExpDir.OrdinalTableRVA := DirRVA + ofs_NameOrds;

    // Seek start.
    Stream.Position := 0;

    // Write export dir.
    Stream.Write(ExpDir, SizeOf(ExpDir));

    // Write RVAs of all symbols.
    StreamWrite(Stream, RVAs[0], Length(RVAs) * SizeOf(RVAs[0]));

    // Write name RVAs.
    for i := 0 to nSyms.Count - 1 do
    begin
      nSym := nSyms[i];
      rva32 := nSym.nameRVA;
      StreamWrite(Stream, rva32, SizeOf(rva32));
    end;

    // Write name ordinals.
    for i := 0 to nSyms.Count - 1 do
    begin
      nSym := nSyms[i];
      ordinal := nSym.sym.ordinal - minIndex;
      StreamWrite(Stream, ordinal, SizeOf(ordinal));
    end;

  finally
    nSyms.Free;
  end;
end;

class function TExportBuilder.GetDefaultSectionFlags: Cardinal;
begin
  Result := $40000040; // readable, initialized data
end;

class function TExportBuilder.GetDefaultSectionName: string;
begin
  Result := '.edata';
end;

class function TExportBuilder.NeedRebuildingIfRVAChanged: Boolean;
begin
  Result := True;
end;

end.


text:
unit PE.Resources.Windows.Bitmap;

interface

uses
  System.Classes,
  System.SysUtils,

  PE.Utils;

// Parse RT_BITMAP into BMP stream.
function ParseBitmapResource(const Stream: TStream): TStream;

implementation

{$ALIGN 1}

type
  TBitmapFileHeader = record
    bfType: uint16;      // BM
    bfSize: uint32;      // Size of bitmap file/stream.
    bfReserved1: uint16; //
    bfReserved2: uint16; //
    bfOffBits: uint32;   // Offset of pixels.
  end;

  TBitmapInfoHeader = record
    biSize: uint32;
    biWidth: int32;
    biHeight: int32;
    biPlanes: uint16;
    biBitCount: uint16;
    biCompression: uint32;
    biSizeImage: uint32;
    biXPelsPerMeter: int32;
    biYPelsPerMeter: int32;
    biClrUsed: uint32;
    biClrImportant: uint32;
  end;

function ParseBitmapResource(const Stream: TStream): TStream;
var
  BmpHdr: TBitmapFileHeader;
  InfoHdr: TBitmapInfoHeader;
begin
  if not StreamRead(Stream, InfoHdr, SizeOf(InfoHdr)) then
    raise Exception.Create('Stream too small.');

  BmpHdr.bfType := $4D42; // BM
  BmpHdr.bfSize := SizeOf(TBitmapFileHeader) + Stream.Size;
  BmpHdr.bfReserved1 := 0;
  BmpHdr.bfReserved2 := 0;
  BmpHdr.bfOffBits := 0; // Nowadays viewers are smart enough to calc this offset themselves.

  // Create bitmap.
  Stream.Position := 0;
  Result := TMemoryStream.Create;
  Result.Write(BmpHdr, SizeOf(BmpHdr));
  Result.CopyFrom(Stream, Stream.Size);

  Result.Position := 0;
end;

end.


text:
{
  *
  * verrsrc.h -   Version Resource definitions
  *
  *               Include file declaring version resources in rc files
  *
  *               Copyright (c) Microsoft Corporation. All rights reserved.
  *
}

const

  (* ----- Symbols ----- *)
  // VS_FILE_INFO            = RT_VERSION;
  VS_VERSION_INFO = 1;
  VS_USER_DEFINED = 100;

  (* ----- VS_VERSION.dwFileFlags ----- *)
{$IFNDEF _MAC}
  VS_FFI_SIGNATURE = $FEEF04BD;
{$ELSE}
  VS_FFI_SIGNATURE = $BD04EFFE;
{$ENDIF}
  VS_FFI_STRUCVERSION  = $00010000;
  VS_FFI_FILEFLAGSMASK = $0000003F;

  (* ----- VS_VERSION.dwFileFlags ----- *)
  VS_FF_DEBUG        = $00000001;
  VS_FF_PRERELEASE   = $00000002;
  VS_FF_PATCHED      = $00000004;
  VS_FF_PRIVATEBUILD = $00000008;
  VS_FF_INFOINFERRED = $00000010;
  VS_FF_SPECIALBUILD = $00000020;

  (* ----- VS_VERSION.dwFileOS ----- *)
  VOS_UNKNOWN = $00000000;
  VOS_DOS     = $00010000;
  VOS_OS216   = $00020000;
  VOS_OS232   = $00030000;
  VOS_NT      = $00040000;
  VOS_WINCE   = $00050000;

  VOS__BASE      = $00000000;
  VOS__WINDOWS16 = $00000001;
  VOS__PM16      = $00000002;
  VOS__PM32      = $00000003;
  VOS__WINDOWS32 = $00000004;

  VOS_DOS_WINDOWS16 = $00010001;
  VOS_DOS_WINDOWS32 = $00010004;
  VOS_OS216_PM16    = $00020002;
  VOS_OS232_PM32    = $00030003;
  VOS_NT_WINDOWS32  = $00040004;

  (* ----- VS_VERSION.dwFileType ----- *)
  VFT_UNKNOWN    = $00000000;
  VFT_APP        = $00000001;
  VFT_DLL        = $00000002;
  VFT_DRV        = $00000003;
  VFT_FONT       = $00000004;
  VFT_VXD        = $00000005;
  VFT_STATIC_LIB = $00000007;

  (* ----- VS_VERSION.dwFileSubtype for VFT_WINDOWS_DRV ----- *)
  VFT2_UNKNOWN               = $00000000;
  VFT2_DRV_PRINTER           = $00000001;
  VFT2_DRV_KEYBOARD          = $00000002;
  VFT2_DRV_LANGUAGE          = $00000003;
  VFT2_DRV_DISPLAY           = $00000004;
  VFT2_DRV_MOUSE             = $00000005;
  VFT2_DRV_NETWORK           = $00000006;
  VFT2_DRV_SYSTEM            = $00000007;
  VFT2_DRV_INSTALLABLE       = $00000008;
  VFT2_DRV_SOUND             = $00000009;
  VFT2_DRV_COMM              = $0000000A;
  VFT2_DRV_INPUTMETHOD       = $0000000B;
  VFT2_DRV_VERSIONED_PRINTER = $0000000C;

  (* ----- VS_VERSION.dwFileSubtype for VFT_WINDOWS_FONT ----- *)
  VFT2_FONT_RASTER   = $00000001;
  VFT2_FONT_VECTOR   = $00000002;
  VFT2_FONT_TRUETYPE = $00000003;

  (* ----- VerFindFile() flags ----- *)
  VFFF_ISSHAREDFILE = $0001;

  VFF_CURNEDEST    = $0001;
  VFF_FILEINUSE    = $0002;
  VFF_BUFFTOOSMALL = $0004;

  (* ----- VerInstallFile() flags ----- *)
  VIFF_FORCEINSTALL  = $0001;
  VIFF_DONTDELETEOLD = $0002;

  VIF_TEMPFILE = $00000001;
  VIF_MISMATCH = $00000002;
  VIF_SRCOLD   = $00000004;

  VIF_DIFFLANG   = $00000008;
  VIF_DIFFCODEPG = $00000010;
  VIF_DIFFTYPE   = $00000020;

  VIF_WRITEPROT        = $00000040;
  VIF_FILEINUSE        = $00000080;
  VIF_OUTOFSPACE       = $00000100;
  VIF_ACCESSVIOLATION  = $00000200;
  VIF_SHARINGVIOLATION = $00000400;
  VIF_CANNOTCREATE     = $00000800;
  VIF_CANNOTDELETE     = $00001000;
  VIF_CANNOTRENAME     = $00002000;
  VIF_CANNOTDELETECUR  = $00004000;
  VIF_OUTOFMEMORY      = $00008000;

  VIF_CANNOTREADSRC = $00010000;
  VIF_CANNOTREADDST = $00020000;

  VIF_BUFFTOOSMALL      = $00040000;
  VIF_CANNOTLOADLZ32    = $00080000;
  VIF_CANNOTLOADCABINET = $00100000;

{$IFNDEF RC_INVOKED}              (* RC doesn't need to see the rest of this *)

  (*
    FILE_VER_GET_... flags are for use by
    GetFileVersionInfoSizeEx
    GetFileVersionInfoExW
  *)
  FILE_VER_GET_LOCALISED  = $01;
  FILE_VER_GET_NEUTRAL    = $02;
  FILE_VER_GET_PREFETCHED = $04;

  (* ----- Types and structures ----- *)

type
  tagVS_FIXEDFILEINFO = packed record
    dwSignature: uint32;        (* e.g. =$feef04bd *)
    dwStrucVersion: uint32;     (* e.g. =$00000042 = "0.42" *)
    dwFileVersionMS: uint32;    (* e.g. =$00030075 = "3.75" *)
    dwFileVersionLS: uint32;    (* e.g. =$00000031 = "0.31" *)
    dwProductVersionMS: uint32; (* e.g. =$00030010 = "3.10" *)
    dwProductVersionLS: uint32; (* e.g. =$00000031 = "0.31" *)
    dwFileFlagsMask: uint32;    (* = $3F for version "0.42" *)
    dwFileFlags: uint32;        (* e.g. VFF_DEBUG | VFF_PRERELEASE *)
    dwFileOS: uint32;           (* e.g. VOS_DOS_WINDOWS16 *)
    dwFileType: uint32;         (* e.g. VFT_DRIVER *)
    dwFileSubtype: uint32;      (* e.g. VFT2_DRV_KEYBOARD *)
    dwFileDateMS: uint32;       (* e.g. 0 *)
    dwFileDateLS: uint32;       (* e.g. 0 *)
  end;

  VS_FIXEDFILEINFO = tagVS_FIXEDFILEINFO;

{$ENDIF}  (* !RC_INVOKED *)


text:
{
  * Class to access memory of Windows process.
  *
  * Stream begin is base of module.
  * Stream size is size of image of target module.
}
unit PE.ProcessModuleStream;

interface

uses
  System.Classes,
  System.SysUtils,

  WinApi.PsApi,
  WinApi.TlHelp32,
  WinApi.Windows,

  WinHelper;

type
  TProcessModuleStream = class(TStream)
  private
    FProcessHandle: THandle;
    FModuleBase: NativeUInt;
    FModuleSize: DWORD;
  private
    FCurrentRVA: UInt64;
  public
    constructor Create(ProcessID: DWORD; const me: TModuleEntry32);

    // Create from known process ID. Module base is found from ModuleName.
    // If process id is invalid or no module found exception raised.
    constructor CreateFromPidAndModuleName(ProcessID: DWORD; const ModuleName: string);

    constructor CreateFromPidAndAddress(ProcessID: DWORD; Address: NativeUInt);

    // Create from known process id. Main module used (i.e. started exe).
    constructor CreateFromPid(ProcessID: DWORD);

    destructor Destroy; override;

    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
    function Read(var Buffer; Count: Longint): Longint; override;

    property ModuleBase: NativeUInt read FModuleBase;
  end;

implementation

{ TProcessModuleStream }

procedure RaiseFailedToFindModule;
begin
  raise Exception.Create('Failed to find main module.');
end;

constructor TProcessModuleStream.Create(ProcessID: DWORD; const me: TModuleEntry32);
begin
  inherited Create;
  FProcessHandle := OpenProcess(MAXIMUM_ALLOWED, False, ProcessID);
  if FProcessHandle = 0 then
    RaiseLastOSError;
  FModuleBase := NativeUInt(me.modBaseAddr);
  FModuleSize := me.modBaseSize;
end;

constructor TProcessModuleStream.CreateFromPidAndModuleName(ProcessID: DWORD; const ModuleName: string);
var
  me: TModuleEntry32;
begin
  if not FindModuleByName(ProcessID, ModuleName) then
    RaiseFailedToFindModule;
  Create(ProcessID, me);
end;

constructor TProcessModuleStream.CreateFromPidAndAddress(ProcessID: DWORD; Address: NativeUInt);
var
  me: TModuleEntry32;
begin
  if not FindModuleByAddress(ProcessID, Address, me) then
    RaiseFailedToFindModule;
  Create(ProcessID, me);
end;

constructor TProcessModuleStream.CreateFromPid(ProcessID: DWORD);
var
  me: TModuleEntry32;
begin
  if not FindMainModule(ProcessID, me) then
    RaiseFailedToFindModule;
  Create(ProcessID, me);
end;

destructor TProcessModuleStream.Destroy;
begin
  CloseHandle(FProcessHandle);
  inherited;
end;

function TProcessModuleStream.Read(var Buffer; Count: Integer): Longint;
var
  p: pbyte;
  done: NativeUInt;
begin
  p := pbyte(FModuleBase) + FCurrentRVA;
  done := 0;
  ReadProcessMemory(FProcessHandle, p, @Buffer, Count, done);
  inc(FCurrentRVA, done);
  Result := done;
end;

function TProcessModuleStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
  case Origin of
    soBeginning:
      FCurrentRVA := Offset;
    soCurrent:
      FCurrentRVA := FCurrentRVA + Offset;
    soEnd:
      FCurrentRVA := FModuleSize + Offset;
  end;
  Result := FCurrentRVA;
end;

end.


text:
unit PE.Types.Imports;

interface

{ 5.4.1. Import Directory Table }
type
  TImportType = (itNoBinding, itOldBinding, itNewBinding);

  TImportDirectoryTable = packed record
  public
    // The RVA of the import lookup table. This table contains
    // a name or ordinal for each import.

    ImportLookupTableRVA: uint32; // OriginalFirstThunk, old (Characteristics)

    // The stamp that is set to zero until the image is bound.
    // After the image is bound, this field is set to the time/data
    // stamp of the DLL.
    TimeDateStamp: uint32;

    // The index of the first forwarder reference.
    ForwarderChain: uint32;

    // The address of an ASCII string that contains the name
    // of the DLL. This address is relative to the image base.
    NameRVA: uint32;

    // (Thunk Table); The RVA of the import address table.
    // The contents of this table are identical to the contents of
    // the import lookup table until the image is bound.

    ImportAddressTable: uint32; // First thunk

    function IsEmpty: boolean; inline;
    function IsBound: boolean; inline;
    function GetType: TImportType; inline;
    procedure Clear; inline;

    property FirstThunk: uint32 read ImportAddressTable;
    property OriginalFirstThunk: uint32 read ImportLookupTableRVA;
  end;
  PImportDirectoryTable = ^TImportDirectoryTable;

  { 5.4.2. Import Lookup Table }
  TImportLookupTable = packed record
  private
    FData: uint64; // 32/64 bits
    FIs32: boolean;
  public
    procedure Create(Data: uint64; Is32: boolean); inline;
    function IsEmpty: boolean; inline;
    function IsImportByOrdinal: boolean; inline;
    function IsImportByName: boolean; inline;
    function OrdinalNumber: uint16; inline; // only if import by ordinal
    function HintNameTableRVA: uint32;      // inline; // only if import by name
  end;

  { 5.4.3. Hint/Name Table }
  THintNameTable = packed record
  public
    // An index into the export name pointer table. A match is attempted
    // first with this value. If it fails, a binary search is performed
    // on the DLL’s export name pointer table.
    Hint: uint16;

    // An ASCII string that contains the name to import. This is
    // the string that must be matched to the public name in the DLL.
    // This string is case sensitive and terminated by a null byte.
    Name: String;

    { Pad : 0/1 bytes }
  end;

implementation

{ TImportLookupTable }

procedure TImportLookupTable.Create(Data: uint64; Is32: boolean);
begin
  FData := Data;
  FIs32 := Is32;
end;

function TImportLookupTable.HintNameTableRVA: uint32;
begin
  if IsImportByName then
    result := FData and $7FFFFFFF // for both 32 and 64 bit images
  else
    result := 0;
end;

function TImportLookupTable.IsEmpty: boolean;
begin
  result := FData = 0;
end;

function TImportLookupTable.IsImportByName: boolean;
begin
  result := not IsImportByOrdinal;
end;

function TImportLookupTable.IsImportByOrdinal: boolean;
begin
  if FIs32 then
    result := (FData and $80000000) <> 0
  else
    result := (FData and $8000000000000000) <> 0;
end;

function TImportLookupTable.OrdinalNumber: uint16;
begin
  if IsImportByOrdinal then
    result := FData and $FFFF
  else
    result := 0;
end;

{ TImportDirectoryTable }

procedure TImportDirectoryTable.Clear;
begin
  FillChar(self, SizeOf(self), 0);
end;

function TImportDirectoryTable.IsBound: boolean;
begin
  result := TimeDateStamp <> 0;
end;

function TImportDirectoryTable.GetType: TImportType;
begin
  case TimeDateStamp of
    0:
      result := itNoBinding;
    $FFFFFFFF:
      result := itNewBinding;
  else
    result := itOldBinding;
  end;
end;

function TImportDirectoryTable.IsEmpty: boolean;
begin
  Result := NameRva = 0;
end;

end.


text:
unit PE.TLS;

interface

uses
  PE.Types,
  PE.Types.TLS;

type
  TTLS = class
  public
    Dir: TTLSDirectory;
    CallbackRVAs: TRVAs;
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
  end;

implementation

procedure TTLS.Clear;
begin
  FillChar(Dir, SizeOf(Dir), 0);
  CallbackRVAs.Clear;
end;

constructor TTLS.Create;
begin
  CallbackRVAs := TRVAs.Create;
end;

destructor TTLS.Destroy;
begin
  CallbackRVAs.Free;
  inherited Destroy;
end;

end.


text:
unit PE.Parser.Resources;

interface

uses
  System.SysUtils,
  PE.Common,
  PE.Types,
  PE.Types.Directories,
  PE.Types.Resources,
  PE.Resources;

type
  TPEResourcesParser = class(TPEParser)
  protected
    FBaseRVA: TRVA; // RVA of RSRC section base
    FTree: TResourceTree;

    // Read resource node entry.
    function ReadEntry(
      ParentNode: TResourceTreeBranchNode;
      RVA: TRVA;
      Index: integer;
      RDT: PResourceDirectoryTable): TResourceTreeNode;

    // Read resource node.
    function ReadNode(
      ParentNode: TResourceTreeBranchNode;
      RVA: TRVA): TParserResult;

    function LogInvalidResourceSizesTraverse(Node: TResourceTreeNode): boolean;
    procedure LogInvalidResourceSizes;
  public
    function Parse: TParserResult; override;
  end;

implementation

uses
  PE.Image;

{ TPEResourcesParser }

procedure TPEResourcesParser.LogInvalidResourceSizes;
begin
  FTree.Root.Traverse(LogInvalidResourceSizesTraverse);
end;

function TPEResourcesParser.LogInvalidResourceSizesTraverse(Node: TResourceTreeNode): boolean;
begin
  if Node.IsLeaf then
    if not TResourceTreeLeafNode(Node).ValidSize then
      TPEImage(FPE).Msg.Write(SCategoryResources, 'Bad size of resource (probably packed): %s', [Node.GetPath]);

  Result := True;
end;

function TPEResourcesParser.Parse: TParserResult;
var
  Img: TPEImage;
  dir: TImageDataDirectory;
begin
  Img := TPEImage(FPE);

  // Check if directory present.
  if not Img.DataDirectories.Get(DDIR_RESOURCE, @dir) then
    exit(PR_OK);

  if dir.IsEmpty then
    exit(PR_OK);

  // Store base RVA.
  FBaseRVA := dir.VirtualAddress;

  // Try to seek resource dir.
  if not Img.SeekRVA(FBaseRVA) then
    exit(PR_ERROR);

  // Read root and children.
  FTree := Img.ResourceTree;
  ReadNode(FTree.Root, FBaseRVA);

  // Log invalid leaf nodes.
  LogInvalidResourceSizes;

  exit(PR_OK);
end;

function TPEResourcesParser.ReadEntry(
  ParentNode: TResourceTreeBranchNode;
  RVA: TRVA;
  Index: integer;
  RDT: PResourceDirectoryTable): TResourceTreeNode;
var
  Img: TPEImage;
  Entry: TResourceDirectoryEntry;
  DataEntry: TResourceDataEntry;
  SubRVA, DataRVA, NameRVA: TRVA;
  LeafNode: TResourceTreeLeafNode;
  BranchNode: TResourceTreeBranchNode;
  EntryName: string;
begin
  Result := nil;
  Img := TPEImage(FPE);

  // Try to read entry.
  if not Img.SeekRVA(RVA + Index * SizeOf(Entry)) then
  begin
    Img.Msg.Write(SCategoryResources, 'Bad resource entry RVA.');
    exit;
  end;

  if not Img.ReadEx(@Entry, SizeOf(Entry)) then
  begin
    Img.Msg.Write(SCategoryResources, 'Bad resource entry.');
    exit;
  end;

  // Prepare entry name.
  EntryName := '';
  if Entry.EntryType = ResourceEntryByName then
  begin
    NameRVA := FBaseRVA + Entry.NameRVA;
    if not Img.SeekRVA(NameRVA) then
    begin
      Img.Msg.Write(SCategoryResources, 'Bad entry name RVA (0x%x)', [NameRVA]);
      exit;
    end;
    EntryName := Img.ReadUnicodeStringLenPfx2;
  end;

  // Check if RVA of child is correct.
  DataRVA := Entry.DataEntryRVA + FBaseRVA;
  if not Img.RVAExists(DataRVA) then
  begin
    Img.Msg.Write(SCategoryResources, 'Bad entry RVA (0x%x)', [DataRVA]);
    exit;
  end;

  // Handle Leaf or Branch.
  if Entry.IsDataEntryRVA then
  begin
    {
      Leaf node
    }

    DataRVA := Entry.DataEntryRVA + FBaseRVA;
    if not(Img.SeekRVA(DataRVA) and Img.ReadEx(@DataEntry, SizeOf(DataEntry))) then
    begin
      Img.Msg.Write(SCategoryResources, 'Bad resource leaf node.');
      exit;
    end;
    LeafNode := TResourceTreeLeafNode.CreateFromEntry(FPE, DataEntry);
    Result := LeafNode;
  end
  else
  begin
    {
      Branch Node.
    }

    // Alloc and fill node.
    BranchNode := TResourceTreeBranchNode.Create;
    if RDT <> nil then
    begin
      BranchNode.Characteristics := RDT^.Characteristics;
      BranchNode.TimeDateStamp := RDT^.TimeDateStamp;
      BranchNode.MajorVersion := RDT^.MajorVersion;
      BranchNode.MinorVersion := RDT^.MinorVersion;
    end;
    // Get sub-level RVA.
    SubRVA := Entry.SubdirectoryRVA + FBaseRVA;
    // Read children.
    ReadNode(BranchNode, SubRVA);
    Result := BranchNode;
  end;

  // Set id or name.
  if Entry.EntryType = ResourceEntryById then
    Result.Id := Entry.IntegerID
  else
    Result.Name := EntryName;

  // Add node.
  ParentNode.Add(Result);
end;

function TPEResourcesParser.ReadNode(ParentNode: TResourceTreeBranchNode; RVA: TRVA): TParserResult;
var
  Img: TPEImage;
  RDT: TResourceDirectoryTable;
  i, Total: integer;
begin
  Img := TPEImage(FPE);

  if not Img.SeekRVA(RVA) then
  begin
    Img.Msg.Write(SCategoryResources, 'Bad resource directory table RVA (0x%x)', [RVA]);
    exit(PR_ERROR);
  end;

  // Read Directory Table.
  if not Img.ReadEx(@RDT, SizeOf(RDT)) then
  begin
    Img.Msg.Write(SCategoryResources, 'Failed to read resource directory table.');
    exit(PR_ERROR);
  end;

  inc(RVA, SizeOf(RDT));

  if (RDT.NumberOfNameEntries = 0) and (RDT.NumberOfIDEntries = 0) then
  begin
    Img.Msg.Write(SCategoryResources, 'Node have no name/id entries.');
    exit(PR_ERROR);
  end;

  // Total number of entries.
  Total := RDT.NumberOfNameEntries + RDT.NumberOfIDEntries;

  // Read entries.
  for i := 0 to Total - 1 do
    if ReadEntry(ParentNode, RVA, i, @RDT) = nil then
      exit(PR_ERROR);

  exit(PR_OK);
end;

end.


text:
unit PE.Image.Defaults;

interface

type
  TPEDefaults = record
  private
    FPE: TObject;
  public
    constructor Create(PEImage: TObject);

    procedure SetImageBits;
    procedure SetFileAlignment;
    procedure SetSectionAlignment;
    procedure SetFileHdr;
    procedure SetOptionalHeader;
    procedure SetLFANew;

    procedure SetAll;
  end;

implementation

uses
  // Expand
  PE.Headers,
  //
  PE.Common,
  PE.Image,
  PE.Types.DOSHeader,
  PE.Types.FileHeader;

{ TPEDefaults }

constructor TPEDefaults.Create(PEImage: TObject);
begin
  FPE := PEImage;
end;

procedure TPEDefaults.SetAll;
begin
  SetLFANew;
  SetImageBits;
  SetFileAlignment;
  SetSectionAlignment;
  SetFileHdr;
  SetOptionalHeader;

  TPEImage(FPE).DataDirectories.Put(15, 0, 0); // 16 directories by default
end;

procedure TPEDefaults.SetFileAlignment;
begin
  with TPEImage(FPE) do
    if FileAlignment = 0 then
      FileAlignment := DEFAULT_SECTOR_SIZE;
end;

procedure TPEDefaults.SetFileHdr;
begin
  with TPEImage(FPE).FileHeader^ do
  begin
    if Machine = 0 then
      Machine := IMAGE_FILE_MACHINE_I386;
    if Characteristics = 0 then
      Characteristics := IMAGE_FILE_RELOCS_STRIPPED +
        IMAGE_FILE_EXECUTABLE_IMAGE + IMAGE_FILE_32BIT_MACHINE;
  end;
end;

procedure TPEDefaults.SetImageBits;
begin
  with TPEImage(FPE) do
    if ImageBits = 0 then
      ImageBits := 32;
end;

procedure TPEDefaults.SetLFANew;
begin
  if TPEImage(FPE).LFANew = 0 then
    TPEImage(FPE).LFANew := SizeOf(TImageDosHeader);
end;

procedure TPEDefaults.SetOptionalHeader;
begin
  with TPEImage(FPE).OptionalHeader^ do
  begin
    if MajorSubsystemVersion = 0 then
      MajorSubsystemVersion := 4;
    if SizeOfStackCommit = 0 then
      SizeOfStackCommit := $1000;
    if SizeOfHeapReserve = 0 then
      SizeOfHeapReserve := $100000;
    if Subsystem = 0 then
      Subsystem := IMAGE_SUBSYSTEM_WINDOWS_GUI;
    if ImageBase = 0 then
      ImageBase := $400000;
  end;
end;

procedure TPEDefaults.SetSectionAlignment;
begin
  with TPEImage(FPE) do
    if SectionAlignment = 0 then
      SectionAlignment := DEFAULT_PAGE_SIZE;
end;

end.


text:
unit PE.ParserCallbacks;

interface

uses
  PE.Common,
  PE.Types.Relocations;

type
  IPEParserCallbacks = interface
    procedure ParsedRelocationBlockHeader(RVA: TRVA; const Block: TBaseRelocationBlock);
  end;

implementation

end.


text:
unit PE.Types.Directories;

interface

type
  TImageDataDirectory = packed record
    RVA: uint32;
    Size: uint32;
    function IsEmpty: boolean; inline;
    function Contain(rva: uint32): boolean; inline;

    // todo: VirtualAddress is deprecated, use RVA instead.
    property VirtualAddress: uint32 read RVA write RVA;
  end;

  PImageDataDirectory = ^TImageDataDirectory;

type
  // 2.4.3. Optional Header Data Directories (Image Only)

  // variant #1
  TImageDataDirectories = packed record
    ExportTable: TImageDataDirectory;         // The export table address and size.
    ImportTable: TImageDataDirectory;         // The import table address and size.
    ResourceTable: TImageDataDirectory;       // The resource table address and size.
    ExceptionTable: TImageDataDirectory;      // The exception table address and size.
    CertificateTable: TImageDataDirectory;    // The attribute certificate table address and size.
    BaseRelocationTable: TImageDataDirectory; // The base relocation table address and size.
    Debug: TImageDataDirectory;               // The debug data starting address and size.
    Architecture: TImageDataDirectory;        // Reserved, must be 0
    GlobalPtr: TImageDataDirectory;           // The RVA of the value to be stored in the global pointer register.
    // The size member of this structure must be set to zero.
    TLSTable: TImageDataDirectory;              // The thread local storage (TLS) table address and size.
    LoadConfigTable: TImageDataDirectory;       // The load configuration table address and size.
    BoundImport: TImageDataDirectory;           // The bound import table address and size.
    IAT: TImageDataDirectory;                   // The import address table address and size.
    DelayImportDescriptor: TImageDataDirectory; // The delay import descriptor address and size.
    CLRRuntimeHeader: TImageDataDirectory;      // The CLR runtime header address and size.
    RESERVED: TImageDataDirectory;              // Reserved, must be zero
  end;

  PImageDataDirectories = ^TImageDataDirectories;

const
  NULL_IMAGE_DATA_DIRECTORY: TImageDataDirectory = (RVA: 0; Size: 0);

  IMAGE_NUMBEROF_DIRECTORY_ENTRIES = 16;

  TYPICAL_NUMBER_OF_DIRECTORIES = IMAGE_NUMBEROF_DIRECTORY_ENTRIES;

  // variant #2
  // TImageDataDirectories = packed array [0 .. IMAGE_NUMBEROF_DIRECTORY_ENTRIES-1] of TImageDataDirectory;

// Get directory name by index or format index as a string (like dir_0001) if
// it's not in range of known names.
function GetDirectoryName(Index: integer): string;

implementation

uses
  System.SysUtils;

function TImageDataDirectory.Contain(rva: uint32): boolean;
begin
  Result := (rva >= Self.VirtualAddress) and (rva < Self.VirtualAddress + Self.Size);
end;

function TImageDataDirectory.IsEmpty: boolean;
begin
  // In some cases Size can be 0, but VirtualAddress will point to valid data.
  Result := (VirtualAddress = 0);
end;

const
  DirectoryNames: array [0 .. IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1] of string =
    (
    'Export',
    'Import',
    'Resource',
    'Exception',
    'Certificate',
    'Base Relocation',
    'Debug',
    'Architecture',
    'Global Pointer',
    'Thread Local Storage',
    'Load Config',
    'Bound Import',
    'Import Address Table',
    'Delay Import Descriptor',
    'CLR Runtime Header',
    ''
    );

function GetDirectoryName(Index: integer): string;
begin
  if (Index >= 0) and (Index < Length(DirectoryNames)) then
    Result := DirectoryNames[Index]
  else
    Result := format('dir_%4.4d', [index]);
end;

end.


text:
unit PE.COFF;

interface

uses
  System.Classes,
  System.SysUtils,
  PE.COFF.Types;

type
  TCOFF = class
  private
    FPE: TObject;
    FStrings: TBytes;
    procedure LoadStrings(AStream: TStream);
  public
    constructor Create(PEImage: TObject);

    procedure Clear;
    procedure LoadFromStream(AStream: TStream);

    function GetString(Offset: integer; out Str: String): boolean;
  end;

implementation

uses
  // Expand
  PE.Types.FileHeader,
  //
  PE.Common,
  PE.Image,
  PE.Utils;

{ TCOFF }

procedure TCOFF.Clear;
begin
  SetLength(FStrings, 0);
end;

constructor TCOFF.Create(PEImage: TObject);
begin
  self.FPE := PEImage;
end;

function TCOFF.GetString(Offset: integer; out Str: String): boolean;
begin
  Result := (Offset >= 0) and (Offset < Length(FStrings));
  if Result then
    Str := String(PAnsiChar(@FStrings[Offset]));
end;

procedure TCOFF.LoadFromStream(AStream: TStream);
begin
  LoadStrings(AStream);
end;

procedure TCOFF.LoadStrings(AStream: TStream);
var
  StrTableOfs, EndPos: uint64;
  cbStringData: uint32;
  FileHdr: TImageFileHeader;
begin
  Clear;

  // 4.6. COFF String Table

  FileHdr := TPEImage(FPE).FileHeader^;

  if FileHdr.PointerToSymbolTable = 0 then
    exit;

  if FileHdr.PointerToSymbolTable >= AStream.Size then
  begin
    TPEImage(FPE).Msg.Write('[FileHeader] Bad PointerToSymbolTable (0x%x)', [FileHdr.PointerToSymbolTable]);
    exit;
  end;

  StrTableOfs :=
    FileHdr.PointerToSymbolTable +
    FileHdr.NumberOfSymbols * SizeOf(TCOFFSymbolTable);

  if not StreamSeek(AStream, StrTableOfs) then
    exit; // table not found

  if not StreamPeek(AStream, cbStringData, SizeOf(cbStringData)) then
    exit;

  EndPos := AStream.Position + cbStringData;

  if EndPos > AStream.Size then
    exit;

  // Load string block.
  if cbStringData <> 0 then
  begin
    SetLength(FStrings, cbStringData);
    StreamRead(AStream, FStrings[0], cbStringData);
  end;
end;

end.


text:
unit PE.Search;

interface

uses
  System.SysUtils,
  PE.Section;

{
  *
  * Search byte pattern in ASection starting from AOffset.
  * Result is True if found and false otherwise.
  * AOffset will be set to last position scanned.
  *
  * Each byte of AMask is AND'ed with source byte and compared to pattern.
  * AMask can be smaller than APattern (or empty), but cannot be bigger.
  *
  * ADirection can be negative or positive to choose search direction.
  * If it is 0 the only match checked.
  *
  * Example:
  *
  *              AA ?? BB should be represented like:
  *   APattern:  AA 00 BB
  *   AMask:     AA 00 BB
  *
  *              AA 00 BB should be represented like:
  *   APattern:  AA 00 BB
  *   AMask:     AA FF BB
  *
}
function SearchBytes(
  const ASection: TPESection;
  const APattern: array of byte;
  const AMask: array of byte;
  var AOffset: UInt32;
  ADirection: Integer
  ): boolean;

{
  * Check string contains valid pattern text and return number of elements on
  * success. Result is 0 if pattern text is invalid or string is empty.
}
function ValidatePattern(const S: string): Integer;

{
  * Convert string like AA??BB (or AA ?? BB)
  * to pattern          AA00BB
  * and mask            FF00FF
  *
  * String must not contain spaces.
  * Output length of Pattern and Mask is same.
}
function StringToPattern(
  const S: string;
  out Pattern: TBytes;
  out Mask: TBytes): boolean;

implementation

function MatchPattern(
  pSrc: pbyte;
  const APattern: array of byte;
  const AMask: array of byte
  ): boolean;
var
  MaskLeft: Integer;
  Mask: byte;
  i: Integer;
begin
  Result := True;

  MaskLeft := Length(AMask);
  for i := 0 to High(APattern) do
  begin
    if MaskLeft <> 0 then
      Mask := AMask[i]
    else
      Mask := $FF;

    if (pSrc[i] and Mask) <> APattern[i] then
    begin
      Result := False;
      break;
    end;

    if MaskLeft <> 0 then
      dec(MaskLeft);
  end;
end;

function SearchBytes;
var
  pSrc: pbyte;
  LastOffset: UInt32;
begin
  Result := False;

  if Length(APattern) = 0 then
    Exit;

  if (AOffset + Length(APattern)) > ASection.AllocatedSize then
    Exit;

  if ADirection < 0 then
    ADirection := -1
  else if ADirection > 0 then
    ADirection := 1;

  pSrc := @ASection.Mem[AOffset];
  LastOffset := ASection.AllocatedSize - Length(APattern);

  while AOffset <= LastOffset do
  begin
    Result := MatchPattern(pSrc, APattern, AMask);

    // Break if: found/no direction/at lower bound.
    if (Result) or (ADirection = 0) or ((ADirection < 0) and (AOffset = 0)) then
      break;

    // Next address/offset.
    inc(AOffset, ADirection);
    inc(pSrc, ADirection);
  end;
end;

function ValidatePattern(const S: string): Integer;
var
  i: Integer;
  ElementLen: Integer;
  c: char;
begin
  Result := 0;

  if S.IsEmpty then
    Exit;

  { Any element is 2 chars max }
  ElementLen := 0;

  i := 0;
  while i < S.Length do
  begin
    c := S.Chars[i];
    case c of
      '?':
        begin
          if (ElementLen = 0) or ((ElementLen < 2) and (S.Chars[i - 1] = '?')) then
            inc(ElementLen)
          else
            Exit(0);
        end;
      '0' .. '9', 'A' .. 'F', 'a' .. 'f':
        begin
          if (ElementLen = 0) or ((ElementLen < 2) and CharInSet(S.Chars[i - 1], ['0' .. '9', 'A' .. 'F', 'a' .. 'f'])) then
            inc(ElementLen)
          else
            Exit(0);
        end;
    end;

    inc(i);

    if (ElementLen <> 0) and ((i = S.Length) or (c = ' ')) then
      inc(Result);

    if c = ' ' then
      ElementLen := 0;
  end;
end;

function StringToPattern(
  const S: string;
  out Pattern: TBytes;
  out Mask: TBytes): boolean;
var
  i, hcn, masked: Integer;
  hc: array [0 .. 1] of byte;
  c: char;
  element, count: Integer;
begin
  count := ValidatePattern(S);
  if count = 0 then
    Exit(False);

  SetLength(Pattern, count);
  SetLength(Mask, count);

  element := 0;

  hcn := 0;
  hc[0] := 0;
  hc[1] := 0;
  masked := 0;

  i := 0;
  while i < S.Length do
  begin
    c := S.Chars[i];

    case c of
      '0' .. '9':
        begin
          hc[hcn] := Integer(c) - Integer('0');
          inc(hcn);
        end;
      'A' .. 'F':
        begin
          hc[hcn] := Integer(c) - Integer('A') + 10;
          inc(hcn);
        end;
      'a' .. 'f':
        begin
          hc[hcn] := Integer(c) - Integer('a') + 10;
          inc(hcn);
        end;
      '?':
        inc(masked);
    end;

    inc(i);

    if (i = S.Length) or (c = ' ') then
    begin
      case hcn of
        0:
          if masked <> 0 then
          begin
            Pattern[element] := 0;
            Mask[element] := 0;
            inc(element);
          end;
        1:
          begin
            Pattern[element] := hc[0];
            Mask[element] := $FF;
            inc(element);
          end;
        2:
          begin
            Pattern[element] := (hc[0] shl 4) or hc[1];
            Mask[element] := $FF;
            inc(element);
          end;
      end;

      hcn := 0;
      hc[0] := 0;
      hc[1] := 0;
      masked := 0;
    end;
  end;

  Exit(True);
end;

end.


text:
unit PE.Build.Relocs;

interface

uses
  System.Classes,
  PE.Common,
  PE.Build.Common,
  PE.Types.Relocations,
  PE.Utils;

type
  TRelocBuilder = class(TDirectoryBuilder)
  public
    procedure Build(DirRVA: TRVA; Stream: TStream); override;
    class function GetDefaultSectionFlags: uint32; override;
    class function GetDefaultSectionName: string; override;
    class function NeedRebuildingIfRVAChanged: boolean; override;
  end;

implementation

const
  RELOC_BLOCK_ALIGN = $1000;

  { TRelocBuilder }

function CalcBaseRVA(RVA: TRVA): TRVA; inline;
begin
  Result := AlignDown(RVA, RELOC_BLOCK_ALIGN);
end;

procedure TRelocBuilder.Build(DirRVA: TRVA; Stream: TStream);
var
  Block: TBaseRelocationBlock;
  Cur: TRelocTree.TRBNodePtr;
  NextBlockRVA: TRVA;
  Pos0, Pos1: UInt64;
  Entry: TBaseRelocationEntry;
begin
  if FPE.Relocs.Count = 0 then
    Exit;
  // Relocations are already sorted by RVA.
  Cur := FPE.Relocs.Items.First;
  while (Cur <> nil) do
  begin
    // New block.
    Pos0 := Stream.Position;
    Stream.Position := Pos0 + SizeOf(Block);
    Block.PageRVA := CalcBaseRVA(Cur^.K.RVA);
    NextBlockRVA := Block.PageRVA + RELOC_BLOCK_ALIGN;
    // Entries.
    while (Cur <> nil) and (Cur^.K.RVA < NextBlockRVA) do
    begin
      Entry.raw := (Cur^.K.RVA and $0FFF) or (Cur^.K.&Type shl 12);
      Stream.Write(Entry, SizeOf(Entry));
      Cur := FPE.Relocs.Items.GetNext(Cur);
    end;
    // If not last block, check if need align for next block.
    if (Cur <> nil) then
    begin
      // Each block must start on a 32-bit boundary.
      Entry.raw := 0;
      while (Stream.Position mod 4) <> 0 do
        Stream.Write(Entry, SizeOf(Entry));
    end;
    // Write block header.
    Pos1 := Stream.Position;
    Block.BlockSize := Pos1 - Pos0;
    // Write block record.
    Stream.Position := Pos0;
    Stream.Write(Block, SizeOf(Block));
    Stream.Position := Pos1;
  end;
end;

class function TRelocBuilder.GetDefaultSectionFlags: uint32;
begin
  Result := $42000040; // Readable, Discardable, Initialized data.
end;

class function TRelocBuilder.GetDefaultSectionName: string;
begin
  Result := '.reloc';
end;

class function TRelocBuilder.NeedRebuildingIfRVAChanged: boolean;
begin
  Result := False;
end;

end.


text:
unit PE.Parser.Headers;

interface

uses
  System.Classes,

  PE.Common,
  PE.Types.DOSHeader,
  PE.Types.FileHeader,
  PE.Types.OptionalHeader,
  PE.Types.NTHeaders,

  PE.Utils;

function LoadDosHeader(AStream: TStream; out AHdr: TImageDOSHeader): boolean;
function LoadFileHeader(AStream: TStream; out AHdr: TImageFileHeader): boolean; inline;

implementation

function LoadDosHeader;
begin
  Result := StreamRead(AStream, AHdr, SizeOf(AHdr)) and AHdr.e_magic.IsMZ;
end;

function LoadFileHeader;
begin
  Result := StreamRead(AStream, AHdr, SizeOf(AHdr));
end;

end.


text:
unit PE.Build.Common;

interface

uses
  System.Classes,
  PE.Common,
  PE.Image,
  NullStream;

type
  // Parent class for any directory builders.
  // Override Build procedure and fill Stream with new dir data.
  TDirectoryBuilder = class
  protected
    FPE: TPEImage;
  public
    constructor Create(PE: TPEImage);

    // Builds bogus directory and return size.
    // Override it if you have better implementation.
    function EstimateTheSize: uint32; virtual;

    // Build directory data and store it to stream.
    // * DirRVA:  RVA of directory start.
    // * Stream:  Stream to store data.
    procedure Build(DirRVA: TRVA; Stream: TStream); virtual; abstract;

    // If new section created, it's called to get the flags.
    class function GetDefaultSectionFlags: uint32; virtual; abstract;

    // If new section created, it's called to get the name.
    class function GetDefaultSectionName: string; virtual; abstract;

    // Return True if need to call Build each time when DirRVA changed.
    class function NeedRebuildingIfRVAChanged: boolean; virtual; abstract;
  end;

  TDirectoryBuilderClass = class of TDirectoryBuilder;

implementation

{ TDirBuilder }

constructor TDirectoryBuilder.Create(PE: TPEImage);
begin
  FPE := PE;
end;

function TDirectoryBuilder.EstimateTheSize: uint32;
var
  tmp: TNullStream;
begin
  tmp := TNullStream.Create;
  try
    Build(0, tmp);
    Result := tmp.Size;
  finally
    tmp.Free;
  end;
end;

end.


text:
unit PE.Types.Resources;

interface

{$IFDEF DEBUG}
uses
  System.SysUtils; // to Raise
{$ENDIF}

// 5.9.1. Resource Directory Table

type

  { TResourceDirectoryTable }

  TResourceDirectoryTable = packed record

    // Resource flags. This field is reserved for future use.
    // It is currently set to zero.
    Characteristics: uint32;

    // The time that the resource data was created by the resource compiler.
    TimeDateStamp: uint32;

    // The major version number, set by the user.
    MajorVersion: uint16;

    // The minor version number, set by the user.
    MinorVersion: uint16;

    // The number of directory entries immediately following the table that
    // use strings to identify Type, Name, or Language entries (depending on
    // the level of the table).
    NumberOfNameEntries: uint16;

    // The number of directory entries immediately following the Name entries
    // that use numeric IDs for Type, Name, or Language entries.
    NumberOfIDEntries: uint16;

  end;

  PResourceDirectoryTable = ^TResourceDirectoryTable;

  TResourceEntryType = (ResourceEntryById, ResourceEntryByName);

  { TResourceDirectoryEntry }

  TResourceDirectoryEntry = packed record
  private

    // Either Name RVA or Id.
    FEntry: uint32;

    DataEntryRVAorSubdirectoryRVA: uint32;

    function GetDataEntryRVAorSubdirectoryRVA: uint32; inline;
    function GetIntegerID: uint32; inline;
    function GetNameRVA: uint32; inline;
    procedure SetSubDirRVA(const Value: uint32); inline;
    procedure SetDataEntryRVA(const Value: uint32); inline;
    procedure SetNameRVA(const Value: uint32); inline;
    procedure SetIntegerID(const Value: uint32); inline;
    function GetResourceEntryType: TResourceEntryType; inline;

  public

    procedure Clear;

    // To check which union select.
    function IsDataEntryRVA: boolean; inline;
    function IsSubdirectoryRVA: boolean; inline;

    // High bit 0. Address of a Resource Data entry (a leaf).
    property DataEntryRVA: uint32 read GetDataEntryRVAorSubdirectoryRVA write SetDataEntryRVA;

    // High bit 1. The lower 31 bits are the address of another resource
    // directory table (the next level down).
    property SubdirectoryRVA: uint32 read GetDataEntryRVAorSubdirectoryRVA write SetSubDirRVA;

    property EntryType: TResourceEntryType read GetResourceEntryType;

    property NameRVA: uint32 read GetNameRVA write SetNameRVA;
    property IntegerID: uint32 read GetIntegerID write SetIntegerID;
  end;

  PResourceDirectoryEntry = ^TResourceDirectoryEntry;

  { TResourceDataEntry }

  TResourceDataEntry = packed record
    // The address of a unit of resource data in the Resource Data area.
    DataRVA: uint32;

    // The size, in bytes, of the resource data that is pointed to by the
    // Data RVA field.
    Size: uint32;

    // The code page that is used to decode code point values within the
    // resource data. Typically, the code page would be the Unicode code page.
    Codepage: uint32;

    // Reserved, must be 0.
    Reserved: uint32;
  end;

implementation

procedure TResourceDirectoryEntry.Clear;
begin
  FEntry := 0;
  DataEntryRVAorSubdirectoryRVA := 0;
end;

function TResourceDirectoryEntry.GetDataEntryRVAorSubdirectoryRVA: uint32;
begin
  Result := DataEntryRVAorSubdirectoryRVA and $7FFFFFFF;
end;

function TResourceDirectoryEntry.GetIntegerID: uint32;
begin
{$IFDEF DEBUG}
  if EntryType <> ResourceEntryById then
    raise Exception.Create('Attempt to get ID of named-entry.');
{$ENDIF}
  Result := FEntry and $FFFF;
end;

function TResourceDirectoryEntry.GetNameRVA: uint32;
begin
{$IFDEF DEBUG}
  if EntryType <> ResourceEntryByName then
    raise Exception.Create('Attempt to get name RVA of ID-entry.');
{$ENDIF}
  Result := FEntry and $7FFFFFFF;
end;

function TResourceDirectoryEntry.GetResourceEntryType: TResourceEntryType;
begin
  if (self.FEntry and $80000000) = 0 then
    Result := ResourceEntryById
  else
    Result := ResourceEntryByName;
end;

function TResourceDirectoryEntry.IsDataEntryRVA: boolean;
begin
  Result := (DataEntryRVAorSubdirectoryRVA and $80000000) = 0;
end;

function TResourceDirectoryEntry.IsSubdirectoryRVA: boolean;
begin
  Result := (DataEntryRVAorSubdirectoryRVA and $80000000) <> 0;
end;

procedure TResourceDirectoryEntry.SetDataEntryRVA(const Value: uint32);
begin
  DataEntryRVAorSubdirectoryRVA := Value and $7FFFFFFF;
end;

procedure TResourceDirectoryEntry.SetIntegerID(const Value: uint32);
begin
  FEntry := Value and $7FFFFFFF;
end;

procedure TResourceDirectoryEntry.SetNameRVA(const Value: uint32);
begin
  FEntry := Value or $80000000;
end;

procedure TResourceDirectoryEntry.SetSubDirRVA(const Value: uint32);
begin
  DataEntryRVAorSubdirectoryRVA := Value or $80000000;
end;

end.


text:
unit PE.Imports;

interface

uses
  System.Generics.Collections,
  System.SysUtils,

  PE.Common,
  PE.Imports.Func,
  PE.Imports.Lib;

type
  TPEImportLibraryObjectList = TObjectList<TPEImportLibrary>;

  TPEImport = class
  private
    FLibs: TPEImportLibraryObjectList;
  public
    constructor Create;
    destructor Destroy; override;

    procedure Clear;

    function Add(Lib: TPEImportLibrary): TPEImportLibrary; inline;
    function NewLib(const Name: string): TPEImportLibrary;

    property Libs: TPEImportLibraryObjectList read FLibs;
  end;

implementation

{ TPEImports }

constructor TPEImport.Create;
begin
  inherited Create;
  FLibs := TPEImportLibraryObjectList.Create;
end;

destructor TPEImport.Destroy;
begin
  FLibs.Free;
  inherited;
end;

function TPEImport.NewLib(const Name: string): TPEImportLibrary;
begin
  result := Add(TPEImportLibrary.Create(Name));
end;

procedure TPEImport.Clear;
begin
  FLibs.Clear;
end;

function TPEImport.Add(Lib: TPEImportLibrary): TPEImportLibrary;
begin
  FLibs.Add(Lib);
  result := Lib;
end;

end.