File Coverage

File:blib/lib/Devel/App/Test/Generator/LCSAJ/Runtime.pm
Coverage:85.1%

linestmtbrancondsubtimecode
1package Devel::App::Test::Generator::LCSAJ::Runtime;
2
3
2
2
2
2
69135
2
22
use strict;
4
2
2
2
2
3
2
39
use warnings;
5
2
2
2
2
180
5947
5
use autodie     qw(open close);
6
2
2
2
2
432
2
43
use Carp        qw(croak);
7
2
2
2
2
4
2
38
use Cwd         qw(abs_path);
8
2
2
2
2
2
4
44
use JSON::MaybeXS;
9
2
2
2
2
4
1
43
use File::Path  qw(make_path);
10
2
2
2
2
264
1658
218
use Readonly;
11
12# --------------------------------------------------
13# Output directory for per-process hit JSON files.
14# One file is written per process (PID) so parallel
15# test runs do not overwrite each other's output.
16# --------------------------------------------------
17Readonly my $OUT_DIR => 'cover_html/lcsaj_hits';
18
19 - 27
=head1 NAME

Devel::App::Test::Generator::LCSAJ::Runtime - Debugger backend for LCSAJ coverage

=head1 VERSION

Version 0.46

=cut
28
29our $VERSION = '0.46';
30
31 - 62
=head1 SYNOPSIS

  PERL5OPT='-d:App::Test::Generator::LCSAJ::Runtime -Mblib' prove -l t

=head1 DESCRIPTION

This module is loaded as a Perl debugger backend using the C<-d:Module> flag.

When Perl sees C<-d:App::Test::Generator::LCSAJ::Runtime> it prepends C<Devel::>
and loads C<Devel/App/Test/Generator/LCSAJ/Runtime.pm> from C<@INC>.
The file must therefore live at that path - typically C<lib/Devel/App/Test/Generator/LCSAJ/Runtime.pm>.

Perl automatically calls C<DB::DB> before executing each statement while the
debugger is active. We record (file, line) pairs to build runtime hit data for
later LCSAJ analysis.

Results are written to C<cover_html/lcsaj_hits/hits_PID.json> at process exit,
one file per process so that parallel test runs do not overwrite each other.

=head1 ENVIRONMENT

=over 4

=item LCSAJ_TARGETS

Optional colon-separated list of B<absolute> paths (as produced by C<realpath>)
to restrict recording to specific source files. When empty or unset every
non-internal file is recorded.

=back

=cut
63
64# --------------------------------------------------
65# %HITS       - { normalised_path => { line_number => hit_count } }
66# %TARGET     - set of normalised paths to record (empty means record everything)
67# %NORM_CACHE - { raw_file => normalised_path }, memoises abs_path()
68#               since DB::DB sees the same $file on every consecutive
69#               statement within a source file
70#
71# These must be package globals (our) rather than lexicals because DB::DB
72# is called by the Perl debugger infrastructure and needs to access them
73# without a closure. Lexical vars would not be visible in DB::DB.
74# --------------------------------------------------
75our %HITS;
76our %TARGET;
77our %NORM_CACHE;
78
79# --------------------------------------------------
80# Populate %TARGET from LCSAJ_TARGETS at compile time.
81# The env var contains absolute realpath() output
82# separated by colons. Stray newlines from broken
83# shell pipelines are stripped defensively.
84# --------------------------------------------------
85BEGIN {
86
2
50
2
8
        my $targets_env = $ENV{LCSAJ_TARGETS} // '';
87
2
2
        $targets_env =~ s/\n//g;
88
89
2
279
        for my $t (split /:/, $targets_env) {
90
0
0
0
                next unless length $t;
91
92                # Inline normalisation — cannot call _normalize here since
93                # BEGIN runs before named subs are compiled when BEGIN
94                # appears at the top of the file
95
0
0
                my $f = $t;
96
0
0
                $f =~ s{^.*/blib/lib/}{lib/};
97
0
0
                $f =~ s{^.*/lib/}{lib/};
98
0
0
                $TARGET{$f} = 1;
99        }
100}
101
102END {
103
2
2
3718
        _write_results();
104}
105
106# --------------------------------------------------
107# _normalize
108#
109# Convert an absolute or build-tree path
110#             to a canonical lib-relative form so that
111#             paths recorded at runtime match the
112#             targets derived from LCSAJ_TARGETS.
113#
114# Entry:      $path - an absolute or relative file path.
115#
116# Exit:       Returns a lib-relative path string,
117#             e.g. lib/Foo/Bar.pm
118#
119# Notes:      Must be defined before the BEGIN block
120#             that calls it, since BEGIN runs at compile
121#             time and later subs may not yet be compiled.
122#
123# Examples:
124#   /home/user/proj/blib/lib/Foo/Bar.pm  ->  lib/Foo/Bar.pm
125#   /home/user/proj/lib/Foo/Bar.pm       ->  lib/Foo/Bar.pm
126# --------------------------------------------------
127sub _normalize {
128
8
8
1253
        my $f = $_[0];
129
130        # Strip everything up to and including blib/lib/ or lib/
131
8
18
        $f =~ s{^.*/blib/lib/}{lib/};
132
8
14
        $f =~ s{^.*/lib/}{lib/};
133
8
18
        return $f;
134}
135
136# --------------------------------------------------
137# DB::DB
138#
139# Called by the Perl debugger before every
140#             statement. Records (file, line) hits for
141#             later LCSAJ coverage analysis.
142#
143# Entry:      No arguments — caller(0) is used to get
144#             the current file and line number.
145#
146# Exit:       Returns nothing. Updates %HITS in place.
147#
148# Side effects: Increments %HITS{$norm}{$line}.
149#
150# Notes:      This sub lives in the DB:: package as
151#             required by Perl's debugger protocol.
152#             It is called for every statement executed
153#             while the debugger is active, so it must
154#             be as fast as possible.
155#             Internal files and out-of-target files
156#             are skipped immediately.
157#             abs_path() resolution is memoised in
158#             %NORM_CACHE per raw $file, since the same
159#             file is seen on every consecutive statement.
160# --------------------------------------------------
161 - 199
=head2 DB::DB

Perl debugger hook, automatically invoked by the interpreter before every
statement while this module is active as a C<-d:> debugger backend.
Records a per-(file, line) hit count used later for LCSAJ coverage
analysis.

=head3 Arguments

None. Perl calls this sub directly; the current execution location is
obtained internally via C<caller(0)>.

=head3 Returns

Nothing meaningful - this is a void debugger callback.

=head3 Side effects

Increments C<%HITS{$norm}{$line}> for the normalised path and line number
of the statement about to execute. Resolves each distinct raw filename
via C<Cwd::abs_path> once, memoising the result in C<%NORM_CACHE>.

=head3 Usage example

Not called directly - activated via the Perl debugger flag:

    PERL5OPT='-d:App::Test::Generator::LCSAJ::Runtime -Mblib' prove -l t

=head3 API specification

=head4 input

    { }

=head4 output

    { type => UNDEF }

=cut
200
201sub DB::DB {
202
7
7
89193
        my (undef, $file, $line) = caller(0);
203
204
7
50
33
66
        return unless defined $file && defined $line;
205
206        # Resolve symlinks and relative components to a stable absolute path,
207        # cached per raw $file to avoid a stat() on every statement
208
7
67
33
37
        my $norm = $NORM_CACHE{$file} //= _normalize(abs_path($file) // $file);
209
210        # Never record hits inside this module itself — suffix match is used
211        # so it works regardless of CWD or install prefix
212
7
100
15
        return if $norm =~ m{(?:^|/)Devel/App/Test/Generator/LCSAJ/Runtime\.pm$};
213
214        # If a target list was provided, skip files not in it
215
6
100
9
        if(%TARGET) {
216
2
100
4
                return unless $TARGET{$norm};
217        }
218
219
5
11
        $HITS{$norm}{$line}++;
220}
221
222# --------------------------------------------------
223# _write_results
224#
225# Serialise %HITS to a per-process JSON
226#             file in the output directory.
227#
228# Entry:      None. Reads %HITS and $OUT_DIR.
229#
230# Exit:       Returns nothing. Writes a JSON file.
231#             Returns immediately if %HITS is empty.
232#
233# Side effects: Creates $OUT_DIR if absent.
234#               Writes cover_html/lcsaj_hits/hits_PID.json
235#
236# Notes:      Called from END so it runs even when
237#             prove exits non-zero — mutation tests
238#             are expected to fail. PID is included
239#             in the filename so parallel test runs
240#             produce separate files without collision.
241# --------------------------------------------------
242sub _write_results {
243
5
100
5
6059
        return unless %HITS;
244
245        # Include PID in filename to support parallel test runs
246
2
12
        my $out_file = "$OUT_DIR/hits_$$.json";
247
248
2
100
12
        make_path($OUT_DIR) unless -d $OUT_DIR;
249
250        # autodie is disabled for this open -- under "use autodie qw(open)"
251        # open() never returns false on failure, it throws its own exception
252        # instead, which would silently make the "or croak" below dead code
253
2
2
2
2
4
5
5
        no autodie qw(open);
254
2
100
237
        open my $fh, '>', $out_file or croak "Cannot write $out_file: $!";
255
256
1
11
        print $fh encode_json(\%HITS);
257
1
5
        close $fh;
258}
259
2601;
261