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