The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package main;

use 5.008;

use strict;
use warnings;

use lib qw{ inc };

use Test::More 0.88;	# Because of done_testing();
use CPAN::Access::AdHoc::Archive;
use File::chdir;

eval {
    require File::Temp;
    File::Temp->can( 'new' ) && File::Temp->can( 'newdir' );
} or plan skip_all =>
    'File::Temp unavailable, or does not support new() or newdir()';

sub are_archives_same (@);

SKIP: {
    my $tests = 1;
    my $name = 'Yehudi-0.001.tar.gz';

    my $arc1 = CPAN::Access::AdHoc::Archive->wrap_archive(
	"mock/repos/authors/id/M/ME/MENUHIN/$name" )
	or skip "Can not wrap original $name", $tests;

    my $td = File::Temp->newdir()
	or skip "Unable to create temp dir: $!", $tests;

    local $CWD = $td;

    $arc1->write();

    my $arc2 = CPAN::Access::AdHoc::Archive->wrap_archive(
	{ author => 'MENUHIN' }, $name );

    are_archives_same "rewritten $name" => $arc2,
	"original $name" => $arc1;
}

SKIP: {
    my $tests = 1;
    my $name = 'Johann-0.001.tar.bz2';

    my $arc1 = CPAN::Access::AdHoc::Archive->wrap_archive(
	"mock/repos/authors/id/B/BA/BACH/$name" )
	or skip "Can not wrap original $name", $tests;

    my $td = File::Temp->newdir()
	or skip "Unable to create temp dir: $!", $tests;

    local $CWD = $td;

    $arc1->write();

    my $arc2 = CPAN::Access::AdHoc::Archive->wrap_archive(
	{ author => 'BACH' }, $name );

    are_archives_same "rewritten $name" => $arc2,
	"original $name" => $arc1;

}

SKIP: {
    my $tests = 1;
    my $name = 'PDQ-0.000_01.zip';

    my $arc1 = CPAN::Access::AdHoc::Archive->wrap_archive(
	"mock/repos/authors/id/B/BA/BACH/$name" )
	or skip "Can not wrap original $name", $tests;

    my $td = File::Temp->newdir()
	or skip "Unable to create temp dir: $!", $tests;

    local $CWD = $td;

    $arc1->write();

    my $arc2 = CPAN::Access::AdHoc::Archive->wrap_archive(
	{ author => 'BACH' }, $name );

    are_archives_same "rewritten $name" => $arc2,
	"original $name" => $arc1;

}

SKIP: {
    my $tests = 1;
    my $name = '02packages.details.txt.gz';

    my $arc1 = CPAN::Access::AdHoc::Archive->wrap_archive(
	"mock/repos/modules/$name" )
	or skip "Can not wrap original $name", $tests;

    my $td = File::Temp->newdir()
	or skip "Unable to create temp dir: $!", $tests;

    local $CWD = $td;

    $arc1->write();

    my $arc2 = CPAN::Access::AdHoc::Archive->wrap_archive(
	{ directory => 'modules' }, $name );

    are_archives_same "rewritten $name" => $arc2,
	"original $name" => $arc1;

}

done_testing;

sub are_archives_same (@) {
    my ( $name1, $arc1, $name2, $arc2 ) = @_;
    my $got1 = $arc1->base_directory();
    my $got2 = $arc2->base_directory();
    $got1 eq $got2 or do {
	@_ = ( $got1, $got2, "$name1 and $name2 base directories same" );
	goto &is;
    };
    my %file;
    my $mask = 1;
    my $full_mask = 0;
    foreach my $arc ( $arc1, $arc2 ) {
	foreach my $fn ( $arc->list_contents() ) {
	    $file{$fn} |= $mask;
	}
	$full_mask |= $mask;
	$mask <<= 1;
    }
    foreach my $fn ( sort keys %file ) {
	if ( $file{$fn} == 1 ) {
	    @_ = ( "$fn appears in $name1 but not $name2" );
	    goto &fail;
	} elsif ( $file{$fn} == 2 ) {
	    @_ = ( "$fn appears in $name2 but not $name1" );
	    goto &fail;
	} elsif ( $file{$fn} == 3 ) {
	    $got1 = $arc1->get_item_content( $fn );
	    $got2 = $arc2->get_item_content( $fn );
	    $got1 eq $got2 or do {
		@_ = ( $got1, $got2,
		    "File $fn is the same in $name1 and $name2" );
		goto &is;
	    };
	}
    }
    @_ = ( "$name1 is the same as $name2" );
    goto &pass;
}

1;

# ex: set textwidth=72 :