unit uHCLArchive;

{$mode objfpc}{$H+}

/// <summary>
/// uHCLArchive — safe ZIP archive inspection and extraction for the HC Launcher.
///
/// Wraps FPC's <c>TUnZipper</c> (paszlib) behind <see cref="IHCLArchive"/>,
/// adding path-traversal ("zip slip") rejection, overwrite policy, byte and
/// file accounting, progress reporting and cooperative cancellation.
///
/// Zero UI dependency — no LCL units are referenced — and zero knowledge of
/// HC artifact types, so the unit is independently testable.  Mapping an
/// archive onto the managed directory tree lives in <c>uHCLImport</c>.
/// </summary>
///
/// <remarks>
/// Every entry is validated by <see cref="HCLIsEntryNameSafe"/> before it is
/// handed to <c>TUnZipper</c>.  Entries naming an absolute path, a drive or
/// alternate data stream (<c>:</c>), or containing a <c>..</c> segment are
/// never extracted; they are reported in
/// <c>THCLExtractResult.UnsafeEntries</c> so the caller can surface them.
/// This matters because archives on community sites are user-uploaded and are
/// not vetted before they reach the launcher.
///
/// Archives in a category's <c>cache\</c> directory are never modified —
/// extraction always writes to a separate destination directory, so a failed
/// or partial extract can be retried from the original download.
/// </remarks>

interface

uses
  SysUtils, Classes, zipper;

// ---------------------------------------------------------------------------
// Enum, record and event types
// ---------------------------------------------------------------------------

type
  /// <summary>
  /// Policy applied when a file to be extracted already exists on disk.
  /// </summary>
  THCLOverwriteMode = (
    omSkip,      ///< Leave the existing file alone; count it in FilesSkipped.
    omOverwrite, ///< Replace the existing file with the archived copy.
    omFail       ///< Extract nothing and fail if any target already exists.
  );

  /// <summary>
  /// One entry in a ZIP archive's central directory.
  /// </summary>
  THCLArchiveEntry = record
    /// <summary>Entry name normalised to the platform path delimiter.</summary>
    Name: String;
    /// <summary>Name exactly as stored in the archive, used for matching.</summary>
    RawName: String;
    /// <summary>Uncompressed size in bytes; 0 for directory entries.</summary>
    Size: Int64;
    /// <summary>True when the entry denotes a directory rather than a file.</summary>
    IsDirectory: Boolean;
    /// <summary>False when the entry was rejected by the path-safety check.</summary>
    IsSafe: Boolean;
  end;

  THCLArchiveEntryArray = array of THCLArchiveEntry;

  /// <summary>
  /// Outcome of an <see cref="IHCLArchive.Extract"/> call.
  /// </summary>
  THCLExtractResult = record
    /// <summary>True when extraction completed without error.</summary>
    Success: Boolean;
    /// <summary>Directory the archive was extracted into.</summary>
    DestDir: String;
    /// <summary>Count of files actually written.</summary>
    FilesExtracted: Integer;
    /// <summary>Total bytes written, measured from the files on disk.</summary>
    BytesExtracted: Int64;
    /// <summary>Count of existing files left alone under <c>omSkip</c>.</summary>
    FilesSkipped: Integer;
    /// <summary>Names of entries rejected by the path-safety check.</summary>
    UnsafeEntries: TStringArray;
    /// <summary>Human-readable error text; empty on success.</summary>
    ErrorMessage: String;
  end;

  /// <summary>
  /// Fired as each file in the archive begins extracting.
  /// </summary>
  /// <param name="ASender">The <see cref="IHCLArchive"/> implementation.</param>
  /// <param name="AEntryName">Archive-relative name of the current entry.</param>
  /// <param name="AEntryIndex">1-based index of the current entry.</param>
  /// <param name="AEntryCount">Total number of entries being extracted.</param>
  THCLExtractProgressEvent = procedure(ASender: TObject; const AEntryName: String;
    AEntryIndex, AEntryCount: Integer) of object;

// ---------------------------------------------------------------------------
// Interface
// ---------------------------------------------------------------------------

type
  /// <summary>
  /// Inspects and extracts ZIP archives with path-traversal protection.
  /// </summary>
  /// <remarks>
  /// Implementations are not thread-safe; one instance drives at most one
  /// extraction at a time.  Errors are reported through
  /// <c>THCLExtractResult.ErrorMessage</c> rather than by raising, matching
  /// the convention used by <c>IHCLDownloader</c>.
  /// </remarks>
  IHCLArchive = interface
    ['{6F2B9D41-3C87-4E5A-9B10-D47E1F8A26C3}']

    /// <summary>
    /// Reads the archive's central directory without extracting anything.
    /// </summary>
    /// <param name="AArchivePath">Full path to the <c>.zip</c> file.</param>
    /// <returns>All entries, each flagged with <c>IsSafe</c>; an empty array
    /// when the file is missing or is not a readable ZIP.</returns>
    function ListEntries(const AArchivePath: String): THCLArchiveEntryArray;

    /// <summary>
    /// Extracts every safe entry of the archive into <paramref name="ADestDir"/>,
    /// creating the destination and any intermediate directories as needed.
    /// </summary>
    /// <param name="AArchivePath">Full path to the <c>.zip</c> file.</param>
    /// <param name="ADestDir">Directory to extract into.</param>
    /// <param name="AOverwrite">Policy for files that already exist.</param>
    /// <param name="AOnProgress">Optional per-entry progress callback; may be nil.</param>
    /// <param name="AStripPrefix">Optional archive-relative directory (for
    /// example <c>GIUK-v1.2</c> or <c>Pack/ExportDLLs</c>) to remove from the
    /// front of every entry name that sits beneath it.  Empty extracts the
    /// archive exactly as packaged.</param>
    /// <param name="AOnlyUnderPrefix">True to extract only the entries beneath
    /// <paramref name="AStripPrefix"/> and leave the rest of the archive alone
    /// (with an empty prefix: only the files at the archive's top level).  Used
    /// to take one database out of an archive that holds several.</param>
    /// <returns>A populated <see cref="THCLExtractResult"/>.</returns>
    /// <remarks>
    /// Stripping happens as each entry is written, so a stripped entry goes
    /// straight to its final path.  Nothing is ever moved after the fact,
    /// which means files already in <paramref name="ADestDir"/> can never be
    /// swept up with the archive's contents, and a stripped directory merges
    /// naturally with an existing one of the same name.
    /// </remarks>
    function Extract(const AArchivePath, ADestDir: String;
      AOverwrite: THCLOverwriteMode;
      AOnProgress: THCLExtractProgressEvent;
      const AStripPrefix: String = '';
      AOnlyUnderPrefix: Boolean = False): THCLExtractResult;

    /// <summary>
    /// Reads one entry into memory without writing anything to disk.
    /// </summary>
    /// <param name="AArchivePath">Full path to the <c>.zip</c> file.</param>
    /// <param name="ARawName">The entry's raw name, as <c>THCLArchiveEntry.RawName</c>.</param>
    /// <param name="AMaxBytes">Largest entry that will be read; a bigger one returns ''.</param>
    /// <returns>The entry's bytes; '' when it is missing, unsafe, a directory,
    /// too large, or the archive cannot be read.  Never raises.</returns>
    function ReadEntry(const AArchivePath, ARawName: String;
      AMaxBytes: Int64): RawByteString;

    /// <summary>
    /// Requests cancellation of the extraction in progress.  Files already
    /// written are left in place.
    /// </summary>
    procedure Cancel;

    /// <summary>Returns True while an extraction is running.</summary>
    function IsExtracting: Boolean;
  end;

// ---------------------------------------------------------------------------
// Factory and helpers
// ---------------------------------------------------------------------------

/// <summary>Creates a new archive handler.</summary>
/// <returns>A reference-counted <see cref="IHCLArchive"/>.</returns>
function CreateArchive: IHCLArchive;

/// <summary>
/// Tests whether an archive entry name is safe to join onto a destination
/// directory.
/// </summary>
/// <param name="AEntryName">Entry name as stored in the archive.</param>
/// <returns>False for empty names, absolute paths, names containing a drive
/// or stream separator (<c>:</c>), or any <c>..</c> path segment.</returns>
/// <remarks>
/// Rejecting rather than sanitising is deliberate: a rewritten path could
/// still collide with an unrelated file, and a hostile entry is a reason to
/// tell the user, not to silently relocate its contents.
/// </remarks>
function HCLIsEntryNameSafe(const AEntryName: String): Boolean;

/// <summary>
/// Converts an archive entry name to platform form, mapping both <c>/</c> and
/// <c>\</c> to <c>PathDelim</c> and dropping any leading delimiter.
/// </summary>
/// <param name="AEntryName">Entry name as stored in the archive.</param>
/// <returns>The normalised name.</returns>
function HCLNormalizeEntryName(const AEntryName: String): String;

/// <summary>
/// Returns the single top-level directory shared by every entry, if there is
/// one.
/// </summary>
/// <param name="AEntries">Entries as returned by <c>ListEntries</c>.</param>
/// <returns>The common wrapper directory name, or an empty string when the
/// entries do not all sit under one directory.</returns>
/// <remarks>
/// Community ZIPs are inconsistent: some wrap their payload in a folder named
/// after the release, others are flat.  Callers use this to avoid creating a
/// redundant nested directory when the archive already supplies one.
/// </remarks>
function HCLArchiveTopLevelDir(const AEntries: THCLArchiveEntryArray): String;

implementation

// ---------------------------------------------------------------------------
// Helpers
// ---------------------------------------------------------------------------

function HCLNormalizeEntryName(const AEntryName: String): String;
var
  I: Integer;
begin
  Result := AEntryName;
  for I := 1 to Length(Result) do
    if (Result[I] = '/') or (Result[I] = '\') then
      Result[I] := PathDelim;

  // Drop leading delimiters so the name always joins as a relative path.
  while (Length(Result) > 0) and (Result[1] = PathDelim) do
    Delete(Result, 1, 1);
end;

function HCLIsEntryNameSafe(const AEntryName: String): Boolean;
var
  LNorm: String;
  LParts: TStringArray;
  I: Integer;
begin
  Result := False;

  if Trim(AEntryName) = '' then
    Exit;

  // A colon anywhere covers both "C:\..." drive paths and NTFS alternate
  // data streams ("file.txt:hidden").
  if Pos(':', AEntryName) > 0 then
    Exit;

  // Absolute in the archive's own terms.
  if (AEntryName[1] = '/') or (AEntryName[1] = '\') then
    Exit;

  LNorm := HCLNormalizeEntryName(AEntryName);
  if LNorm = '' then
    Exit;

  LParts := LNorm.Split([PathDelim]);
  for I := 0 to High(LParts) do
    if LParts[I] = '..' then
      Exit;

  Result := True;
end;

function HCLArchiveTopLevelDir(const AEntries: THCLArchiveEntryArray): String;
var
  I, LDelimPos: Integer;
  LNorm, LFirst, LThis: String;
begin
  Result := '';
  LFirst := '';

  for I := 0 to High(AEntries) do
  begin
    if not AEntries[I].IsSafe then
      Continue;

    LNorm := HCLNormalizeEntryName(AEntries[I].Name);
    LNorm := ExcludeTrailingPathDelimiter(LNorm);
    if LNorm = '' then
      Continue;

    LDelimPos := Pos(PathDelim, LNorm);
    if LDelimPos = 0 then
    begin
      // A file at the archive root means there is no single wrapper directory.
      if not AEntries[I].IsDirectory then
        Exit('');
      LThis := LNorm;
    end
    else
      LThis := Copy(LNorm, 1, LDelimPos - 1);

    if LFirst = '' then
      LFirst := LThis
    else if not SameText(LFirst, LThis) then
      Exit('');
  end;

  Result := LFirst;
end;

// ---------------------------------------------------------------------------
// TDiscardStream
// ---------------------------------------------------------------------------

type
  /// <summary>
  /// Write-only stream that throws its data away.
  /// </summary>
  /// <remarks>
  /// Handed to <c>TUnZipper</c> for any entry that must not reach the disk (a
  /// cancelled run, or an entry that was never planned).  Returning
  /// <c>nil</c> instead is not an option: with a custom stream handler
  /// installed, <c>TUnZipper</c> ignores <c>OutputPath</c> and would fall back
  /// to creating the file at its bare archive-relative name — relative to the
  /// process's current directory, wherever that happens to be.
  /// </remarks>
  TDiscardStream = class(TStream)
  public
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
  end;

function TDiscardStream.Read(var Buffer; Count: Longint): Longint;
begin
  Result := 0;
end;

function TDiscardStream.Write(const Buffer; Count: Longint): Longint;
begin
  Result := Count;
end;

function TDiscardStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
  Result := 0;
end;

// ---------------------------------------------------------------------------
// THCLArchive
// ---------------------------------------------------------------------------

type
  /// <summary>
  /// Default <see cref="IHCLArchive"/> implementation backed by
  /// <c>TUnZipper</c>.
  /// </summary>
  /// <remarks>
  /// Output files are created by this class, not by <c>TUnZipper</c>: an
  /// <c>OnCreateStream</c> handler opens each entry at the target path worked
  /// out in advance by <c>Extract</c>.  That is what lets a wrapper prefix be
  /// stripped on the way out rather than by moving files afterwards.
  /// </remarks>
  THCLArchive = class(TInterfacedObject, IHCLArchive)
  private
    FUnZip: TUnZipper;
    FExtracting: Boolean;
    FCancelled: Boolean;
    FOnProgress: THCLExtractProgressEvent;
    FEntryIndex: Integer;
    FEntryCount: Integer;
    /// <summary>Raw archive names of planned entries; sorted, Objects index the lists below.</summary>
    FPlanRaw: TStringList;
    /// <summary>Destination-relative name per planned entry, for progress reports.</summary>
    FPlanRel: TStringList;
    /// <summary>Absolute output path per planned entry.</summary>
    FPlanTarget: TStringList;
    /// <summary>Output path of the entry currently being written; empty when discarding.</summary>
    FCurrentTarget: String;

    /// <summary>
    /// <c>TUnZipper.OnCreateStream</c> handler.  Opens the planned target for
    /// the entry, reports progress, and honours a pending cancellation.
    /// </summary>
    /// <param name="Sender">The TUnZipper instance.</param>
    /// <param name="AStream">Receives the output stream; never left nil.</param>
    /// <param name="AItem">Entry about to be decompressed.</param>
    procedure DoCreateStream(Sender: TObject; var AStream: TStream;
      AItem: TFullZipFileEntry);

    /// <summary>
    /// <c>TUnZipper.OnDoneStream</c> handler.  Closes the output and restores
    /// the entry's timestamp, which <c>TUnZipper</c> skips for custom streams.
    /// </summary>
    /// <param name="Sender">The TUnZipper instance.</param>
    /// <param name="AStream">Stream to close; freed here.</param>
    /// <param name="AItem">Entry just written.</param>
    procedure DoDoneStream(Sender: TObject; var AStream: TStream;
      AItem: TFullZipFileEntry);
  public
    constructor Create;
    destructor Destroy; override;

    function ListEntries(const AArchivePath: String): THCLArchiveEntryArray;
    function Extract(const AArchivePath, ADestDir: String;
      AOverwrite: THCLOverwriteMode;
      AOnProgress: THCLExtractProgressEvent;
      const AStripPrefix: String = '';
      AOnlyUnderPrefix: Boolean = False): THCLExtractResult;
    function ReadEntry(const AArchivePath, ARawName: String;
      AMaxBytes: Int64): RawByteString;
    procedure Cancel;
    function IsExtracting: Boolean;
  end;

  /// <summary>
  /// Collects one entry's bytes for <c>ReadEntry</c>: TUnZipper writes into
  /// Buffer, which this object owns (so OnDoneStream must not free it).
  /// </summary>
  TEntryReader = class
  public
    Buffer: TMemoryStream;
    constructor Create;
    destructor Destroy; override;
    procedure DoCreateStream(Sender: TObject; var AStream: TStream;
      AItem: TFullZipFileEntry);
    procedure DoDoneStream(Sender: TObject; var AStream: TStream;
      AItem: TFullZipFileEntry);
  end;

constructor TEntryReader.Create;
begin
  inherited Create;
  Buffer := TMemoryStream.Create;
end;

destructor TEntryReader.Destroy;
begin
  Buffer.Free;
  inherited Destroy;
end;

procedure TEntryReader.DoCreateStream(Sender: TObject; var AStream: TStream;
  AItem: TFullZipFileEntry);
begin
  AStream := Buffer;
end;

procedure TEntryReader.DoDoneStream(Sender: TObject; var AStream: TStream;
  AItem: TFullZipFileEntry);
begin
  AStream := nil; // Buffer stays with its owner
end;

function THCLArchive.ReadEntry(const AArchivePath, ARawName: String;
  AMaxBytes: Int64): RawByteString;
var
  LEntries: THCLArchiveEntryArray;
  LUnZip: TUnZipper;
  LReader: TEntryReader;
  LFiles: TStringList;
  I: Integer;
  LFound: Boolean;
begin
  Result := '';
  if FExtracting then
    Exit;

  // Only a safe, file-sized entry the archive really lists.
  LEntries := ListEntries(AArchivePath);
  LFound := False;
  for I := 0 to High(LEntries) do
    if (LEntries[I].RawName = ARawName) and LEntries[I].IsSafe and
       not LEntries[I].IsDirectory and (LEntries[I].Size <= AMaxBytes) then
      LFound := True;
  if not LFound then
    Exit;

  // A TUnZipper of its own, so Extract's handlers and plan are untouched.
  LUnZip := TUnZipper.Create;
  LReader := TEntryReader.Create;
  LFiles := TStringList.Create;
  try
    try
      LUnZip.FileName := AArchivePath;
      LUnZip.OnCreateStream := @LReader.DoCreateStream;
      LUnZip.OnDoneStream := @LReader.DoDoneStream;
      LFiles.Add(ARawName);
      LUnZip.UnZipFiles(LFiles);
      if (LReader.Buffer.Size > 0) and (LReader.Buffer.Size <= AMaxBytes) then
      begin
        SetLength(Result, LReader.Buffer.Size);
        Move(LReader.Buffer.Memory^, Result[1], LReader.Buffer.Size);
        SetCodePage(Result, CP_NONE, False);
      end;
    except
      on E: Exception do
        Result := '';
    end;
  finally
    LFiles.Free;
    LReader.Free;
    LUnZip.Free;
  end;
end;

constructor THCLArchive.Create;
begin
  inherited Create;
  FUnZip := TUnZipper.Create;
  FExtracting := False;
  FCancelled := False;

  FPlanRaw := TStringList.Create;
  FPlanRaw.CaseSensitive := True;
  FPlanRaw.Duplicates := dupAccept;
  FPlanRaw.Sorted := True;
  FPlanRel := TStringList.Create;
  FPlanTarget := TStringList.Create;
end;

destructor THCLArchive.Destroy;
begin
  FreeAndNil(FUnZip);
  FreeAndNil(FPlanRaw);
  FreeAndNil(FPlanRel);
  FreeAndNil(FPlanTarget);
  inherited Destroy;
end;

procedure THCLArchive.DoCreateStream(Sender: TObject; var AStream: TStream;
  AItem: TFullZipFileEntry);
var
  LIdx, LPlan: Integer;
begin
  FCurrentTarget := '';

  if FCancelled then
  begin
    FUnZip.Terminate;
    AStream := TDiscardStream.Create;
    Exit;
  end;

  LIdx := FPlanRaw.IndexOf(AItem.ArchiveFileName);
  if LIdx < 0 then
  begin
    // TUnZipper only visits entries we asked for, so this is defensive: an
    // unplanned entry must never be written anywhere.
    AStream := TDiscardStream.Create;
    Exit;
  end;

  LPlan := PtrInt(FPlanRaw.Objects[LIdx]);
  FCurrentTarget := FPlanTarget[LPlan];

  ForceDirectories(ExtractFileDir(FCurrentTarget));
  AStream := TFileStream.Create(FCurrentTarget, fmCreate);

  Inc(FEntryIndex);
  if Assigned(FOnProgress) then
    FOnProgress(Self, FPlanRel[LPlan], FEntryIndex, FEntryCount);
end;

procedure THCLArchive.DoDoneStream(Sender: TObject; var AStream: TStream;
  AItem: TFullZipFileEntry);
begin
  FreeAndNil(AStream);

  // Only the timestamp is restored.  File attributes are deliberately not
  // carried over: a read-only flag from the archive would make the next
  // omOverwrite import of the same artifact fail.
  if (FCurrentTarget <> '') and FileExists(FCurrentTarget) then
    FileSetDate(FCurrentTarget, DateTimeToFileDate(AItem.DateTime));

  FCurrentTarget := '';
end;

procedure THCLArchive.Cancel;
begin
  FCancelled := True;
  if FExtracting then
    FUnZip.Terminate;
end;

function THCLArchive.IsExtracting: Boolean;
begin
  Result := FExtracting;
end;

function THCLArchive.ListEntries(const AArchivePath: String): THCLArchiveEntryArray;
var
  I, LCount: Integer;
  LEntry: TFullZipFileEntry;
begin
  Result := nil;

  if not FileExists(AArchivePath) then
    Exit;

  try
    FUnZip.Clear;
    FUnZip.FileName := AArchivePath;
    FUnZip.Examine;

    LCount := FUnZip.Entries.Count;
    SetLength(Result, LCount);
    for I := 0 to LCount - 1 do
    begin
      LEntry := FUnZip.Entries.FullEntries[I];
      Result[I].RawName     := LEntry.ArchiveFileName;
      Result[I].Name        := HCLNormalizeEntryName(LEntry.ArchiveFileName);
      Result[I].Size        := LEntry.Size;
      Result[I].IsDirectory := LEntry.IsDirectory;
      Result[I].IsSafe      := HCLIsEntryNameSafe(LEntry.ArchiveFileName);
    end;
  except
    // A corrupt or non-ZIP file is a normal condition here, not a crash:
    // report it as "no entries" and let Extract surface the diagnostic.
    on E: Exception do
      Result := nil;
  end;
end;

function THCLArchive.Extract(const AArchivePath, ADestDir: String;
  AOverwrite: THCLOverwriteMode;
  AOnProgress: THCLExtractProgressEvent;
  const AStripPrefix: String = '';
  AOnlyUnderPrefix: Boolean = False): THCLExtractResult;
var
  LEntries: THCLArchiveEntryArray;
  LWanted: TStringList;
  LUnsafe: TStringArray;
  LUnsafeCount: Integer;
  I, LPlan: Integer;
  LDestDir, LPrefix, LRel, LTarget: String;
  LInfo: TSearchRec;

  procedure Fail(const AMsg: String);
  begin
    Result.Success := False;
    Result.ErrorMessage := AMsg;
  end;

begin
  Result := Default(THCLExtractResult);
  Result.DestDir := ADestDir;

  if FExtracting then
  begin
    Fail('An extraction is already in progress');
    Exit;
  end;

  if not FileExists(AArchivePath) then
  begin
    Fail('Archive not found: ' + AArchivePath);
    Exit;
  end;

  if Trim(ADestDir) = '' then
  begin
    Fail('No destination directory specified');
    Exit;
  end;

  LEntries := ListEntries(AArchivePath);
  if Length(LEntries) = 0 then
  begin
    Fail('Archive is empty or could not be read: ' + AArchivePath);
    Exit;
  end;

  FCancelled := False;
  FOnProgress := AOnProgress;
  FEntryIndex := 0;
  FPlanRaw.Clear;
  FPlanRel.Clear;
  FPlanTarget.Clear;

  LDestDir := ExcludeTrailingPathDelimiter(ADestDir);
  LPrefix := ExcludeTrailingPathDelimiter(HCLNormalizeEntryName(AStripPrefix));

  LWanted := TStringList.Create;
  try
    try
      // Collect the unsafe entries in a pass of their own so the caller is
      // told about every one of them even when the run is abandoned early
      // by omFail.
      LUnsafe := nil;
      LUnsafeCount := 0;
      SetLength(LUnsafe, Length(LEntries));
      for I := 0 to High(LEntries) do
        if not LEntries[I].IsSafe then
        begin
          LUnsafe[LUnsafeCount] := LEntries[I].RawName;
          Inc(LUnsafeCount);
        end;
      SetLength(LUnsafe, LUnsafeCount);
      Result.UnsafeEntries := LUnsafe;

      for I := 0 to High(LEntries) do
      begin
        if (not LEntries[I].IsSafe) or LEntries[I].IsDirectory then
          Continue;

        // Strip the wrapper from entries beneath it.  The remainder is a
        // suffix of a name that already passed HCLIsEntryNameSafe, so it
        // cannot introduce a traversal of its own.
        LRel := LEntries[I].Name;
        if (LPrefix <> '') and (Length(LRel) > Length(LPrefix) + 1) and
           SameText(Copy(LRel, 1, Length(LPrefix) + 1), LPrefix + PathDelim) then
          Delete(LRel, 1, Length(LPrefix) + 1)
        else if AOnlyUnderPrefix and ((LPrefix <> '') or (Pos(PathDelim, LRel) > 0)) then
          Continue; // outside the one directory wanted

        if LRel = '' then
          Continue;

        LTarget := LDestDir + PathDelim + LRel;

        if FileExists(LTarget) then
        begin
          case AOverwrite of
            omFail:
              begin
                Fail('File already exists: ' + LTarget);
                Exit;
              end;
            omSkip:
              begin
                Inc(Result.FilesSkipped);
                Continue;
              end;
            omOverwrite:
              ; // fall through and extract over it
          end;
        end;

        LPlan := FPlanTarget.Add(LTarget);
        FPlanRel.Add(LRel);
        FPlanRaw.AddObject(LEntries[I].RawName, TObject(PtrInt(LPlan)));
        LWanted.Add(LEntries[I].RawName);
      end;

      if LWanted.Count = 0 then
      begin
        // Nothing to do is a success: either everything was skipped, or the
        // archive holds only directories.
        Result.Success := True;
        Exit;
      end;

      if not ForceDirectories(LDestDir) then
      begin
        Fail('Could not create destination directory: ' + LDestDir);
        Exit;
      end;

      FEntryCount := LWanted.Count;
      FExtracting := True;
      try
        // Note: ListEntries above already did Examine, and UnZipFiles reads
        // the central directory a second time.  That is safe only because
        // TUnZipper.ReadZipDirectory clears FEntries first — without that,
        // every entry would be extracted (and reported) twice.
        FUnZip.OnCreateStream := @DoCreateStream;
        FUnZip.OnDoneStream := @DoDoneStream;
        FUnZip.FileName := AArchivePath;
        FUnZip.UnZipFiles(LWanted);
      finally
        FExtracting := False;
        FUnZip.OnCreateStream := nil;
        FUnZip.OnDoneStream := nil;
        FOnProgress := nil;
      end;

      if FCancelled then
      begin
        Fail('Extraction cancelled');
        Exit;
      end;

      // Measure what actually landed on disk rather than trusting the
      // archive's declared sizes.
      for I := 0 to FPlanTarget.Count - 1 do
        if FindFirst(FPlanTarget[I], faAnyFile, LInfo) = 0 then
        begin
          Inc(Result.FilesExtracted);
          Result.BytesExtracted := Result.BytesExtracted + LInfo.Size;
          FindClose(LInfo);
        end;

      if Result.FilesExtracted < FPlanTarget.Count then
      begin
        Fail(Format('Extracted %d of %d files',
          [Result.FilesExtracted, FPlanTarget.Count]));
        Exit;
      end;

      Result.Success := True;
    except
      on E: Exception do
      begin
        FExtracting := False;
        Fail(E.ClassName + ': ' + E.Message);
      end;
    end;
  finally
    LWanted.Free;
  end;
end;

function CreateArchive: IHCLArchive;
begin
  Result := THCLArchive.Create;
end;

end.