File Coverage

File:bin/extract-schemas2
Coverage:83.6%

linestmtbrancondsubtimecode
1#!/usr/bin/env perl
2
3
1
1
1
1
1793
1
42
use strict;
4
1
1
1
1
4
1
22
use warnings;
5
6
1
1
1
1
217
3248
26
use Data::Dumper;
7
1
1
1
1
293
4523
2
use Getopt::Long;
8
1
1
1
1
68
1
25
use File::Path qw(make_path);
9
1
1
1
1
195
25381
47
use Pod::Usage;
10
1
1
1
1
156
442
26
use FindBin;
11
1
1
1
1
161
289
2
use lib "$FindBin::Bin/../lib";
12
13
1
1
1
1
688
2
16
use App::Test::Generator::SchemaExtractor;
14
1
1
1
1
132
27
16
use App::Test::Generator::Planner;
15
1
1
1
1
155
1
1213
use App::Test::Generator::Emitter::Perl;
16
17 - 39
=head1 NAME

extract-schemas2 - Extract schemas and optionally emit Perl tests

=head1 SYNOPSIS

    extract-schemas2 [options] <module.pm>

    Options:
      --output-dir DIR       Directory for schema files (default: schemas/)
      --emit-tests           Generate Perl tests from schemas
      --test-dir DIR         Output directory for generated tests (default: t/generated/)
      --strict-pod=off|warn|fatal
      --verbose
      --help
      --man

=head1 DESCRIPTION

This tool extracts method schemas from a Perl module and can optionally
generate Perl test files using App::Test::Generator::Emitter::Perl.

=cut
40
41# ----------------------------------------------------------------------
42# CLI Options
43# ----------------------------------------------------------------------
44
45
1
77835
my %cli_opts = (
46        help => 0,
47        man  => 0,
48);
49
50
1
2
my %opts = (
51    output_dir => 'schemas',
52    test_dir   => 't/generated',
53    strict_pod => 'warn',
54    verbose    => 0,
55    emit_tests => 0,
56);
57
58GetOptions(
59    'output-dir|o=s' => \$opts{output_dir},
60    'emit-tests|e'   => \$opts{emit_tests},
61    'test-dir|t=s'   => \$opts{test_dir},
62    'strict-pod|s=s' => \$opts{strict_pod},
63    'verbose|v'      => \$opts{verbose},
64    'help|h'         => \$cli_opts{help},
65    'man|m'          => \$cli_opts{man},
66
1
50
4
) or pod2usage(2);
67
68
1
50
542
pod2usage(-exitval => 0, -verbose => 1) if $cli_opts{help};
69
1
50
1
pod2usage(-exitval => 0, -verbose => 2) if $cli_opts{man};
70
71
1
50
2
if ($opts{strict_pod} !~ /^(off|warn|fatal)$/) {
72
0
0
    die "Invalid --strict-pod value '$opts{strict_pod}'. Expected off, warn, or fatal\n";
73}
74
75
1
50
2
my $input_file = shift @ARGV
76    or pod2usage('Error: No input file specified');
77
78
1
50
7
die "Error: File not found: $input_file\n" unless -f $input_file;
79
80# ----------------------------------------------------------------------
81# Extraction Phase
82# ----------------------------------------------------------------------
83
84
1
4
print "Extracting schemas from: $input_file\n";
85
1
1
print "Schema output directory: $opts{output_dir}\n";
86
87
1
50
139
make_path($opts{output_dir}) unless -d $opts{output_dir};
88
89
1
5
my $extractor = App::Test::Generator::SchemaExtractor->new(
90    input_file => $input_file,
91    %opts,
92);
93
94
1
2
my $schemas = $extractor->extract_all();
95
96# ----------------------------------------------------------------------
97# Summary
98# ----------------------------------------------------------------------
99
100
1
2
print "\n", '=' x 70, "\n";
101
1
0
print "EXTRACTION SUMMARY\n";
102
1
1
print '=' x 70, "\n\n";
103
104
1
4
my %confidence = (
105    input  => { high => 0, medium => 0, low => 0 },
106    output => { high => 0, medium => 0, low => 0 },
107);
108
109
1
2
foreach my $method (sort keys %$schemas) {
110
1
1
    my $schema = $schemas->{$method};
111
112
1
50
2
    my $iconf = $schema->{_confidence}{input}{level}  // 'low';
113
1
50
1
    my $oconf = $schema->{_confidence}{output}{level} // 'low';
114
115
1
1
    $confidence{input}{$iconf}++;
116
1
1
    $confidence{output}{$oconf}++;
117
118    my $param_count =
119
1
2
1
1
2
2
        scalar grep { $_ !~ /^_/ } keys %{ $schema->{input} };
120
121
1
3
    printf "%-30s %2d params  [%s input] [%s output]\n",
122        $method,
123        $param_count,
124        uc($iconf),
125        uc($oconf);
126}
127
128
1
5
print "\nTotal methods: ", scalar(keys %$schemas), "\n";
129
130
1
1
foreach my $phase (qw(input output)) {
131
2
1
    print ucfirst($phase), " confidence:\n";
132
2
2
    foreach my $level (qw(high medium low)) {
133
6
6
        printf "  %-6s %d\n", ucfirst($level), $confidence{$phase}{$level};
134    }
135}
136
137# ----------------------------------------------------------------------
138# Test Emission Phase
139# ----------------------------------------------------------------------
140
141
1
50
2
if ($opts{emit_tests}) {
142
143
1
1
    print "\nGenerating Perl tests...\n";
144
1
1
    print "Test output directory: $opts{test_dir}\n";
145
146
1
50
83
    make_path($opts{test_dir}) unless -d $opts{test_dir};
147
148    # ------------------------------------------------------------
149    # Derive package name from input file
150    # ------------------------------------------------------------
151
152
1
50
14
    open my $fh, '<', $input_file
153        or die "Cannot open $input_file: $!";
154
155
1
0
    my $package_name;
156
1
6
    while (<$fh>) {
157
1
50
3
        if (/^\s*package\s+([\w:]+)\s*;/) {
158
1
1
            $package_name = $1;
159
1
1
            last;
160        }
161    }
162
1
4
    close $fh;
163
164
1
50
1
    die "Could not determine package name from $input_file\n"
165        unless $package_name;
166
167    # ------------------------------------------------------------
168    # Generate very basic plans from schema
169    # ------------------------------------------------------------
170
171
1
1
    my %plans;
172
173
1
2
    foreach my $method (keys %$schemas) {
174
1
1
        my $schema = $schemas->{$method};
175
176
1
50
3
        my $accessor = $schema->{accessor}{type} // '';
177
178
1
50
50
50
50
5
        $plans{$method} = {
179            basic_test       => 1,
180            getter_test      => $accessor eq 'getter'  ? 1 : 0,
181            setter_test      => $accessor eq 'setter'  ? 1 : 0,
182            getset_test      => $accessor eq 'getset'  ? 1 : 0,
183            chaining_test    => $accessor eq 'setter'  ? 1 : 0,
184            error_handling_test => 0,
185            context_tests    => 0,
186        };
187    }
188
189# ----------------------------------------------------------
190# Planning Phase
191# ----------------------------------------------------------
192
193
1
50
1
print "Planning tests...\n" if $opts{verbose};
194
195
1
3
my $planner = App::Test::Generator::Planner->new(schemas => $schemas, package => $package_name);
196
197
1
1
my $plans = $planner->plan_all();
198
199# ----------------------------------------------------------
200# Emission Phase
201# ----------------------------------------------------------
202
203
1
4
        my $emitter = App::Test::Generator::Emitter::Perl->new(
204                package => $package_name,
205                schema  => $schemas,
206                plans   => $plans,
207        );
208
209
1
1
        my $code = $emitter->emit();
210
211    # ------------------------------------------------------------
212    # Write output file
213    # ------------------------------------------------------------
214
215
1
1
    my $test_file = "$opts{test_dir}/01-basic.t";
216
217
1
50
32
    open my $out, '>', $test_file
218        or die "Cannot write $test_file: $!";
219
220
1
3
    print $out $code;
221
1
13
    close $out;
222
223
1
8
    print "Wrote test file: $test_file\n";
224}
225
226
227
1
50
2
if ($opts{verbose}) {
228
0
0
    print "\nSchemas structure:\n";
229
0
0
    print Dumper($schemas);
230}
231
232
1
12
print "\nDone.\n";
233