unit test_Archive;

{$mode objfpc}{$H+}

/// <summary>
/// test_Archive — FPCUnit tests for uHCLArchive.
///
/// Three layers are exercised:
///
/// 1. The pure path helpers — <see cref="HCLIsEntryNameSafe"/>,
///    <see cref="HCLNormalizeEntryName"/> and
///    <see cref="HCLArchiveTopLevelDir"/> — which need no archive at all and
///    carry the "zip slip" protection.
/// 2. <c>IHCLArchive.ListEntries</c> against real ZIP fixtures built on the
///    fly with FPC's <c>TZipper</c>.
/// 3. <c>IHCLArchive.Extract</c> — happy path, the three
///    <see cref="THCLOverwriteMode"/> policies, error handling, the
///    per-entry progress callback, wrapper-prefix stripping, timestamp
///    restoration and the absence of stray files in the current directory.
///
/// Hostile entry names (<c>..\evil.txt</c> and friends) are tested at the
/// pure-function level only: <c>TZipper</c> rewrites separators as it stores
/// an archive name, so authoring a genuinely malicious fixture through it is
/// not dependable.  The rejection logic itself is fully covered by the
/// <c>HCLIsEntryNameSafe</c> tests, and <c>Extract</c> consults exactly that
/// function.
///
/// Each test gets a private temp directory created in SetUp and recursively
/// deleted in TearDown so no test state leaks.
/// </summary>

interface

uses
  Classes, SysUtils, FileUtil, zipper,
  fpcunit, testregistry,
  uHCLArchive;

type
  /// <summary>
  /// FPCUnit test suite for <see cref="IHCLArchive"/>, its factory
  /// <see cref="CreateArchive"/> and the unit's exported path helpers.
  /// </summary>
  TTestArchive = class(TTestCase)
  private
    FTempDir: String;
    FArc: IHCLArchive;

    /// <summary>Sequence number keeping each MakeZip staging dir unique.</summary>
    FZipSeq: Integer;

    // --- progress-callback capture state ---------------------------------
    FProgressCalls: Integer;
    FProgressLastIndex: Integer;
    FProgressLastCount: Integer;
    FProgressNames: String;

    /// <summary>
    /// Returns <paramref name="ARelative"/> resolved under the test's
    /// private temp directory.
    /// </summary>
    function TempPath(const ARelative: String): String;

    /// <summary>
    /// Writes <paramref name="AContent"/> verbatim (no trailing newline, no
    /// BOM) to <paramref name="APath"/>, creating parent directories as
    /// needed.  Byte-exact, so BytesExtracted assertions are meaningful.
    /// </summary>
    procedure WriteTextFile(const APath, AContent: String);

    /// <summary>
    /// Reads a whole file back as a string; returns '' when it is missing.
    /// </summary>
    function ReadTextFile(const APath: String): String;

    /// <summary>
    /// Builds a ZIP fixture at <paramref name="AZipPath"/>.
    ///
    /// Each element of <paramref name="AContents"/> is written to a staging
    /// file on disk and added to the archive under the matching element of
    /// <paramref name="ANames"/>.  Note the argument order of
    /// <c>TZipper.Entries.AddFileEntry</c>: (disk filename, archive filename).
    /// </summary>
    /// <param name="AZipPath">Full path of the .zip to create.</param>
    /// <param name="ANames">Archive-relative entry names.</param>
    /// <param name="AContents">Entry payloads, parallel to ANames.</param>
    procedure MakeZip(const AZipPath: String; const ANames: array of String;
      const AContents: array of String);

    /// <summary>
    /// Writes non-ZIP junk to <paramref name="APath"/> so the archive reader
    /// has a file that exists but cannot be parsed — the shape of a
    /// truncated download or an HTML error page saved as .zip.
    /// </summary>
    procedure MakeJunkFile(const APath: String);

    /// <summary>
    /// Builds a <see cref="THCLArchiveEntry"/> literal for the
    /// HCLArchiveTopLevelDir tests, bypassing any real archive.
    /// </summary>
    function MakeEntry(const AName: String;
      AIsDirectory, AIsSafe: Boolean): THCLArchiveEntry;

    /// <summary>
    /// Finds the entry whose normalised Name matches
    /// <paramref name="AName"/>, so tests do not depend on central-directory
    /// ordering.
    /// </summary>
    /// <returns>True, and the entry via <paramref name="AEntry"/>, when found.</returns>
    function FindEntry(const AEntries: THCLArchiveEntryArray;
      const AName: String; out AEntry: THCLArchiveEntry): Boolean;

    /// <summary>
    /// <see cref="THCLExtractProgressEvent"/> handler recording how often it
    /// fired, the last index/count reported and the names it saw.  Assigned
    /// with <c>@</c> because the suite compiles in objfpc mode.
    /// </summary>
    procedure ProgressHandler(ASender: TObject; const AEntryName: String;
      AEntryIndex, AEntryCount: Integer);

  protected
    /// <summary>Creates a unique temp directory and the IHCLArchive under test.</summary>
    procedure SetUp; override;

    /// <summary>Releases the interface and recursively deletes the temp directory.</summary>
    procedure TearDown; override;

  published
    // --- HCLIsEntryNameSafe -----------------------------------------------

    /// <summary>A bare filename with no path is safe.</summary>
    procedure TestIsEntryNameSafe_AcceptsPlainName;

    /// <summary>
    /// Relative subdirectory paths are safe with either separator, since
    /// community ZIPs are produced by a mix of tools.
    /// </summary>
    procedure TestIsEntryNameSafe_AcceptsRelativePaths;

    /// <summary>
    /// Dots inside a segment ('my..file.txt', 'v1.2/readme.txt') are safe —
    /// only a whole '..' segment is a traversal.
    /// </summary>
    procedure TestIsEntryNameSafe_AcceptsDotsWithinName;

    /// <summary>Empty and whitespace-only names are rejected.</summary>
    procedure TestIsEntryNameSafe_RejectsEmptyAndWhitespace;

    /// <summary>A leading '..' segment is rejected with either separator.</summary>
    procedure TestIsEntryNameSafe_RejectsParentSegment;

    /// <summary>
    /// A '..' segment anywhere in the path is rejected, even when the path
    /// starts out looking innocent ('a/../../b.txt').
    /// </summary>
    procedure TestIsEntryNameSafe_RejectsEmbeddedParentSegment;

    /// <summary>Absolute paths are rejected with either separator.</summary>
    procedure TestIsEntryNameSafe_RejectsAbsolutePaths;

    /// <summary>
    /// A colon is rejected wherever it appears: it means either a drive
    /// letter or an NTFS alternate data stream.
    /// </summary>
    procedure TestIsEntryNameSafe_RejectsDriveAndStream;

    // --- HCLNormalizeEntryName --------------------------------------------

    /// <summary>A name with no separators is returned unchanged.</summary>
    procedure TestNormalizeEntryName_PlainNameUnchanged;

    /// <summary>Forward slashes become PathDelim.</summary>
    procedure TestNormalizeEntryName_ForwardSlashes;

    /// <summary>Backslashes become PathDelim.</summary>
    procedure TestNormalizeEntryName_Backslashes;

    /// <summary>
    /// Leading delimiters are stripped so the result always joins as a
    /// relative path.
    /// </summary>
    procedure TestNormalizeEntryName_StripsLeadingDelimiters;

    // --- HCLArchiveTopLevelDir --------------------------------------------

    /// <summary>An empty entry array yields ''.</summary>
    procedure TestTopLevelDir_EmptyArray;

    /// <summary>
    /// When every entry sits under one directory, that directory is returned.
    /// </summary>
    procedure TestTopLevelDir_CommonWrapper;

    /// <summary>A file at the archive root means there is no wrapper dir.</summary>
    procedure TestTopLevelDir_FileAtRoot;

    /// <summary>Two different top-level directories yield ''.</summary>
    procedure TestTopLevelDir_TwoTopLevelDirs;

    /// <summary>
    /// Entries flagged unsafe are skipped entirely, so a hostile name cannot
    /// veto an otherwise well-formed wrapper directory.
    /// </summary>
    procedure TestTopLevelDir_IgnoresUnsafeEntries;

    /// <summary>
    /// An explicit directory entry at the root is treated as the wrapper
    /// rather than as a loose root file.
    /// </summary>
    procedure TestTopLevelDir_DirectoryEntryAtRoot;

    /// <summary>
    /// Top-level names are compared case-insensitively; the first spelling
    /// encountered is the one returned.
    /// </summary>
    procedure TestTopLevelDir_CaseInsensitive;

    // --- ListEntries ------------------------------------------------------

    /// <summary>
    /// A two-file fixture lists two entries with the expected names, sizes
    /// and safety flags.
    /// </summary>
    procedure TestListEntries_CountNamesAndSizes;

    /// <summary>
    /// A nested entry keeps its raw '/' name (what TUnZipper matches on) and
    /// reports a Name normalised to PathDelim.
    /// </summary>
    procedure TestListEntries_NestedNameNormalised;

    /// <summary>A path that does not exist yields an empty array.</summary>
    procedure TestListEntries_MissingFile;

    /// <summary>
    /// A file that exists but is not a ZIP yields an empty array rather than
    /// raising.
    /// </summary>
    procedure TestListEntries_NotAZipFile;

    // --- Extract: happy path ----------------------------------------------

    /// <summary>
    /// Files land at the expected paths with byte-exact contents, and
    /// Success is True with an empty ErrorMessage.
    /// </summary>
    procedure TestExtract_HappyPath;

    /// <summary>
    /// FilesExtracted, BytesExtracted, FilesSkipped and UnsafeEntries are all
    /// accounted for on a clean archive.
    /// </summary>
    procedure TestExtract_Counters;

    /// <summary>
    /// Intermediate directories named by an entry are recreated under the
    /// destination.
    /// </summary>
    procedure TestExtract_NestedSubdirectoryRecreated;

    // --- Extract: overwrite policy ----------------------------------------

    /// <summary>
    /// omSkip leaves an existing target untouched, counts it in FilesSkipped,
    /// and still extracts the remaining entries.
    /// </summary>
    procedure TestExtract_SkipMode;

    /// <summary>omOverwrite replaces an existing target with the archived copy.</summary>
    procedure TestExtract_OverwriteMode;

    /// <summary>
    /// omFail aborts the whole extraction: Success is False, ErrorMessage is
    /// populated and no other entry is written.
    /// </summary>
    procedure TestExtract_FailMode;

    // --- Extract: error handling ------------------------------------------

    /// <summary>A missing archive fails cleanly without raising.</summary>
    procedure TestExtract_MissingArchive;

    /// <summary>An empty destination string fails cleanly without raising.</summary>
    procedure TestExtract_EmptyDestination;

    /// <summary>An unreadable (non-ZIP) archive fails cleanly without raising.</summary>
    procedure TestExtract_NotAZipFile;

    // --- Extract: progress and state ---------------------------------------

    /// <summary>
    /// The progress callback fires exactly once per extracted file, with a
    /// 1-based index and an AEntryCount matching the number of files.
    /// </summary>
    procedure TestExtract_ProgressCallback;

    /// <summary>IsExtracting is False before and after a synchronous Extract.</summary>
    procedure TestIsExtracting_FalseBeforeAndAfter;

    /// <summary>
    /// A Cancel issued while idle does not poison the next Extract — the
    /// cancelled flag is reset at the start of each run.
    /// </summary>
    procedure TestCancelWhileIdleIsReset;

    // --- Extract: strip prefix ---------------------------------------------

    /// <summary>
    /// Entries beneath the strip prefix land directly in the destination,
    /// subdirectories below the prefix are kept, and no prefix directory is
    /// created.
    /// </summary>
    procedure TestExtract_StripPrefixHappyPath;

    /// <summary>
    /// A prefix written with '/' or '\', or with a trailing delimiter,
    /// behaves exactly like the bare name.
    /// </summary>
    procedure TestExtract_StripPrefixSeparatorsAndTrailingDelim;

    /// <summary>The prefix is matched case-insensitively.</summary>
    procedure TestExtract_StripPrefixCaseInsensitive;

    /// <summary>Entries not beneath the prefix are extracted unchanged.</summary>
    procedure TestExtract_StripPrefixLeavesOtherEntries;
    /// <summary>With AOnlyUnderPrefix, entries outside the prefix are not extracted at all.</summary>
    procedure TestExtract_OnlyUnderPrefix;
    /// <summary>With AOnlyUnderPrefix and no prefix, only top-level files are extracted.</summary>
    procedure TestExtract_OnlyUnderEmptyPrefixIsTopLevel;
    /// <summary>ReadEntry returns one entry's bytes and writes nothing to disk.</summary>
    procedure TestReadEntry;
    /// <summary>ReadEntry refuses missing, oversized and unreadable entries with ''.</summary>
    procedure TestReadEntryRefusals;

    /// <summary>
    /// Stripped entries merge into a destination that already holds files,
    /// leaving those files untouched.
    /// </summary>
    procedure TestExtract_StripPrefixMergesWithExisting;

    /// <summary>
    /// The overwrite policy is applied to the stripped target path, not to
    /// the archive-relative path.
    /// </summary>
    procedure TestExtract_StripPrefixSkipUsesStrippedTarget;

    /// <summary>The progress callback reports the stripped relative name.</summary>
    procedure TestExtract_StripPrefixProgressNames;

    // --- Extract: output-file handling -------------------------------------

    /// <summary>
    /// An extracted file carries the archive entry's timestamp, within the
    /// 2-second resolution of a ZIP DOS timestamp.
    /// </summary>
    procedure TestExtract_TimestampPreserved;

    /// <summary>
    /// Extraction writes nothing to the process's current directory — guards
    /// the TUnZipper fallback that creates files relative to the CWD.
    /// </summary>
    procedure TestExtract_NoStrayFilesInCurrentDir;
  end;

implementation

{ --------------------------------------------------------------------------- }
{ Helpers                                                                      }
{ --------------------------------------------------------------------------- }

function TTestArchive.TempPath(const ARelative: String): String;
begin
  Result := FTempDir + PathDelim + ARelative;
end;

procedure TTestArchive.WriteTextFile(const APath, AContent: String);
var
  LDir: String;
  LStream: TFileStream;
begin
  LDir := ExtractFilePath(APath);
  if (LDir <> '') and (not DirectoryExists(LDir)) then
    ForceDirectories(LDir);

  LStream := TFileStream.Create(APath, fmCreate);
  try
    if Length(AContent) > 0 then
      LStream.WriteBuffer(AContent[1], Length(AContent));
  finally
    LStream.Free;
  end;
end;

function TTestArchive.ReadTextFile(const APath: String): String;
var
  LStream: TFileStream;
  LSize: Integer;
begin
  Result := '';
  if not FileExists(APath) then
    Exit;

  LStream := TFileStream.Create(APath, fmOpenRead or fmShareDenyNone);
  try
    LSize := Integer(LStream.Size);
    SetLength(Result, LSize);
    if LSize > 0 then
      LStream.ReadBuffer(Result[1], LSize);
  finally
    LStream.Free;
  end;
end;

procedure TTestArchive.MakeZip(const AZipPath: String;
  const ANames: array of String; const AContents: array of String);
var
  LZip: TZipper;
  LSrcDir, LDiskFile: String;
  I: Integer;
begin
  Inc(FZipSeq);
  LSrcDir := TempPath('zipsrc' + IntToStr(FZipSeq));
  ForceDirectories(LSrcDir);
  ForceDirectories(ExtractFileDir(AZipPath));

  LZip := TZipper.Create;
  try
    LZip.FileName := AZipPath;
    for I := Low(ANames) to High(ANames) do
    begin
      LDiskFile := LSrcDir + PathDelim + 'entry' + IntToStr(I) + '.dat';
      WriteTextFile(LDiskFile, AContents[I]);
      // (disk filename, archive filename) — in that order.
      LZip.Entries.AddFileEntry(LDiskFile, ANames[I]);
    end;
    LZip.ZipAllFiles;
  finally
    LZip.Free;
  end;
end;

procedure TTestArchive.MakeJunkFile(const APath: String);
begin
  // Deliberately free of any PK signature so the central-directory scan fails.
  WriteTextFile(APath,
    'This is not a ZIP archive. It is ordinary text that happens to live at '
    + 'a .zip path, which is exactly the shape of a truncated download or an '
    + 'HTML error page saved under the wrong extension.');
end;

function TTestArchive.MakeEntry(const AName: String;
  AIsDirectory, AIsSafe: Boolean): THCLArchiveEntry;
begin
  Result.Name        := AName;
  Result.RawName     := AName;
  Result.Size        := 0;
  Result.IsDirectory := AIsDirectory;
  Result.IsSafe      := AIsSafe;
end;

function TTestArchive.FindEntry(const AEntries: THCLArchiveEntryArray;
  const AName: String; out AEntry: THCLArchiveEntry): Boolean;
var
  I: Integer;
begin
  Result := False;
  AEntry := Default(THCLArchiveEntry);
  for I := 0 to High(AEntries) do
    if SameText(AEntries[I].Name, AName) then
    begin
      AEntry := AEntries[I];
      Exit(True);
    end;
end;

procedure TTestArchive.ProgressHandler(ASender: TObject;
  const AEntryName: String; AEntryIndex, AEntryCount: Integer);
begin
  Inc(FProgressCalls);
  FProgressLastIndex := AEntryIndex;
  FProgressLastCount := AEntryCount;
  if FProgressNames <> '' then
    FProgressNames := FProgressNames + '|';
  FProgressNames := FProgressNames + AEntryName;
end;

{ --------------------------------------------------------------------------- }
{ SetUp / TearDown                                                             }
{ --------------------------------------------------------------------------- }

procedure TTestArchive.SetUp;
begin
  FTempDir := GetTempDir + 'HCLArchiveTest_' + IntToStr(GetTickCount64);
  ForceDirectories(FTempDir);

  FArc := CreateArchive;

  FZipSeq            := 0;
  FProgressCalls     := 0;
  FProgressLastIndex := 0;
  FProgressLastCount := 0;
  FProgressNames     := '';
end;

procedure TTestArchive.TearDown;
begin
  FArc := nil;
  if DirectoryExists(FTempDir) then
    DeleteDirectory(FTempDir, False);
end;

{ --------------------------------------------------------------------------- }
{ HCLIsEntryNameSafe                                                           }
{ --------------------------------------------------------------------------- }

procedure TTestArchive.TestIsEntryNameSafe_AcceptsPlainName;
begin
  AssertTrue('readme.txt is safe', HCLIsEntryNameSafe('readme.txt'));
  AssertTrue('GIUK.RES is safe',   HCLIsEntryNameSafe('GIUK.RES'));
end;

procedure TTestArchive.TestIsEntryNameSafe_AcceptsRelativePaths;
begin
  AssertTrue('forward-slash path is safe',
    HCLIsEntryNameSafe('sub/dir/file.res'));
  AssertTrue('backslash path is safe',
    HCLIsEntryNameSafe('sub\dir\file.res'));
  AssertTrue('mixed separators are safe',
    HCLIsEntryNameSafe('sub/dir\file.res'));
end;

procedure TTestArchive.TestIsEntryNameSafe_AcceptsDotsWithinName;
begin
  // Only a whole '..' segment is a traversal; dots inside a segment are not.
  AssertTrue('my..file.txt is safe',
    HCLIsEntryNameSafe('my..file.txt'));
  AssertTrue('v1.2/readme.txt is safe',
    HCLIsEntryNameSafe('v1.2/readme.txt'));
  AssertTrue('..hidden.txt is safe',
    HCLIsEntryNameSafe('..hidden.txt'));
  AssertTrue('a/..b/c.txt is safe',
    HCLIsEntryNameSafe('a/..b/c.txt'));
end;

procedure TTestArchive.TestIsEntryNameSafe_RejectsEmptyAndWhitespace;
begin
  AssertFalse('empty name is unsafe',       HCLIsEntryNameSafe(''));
  AssertFalse('spaces-only name is unsafe', HCLIsEntryNameSafe('   '));
  AssertFalse('tab-only name is unsafe',    HCLIsEntryNameSafe(#9));
end;

procedure TTestArchive.TestIsEntryNameSafe_RejectsParentSegment;
begin
  AssertFalse('../evil.txt is unsafe', HCLIsEntryNameSafe('../evil.txt'));
  AssertFalse('..\evil.txt is unsafe', HCLIsEntryNameSafe('..\evil.txt'));
  AssertFalse('bare .. is unsafe',     HCLIsEntryNameSafe('..'));
end;

procedure TTestArchive.TestIsEntryNameSafe_RejectsEmbeddedParentSegment;
begin
  AssertFalse('a/../../b.txt is unsafe',
    HCLIsEntryNameSafe('a/../../b.txt'));
  AssertFalse('good/../../../bad.txt is unsafe',
    HCLIsEntryNameSafe('good/../../../bad.txt'));
  AssertFalse('a trailing .. segment is unsafe',
    HCLIsEntryNameSafe('a/b/..'));
end;

procedure TTestArchive.TestIsEntryNameSafe_RejectsAbsolutePaths;
begin
  AssertFalse('/abs/path.txt is unsafe', HCLIsEntryNameSafe('/abs/path.txt'));
  AssertFalse('\abs\path.txt is unsafe', HCLIsEntryNameSafe('\abs\path.txt'));
end;

procedure TTestArchive.TestIsEntryNameSafe_RejectsDriveAndStream;
begin
  AssertFalse('C:\win\evil.txt is unsafe',
    HCLIsEntryNameSafe('C:\win\evil.txt'));
  AssertFalse('alternate data stream is unsafe',
    HCLIsEntryNameSafe('file.txt:stream'));
  AssertFalse('bare drive reference is unsafe',
    HCLIsEntryNameSafe('C:evil.txt'));
end;

{ --------------------------------------------------------------------------- }
{ HCLNormalizeEntryName                                                        }
{ --------------------------------------------------------------------------- }

procedure TTestArchive.TestNormalizeEntryName_PlainNameUnchanged;
begin
  AssertEquals('plain name untouched',
    'readme.txt', HCLNormalizeEntryName('readme.txt'));
  AssertEquals('empty name stays empty',
    '', HCLNormalizeEntryName(''));
end;

procedure TTestArchive.TestNormalizeEntryName_ForwardSlashes;
begin
  AssertEquals('forward slashes mapped to PathDelim',
    'sub' + PathDelim + 'dir' + PathDelim + 'file.res',
    HCLNormalizeEntryName('sub/dir/file.res'));
end;

procedure TTestArchive.TestNormalizeEntryName_Backslashes;
begin
  AssertEquals('backslashes mapped to PathDelim',
    'sub' + PathDelim + 'dir' + PathDelim + 'file.res',
    HCLNormalizeEntryName('sub\dir\file.res'));
end;

procedure TTestArchive.TestNormalizeEntryName_StripsLeadingDelimiters;
begin
  AssertEquals('single leading forward slash stripped',
    'leading' + PathDelim + 'x.txt',
    HCLNormalizeEntryName('/leading/x.txt'));

  AssertEquals('single leading backslash stripped',
    'leading' + PathDelim + 'x.txt',
    HCLNormalizeEntryName('\leading\x.txt'));

  AssertEquals('repeated leading delimiters stripped',
    'a.txt',
    HCLNormalizeEntryName('//a.txt'));

  AssertEquals('UNC-style leading delimiters stripped',
    'server' + PathDelim + 'share',
    HCLNormalizeEntryName('\\server\share'));
end;

{ --------------------------------------------------------------------------- }
{ HCLArchiveTopLevelDir                                                        }
{ --------------------------------------------------------------------------- }

procedure TTestArchive.TestTopLevelDir_EmptyArray;
var
  LEntries: THCLArchiveEntryArray;
begin
  LEntries := nil;
  AssertEquals('no entries means no wrapper dir',
    '', HCLArchiveTopLevelDir(LEntries));
end;

procedure TTestArchive.TestTopLevelDir_CommonWrapper;
var
  LEntries: THCLArchiveEntryArray;
begin
  SetLength(LEntries, 3);
  LEntries[0] := MakeEntry('wrapper/', True, True);
  LEntries[1] := MakeEntry('wrapper/readme.txt', False, True);
  LEntries[2] := MakeEntry('wrapper/data/GIUK.RES', False, True);

  AssertEquals('common wrapper dir returned',
    'wrapper', HCLArchiveTopLevelDir(LEntries));
end;

procedure TTestArchive.TestTopLevelDir_FileAtRoot;
var
  LEntries: THCLArchiveEntryArray;
begin
  SetLength(LEntries, 2);
  LEntries[0] := MakeEntry('readme.txt', False, True);
  LEntries[1] := MakeEntry('wrapper/data.bin', False, True);

  AssertEquals('a file at the root defeats the wrapper dir',
    '', HCLArchiveTopLevelDir(LEntries));
end;

procedure TTestArchive.TestTopLevelDir_TwoTopLevelDirs;
var
  LEntries: THCLArchiveEntryArray;
begin
  SetLength(LEntries, 2);
  LEntries[0] := MakeEntry('alpha/a.txt', False, True);
  LEntries[1] := MakeEntry('beta/b.txt', False, True);

  AssertEquals('two top-level dirs mean no single wrapper',
    '', HCLArchiveTopLevelDir(LEntries));
end;

procedure TTestArchive.TestTopLevelDir_IgnoresUnsafeEntries;
var
  LEntries: THCLArchiveEntryArray;
begin
  SetLength(LEntries, 3);
  LEntries[0] := MakeEntry('../evil.txt', False, False);   // skipped entirely
  LEntries[1] := MakeEntry('wrapper/a.txt', False, True);
  LEntries[2] := MakeEntry('wrapper/b.txt', False, True);

  AssertEquals('unsafe entries do not affect the wrapper dir',
    'wrapper', HCLArchiveTopLevelDir(LEntries));
end;

procedure TTestArchive.TestTopLevelDir_DirectoryEntryAtRoot;
var
  LEntries: THCLArchiveEntryArray;
begin
  SetLength(LEntries, 1);
  LEntries[0] := MakeEntry('wrapper/', True, True);

  AssertEquals('a lone root directory entry is the wrapper',
    'wrapper', HCLArchiveTopLevelDir(LEntries));
end;

procedure TTestArchive.TestTopLevelDir_CaseInsensitive;
var
  LEntries: THCLArchiveEntryArray;
begin
  SetLength(LEntries, 2);
  LEntries[0] := MakeEntry('Wrapper/a.txt', False, True);
  LEntries[1] := MakeEntry('wrapper/b.txt', False, True);

  // Comparison is SameText, so the two spellings agree and the first wins.
  AssertEquals('case-insensitive match keeps the first spelling',
    'Wrapper', HCLArchiveTopLevelDir(LEntries));
end;

{ --------------------------------------------------------------------------- }
{ ListEntries                                                                  }
{ --------------------------------------------------------------------------- }

procedure TTestArchive.TestListEntries_CountNamesAndSizes;
var
  LZipPath: String;
  LEntries: THCLArchiveEntryArray;
  LEntry: THCLArchiveEntry;
begin
  LZipPath := TempPath('list.zip');
  MakeZip(LZipPath, ['readme.txt', 'data.bin'], ['hello', 'abcdefgh']);

  LEntries := FArc.ListEntries(LZipPath);

  AssertEquals('entry count', 2, Length(LEntries));

  AssertTrue('readme.txt listed',
    FindEntry(LEntries, 'readme.txt', LEntry));
  AssertEquals('readme.txt size', Int64(5), LEntry.Size);
  AssertEquals('readme.txt raw name', 'readme.txt', LEntry.RawName);
  AssertFalse('readme.txt is not a directory', LEntry.IsDirectory);
  AssertTrue('readme.txt is safe', LEntry.IsSafe);

  AssertTrue('data.bin listed',
    FindEntry(LEntries, 'data.bin', LEntry));
  AssertEquals('data.bin size', Int64(8), LEntry.Size);
  AssertTrue('data.bin is safe', LEntry.IsSafe);
end;

procedure TTestArchive.TestListEntries_NestedNameNormalised;
var
  LZipPath: String;
  LEntries: THCLArchiveEntryArray;
  LEntry: THCLArchiveEntry;
begin
  LZipPath := TempPath('nested.zip');
  MakeZip(LZipPath, ['sub/dir/file.res'], ['1234']);

  LEntries := FArc.ListEntries(LZipPath);
  AssertEquals('entry count', 1, Length(LEntries));

  AssertTrue('nested entry listed under its normalised name',
    FindEntry(LEntries,
      'sub' + PathDelim + 'dir' + PathDelim + 'file.res', LEntry));

  // The ZIP standard stores '/' regardless of platform, and RawName must keep
  // it because that is what TUnZipper matches against.
  AssertEquals('raw name keeps ZIP separators',
    'sub/dir/file.res', LEntry.RawName);
  AssertEquals('nested entry size', Int64(4), LEntry.Size);
  AssertTrue('nested entry is safe', LEntry.IsSafe);
end;

procedure TTestArchive.TestListEntries_MissingFile;
var
  LEntries: THCLArchiveEntryArray;
begin
  LEntries := FArc.ListEntries(TempPath('no_such_archive.zip'));
  AssertEquals('missing archive lists no entries', 0, Length(LEntries));
end;

procedure TTestArchive.TestListEntries_NotAZipFile;
var
  LPath: String;
  LEntries: THCLArchiveEntryArray;
begin
  LPath := TempPath('junk.zip');
  MakeJunkFile(LPath);

  LEntries := FArc.ListEntries(LPath);
  AssertEquals('unparseable archive lists no entries', 0, Length(LEntries));
end;

{ --------------------------------------------------------------------------- }
{ Extract — happy path                                                         }
{ --------------------------------------------------------------------------- }

procedure TTestArchive.TestExtract_HappyPath;
var
  LZipPath, LDest: String;
  LResult: THCLExtractResult;
begin
  LZipPath := TempPath('happy.zip');
  LDest    := TempPath('out_happy');
  MakeZip(LZipPath, ['readme.txt', 'data.bin'], ['hello', 'abcdefgh']);

  LResult := FArc.Extract(LZipPath, LDest, omOverwrite, nil);

  AssertTrue('Extract succeeded: ' + LResult.ErrorMessage, LResult.Success);
  AssertEquals('ErrorMessage empty on success', '', LResult.ErrorMessage);
  AssertEquals('DestDir echoed back', LDest, LResult.DestDir);

  AssertTrue('readme.txt written',
    FileExists(LDest + PathDelim + 'readme.txt'));
  AssertTrue('data.bin written',
    FileExists(LDest + PathDelim + 'data.bin'));

  AssertEquals('readme.txt content',
    'hello', ReadTextFile(LDest + PathDelim + 'readme.txt'));
  AssertEquals('data.bin content',
    'abcdefgh', ReadTextFile(LDest + PathDelim + 'data.bin'));
end;

procedure TTestArchive.TestExtract_Counters;
var
  LZipPath, LDest: String;
  LResult: THCLExtractResult;
begin
  LZipPath := TempPath('counters.zip');
  LDest    := TempPath('out_counters');
  MakeZip(LZipPath, ['a.txt', 'b.txt'], ['hello', 'abcdefgh']);

  LResult := FArc.Extract(LZipPath, LDest, omOverwrite, nil);

  AssertTrue('Extract succeeded: ' + LResult.ErrorMessage, LResult.Success);
  AssertEquals('FilesExtracted', 2, LResult.FilesExtracted);
  AssertEquals('BytesExtracted', Int64(13), LResult.BytesExtracted);
  AssertEquals('FilesSkipped', 0, LResult.FilesSkipped);
  AssertEquals('no unsafe entries in a clean archive',
    0, Length(LResult.UnsafeEntries));
end;

procedure TTestArchive.TestExtract_NestedSubdirectoryRecreated;
var
  LZipPath, LDest, LNested: String;
  LResult: THCLExtractResult;
begin
  LZipPath := TempPath('nestedex.zip');
  LDest    := TempPath('out_nested');
  MakeZip(LZipPath,
    ['top.txt', 'sub/dir/deep.res'],
    ['TT', 'DEEPDATA']);

  LResult := FArc.Extract(LZipPath, LDest, omOverwrite, nil);

  AssertTrue('Extract succeeded: ' + LResult.ErrorMessage, LResult.Success);

  AssertTrue('intermediate directory created',
    DirectoryExists(LDest + PathDelim + 'sub' + PathDelim + 'dir'));

  LNested := LDest + PathDelim + 'sub' + PathDelim + 'dir'
    + PathDelim + 'deep.res';
  AssertTrue('nested file written', FileExists(LNested));
  AssertEquals('nested file content', 'DEEPDATA', ReadTextFile(LNested));

  AssertEquals('FilesExtracted', 2, LResult.FilesExtracted);
  AssertEquals('BytesExtracted', Int64(10), LResult.BytesExtracted);
end;

{ --------------------------------------------------------------------------- }
{ Extract — overwrite policy                                                   }
{ --------------------------------------------------------------------------- }

procedure TTestArchive.TestExtract_SkipMode;
var
  LZipPath, LDest, LFirst, LSecond: String;
  LResult: THCLExtractResult;
begin
  LZipPath := TempPath('skip.zip');
  LDest    := TempPath('out_skip');
  MakeZip(LZipPath, ['first.txt', 'second.txt'], ['ZIPPED-1', 'ZIPPED-2']);

  LFirst  := LDest + PathDelim + 'first.txt';
  LSecond := LDest + PathDelim + 'second.txt';

  ForceDirectories(LDest);
  WriteTextFile(LSecond, 'ORIGINAL');

  LResult := FArc.Extract(LZipPath, LDest, omSkip, nil);

  AssertTrue('Extract succeeded: ' + LResult.ErrorMessage, LResult.Success);
  AssertEquals('one file skipped', 1, LResult.FilesSkipped);
  AssertEquals('one file extracted', 1, LResult.FilesExtracted);

  AssertEquals('existing file left untouched',
    'ORIGINAL', ReadTextFile(LSecond));
  AssertTrue('the other entry was still extracted', FileExists(LFirst));
  AssertEquals('the other entry has the archived content',
    'ZIPPED-1', ReadTextFile(LFirst));
end;

procedure TTestArchive.TestExtract_OverwriteMode;
var
  LZipPath, LDest, LSecond: String;
  LResult: THCLExtractResult;
begin
  LZipPath := TempPath('over.zip');
  LDest    := TempPath('out_over');
  MakeZip(LZipPath, ['first.txt', 'second.txt'], ['ZIPPED-1', 'ZIPPED-2']);

  LSecond := LDest + PathDelim + 'second.txt';

  ForceDirectories(LDest);
  WriteTextFile(LSecond, 'ORIGINAL-CONTENT-THAT-IS-LONGER');

  LResult := FArc.Extract(LZipPath, LDest, omOverwrite, nil);

  AssertTrue('Extract succeeded: ' + LResult.ErrorMessage, LResult.Success);
  AssertEquals('nothing skipped under omOverwrite', 0, LResult.FilesSkipped);
  AssertEquals('both files extracted', 2, LResult.FilesExtracted);

  AssertEquals('existing file replaced by the archived copy',
    'ZIPPED-2', ReadTextFile(LSecond));
end;

procedure TTestArchive.TestExtract_FailMode;
var
  LZipPath, LDest, LFirst, LSecond: String;
  LResult: THCLExtractResult;
begin
  LZipPath := TempPath('fail.zip');
  LDest    := TempPath('out_fail');
  MakeZip(LZipPath, ['first.txt', 'second.txt'], ['ZIPPED-1', 'ZIPPED-2']);

  LFirst  := LDest + PathDelim + 'first.txt';
  LSecond := LDest + PathDelim + 'second.txt';

  ForceDirectories(LDest);
  WriteTextFile(LSecond, 'ORIGINAL');

  LResult := FArc.Extract(LZipPath, LDest, omFail, nil);

  AssertFalse('Extract must fail when a target already exists',
    LResult.Success);
  AssertTrue('ErrorMessage is populated', LResult.ErrorMessage <> '');
  AssertEquals('nothing counted as extracted', 0, LResult.FilesExtracted);

  // The whole operation is abandoned, so the other entry is never written.
  AssertFalse('no other entry extracted', FileExists(LFirst));
  AssertEquals('pre-existing file untouched',
    'ORIGINAL', ReadTextFile(LSecond));
end;

{ --------------------------------------------------------------------------- }
{ Extract — error handling                                                     }
{ --------------------------------------------------------------------------- }

procedure TTestArchive.TestExtract_MissingArchive;
var
  LResult: THCLExtractResult;
begin
  // Must report, not raise.
  LResult := FArc.Extract(TempPath('nothing_here.zip'),
    TempPath('out_missing'), omOverwrite, nil);

  AssertFalse('missing archive must not succeed', LResult.Success);
  AssertTrue('ErrorMessage is populated', LResult.ErrorMessage <> '');
  AssertEquals('nothing extracted', 0, LResult.FilesExtracted);
  AssertFalse('destination not created',
    DirectoryExists(TempPath('out_missing')));
end;

procedure TTestArchive.TestExtract_EmptyDestination;
var
  LZipPath: String;
  LResult: THCLExtractResult;
begin
  // The archive must exist, or the "not found" check would fire first.
  LZipPath := TempPath('emptydest.zip');
  MakeZip(LZipPath, ['readme.txt'], ['hello']);

  LResult := FArc.Extract(LZipPath, '', omOverwrite, nil);

  AssertFalse('empty destination must not succeed', LResult.Success);
  AssertTrue('ErrorMessage is populated', LResult.ErrorMessage <> '');
  AssertEquals('nothing extracted', 0, LResult.FilesExtracted);
end;

procedure TTestArchive.TestExtract_NotAZipFile;
var
  LPath: String;
  LResult: THCLExtractResult;
begin
  LPath := TempPath('junk2.zip');
  MakeJunkFile(LPath);

  LResult := FArc.Extract(LPath, TempPath('out_junk'), omOverwrite, nil);

  AssertFalse('unreadable archive must not succeed', LResult.Success);
  AssertTrue('ErrorMessage is populated', LResult.ErrorMessage <> '');
  AssertEquals('nothing extracted', 0, LResult.FilesExtracted);
end;

{ --------------------------------------------------------------------------- }
{ Extract — progress and state                                                 }
{ --------------------------------------------------------------------------- }

procedure TTestArchive.TestExtract_ProgressCallback;
var
  LZipPath, LDest: String;
  LResult: THCLExtractResult;
begin
  LZipPath := TempPath('progress.zip');
  LDest    := TempPath('out_progress');
  MakeZip(LZipPath,
    ['one.txt', 'two.txt', 'sub/nested.txt'],
    ['AA', 'BB', 'CC']);

  LResult := FArc.Extract(LZipPath, LDest, omOverwrite, @ProgressHandler);

  AssertTrue('Extract succeeded: ' + LResult.ErrorMessage, LResult.Success);
  AssertEquals('three files extracted', 3, LResult.FilesExtracted);

  AssertEquals('callback fired once per extracted file', 3, FProgressCalls);
  AssertEquals('AEntryCount matches the number of files extracted',
    3, FProgressLastCount);
  AssertEquals('AEntryIndex is 1-based and ends at the file count',
    3, FProgressLastIndex);

  // Names are reported relative to the destination directory.
  AssertTrue('progress reported archive-relative names, got: ' + FProgressNames,
    Pos('one.txt', FProgressNames) > 0);
  AssertTrue('progress reported the nested name, got: ' + FProgressNames,
    Pos('sub' + PathDelim + 'nested.txt', FProgressNames) > 0);
  AssertEquals('destination path not leaked into progress names',
    0, Pos(LDest, FProgressNames));
end;

procedure TTestArchive.TestIsExtracting_FalseBeforeAndAfter;
var
  LZipPath, LDest: String;
  LResult: THCLExtractResult;
begin
  LZipPath := TempPath('state.zip');
  LDest    := TempPath('out_state');
  MakeZip(LZipPath, ['readme.txt'], ['hello']);

  AssertFalse('IsExtracting False before Extract', FArc.IsExtracting);

  LResult := FArc.Extract(LZipPath, LDest, omOverwrite, nil);

  AssertTrue('Extract succeeded: ' + LResult.ErrorMessage, LResult.Success);
  AssertFalse('IsExtracting False after Extract', FArc.IsExtracting);
end;

procedure TTestArchive.TestCancelWhileIdleIsReset;
var
  LZipPath, LDest: String;
  LResult: THCLExtractResult;
begin
  LZipPath := TempPath('cancel.zip');
  LDest    := TempPath('out_cancel');
  MakeZip(LZipPath, ['readme.txt'], ['hello']);

  // Cancel with no extraction running only raises the flag; the next Extract
  // clears it, so the request must not leak into a later run.
  FArc.Cancel;
  AssertFalse('Cancel while idle does not start an extraction',
    FArc.IsExtracting);

  LResult := FArc.Extract(LZipPath, LDest, omOverwrite, nil);

  AssertTrue('Extract after an idle Cancel still succeeds: '
    + LResult.ErrorMessage, LResult.Success);
  AssertEquals('file extracted', 1, LResult.FilesExtracted);
  AssertEquals('content intact',
    'hello', ReadTextFile(LDest + PathDelim + 'readme.txt'));
end;

{ --------------------------------------------------------------------------- }
{ Extract — strip prefix                                                       }
{ --------------------------------------------------------------------------- }

procedure TTestArchive.TestExtract_StripPrefixHappyPath;
var
  LZipPath, LDest: String;
  LResult: THCLExtractResult;
begin
  LZipPath := TempPath('strip.zip');
  LDest    := TempPath('out_strip');
  MakeZip(LZipPath, ['Wrap/a.txt', 'Wrap/sub/b.txt'], ['AAA', 'BBBB']);

  LResult := FArc.Extract(LZipPath, LDest, omOverwrite, nil, 'Wrap');

  AssertTrue('Extract succeeded: ' + LResult.ErrorMessage, LResult.Success);
  AssertEquals('FilesExtracted', 2, LResult.FilesExtracted);
  AssertEquals('a.txt stripped to the destination root',
    'AAA', ReadTextFile(LDest + PathDelim + 'a.txt'));
  AssertEquals('sub\b.txt keeps its subdirectory below the prefix',
    'BBBB', ReadTextFile(LDest + PathDelim + 'sub' + PathDelim + 'b.txt'));
  AssertFalse('no wrapper directory created',
    DirectoryExists(LDest + PathDelim + 'Wrap'));
end;

procedure TTestArchive.TestExtract_StripPrefixSeparatorsAndTrailingDelim;
const
  PREFIXES: array[0..2] of String = ('Wrap/', 'Wrap\', 'Wrap');
var
  LZipPath, LDest: String;
  LResult: THCLExtractResult;
  I: Integer;
begin
  LZipPath := TempPath('stripsep.zip');
  MakeZip(LZipPath, ['Wrap/a.txt', 'Wrap/sub/b.txt'], ['AAA', 'BBBB']);

  for I := Low(PREFIXES) to High(PREFIXES) do
  begin
    LDest := TempPath('out_stripsep' + IntToStr(I));
    LResult := FArc.Extract(LZipPath, LDest, omOverwrite, nil, PREFIXES[I]);

    AssertTrue('Extract with prefix "' + PREFIXES[I] + '" succeeded: '
      + LResult.ErrorMessage, LResult.Success);
    AssertTrue('a.txt stripped with prefix "' + PREFIXES[I] + '"',
      FileExists(LDest + PathDelim + 'a.txt'));
    AssertTrue('sub\b.txt stripped with prefix "' + PREFIXES[I] + '"',
      FileExists(LDest + PathDelim + 'sub' + PathDelim + 'b.txt'));
    AssertFalse('no wrapper directory with prefix "' + PREFIXES[I] + '"',
      DirectoryExists(LDest + PathDelim + 'Wrap'));
  end;
end;

procedure TTestArchive.TestExtract_StripPrefixCaseInsensitive;
var
  LZipPath, LDest: String;
  LResult: THCLExtractResult;
begin
  LZipPath := TempPath('stripcase.zip');
  LDest    := TempPath('out_stripcase');
  MakeZip(LZipPath, ['Wrap/a.txt'], ['AAA']);

  LResult := FArc.Extract(LZipPath, LDest, omOverwrite, nil, 'wrap');

  AssertTrue('Extract succeeded: ' + LResult.ErrorMessage, LResult.Success);
  AssertTrue('lowercase prefix strips the Wrap directory',
    FileExists(LDest + PathDelim + 'a.txt'));
  AssertFalse('no wrapper directory created',
    DirectoryExists(LDest + PathDelim + 'Wrap'));
end;

procedure TTestArchive.TestExtract_StripPrefixLeavesOtherEntries;
var
  LZipPath, LDest: String;
  LResult: THCLExtractResult;
begin
  LZipPath := TempPath('stripother.zip');
  LDest    := TempPath('out_stripother');
  MakeZip(LZipPath, ['Wrap/a.txt', 'Other/c.txt'], ['AAA', 'CCC']);

  LResult := FArc.Extract(LZipPath, LDest, omOverwrite, nil, 'Wrap');

  AssertTrue('Extract succeeded: ' + LResult.ErrorMessage, LResult.Success);
  AssertEquals('FilesExtracted', 2, LResult.FilesExtracted);
  AssertEquals('entry under the prefix is stripped',
    'AAA', ReadTextFile(LDest + PathDelim + 'a.txt'));
  AssertEquals('entry outside the prefix keeps its path',
    'CCC', ReadTextFile(LDest + PathDelim + 'Other' + PathDelim + 'c.txt'));
end;

procedure TTestArchive.TestExtract_OnlyUnderPrefix;
var
  LZipPath, LDest: String;
  LResult: THCLExtractResult;
begin
  LZipPath := TempPath('onlyunder.zip');
  LDest    := TempPath('out_onlyunder');
  MakeZip(LZipPath, ['Pack/db1/commondb.res', 'Pack/db1/sub/x.txt', 'Pack/db2/commondb.res', 'top.txt'],
    ['R1', 'X1', 'R2', 'T']);

  LResult := FArc.Extract(LZipPath, LDest, omOverwrite, nil, 'Pack/db1', True);

  AssertTrue('Extract succeeded: ' + LResult.ErrorMessage, LResult.Success);
  AssertEquals('only db1''s two files', 2, LResult.FilesExtracted);
  AssertEquals('stripped to the top', 'R1', ReadTextFile(LDest + PathDelim + 'commondb.res'));
  AssertEquals('its own subdirectory kept', 'X1',
    ReadTextFile(LDest + PathDelim + 'sub' + PathDelim + 'x.txt'));
  AssertFalse('not the other database', DirectoryExists(LDest + PathDelim + 'Pack'));
  AssertFalse('not the top-level file', FileExists(LDest + PathDelim + 'top.txt'));
end;

procedure TTestArchive.TestExtract_OnlyUnderEmptyPrefixIsTopLevel;
var
  LZipPath, LDest: String;
  LResult: THCLExtractResult;
begin
  LZipPath := TempPath('onlytop.zip');
  LDest    := TempPath('out_onlytop');
  MakeZip(LZipPath, ['commondb.res', 'Other/c.txt'], ['R', 'C']);

  LResult := FArc.Extract(LZipPath, LDest, omOverwrite, nil, '', True);

  AssertTrue('Extract succeeded: ' + LResult.ErrorMessage, LResult.Success);
  AssertEquals('the top-level file only', 1, LResult.FilesExtracted);
  AssertTrue('top-level file', FileExists(LDest + PathDelim + 'commondb.res'));
  AssertFalse('nothing from subdirectories', DirectoryExists(LDest + PathDelim + 'Other'));
end;

procedure TTestArchive.TestReadEntry;
var
  LZipPath: String;
  LBefore: TStringList;
  LInfo: TSearchRec;
  LCount: Integer;
begin
  LZipPath := TempPath('readentry.zip');
  MakeZip(LZipPath, ['Pinger/PINGER.SCm', 'Pinger/readme.txt'], ['SCENARIO-BYTES', 'README']);

  LCount := 0;
  if FindFirst(GetCurrentDir + PathDelim + '*', faAnyFile, LInfo) = 0 then
  try
    repeat Inc(LCount); until FindNext(LInfo) <> 0;
  finally
    FindClose(LInfo);
  end;

  AssertEquals('the entry''s bytes', 'SCENARIO-BYTES',
    FArc.ReadEntry(LZipPath, 'Pinger/PINGER.SCm', 1024));
  AssertEquals('the other one', 'README', FArc.ReadEntry(LZipPath, 'Pinger/readme.txt', 1024));

  LBefore := TStringList.Create;
  try
    if FindFirst(GetCurrentDir + PathDelim + '*', faAnyFile, LInfo) = 0 then
    try
      repeat LBefore.Add(LInfo.Name); until FindNext(LInfo) <> 0;
    finally
      FindClose(LInfo);
    end;
    AssertEquals('nothing written to the current directory', LCount, LBefore.Count);
  finally
    LBefore.Free;
  end;
end;

procedure TTestArchive.TestReadEntryRefusals;
var
  LZipPath, LJunk: String;
begin
  LZipPath := TempPath('readrefuse.zip');
  MakeZip(LZipPath, ['a.txt', 'big.bin'], ['A', StringOfChar('x', 5000)]);
  AssertEquals('missing entry', '', FArc.ReadEntry(LZipPath, 'nope.txt', 1024));
  AssertEquals('over the cap', '', FArc.ReadEntry(LZipPath, 'big.bin', 4096));
  AssertEquals('within the cap', 5000, Length(FArc.ReadEntry(LZipPath, 'big.bin', 5000)));
  AssertEquals('missing archive', '', FArc.ReadEntry(TempPath('none.zip'), 'a.txt', 1024));
  LJunk := TempPath('junk_read.zip');
  MakeJunkFile(LJunk);
  AssertEquals('not a zip', '', FArc.ReadEntry(LJunk, 'a.txt', 1024));
end;

procedure TTestArchive.TestExtract_StripPrefixMergesWithExisting;
var
  LZipPath, LDest: String;
  LResult: THCLExtractResult;
begin
  LZipPath := TempPath('stripmerge.zip');
  LDest    := TempPath('out_stripmerge');
  MakeZip(LZipPath, ['Wrap/new.txt'], ['NEW']);

  WriteTextFile(LDest + PathDelim + 'keep.txt', 'KEEP');

  LResult := FArc.Extract(LZipPath, LDest, omOverwrite, nil, 'Wrap');

  AssertTrue('Extract succeeded: ' + LResult.ErrorMessage, LResult.Success);
  AssertEquals('new file merged in',
    'NEW', ReadTextFile(LDest + PathDelim + 'new.txt'));
  AssertEquals('pre-existing file untouched',
    'KEEP', ReadTextFile(LDest + PathDelim + 'keep.txt'));
end;

procedure TTestArchive.TestExtract_StripPrefixSkipUsesStrippedTarget;
var
  LZipPath, LDest: String;
  LResult: THCLExtractResult;
begin
  LZipPath := TempPath('stripskip.zip');
  LDest    := TempPath('out_stripskip');
  MakeZip(LZipPath, ['Wrap/a.txt'], ['ZIPPED']);

  WriteTextFile(LDest + PathDelim + 'a.txt', 'ORIGINAL');

  LResult := FArc.Extract(LZipPath, LDest, omSkip, nil, 'Wrap');

  AssertTrue('Extract succeeded: ' + LResult.ErrorMessage, LResult.Success);
  AssertEquals('stripped target counted as skipped', 1, LResult.FilesSkipped);
  AssertEquals('nothing extracted', 0, LResult.FilesExtracted);
  AssertEquals('original content kept',
    'ORIGINAL', ReadTextFile(LDest + PathDelim + 'a.txt'));
  AssertFalse('unstripped path not written instead',
    FileExists(LDest + PathDelim + 'Wrap' + PathDelim + 'a.txt'));
end;

procedure TTestArchive.TestExtract_StripPrefixProgressNames;
var
  LZipPath, LDest: String;
  LResult: THCLExtractResult;
begin
  LZipPath := TempPath('stripprogress.zip');
  LDest    := TempPath('out_stripprogress');
  MakeZip(LZipPath, ['Wrap/a.txt'], ['AAA']);

  LResult := FArc.Extract(LZipPath, LDest, omOverwrite, @ProgressHandler, 'Wrap');

  AssertTrue('Extract succeeded: ' + LResult.ErrorMessage, LResult.Success);
  AssertEquals('callback fired once', 1, FProgressCalls);
  AssertEquals('progress reports the stripped name', 'a.txt', FProgressNames);
end;

{ --------------------------------------------------------------------------- }
{ Extract — output-file handling                                               }
{ --------------------------------------------------------------------------- }

procedure TTestArchive.TestExtract_TimestampPreserved;
var
  LZipPath, LDest, LTarget: String;
  LZip: TZipper;
  LSrc: TStringStream;
  LStamp, LActual: TDateTime;
  LResult: THCLExtractResult;
begin
  // A stream-backed entry is used because TZipper overwrites the DateTime of
  // a disk-file entry with the file's own age when it zips; for a stream
  // entry the DateTime set here is what is written to the archive.
  LStamp   := EncodeDate(2001, 2, 3) + EncodeTime(4, 5, 6, 0);
  LZipPath := TempPath('dated.zip');
  LDest    := TempPath('out_dated');
  LTarget  := LDest + PathDelim + 'old.txt';

  LSrc := TStringStream.Create('OLD');
  LZip := TZipper.Create;
  try
    LZip.FileName := LZipPath;
    LZip.Entries.AddFileEntry(LSrc, 'old.txt').DateTime := LStamp;
    LZip.ZipAllFiles;
  finally
    LZip.Free;
    LSrc.Free;
  end;

  LResult := FArc.Extract(LZipPath, LDest, omOverwrite, nil);

  AssertTrue('Extract succeeded: ' + LResult.ErrorMessage, LResult.Success);
  AssertTrue('file written', FileExists(LTarget));

  LActual := FileDateToDateTime(FileAge(LTarget));
  AssertTrue(Format('timestamp preserved: expected %s, got %s',
      [DateTimeToStr(LStamp), DateTimeToStr(LActual)]),
    Abs(LActual - LStamp) <= 2 / SecsPerDay);
end;

procedure TTestArchive.TestExtract_NoStrayFilesInCurrentDir;
var
  LZipPath, LDest, LCwd, LLeaf, LSubLeaf: String;
  LResult: THCLExtractResult;
begin
  LCwd := ExcludeTrailingPathDelimiter(GetCurrentDir);
  AssertFalse('test temp dir is not the current directory',
    SameText(LCwd, ExcludeTrailingPathDelimiter(FTempDir)));

  // Distinctive leaf names, so a hit in the CWD can only have come from
  // this extraction.
  LLeaf    := 'hcl_stray_probe_' + IntToStr(GetTickCount64) + '.txt';
  LSubLeaf := 'hcl_stray_dir_' + IntToStr(GetTickCount64);
  AssertFalse('precondition: probe not in CWD',
    FileExists(LCwd + PathDelim + LLeaf));

  LZipPath := TempPath('stray.zip');
  LDest    := TempPath('out_stray');
  MakeZip(LZipPath, [LLeaf, LSubLeaf + '/' + LLeaf], ['AAA', 'BBB']);

  LResult := FArc.Extract(LZipPath, LDest, omOverwrite, nil);

  AssertTrue('Extract succeeded: ' + LResult.ErrorMessage, LResult.Success);
  AssertTrue('file landed in the destination',
    FileExists(LDest + PathDelim + LLeaf));
  AssertFalse('no stray root file in the current directory',
    FileExists(LCwd + PathDelim + LLeaf));
  AssertFalse('no stray subdirectory in the current directory',
    DirectoryExists(LCwd + PathDelim + LSubLeaf));
end;

{ --------------------------------------------------------------------------- }
{ Registration                                                                 }
{ --------------------------------------------------------------------------- }

initialization
  RegisterTest(TTestArchive);

end.