view release on metacpan or  search on metacpan

t/exporter.t  view on Meta::CPAN

	my $path = shift;
	open my $fh, '<:raw', $path or die "$path: $!";
	local $/;
	return scalar <$fh>;
}

# export(%args): run an exporter over @tables in a fresh directory and
# return (status, output dir, stdout, stderr, logger)
sub export {
	my ($tables, %args) = @_;

	my $dir = tempdir(CLEANUP => 1);
	my $db = make_database($dir, @{$tables});
	my $out = File::Spec->catdir($dir, 'out');
	my $logger = Local::Logger->new();

	my $e = App::Access2CSV::Exporter->new(output_dir => $out, progress => 0, logger => $logger, %args);
	my $status;
	my ($stdout, $stderr) = capture { $status = $e->run($db) };
	return ($status, $out, $stdout, $stderr, $logger, $e, $db);
}

subtest 'constructor validation' => sub {
	isa_ok(App::Access2CSV::Exporter->new(), 'App::Access2CSV::Exporter');
	isa_ok(App::Access2CSV::Exporter->new({ encoding => 'cp1252' }), 'App::Access2CSV::Exporter', 'hashref form');
	lives_ok { App::Access2CSV::Exporter->new(tables => undef) } 'undef means default';
	throws_ok { App::Access2CSV::Exporter->new(encoding => 'latin1') } qr/encoding/, 'bad encoding';
	throws_ok { App::Access2CSV::Exporter->new(bogus => 1) } qr/Unknown parameter 'bogus'/, 'unknown setting';
	throws_ok { App::Access2CSV::Exporter->new(logger => 'file.log') } qr/logger/, 'logger must be an object';
	throws_ok { App::Access2CSV::Exporter->new(logger => bless({}, 'Local::NoMethods')) } qr/logger.*debug/, 'logger must have debug/info/warn';
	throws_ok { App::Access2CSV::Exporter->new(tables => [['nested']]) } qr/'?tables'? can only contain strings/, 'tables must be strings';

	my @tables = ('A');
	my $e = App::Access2CSV::Exporter->new(tables => \@tables);
	push @tables, 'B';
	is_deeply($e->{tables}, ['A'], 'table list is copied');
};

subtest 'exports user tables and skips system tables' => sub {
	my ($status, $out, $stdout, $stderr, $logger) = export([qw(Orders Customers MSysObjects USysRibbons ~TMPCLP1)]);

	is($status, 0, 'success');
	ok(-f File::Spec->catfile($out, 'Customers.csv'), 'Customers.csv');
	ok(-f File::Spec->catfile($out, 'Orders.csv'), 'Orders.csv');
	ok(!-e File::Spec->catfile($out, 'MSysObjects.csv'), 'MSys* skipped');
	ok(!-e File::Spec->catfile($out, 'USysRibbons.csv'), 'USys* skipped');
	is(slurp(File::Spec->catfile($out, 'Orders.csv')), qq{"id","name"\n1,"Orders"\n}, 'content');

	opendir(my $dh, $out);
	is_deeply([sort grep { !/^\.\.?$/ } readdir $dh], ['Customers.csv', 'Orders.csv'], 'no temporary files left');
	is($stderr, '', 'no warnings');
	like($logger->{lines}[-1], qr/INFO Processed 2 tables, 0 failed/, 'summary logged');
	like($logger->{lines}[0], qr/INFO Exported Customers => /, 'export logged');
};

subtest 'new files get normal permissions, not File::Temp 0600' => sub {
	plan(skip_all => 'Windows has no Unix permission bits') if $^O eq 'MSWin32';
	my $old = umask(022);
	my (undef, $out) = export(['Orders']);
	umask($old);
	is((stat(File::Spec->catfile($out, 'Orders.csv')))[2] & oct(777), oct(644), 'mode 0644 under umask 022');
};

subtest 'progress goes to STDERR' => sub {
	my ($status, undef, $stdout, $stderr) = export([qw(A B)], progress => 1);
	is($stdout, '', 'nothing on STDOUT');
	like($stderr, qr/^\[1\/2\] A\n\[2\/2\] B\n\z/, 'numbered progress');
};

subtest 'encodings' => sub {
	my (undef, $out) = export(['Unicode'], encoding => 'utf8');
	is(slurp("$out/Unicode.csv"), qq{"id","name"\n1,"Caf\xC3\xA9 \xE2\x82\xAC"\n}, 'utf8 is passed through');

	(undef, $out) = export(['Unicode'], encoding => 'utf8-bom');
	is(slurp("$out/Unicode.csv"), qq{\xEF\xBB\xBF"id","name"\n1,"Caf\xC3\xA9 \xE2\x82\xAC"\n}, 'utf8-bom adds a BOM, once');

	(undef, $out) = export(['Unicode'], encoding => 'cp1252');
	is(slurp("$out/Unicode.csv"), qq{"id","name"\n1,"Caf\xE9 \x80"\n}, 'cp1252 is converted');
};

subtest 'cp1252 refuses characters it cannot represent' => sub {
	my ($status, $out, undef, $stderr, $logger) = export([qw(Japanese Orders)], encoding => 'cp1252');
	is($status, 1, 'failure status');
	like($stderr, qr/FAILED: Japanese: Table Japanese, line 2: cannot be represented in cp1252/, 'warned');
	ok(!-e "$out/Japanese.csv", 'no partial file');
	ok(-e "$out/Orders.csv", 'other tables still exported');
	ok((grep { /^WARN FAILED: Japanese/ } @{ $logger->{lines} }), 'failure logged');
};

subtest 'cp1252 reports invalid UTF-8 from mdb-export' => sub {
	my ($status, undef, undef, $stderr) = export(['Latin1'], encoding => 'cp1252');
	is($status, 1, 'failure status');
	like($stderr, qr/Table Latin1, line 2: output of mdb-export is not valid UTF-8/, 'warned');
};

subtest 'mdb-export failures are per table' => sub {
	# "Killed" kills itself with a signal, which only Unix has
	my @tables = $^O eq 'MSWin32' ? qw(Broken Orders) : qw(Broken Killed Orders);
	my ($status, $out, undef, $stderr, $logger) = export(\@tables);
	is($status, 1, 'failure status');
	like($stderr, qr/FAILED: Broken: mdb-export failed with exit status 1: corrupt table/, 'exit status');
	SKIP: {
		skip('Windows has no signals', 1) if $^O eq 'MSWin32';
		like($stderr, qr/FAILED: Killed: mdb-export was killed by signal \d+/, 'signal');
	}
	ok(!-e "$out/Broken.csv", 'no partial file');
	ok(-e "$out/Orders.csv", 'good table exported');
	my ($total, $failed) = (scalar(@tables), scalar(@tables) - 1);
	like($logger->{lines}[-1], qr/Processed $total tables, $failed failed/, 'summary');
};

subtest 'existing files' => sub {
	my ($status, $out, undef, undef, undef, $e, $db) = export(['Orders']);
	is($status, 0, 'first run');

	my $stderr;
	(undef, $stderr) = capture { $status = $e->run($db) };
	is($status, 1, 'second run fails without --overwrite');
	like($stderr, qr/Output file already exists: .*Orders\.csv \(use --overwrite/, 'explains why');

	$e->{overwrite} = 1;