File Coverage

blib/lib/Test/Smoke/Archiver.pm
Criterion Covered Total %
statement 32 100 32.0
branch 1 38 2.6
condition n/a
subroutine 9 14 64.2
pod 5 5 100.0
total 47 157 29.9


line stmt bran cond sub pod time code
1             package Test::Smoke::Archiver;
2 2     2   12 use warnings;
  2         4  
  2         55  
3 2     2   9 use strict;
  2         2  
  2         60  
4              
5             our $VERSION = '0.001';
6              
7 2     2   10 use base 'Test::Smoke::ObjectBase';
  2         4  
  2         178  
8 2     2   19 use Test::Smoke::LogMixin;
  2         4  
  2         105  
9              
10 2     2   799 use File::Copy;
  2         3874  
  2         88  
11 2     2   12 use File::Path;
  2         3  
  2         83  
12 2     2   378 use File::Spec::Functions;
  2         736  
  2         119  
13 2     2   899 use Test::Smoke::Util qw/get_patch/;
  2         5  
  2         1685  
14              
15             =head1 NAME
16              
17             Test::Smoke::Archiver - Archive the smoke files.
18              
19             =head1 DESCRIPTION
20              
21             =head2 Test::Smoke::Archiver->new(%arguments)
22              
23             =head3 Arguments
24              
25             =over
26              
27             =item archive => [0|1]
28              
29             =item ddir => $smoke_destination_directory
30              
31             =item adir => $archive_destination_directory
32              
33             =item outfile => 'mktest.out'
34              
35             =item rptfile => 'mktest.rpt'
36              
37             =item jsnfile => 'mktest.jsn'
38              
39             =item lfile => $logfile_name
40              
41             =item v => [0|1|2]
42              
43             =back
44              
45             =head3 Returns
46              
47             The instance...
48              
49             =cut
50              
51             my %CONFIG = (
52             df_archive => 1,
53             df_ddir => '.',
54             df_adir => undef,
55              
56             df_outfile => 'mktest.out',
57             df_rptfile => 'mktest.rpt',
58             df_jsnfile => 'mktest.jsn',
59             df_lfile => undef,
60              
61             df_v => 0,
62             );
63              
64             sub new {
65 2     2 1 10 my $class = shift;
66 2         25 my %args = @_;
67              
68 2         10 my %struct;
69 2         31 for my $dfkey (keys %CONFIG) {
70 16         52 (my $key = $dfkey) =~ s/^df_//;
71 16 50       74 $struct{"_$key"} = exists $args{$key} ? $args{$key} : $CONFIG{$dfkey};
72             }
73              
74 2         9 my $self = bless \%struct, $class;
75              
76 2         14 return $self;
77             }
78              
79             =head2 $archiver->archive_files()
80              
81             Copy files.
82              
83             =cut
84              
85             sub archive_files {
86 0     0     my $self = shift;
87 0 0         if (!$self->archive) {
88 0           return $self->log_info("Skipping archive: --noarchive.");
89             }
90 0 0         if (!$self->adir) {
91 0           return $self->log_info("Skipping archive: No archive directory set.");
92             }
93              
94 0 0         if (!-d $self->adir) {
95 0           open my $ch, '>', \my $output;
96 0           my $stdout = select $ch;
97 0 0         mkpath($self->adir, 1, 0775)
98 0           or die "Cannot mkpath(@{[$self->adir]}): $!";
99 0           select $stdout;
100 0           $self->log_debug($_) for split /\n/, $output;
101             }
102              
103 0           (my $patch_level = get_patch($self->ddir)->[0]) =~ tr/ //sd;
104 0           $self->{_patchlevel} = $patch_level;
105              
106 0           my @archived;
107 0           for my $filetype (qw/rpt out jsn log/) {
108 0           my $to_archive = "archive_$filetype";
109 0 0         my $filename = $filetype eq 'log' ? 'lfile' : "${filetype}file";
110 0 0         push @archived, $self->$filename if $self->$to_archive;
111             }
112 0           return \@archived;
113             }
114              
115             =head2 $archiver->archive_rpt
116              
117             =cut
118              
119             sub archive_rpt {
120 0     0 1   my $self = shift;
121 0           my $src = catfile($self->ddir, $self->rptfile);
122 0 0         if (! -f $src) {
123 0           return $self->log_info("%s not found: skip archive rpt", $src);
124             }
125 0           my $dst = catfile($self->adir, sprintf("rpt%s.rpt", $self->patchlevel));
126 0 0         if (-f $dst) {
127 0           return $self->log_info("%s exists, skip archive rpt", $dst);
128             }
129              
130 0           my $success = copy($src, $dst);
131 0 0         if (!$success) {
132 0           $self->log_warn("Failed to cp(%s,%s): %s", $src, $dst, $!);
133             }
134             else {
135 0           $self->log_info("Copy(%s, %s): ok", $src, $dst);
136             }
137 0           return $success;
138             }
139              
140             =head2 $archiver->archive_out
141              
142             =cut
143              
144             sub archive_out {
145 0     0 1   my $self = shift;
146 0           my $src = catfile($self->ddir, $self->outfile);
147 0 0         if (! -f $src) {
148 0           return $self->log_info("%s not found: skip archive out", $src);
149             }
150 0           my $dst = catfile($self->adir, sprintf("out%s.out", $self->patchlevel));
151 0 0         if (-f $dst) {
152 0           return $self->log_info("%s exists, skip archive out", $dst);
153             }
154              
155 0           my $success = copy($src, $dst);
156 0 0         if (!$success) {
157 0           $self->log_warn("Failed to cp(%s,%s): %s", $src, $dst, $!);
158             }
159             else {
160 0           $self->log_info("Copy(%s, %s): ok", $src, $dst);
161             }
162 0           return $success;
163             }
164              
165             =head2 $archiver->archive_jsn
166              
167             =cut
168              
169             sub archive_jsn {
170 0     0 1   my $self = shift;
171 0           my $src = catfile($self->ddir, $self->jsnfile);
172 0 0         if (! -f $src) {
173 0           return $self->log_info("%s not found: skip archive jsn", $src);
174             }
175 0           my $dst = catfile($self->adir, sprintf("jsn%s.jsn", $self->patchlevel));
176 0 0         if (-f $dst) {
177 0           return $self->log_info("%s exists, skip archive jsn", $dst);
178             }
179              
180 0           my $success = copy($src, $dst);
181 0 0         if (!$success) {
182 0           $self->log_warn("Failed to cp(%s,%s): %s", $src, $dst, $!);
183             }
184             else {
185 0           $self->log_info("Copy(%s, %s): ok", $src, $dst);
186             }
187 0           return $success;
188             }
189              
190             =head2 $archiver->archive_log
191              
192             =cut
193              
194             sub archive_log {
195 0     0 1   my $self = shift;
196 0           my $src = $self->lfile;
197 0 0         if (! -f $src) {
198 0           return $self->log_info("%s not found: skip archive log", $src);
199             }
200 0           my $dst = catfile($self->adir, sprintf("log%s.log", $self->patchlevel));
201 0 0         if (-f $dst) {
202 0           return $self->log_info("%s exists, skip archive log", $dst);
203             }
204              
205 0           my $success = copy($src, $dst);
206 0 0         if (!$success) {
207 0           $self->log_warn("Failed to cp(%s,%s): %s", $src, $dst, $!);
208             }
209             else {
210 0           $self->log_info("Copy(%s, %s): ok", $src, $dst);
211             }
212 0           return $success;
213             }
214              
215             1;
216              
217             =head1 COPYRIGHT
218              
219             (c) 2002-2013, Abe Timmerman All rights reserved.
220              
221             With contributions from Jarkko Hietaniemi, Merijn Brand, Campo
222             Weijerman, Alan Burlison, Allen Smith, Alain Barbet, Dominic Dunlop,
223             Rich Rauenzahn, David Cantrell.
224              
225             This library is free software; you can redistribute it and/or modify
226             it under the same terms as Perl itself.
227              
228             See:
229              
230             =over 4
231              
232             =item * L
233              
234             =item * L
235              
236             =back
237              
238             This program is distributed in the hope that it will be useful,
239             but WITHOUT ANY WARRANTY; without even the implied warranty of
240             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
241              
242             =cut