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