package Test::Smoke::Archiver;
use warnings;
use strict;
use base 'Test::Smoke::ObjectBase';
use Test::Smoke::LogMixin;
use File::Copy;
use File::Path;
use File::Spec::Functions;
use Test::Smoke::Util qw/get_patch/;
=head1 NAME
Test::Smoke::Archiver - Archive the smoke files.
=head1 DESCRIPTION
=head2 Test::Smoke::Archiver->new(%arguments)
=head3 Arguments
=over
=item archive => [0|1]
=item ddir => $smoke_destination_directory
=item adir => $archive_destination_directory
=item outfile => 'mktest.out'
=item rptfile => 'mktest.rpt'
=item jsnfile => 'mktest.jsn'
=item lfile => $logfile_name
=item v => [0|1|2]
=back
=head3 Returns
The instance...
=cut
my %CONFIG = (
df_archive => 1,
df_ddir => '.',
df_adir => undef,
df_outfile => 'mktest.out',
df_rptfile => 'mktest.rpt',
df_jsnfile => 'mktest.jsn',
df_lfile => undef,
df_v => 0,
);
sub new {
my $class = shift;
my %args = @_;
my %struct;
for my $dfkey (keys %CONFIG) {
(my $key = $dfkey) =~ s/^df_//;
$struct{"_$key"} = exists $args{$key} ? $args{$key} : $CONFIG{$dfkey};
}
my $self = bless \%struct, $class;
return $self;
}
=head2 $archiver->archive_files()
Copy files.
=cut
sub archive_files {
my $self = shift;
if (!$self->archive) {
return $self->log_info("Skipping archive: --noarchive.");
}
if (!$self->adir) {
return $self->log_info("Skipping archive: No archive directory set.");
}
if (!-d $self->adir) {
open my $ch, '>', \my $output;
my $stdout = select $ch;
mkpath($self->adir, 1, 0775)
or die "Cannot mkpath(@{[$self->adir]}): $!";
select $stdout;
$self->log_debug($_) for split /\n/, $output;
}
(my $patch_level = get_patch($self->ddir)->[0]) =~ tr/ //sd;
$self->{_patchlevel} = $patch_level;
my @archived;
for my $filetype (qw/rpt out jsn log/) {
my $to_archive = "archive_$filetype";
my $filename = $filetype eq 'log' ? 'lfile' : "${filetype}file";
push @archived, $self->$filename if $self->$to_archive;
}
return \@archived;
}
=head2 $archiver->archive_rpt
=cut
sub archive_rpt {
my $self = shift;
my $src = catfile($self->ddir, $self->rptfile);
if (! -f $src) {
return $self->log_info("%s not found: skip archive rpt", $src);
}
my $dst = catfile($self->adir, sprintf("rpt%s.rpt", $self->patchlevel));
if (-f $dst) {
return $self->log_info("%s exits, skip archive rpt", $dst);
}
my $success = copy($src, $dst);
if (!$success) {
$self->log_warn("Failed to cp(%s,%s): %s", $src, $dst, $!);
}
else {
$self->log_info("Copy(%s, %s): ok", $src, $dst);
}
return $success;
}
=head2 $archiver->archive_out
=cut
sub archive_out {
my $self = shift;
my $src = catfile($self->ddir, $self->outfile);
if (! -f $src) {
return $self->log_info("%s not found: skip archive out", $src);
}
my $dst = catfile($self->adir, sprintf("out%s.out", $self->patchlevel));
if (-f $dst) {
return $self->log_info("%s exits, skip archive out", $dst);
}
my $success = copy($src, $dst);
if (!$success) {
$self->log_warn("Failed to cp(%s,%s): %s", $src, $dst, $!);
}
else {
$self->log_info("Copy(%s, %s): ok", $src, $dst);
}
return $success;
}
=head2 $archiver->archive_jsn
=cut
sub archive_jsn {
my $self = shift;
my $src = catfile($self->ddir, $self->jsnfile);
if (! -f $src) {
return $self->log_info("%s not found: skip archive jsn", $src);
}
my $dst = catfile($self->adir, sprintf("jsn%s.jsn", $self->patchlevel));
if (-f $dst) {
return $self->log_info("%s exits, skip archive jsn", $dst);
}
my $success = copy($src, $dst);
if (!$success) {
$self->log_warn("Failed to cp(%s,%s): %s", $src, $dst, $!);
}
else {
$self->log_info("Copy(%s, %s): ok", $src, $dst);
}
return $success;
}
=head2 $archiver->archive_log
=cut
sub archive_log {
my $self = shift;
my $src = $self->lfile;
if (! -f $src) {
return $self->log_info("%s not found: skip archive log", $src);
}
my $dst = catfile($self->adir, sprintf("log%s.log", $self->patchlevel));
if (-f $dst) {
return $self->log_info("%s exits, skip archive log", $dst);
}
my $success = copy($src, $dst);
if (!$success) {
$self->log_warn("Failed to cp(%s,%s): %s", $src, $dst, $!);
}
else {
$self->log_info("Copy(%s, %s): ok", $src, $dst);
}
return $success;
}
1;
=head1 COPYRIGHT
(c) 2002-2013, Abe Timmerman <abeltje@cpan.org> All rights reserved.
With contributions from Jarkko Hietaniemi, Merijn Brand, Campo
Weijerman, Alan Burlison, Allen Smith, Alain Barbet, Dominic Dunlop,
Rich Rauenzahn, David Cantrell.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
See:
=over 4
=item * L<http://www.perl.com/perl/misc/Artistic.html>
=item * L<http://www.gnu.org/copyleft/gpl.html>
=back
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
=cut