1# Copyright 2004-2019, Paul Johnson (paul@pjcj.net) 2 3# This software is free. It is licensed under the same terms as Perl itself. 4 5# The latest version of this software should be available from my homepage: 6# http://www.pjcj.net 7 8package Devel::Cover::DB::Structure; 9 10use strict; 11use warnings; 12 13use Carp; 14use Digest::MD5; 15 16use Devel::Cover::DB; 17use Devel::Cover::DB::IO; 18use Devel::Cover::Dumper; 19 20# For comprehensive debug logging. 21use constant DEBUG => 0; 22 23our $VERSION = '1.36'; # VERSION 24our $AUTOLOAD; 25 26sub new { 27 my $class = shift; 28 my $self = { @_ }; 29 bless $self, $class 30} 31 32sub DESTROY {} 33 34sub AUTOLOAD { 35 my $self = $_[0]; 36 my $func = $AUTOLOAD; 37 $func =~ s/.*:://; 38 my ($function, $criterion) = $func =~ /^(add|get)_(.*)/; 39 croak "Undefined subroutine $func called" 40 unless $criterion && 41 grep $_ eq $criterion, @Devel::Cover::DB::Criteria, 42 qw( sub_name file line ); 43 no strict "refs"; 44 if ($function eq "get") { 45 my $c = $criterion eq "time" ? "statement" : $criterion; 46 if (grep $_ eq $c, qw( sub_name file line )) { 47 *$func = sub { shift->{$c} }; 48 } else { 49 *$func = sub { 50 my $self = shift; 51 my $digest = shift; 52 # print STDERR "file: $digest, condition: $c\n"; 53 for my $fval (values %{$self->{f}}) { 54 return $fval->{$c} if $fval->{digest} eq $digest; 55 } 56 return 57 } 58 }; 59 } else { 60 *$func = sub { 61 my $self = shift; 62 my $file = shift; 63 push @{$self->{f}{$file}{$criterion}}, @_; 64 }; 65 } 66 goto &$func 67} 68 69sub debuglog { 70 my $self = shift; 71 my $dir = "$self->{base}/debuglog"; 72 unless (mkdir $dir) { 73 confess "Can't mkdir $dir: $!" unless -d $dir; 74 } 75 76 local $\; 77 # One log file per process, as we're potentially dumping out large amounts, 78 # and might exceed the atomic write size of the OS 79 open my $fh, '>>', "$dir/$$" or confess "Can't open $dir/$$: $!"; 80 print $fh "----------------" . gmtime() . "----------------\n"; 81 print $fh ref $_ ? Dumper($_) : $_; 82 print $fh "\n"; 83 close $fh or confess "Can't close $dir/$$: $!"; 84} 85 86sub add_criteria { 87 my $self = shift; 88 @{$self->{criteria}}{@_} = (); 89 $self 90} 91 92sub criteria { 93 my $self = shift; 94 keys %{$self->{criteria}} 95} 96 97sub set_subroutine { 98 my $self = shift; 99 my ($sub_name, $file, $line, $scount) = 100 @{$self}{qw( sub_name file line scount )} = @_; 101 102 # When new code is added at runtime, via a string eval in some guise, we 103 # need information about where structure information for the subroutine 104 # is. This information is stored in $self->{f}{$file}{start} keyed on the 105 # filename, line number, subroutine name and the count, the count being 106 # for when there are multiple subroutines of the same name on the same 107 # line (such subroutines generally being called BEGIN). 108 109 # print STDERR "set_subroutine start $file:$line $sub_name($scount) ", 110 # Dumper $self->{f}{$file}{start}; 111 $self->{additional} = 0; 112 if ($self->reuse($file)) { 113 # reusing a structure 114 if (exists $self->{f}{$file}{start}{$line}{$sub_name}[$scount]) { 115 # sub already exists - normal case 116 # print STDERR "reuse $file:$line:$sub_name\n"; 117 $self->{count}{$_}{$file} = 118 $self->{f}{$file}{start}{$line}{$sub_name}[$scount]{$_} 119 for $self->criteria; 120 } else { 121 # sub doesn't exist, for example a conditional C<eval "use M"> 122 $self->{additional} = 1; 123 if (exists $self->{additional_count}{($self->criteria)[0]}{$file}) { 124 # already had such a sub in module 125 # print STDERR "reuse additional $file:$line:$sub_name\n"; 126 $self->{count}{$_}{$file} = 127 $self->{f}{$file}{start}{$line}{$sub_name}[$scount]{$_} = 128 ($self->add_count($_))[0] 129 for $self->criteria; 130 } else { 131 # first such a sub in module 132 # print STDERR "reuse first $file:$line:$sub_name\n"; 133 $self->{count}{$_}{$file} = 134 $self->{additional_count}{$_}{$file} = 135 $self->{f}{$file}{start}{$line}{$sub_name}[$scount]{$_} = 136 $self->{f}{$file}{start}{-1}{"__COVER__"}[$scount]{$_} 137 for $self->criteria; 138 } 139 } 140 } else { 141 # first time sub seen in new structure 142 # print STDERR "new $file:$line:$sub_name\n"; 143 $self->{count}{$_}{$file} = 144 $self->{f}{$file}{start}{$line}{$sub_name}[$scount]{$_} = 145 $self->get_count($file, $_) 146 for $self->criteria; 147 } 148 # print STDERR "set_subroutine start $file:$line $sub_name($scount) ", 149 # Dumper $self->{f}{$file}{start}; 150} 151 152sub store_counts { 153 my $self = shift; 154 my ($file) = @_; 155 $self->{count}{$_}{$file} = 156 $self->{f}{$file}{start}{-1}{__COVER__}[0]{$_} = 157 $self->get_count($file, $_) 158 for $self->criteria; 159 # print STDERR "store_counts: ", Dumper $self->{f}{$file}{start}; 160} 161 162sub reuse { 163 my $self = shift; 164 my ($file) = @_; 165 exists $self->{f}{$file}{start}{-1}{"__COVER__"} 166 # TODO - exists $self->{f}{$file}{start}{-1} 167} 168 169sub set_file { 170 my $self = shift; 171 my ($file) = @_; 172 $self->{file} = $file; 173 my $digest = $self->digest($file); 174 if ($digest) { 175 # print STDERR "Adding $digest for $file\n"; 176 $self->{f}{$file}{digest} = $digest; 177 push @{$self->{digests}{$digest}}, $file; 178 } 179 $digest 180} 181 182sub digest { 183 my $self = shift; 184 my ($file) = @_; 185 186 # print STDERR "Opening $file for MD5 digest\n"; 187 188 my $digest; 189 if (open my $fh, "<", $file) { 190 binmode $fh; 191 $digest = Digest::MD5->new->addfile($fh)->hexdigest; 192 } else { 193 print STDERR "Devel::Cover: Warning: can't open $file " . 194 "for MD5 digest: $!\n" 195 unless lc $file eq "-e" or 196 $Devel::Cover::Silent or 197 $file =~ $Devel::Cover::DB::Ignore_filenames; 198 # require "Cwd"; print STDERR Carp::longmess("in " . Cwd::cwd()); 199 } 200 $digest 201} 202 203sub get_count { 204 my $self = shift; 205 my ($file, $criterion) = @_; 206 $self->{count}{$criterion}{$file} 207} 208 209sub add_count { 210 my $self = shift; 211 # warn Carp::longmess("undefined file") unless defined $self->{file}; 212 return unless defined $self->{file}; # can happen during self_cover 213 my ($criterion) = @_; 214 $self->{additional_count}{$criterion}{$self->{file}}++ 215 if $self->{additional}; 216 ($self->{count}{$criterion}{$self->{file}}++, 217 !$self->reuse($self->{file}) || $self->{additional}) 218} 219 220sub delete_file { 221 my $self = shift; 222 my ($file) = @_; 223 delete $self->{f}{$file}; 224} 225 226# TODO - concurrent runs updating structure? 227 228sub write { 229 my $self = shift; 230 my ($dir) = @_; 231 # print STDERR Dumper $self; 232 $dir .= "/structure"; 233 unless (mkdir $dir) { 234 confess "Can't mkdir $dir: $!" unless -d $dir; 235 } 236 chmod 0777, $dir if $self->{loose_perms}; 237 for my $file (sort keys %{$self->{f}}) { 238 $self->{f}{$file}{file} = $file; 239 my $digest = $self->{f}{$file}{digest}; 240 $digest = $1 if defined $digest && $digest =~ /(.*)/; # ie tainting 241 unless ($digest) { 242 print STDERR "Can't find digest for $file" 243 unless $Devel::Cover::Silent || 244 $file =~ $Devel::Cover::DB::Ignore_filenames || 245 ($Devel::Cover::Self_cover && 246 $file =~ q|/Devel/Cover[./]|); 247 next; 248 } 249 my $df_final = "$dir/$digest"; 250 my $df_temp = "$dir/.$digest.$$"; 251 # TODO - determine if Structure has changed to save writing it 252 # my $f = $df; my $n = 1; $df = $f . "." . $n++ while -e $df; 253 my $io = Devel::Cover::DB::IO->new; 254 $io->write($self->{f}{$file}, $df_temp); # unless -e $df; 255 unless (rename $df_temp, $df_final) { 256 unless ($Devel::Cover::Silent) { 257 if(-e $df_final) { 258 print STDERR "Can't rename $df_temp to $df_final " . 259 "(which exists): $!"; 260 $self->debuglog("Can't rename $df_temp to $df_final " . 261 "(which exists): $!") 262 if DEBUG; 263 } else { 264 print STDERR "Can't rename $df_temp to $df_final: $!"; 265 $self->debuglog("Can't rename $df_temp to $df_final: $!") 266 if DEBUG; 267 } 268 } 269 unless (unlink $df_temp) { 270 print STDERR "Can't remove $df_temp after failed rename: $!" 271 unless $Devel::Cover::Silent; 272 $self->debuglog("Can't remove $df_temp after failed rename: $!") 273 if DEBUG; 274 } 275 } 276 } 277} 278 279sub read { 280 my $self = shift; 281 my ($digest) = @_; 282 my $file = "$self->{base}/structure/$digest"; 283 my $io = Devel::Cover::DB::IO->new; 284 my $s = eval { $io->read($file) }; 285 if ($@ or !$s) { 286 $self->debuglog("read retrieve $file failed: $@") if DEBUG; 287 die $@; 288 } 289 if (DEBUG) { 290 foreach my $key (qw(file digest)) { 291 if (!defined $s->{$key}) { 292 $self->debuglog("retrieve $file had no $key entry. Got:\n", $s); 293 } 294 } 295 } 296 my $d = $self->digest($s->{file}); 297 # print STDERR "reading $digest from $file: ", Dumper $s; 298 if (!$d) { 299 # No digest implies that we can't read the file. Likely this is because 300 # it's stored with a relative path. In which case, it's not valid to 301 # assume that the file has been changed, and hence that we need to 302 # "update" the structure database on disk. 303 } elsif ($d eq $s->{digest}) { 304 $self->{f}{$s->{file}} = $s; 305 } else { 306 print STDERR "Devel::Cover: Deleting old coverage ", 307 "for changed file $s->{file}\n"; 308 if (unlink $file) { 309 $self->debuglog("Deleting old coverage $file for changed " 310 . "$s->{file} $s->{digest} vs $d. Got:\n", $s, 311 "Have:\n", $self->{f}{$file}) 312 if DEBUG; 313 } else { 314 print STDERR "Devel::Cover: can't delete $file: $!\n"; 315 $self->debuglog("Failed to delete coverage $file for changed " 316 . "$s->{file} ($!) $s->{digest} vs $d. Got:\n", $s, 317 "Have:\n", $self->{f}{$file}) 318 if DEBUG; 319 } 320 } 321 $self 322} 323 324sub read_all { 325 my ($self) = @_; 326 my $dir = $self->{base}; 327 $dir .= "/structure"; 328 opendir D, $dir or return; 329 for my $d (sort grep $_ !~ /\./, readdir D) { 330 $d = $1 if $d =~ /(.*)/; # Die tainting 331 $self->read($d); 332 } 333 closedir D or die "Can't closedir $dir: $!"; 334 $self 335} 336 337sub merge { 338 my $self = shift; 339 my ($from) = @_; 340 Devel::Cover::DB::_merge_hash($self->{f}, $from->{f}, "noadd"); 341} 342 3431 344 345__END__ 346 347=head1 NAME 348 349Devel::Cover::DB::Structure - Internal: abstract structure of a source file 350 351=head1 VERSION 352 353version 1.36 354 355=head1 SYNOPSIS 356 357 use Devel::Cover::DB::Structure; 358 359=head1 DESCRIPTION 360 361=head1 SEE ALSO 362 363 Devel::Cover 364 Devel::Cover::DB 365 366=head1 METHODS 367 368=head1 BUGS 369 370Huh? 371 372=head1 LICENCE 373 374Copyright 2004-2019, Paul Johnson (paul@pjcj.net) 375 376This software is free. It is licensed under the same terms as Perl itself. 377 378The latest version of this software should be available from my homepage: 379http://www.pjcj.net 380 381=cut 382