Reading Info From a Package Part IV

Well this week really became package week. I posed part I here, part II here and part III here.

For this version I wrapped up the previous package cracking code into a class for easy consumption by any program. Notice I used the previously unused second parameter on GetPackageInfo which is just passed to PackageInfoProc via the Param parameter. This allows us to pass the Self pointer to remove globals. I also added error checking and removed some hard coded constants readers had commented on.

program pdump;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  Classes;

type
  TPackageProducer = (ppOld, ppUndefined, ppBCB, ppDelphi);
  TPackageConsumer = (pcCompat, pcDelphi, pcBCB);

  TPackage = class
  private
    FProducer: TPackageProducer;
    FConsumer: TPackageConsumer;
    FRequiresList: TStrings;
    FImplicitUnits: TStrings;
    FContainsList: TStrings;
    FNeverBuild: Boolean;
    FDesignOnly: Boolean;
    FRunOnly: Boolean;
  public
    constructor Create;
    destructor Destroy; override;
    function LoadFromFile(const FileName: string): Boolean;

   property RequiresList: TStrings read FRequiresList;
    property ImplicitUnits: TStrings read FImplicitUnits;
   property ContainsList: TStrings read FContainsList;
    property Producer: TPackageProducer read FProducer;
   property Consumer: TPackageConsumer read FConsumer;
    property NeverBuild: Boolean read FNeverBuild;
    property DesignOnly: Boolean read FDesignOnly;
    property RunOnly: Boolean read FRunOnly;
  end;

procedure WriteStrings(Strings: TStrings);
var
  Index: Integer;
begin
  for Index := 0 to Strings.Count - 1 do
    WriteLn(Strings[Index]);
end;

procedure PackageInfoProc(const Name: string;
                          NameType: TNameType; Flags: Byte;
                          Param: Pointer);
begin
  if NameType = ntContainsUnit then
  begin
    TPackage(Param).ContainsList.Add(Name);

    if (Flags and ufImplicitUnit <> 0) and
      (Flags and ufWeakPackageUnit = 0) then
    begin
      TPackage(Param).ImplicitUnits.Add(Name);
    end;
  end
  else if NameType = ntRequiresPackage then
    TPackage(Param).RequiresList.Add(Name);
end;

{ TPackage }

constructor TPackage.Create;
begin
  FRequiresList := TStringList.Create;
  FImplicitUnits := TStringList.Create;
  FContainsList := TStringList.Create;
end;

destructor TPackage.Destroy;
begin
  FRequiresList.Free;
  FImplicitUnits.Free;
  FContainsList.Free;
  inherited;
end;

function TPackage.LoadFromFile(const FileName: string): Boolean;
var
  Module: HMODULE;
  Flags: Longint;
begin
  Result := False;
  Module := LoadPackage(FileName);

  try
    if Module <> 0 then
    begin
      GetPackageInfo(Module, Self, Flags, PackageInfoProc);

      FNeverBuild := (Flags and pfNeverBuild) <> 0;
      FDesignOnly := (Flags and pfDesignOnly) <> 0;
      FRunOnly := (Flags and pfRunOnly) <> 0;

      case Flags and pfProducerMask of
        pfV3Produced:        FProducer := ppOld;
        pfProducerUndefined: FProducer := ppUndefined;
        pfBCB4Produced:      FProducer := ppBCB;
        pfDelphi4Produced:   FProducer := ppDelphi;
      else
        FProducer := ppUndefined;
      end;

      case Flags and pfConsumerMask of
        pfConsumerDelphi: FConsumer := pcDelphi;
        pfConsumerBCB: FConsumer := pcBCB;
      else
        if FProducer <> ppBCB then
          FConsumer := pcCompat
        else
          FConsumer := pcBCB;
      end;

      Result := True;
    end;
  finally
    UnloadPackage(Module);
  end;
end;

var
  Package: TPackage;
  FileName: string;
begin
  if ParamCount <> 1 then
  begin
    WriteLn('Usage: PDUMP [PackageFileName]');
    Exit;
  end;

  FileName := ParamStr(1);

  if not FileExists(FileName) then
  begin
    WriteLn(Format('File %s does not exist.', [FileName]));
    Exit;
  end;

  Package := TPackage.Create;

  try
    if Package.LoadFromFile(FileName) then
    begin
      if Package.NeverBuild then
        WriteLn('Never Build');

      if Package.DesignOnly then
        WriteLn('Design Only');

      if Package.RunOnly then
        WriteLn('Run Only');

      case Package.Producer of
        ppOld:       WriteLn('Old Producer');
        ppUndefined: WriteLn('Undefined Producer');
        ppBCB:       WriteLn('BCB Producer');
        ppDelphi:    WriteLn('Delphi Producer');
      end;

      case Package.Consumer of
        pcCompat: WriteLn('Compat Consumer');
        pcBCB:    WriteLn('BCB Consumer');
        pcDelphi: WriteLn('Delphi Consumer');
      end;

      if Package.RequiresList.Count > 0 then
      begin
        WriteLn(#13#10 + 'Requires List:');
        WriteStrings(Package.RequiresList);
      end;

      if Package.ImplicitUnits.Count > 0 then
      begin
        WriteLn(#13#10 + 'Implicit Uses:');
        WriteStrings(Package.ImplicitUnits);
      end;

      if Package.ContainsList.Count > 0 then
      begin
        WriteLn(#13#10 + 'Contains List:');
        WriteStrings(Package.ContainsList);
      end;
    end;
  finally
    Package.Free;
  end;
end.