File Coverage

blib/lib/CPAN/Testers/Common/Client/History.pm
Criterion Covered Total %
statement 110 113 97.3
branch 28 42 66.6
condition 11 17 64.7
subroutine 21 21 100.0
pod 3 3 100.0
total 173 196 88.2


line stmt bran cond sub pod time code
1             package CPAN::Testers::Common::Client::History;
2 4     4   1469 use strict;
  4         6  
  4         105  
3 4     4   15 use warnings;
  4         5  
  4         110  
4              
5 4     4   1722 use CPAN::Testers::Common::Client::Config;
  4         9  
  4         186  
6              
7 4     4   40 use Config;
  4         4  
  4         165  
8 4     4   15 use Carp ();
  4         4  
  4         60  
9 4     4   18 use Fcntl qw(:flock);
  4         5  
  4         538  
10 4     4   19 use File::Spec ();
  4         5  
  4         49  
11 4     4   46 use IO::File ();
  4         5  
  4         345  
12              
13              
14             # Some platforms don't implement flock(), so fake it if necessary
15             BEGIN {
16 4     4   6 eval {
17 4         469 my $temp_file = File::Spec->catfile(
18             File::Spec->tmpdir(), $$ . time()
19             );
20 4         34 my $fh = IO::File->new( $temp_file, "w" );
21 4         927 flock $fh, LOCK_EX;
22 4         34 $fh->close;
23 4         305 unlink $temp_file;
24             };
25 4 50       4602 if ( $@ ) {
26 0         0 *CORE::GLOBAL::flock = sub (*$) { 1 };
  0         0  
27             }
28             }
29              
30             # Back-compatibility checks -- just once per load
31             #
32             # 0.99_08 changed the history file format and name.
33             # If an old file exists, convert it to the new name and format. Note --
34             # someone running multiple installations of reporter modules might have old
35             # and new versions running so only convert in the case where the old file
36             # exists and the new file does not.
37             {
38             my $old_history_file = _get_old_history_file();
39             my $new_history_file = _get_history_file();
40             last if -f $new_history_file || ! -f $old_history_file;
41              
42             # FIXME: all CORE::warn calls here should be 'mywarn' like in CTCC::Config
43             CORE::warn("CPAN Testers: Your history file is in an old format. Upgrading automatically.\n");
44              
45             # open old and new files
46             my ($old_fh, $new_fh);
47             if (! ( $old_fh = IO::File->new( $old_history_file ) ) ) {
48             CORE::warn("CPAN Testers: error opening old history file: $!\nContinuing without conversion.\n");
49             last;
50             }
51             if (! ($new_fh = IO::File->new( $new_history_file, 'w' ) ) ) {
52             CORE::warn("CPAN Testers: error opening new history file: $!\nContinuing without conversion.\n");
53             last;
54             }
55              
56             print {$new_fh} _generated_by();
57             while ( my $line = <$old_fh> ) {
58             chomp $line;
59             # strip off perl version and convert
60             # try not to match 5.1 from "MSWin32-x86-multi-thread 5.1"
61             # from really old CPAN Testers' history formats
62             my ($old_version, $perl_patch);
63             if ( $line =~ m{ (5\.0\d{2,5}) ?(patch \d+)?\z} ) {
64             ($old_version, $perl_patch) = ($1, $2);
65             $line =~ s{ (5\.0\d{2,5}) ?(patch \d+)?\z}{};
66             }
67             my $pv = $old_version ? 'perl-' . _perl_version($old_version)
68             : 'unknown';
69             $pv .= " $perl_patch" if $perl_patch;
70             my ($grade_dist, $arch_os) = ($line =~ /(\S+ \S+) (.+)/);
71             print {$new_fh} "test $grade_dist ($pv) $arch_os\n";
72             }
73             close $old_fh;
74             close $new_fh;
75             }
76              
77             sub _get_history_file {
78 14     14   1633 return File::Spec->catdir(
79             CPAN::Testers::Common::Client::Config::get_config_dir(),
80             'reports-sent.db'
81             );
82             }
83              
84             # prior to 0.99_08
85             sub _get_old_history_file {
86 4     4   33 return File::Spec->catdir(
87             CPAN::Testers::Common::Client::Config::get_config_dir(),
88             'history.db'
89             );
90             }
91              
92             sub _generated_by {
93 1     1   618 require CPAN::Testers::Common::Client;
94 1         8 return '# Generated by CPAN::Testers::Common::Client '
95             . "$CPAN::Testers::Common::Client::VERSION\n";
96             }
97              
98             sub _perl_version {
99 9   33 9   37 my $ver = shift || "$]";
100 9         76 $ver =~ qr/(\d)\.(\d{3})(\d{0,3})/;
101 9   50     60 my ($maj,$min,$pat) = (0 + ($1||0), 0 + ($2||0), 0 + ($3||0));
      50        
      50        
102 9         7 my $pv;
103 9 50       15 if ( $min < 6 ) {
104 0         0 $pv = $ver;
105             }
106             else {
107 9         19 $pv = "$maj\.$min\.$pat";
108             }
109 9         12 return $pv;
110             }
111              
112             # search for dist in history file
113             sub have_tested {
114 2 50   2 1 405 Carp::croak "arguments to have_tested() must be key value pairs"
115             if @_ % 2;
116              
117 2         7 my $args = { @_ };
118              
119             my @bad_params = grep {
120 2         5 $_ !~ m{^(?:dist|phase|grade|perl|archname|osvers)$}
  2         14  
121             } keys %$args;
122              
123 2 50       5 Carp::croak "bad parameters for have_tested(): " . join(q{, },@bad_params)
124             if @bad_params;
125              
126             # DWIM: grades to upper case
127 2 100       7 $args->{grade} = uc $args->{grade} if defined $args->{grade};
128              
129             # default to current platform
130 2 50       7 $args->{perl} = _format_perl_version() unless defined $args->{perl};
131 2 50       10 $args->{archname} = $Config{archname} unless defined $args->{archname};
132 2 50       33 $args->{osvers} = $Config{osvers} unless defined $args->{osvers};
133              
134 2         3 my @found;
135 2 50       4 my $history = _open_history_file('<') or return;
136 2         8 flock $history, LOCK_SH;
137 2         17 <$history>; # throw away format line
138 2         8 while ( defined (my $line = <$history>) ) {
139 8 50       10 my $fields = _split_history( $line ) or next;
140 8 100       9 push @found, $fields if _match($fields, $args);
141             }
142 2         7 $history->close;
143 2         31 return @found;
144             }
145              
146             sub _match {
147 8     8   5 my ($fields, $search) = @_;
148 8         13 for my $k ( keys %$search ) {
149 28 50       34 next if $search->{$k} eq q{}; # empty string matches anything
150 28 100       54 return unless $fields->{$k} eq $search->{$k};
151             }
152 4         14 return 1; # all keys matched
153             }
154              
155             sub _format_perl_version {
156 9     9   12 my $pv = _perl_version();
157             $pv .= " patch $Config{perl_patchlevel}"
158 9 50       110 if $Config{perl_patchlevel};
159 9         21 return $pv;
160             }
161              
162             sub _open_history_file {
163 9   50 9   16 my $mode = shift || '<';
164 9         12 my $history_filename = _get_history_file();
165 9         154 my $file_exists = -f $history_filename;
166              
167             # shortcut if reading and doesn't exist
168 9 100 100     34 return if ( $mode eq '<' && ! $file_exists );
169              
170             # open it in the desired mode
171 8 50       38 my $history = IO::File->new( $history_filename, $mode )
172             or CORE::warn("CPAN Testers: couldn't open history file "
173             . "'$history_filename': $!\n");
174              
175             # if writing and it didn't exist before, initialize with header
176 8 100 100     548 if ( substr($mode,0,1) eq '>' && ! $file_exists ) {
177 1         2 print {$history} _generated_by();
  1         2  
178             }
179              
180 8         23 return $history;
181             }
182              
183             # phase grade dist-version (perl-version patchlevel) archname osvers
184             sub _format_history {
185 7     7   7 my ($result) = @_;
186              
187 7         8 my $phase = $result->{phase};
188 7         9 my $grade = uc $result->{grade};
189 7         9 my $dist_name = $result->{dist_name};
190 7         12 my $perlver = "perl-" . _format_perl_version();
191 7         39 my $platform = "$Config{archname} $Config{osvers}";
192              
193 7         21 return "$phase $grade $dist_name ($perlver) $platform\n";
194             }
195              
196             sub is_duplicate {
197 3     3 1 323 my ($result) = @_;
198 3         6 my $log_line = _format_history( $result );
199 3 100       6 my $history = _open_history_file('<') or return;
200 2         2 my $found = 0;
201 2         7 flock $history, LOCK_SH;
202 2         18 while ( defined (my $line = <$history>) ) {
203 7 100       18 if ( $line eq $log_line ) {
204 1         1 $found++;
205 1         2 last;
206             }
207             }
208 2         6 $history->close;
209 2         26 return $found;
210             }
211              
212             sub record_history {
213 4     4 1 1156 my ($result) = @_;
214 4         9 my $log_line = _format_history( $result );
215 4 50       8 my $history = _open_history_file('>>') or return;
216              
217 4         60 flock( $history, LOCK_EX );
218 4         9 seek( $history, 0, 2 ); # seek to end of file
219 4         19 $history->print( $log_line );
220 4         64 flock( $history, LOCK_UN );
221              
222 4         10 $history->close;
223 4         43 return;
224             }
225              
226             # splits lines created with _format_history. Returns hashref with
227             # phase, grade, dist, perl, platform
228             sub _split_history {
229 8     8   8 my ($line) = @_;
230 8         7 chomp $line;
231 8         7 my %fields;
232 8         44 @fields{qw/phase grade dist perl archname osvers/} =
233             $line =~ m{
234             ^(\S+) \s+ # phase
235             (\S+) \s+ # grade
236             (\S+) \s+ # dist
237             \(perl- ([^)]+) \) \s+ # (perl-version-patchlevel)
238             (\S+) \s+ # archname
239             (.+)$ # osvers
240             }xms;
241              
242             # return nothing if parse fails
243 8 50       15 return if scalar keys %fields == 0;
244              
245             # otherwise return hashref
246 8         15 return \%fields;
247             }
248              
249             1;
250             __END__