1use strict;
2package CPAN::Reporter::History;
3
4our $VERSION = '1.2018';
5
6use vars qw/@ISA @EXPORT_OK/;
7
8use Config;
9use Carp;
10use Fcntl qw/:flock/;
11use File::HomeDir ();
12use File::Path (qw/mkpath/);
13use File::Spec ();
14use IO::File ();
15use CPAN (); # for printing warnings
16use CPAN::Reporter::Config ();
17
18require Exporter;
19@ISA = qw/Exporter/;
20@EXPORT_OK = qw/have_tested/;
21
22#--------------------------------------------------------------------------#
23# Some platforms don't implement flock, so fake it if necessary
24#--------------------------------------------------------------------------#
25
26BEGIN {
27    eval {
28        my $temp_file = File::Spec->catfile(
29            File::Spec->tmpdir(), $$ . time()
30        );
31        my $fh = IO::File->new( $temp_file, "w" );
32        flock $fh, LOCK_EX;
33        $fh->close;
34        unlink $temp_file;
35    };
36    if ( $@ ) {
37        *CORE::GLOBAL::flock = sub (*$) { 1 };
38    }
39}
40
41#--------------------------------------------------------------------------#
42# Back-compatibility checks -- just once per load
43#--------------------------------------------------------------------------#
44
45
46# 0.99_08 changed the history file format and name
47# If an old file exists, convert it to the new name and format.  Note --
48# someone running multiple installations of CPAN::Reporter might have old
49# and new versions running so only convert in the case where the old file
50# exists and the new file does not
51
52{
53    my $old_history_file = _get_old_history_file();
54    my $new_history_file = _get_history_file();
55    last if -f $new_history_file || ! -f $old_history_file;
56
57    $CPAN::Frontend->mywarn("CPAN::Reporter: Your history file is in an old format. Upgrading automatically.\n");
58
59    # open old and new files
60    my ($old_fh, $new_fh);
61    if (! ( $old_fh = IO::File->new( $old_history_file ) ) ) {
62        $CPAN::Frontend->mywarn("CPAN::Reporter: error opening old history file: $!\nContinuing without conversion.\n");
63        last;
64    }
65    if (! ($new_fh = IO::File->new( $new_history_file, "w" ) ) ) {
66        $CPAN::Frontend->mywarn("CPAN::Reporter: error opening new history file: $!\nContinuing without conversion.\n");
67        last;
68    }
69
70    print {$new_fh} _generated_by();
71    while ( my $line = <$old_fh> ) {
72        chomp $line;
73        # strip off perl version and convert
74        # try not to match 5.1 from "MSWin32-x86-multi-thread 5.1"
75        # from really old CPAN::Reporter history formats
76        my ($old_version, $perl_patch);
77        if ( $line =~ m{ (5\.0\d{2,5}) ?(patch \d+)?\z} ) {
78            ($old_version, $perl_patch) = ($1, $2);
79            $line =~ s{ (5\.0\d{2,5}) ?(patch \d+)?\z}{};
80        }
81        my $pv = $old_version ? "perl-" . _perl_version($old_version)
82                              : "unknown";
83        $pv .= " $perl_patch" if $perl_patch;
84        my ($grade_dist, $arch_os) = ($line =~ /(\S+ \S+) (.+)/);
85        print {$new_fh} "test $grade_dist ($pv) $arch_os\n";
86    }
87    close $old_fh;
88    close $new_fh;
89}
90
91
92#--------------------------------------------------------------------------#
93# Public methods
94#--------------------------------------------------------------------------#
95
96#--------------------------------------------------------------------------#
97# have_tested -- search for dist in history file
98#--------------------------------------------------------------------------#
99
100sub have_tested { ## no critic RequireArgUnpacking
101    # validate arguments
102    croak "arguments to have_tested() must be key value pairs"
103      if @_ % 2;
104
105    my $args = { @_ };
106
107    my @bad_params = grep {
108        $_ !~ m{^(?:dist|phase|grade|perl|archname|osvers)$} } keys %$args;
109    croak "bad parameters for have_tested(): " . join(q{, },@bad_params)
110        if @bad_params;
111
112
113    # DWIM: grades to upper case
114    $args->{grade} = uc $args->{grade} if defined $args->{grade};
115
116    # default to current platform
117    $args->{perl} = _format_perl_version() unless defined $args->{perl};
118    $args->{archname} = $Config{archname} unless defined $args->{archname};
119    $args->{osvers} = $Config{osvers} unless defined $args->{osvers};
120
121    my @found;
122    my $history = _open_history_file('<') or return;
123    flock $history, LOCK_SH;
124    <$history>; # throw away format line
125    while ( defined (my $line = <$history>) ) {
126        my $fields = _split_history( $line ) or next;
127        push @found, $fields if _match($fields, $args);
128    }
129    $history->close;
130    return @found;
131}
132
133#--------------------------------------------------------------------------#
134# Private methods
135#--------------------------------------------------------------------------#
136
137#--------------------------------------------------------------------------#
138# _format_history --
139#
140# phase grade dist-version (perl-version patchlevel) archname osvers
141#--------------------------------------------------------------------------#
142
143sub _format_history {
144    my ($result) = @_;
145    my $phase = $result->{phase};
146    my $grade = uc $result->{grade};
147    my $dist_name = $result->{dist_name};
148    my $perlver = "perl-" . _format_perl_version();
149    my $platform = "$Config{archname} $Config{osvers}";
150    return "$phase $grade $dist_name ($perlver) $platform\n";
151}
152
153#--------------------------------------------------------------------------#
154# _format_perl_version
155#--------------------------------------------------------------------------#
156
157sub _format_perl_version {
158    my $pv = _perl_version();
159    $pv .= " patch $Config{perl_patchlevel}"
160        if $Config{perl_patchlevel};
161    return $pv;
162}
163
164sub _generated_by {
165  return "# Generated by CPAN::Reporter "
166    . "$CPAN::Reporter::History::VERSION\n";
167}
168
169#--------------------------------------------------------------------------#
170# _get_history_file
171#--------------------------------------------------------------------------#
172
173sub _get_history_file {
174    return File::Spec->catdir(
175        CPAN::Reporter::Config::_get_config_dir(), "reports-sent.db"
176    );
177}
178
179#--------------------------------------------------------------------------#
180# _get_old_history_file -- prior to 0.99_08
181#--------------------------------------------------------------------------#
182
183sub _get_old_history_file {
184    return File::Spec->catdir(
185        CPAN::Reporter::Config::_get_config_dir(), "history.db"
186    );
187}
188
189#--------------------------------------------------------------------------#
190# _is_duplicate
191#--------------------------------------------------------------------------#
192
193sub _is_duplicate {
194    my ($result) = @_;
195    my $log_line = _format_history( $result );
196    my $history = _open_history_file('<') or return;
197    my $found = 0;
198    flock $history, LOCK_SH;
199    while ( defined (my $line = <$history>) ) {
200        if ( $line eq $log_line ) {
201            $found++;
202            last;
203        }
204    }
205    $history->close;
206    return $found;
207}
208
209#--------------------------------------------------------------------------#
210# _match
211#--------------------------------------------------------------------------#
212
213sub _match {
214    my ($fields, $search) = @_;
215    for my $k ( keys %$search ) {
216        next if $search->{$k} eq q{}; # empty string matches anything
217        return unless $fields->{$k} eq $search->{$k};
218    }
219    return 1; # all keys matched
220}
221
222#--------------------------------------------------------------------------#
223# _open_history_file
224#--------------------------------------------------------------------------#
225
226sub _open_history_file {
227    my $mode = shift || '<';
228    my $history_filename = _get_history_file();
229    my $file_exists = -f $history_filename;
230
231    # shortcut if reading and doesn't exist
232    return if ( $mode eq '<' && ! $file_exists );
233
234    # open it in the desired mode
235    my $history = IO::File->new( $history_filename, $mode )
236        or $CPAN::Frontend->mywarn("CPAN::Reporter: couldn't open history file "
237        . "'$history_filename': $!\n");
238
239    # if writing and it didn't exist before, initialize with header
240    if ( substr($mode,0,1) eq '>' && ! $file_exists ) {
241        print {$history} _generated_by();
242    }
243
244    return $history;
245}
246
247#--------------------------------------------------------------------------#
248# _perl_version
249#--------------------------------------------------------------------------#
250
251sub _perl_version {
252    my $ver = shift || "$]";
253    $ver =~ qr/(\d)\.(\d{3})(\d{0,3})/;
254    my ($maj,$min,$pat) = (0 + ($1||0), 0 + ($2||0), 0 + ($3||0));
255    my $pv;
256    if ( $min < 6 ) {
257        $pv = $ver;
258    }
259    else {
260        $pv = "$maj\.$min\.$pat";
261    }
262    return $pv;
263}
264
265#--------------------------------------------------------------------------#
266# _record_history
267#--------------------------------------------------------------------------#
268
269sub _record_history {
270    my ($result) = @_;
271    my $log_line = _format_history( $result );
272    my $history = _open_history_file('>>') or return;
273
274    flock( $history, LOCK_EX );
275    seek( $history, 0, 2 ); # seek to end of file
276    $history->print( $log_line );
277    flock( $history, LOCK_UN );
278
279    $history->close;
280    return;
281}
282
283#--------------------------------------------------------------------------#
284# _split_history
285#
286# splits lines created with _format_history. Returns hash ref with
287#   phase, grade, dist, perl, platform
288#--------------------------------------------------------------------------#
289
290sub _split_history {
291    my ($line) = @_;
292    chomp $line;
293    my %fields;
294    @fields{qw/phase grade dist perl archname osvers/} =
295        $line =~ m{
296            ^(\S+) \s+              # phase
297             (\S+) \s+              # grade
298             (\S+) \s+              # dist
299             \(perl- ([^)]+) \) \s+ # (perl-version-patchlevel)
300             (\S+) \s+              # archname
301             (.+)$                  # osvers
302        }xms;
303
304    # return nothing if parse fails
305    return if scalar keys %fields == 0;# grep { ! defined($_) } values %fields;
306    # otherwise return hashref
307    return \%fields;
308}
309
3101;
311
312# ABSTRACT: Read or write a CPAN::Reporter history log
313
314__END__
315
316=pod
317
318=encoding UTF-8
319
320=head1 NAME
321
322CPAN::Reporter::History - Read or write a CPAN::Reporter history log
323
324=head1 VERSION
325
326version 1.2018
327
328=head1 SYNOPSIS
329
330     use CPAN::Reporter::History 'have_tested';
331
332     @results = have_tested( dist => 'Dist-Name-1.23' );
333
334=head1 DESCRIPTION
335
336Interface for interacting with the CPAN::Reporter history file.  Most methods
337are private for use only within CPAN::Reporter itself.  However, a public
338function is provided to query the history file for results.
339
340=head1 USAGE
341
342The following function is available.  It is not exported by default.
343
344=head2 C<<< have_tested() >>>
345
346     # all reports for Foo-Bar-1.23
347     @results = have_tested( dist => 'Foo-Bar-1.23' );
348
349     # all NA reports
350     @results = have_tested( grade => 'NA' );
351
352     # all reports on the current Perl/platform
353     @results = have_tested();
354
355Searches the CPAN::Reporter history file for records exactly matching search
356criteria, given as pairs of field-names and desired values.
357
358Ordinary search criteria include:
359
360=over
361
362=item *
363
364C<<< dist >>> -- the distribution tarball name without any filename suffix; from
365a C<<< CPAN::Distribution >>> object, this is provided by the C<<< base_id >>> method.
366
367=item *
368
369C<<< phase >>> -- phase the report was generated during: either 'PL',
370'make' or 'test'
371
372=item *
373
374C<<< grade >>> -- CPAN Testers grade: 'PASS', 'FAIL', 'NA' or 'UNKNOWN'; Also may
375be 'DISCARD' for any failing reports not sent due to missing prerequisites
376
377=back
378
379Without additional criteria, a search will be limited to the current
380version of Perl and the current architecture and OS version.
381Additional criteria may be specified explicitly or, by specifying the empty
382string, C<<< q{} >>>, will match that field for I<any> record.
383
384     # all reports for Foo-Bar-1.23 on any version of perl
385     # on the current architecture and OS version
386     @results = have_tested( dist => 'Foo-Bar-1.23', perl => q{} );
387
388These additional criteria include:
389
390=over
391
392=item *
393
394C<<< perl >>> -- perl version and possible patchlevel; this will be
395dotted decimal (5.6.2) starting with version 5.6, or will be numeric style as
396given by C<<< $] >>> for older versions; if a patchlevel exists, it must be specified
397similar to "5.11.0 patch 12345"
398
399=item *
400
401C<<< archname >>> -- platform architecture name as given by $Config{archname}
402
403=item *
404
405C<<< osvers >>> -- operating system version as given by $Config{osvers}
406
407=back
408
409The function returns an array of hashes representing each test result, with
410all of the fields listed above.
411
412=head1 SEE ALSO
413
414=over
415
416=item *
417
418L<CPAN::Reporter>
419
420=item *
421
422L<CPAN::Reporter::FAQ>
423
424=back
425
426=head1 AUTHOR
427
428David Golden <dagolden@cpan.org>
429
430=head1 COPYRIGHT AND LICENSE
431
432This software is Copyright (c) 2006 by David Golden.
433
434This is free software, licensed under:
435
436  The Apache License, Version 2.0, January 2004
437
438=cut
439