File Coverage

blib/lib/Data/Sah/DefaultValue.pm
Criterion Covered Total %
statement 38 44 86.3
branch 6 14 42.8
condition n/a
subroutine 8 8 100.0
pod 1 1 100.0
total 53 67 79.1


line stmt bran cond sub pod time code
1             package Data::Sah::DefaultValue;
2              
3 1     1   76300 use 5.010001;
  1         14  
4 1     1   6 use strict;
  1         1  
  1         21  
5 1     1   5 use warnings;
  1         2  
  1         24  
6 1     1   6 no warnings 'once';
  1         2  
  1         28  
7 1     1   1849 use Log::ger;
  1         56  
  1         4  
8              
9 1     1   664 use Data::Sah::DefaultValueCommon;
  1         2  
  1         36  
10              
11 1     1   7 use Exporter qw(import);
  1         2  
  1         449  
12              
13             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
14             our $DATE = '2023-01-20'; # DATE
15             our $DIST = 'Data-Sah-DefaultValue'; # DIST
16             our $VERSION = '0.002'; # VERSION
17              
18             our @EXPORT_OK = qw(gen_default_value_code);
19              
20             our %SPEC;
21              
22             our $Log_Default_Value_Code = $ENV{LOG_SAH_DEFAULT_VALUE_CODE} // 0;
23              
24             $SPEC{gen_default_value_code} = {
25             v => 1.1,
26             summary => 'Generate code to set default value',
27             description => <<'_',
28              
29             This is mostly for testing. Normally the default value rules will be used from
30             via the `x.perl.default_value_rules` or
31             `x.js.default_value_rules` or `x.default_value_rules` property.
32              
33             _
34             args => {
35             %Data::Sah::DefaultValueCommon::gen_default_value_code_args,
36             },
37             result_naked => 1,
38             };
39             sub gen_default_value_code {
40 1     1 1 1100 my %args = @_;
41              
42 1         6 my $rules = Data::Sah::DefaultValueCommon::get_default_value_rules(
43             %args,
44             compiler=>'perl',
45             );
46              
47 1         3 my $code;
48 1 50       4 if (@$rules) {
49 1         2 my $code_require = '';
50 1         2 my %mem;
51 1         4 for my $rule (@$rules) {
52 1 50       4 next unless $rule->{modules};
53 0         0 for my $mod (keys %{$rule->{modules}}) {
  0         0  
54 0 0       0 next if $mem{$mod}++;
55 0         0 $code_require .= "require $mod;\n";
56             }
57             }
58              
59 1         2 my $expr = '';
60 1         3 for my $i (reverse 0..$#{$rules}) {
  1         4  
61 1 50       6 $expr .= (length($expr) ? ' // ' : '') .
62             "($rules->[$i]{expr_value})";
63             }
64              
65 1         5 $code = join(
66             "",
67             $code_require,
68             "sub { shift // $expr };\n",
69             );
70             } else {
71 0         0 $code = 'sub { shift }';
72             }
73              
74 1 50       3 if ($Log_Default_Value_Code) {
75 0         0 log_trace("Default-value code (gen args: %s): %s", \%args, $code);
76             }
77              
78 1 50       4 return $code if $args{source};
79              
80 1         91 my $default_value_code = eval $code; ## no critic: BuiltinFunctions::ProhibitStringyEval
81 1 50       5 die if $@;
82 1         6 $default_value_code;
83             }
84              
85             1;
86             # ABSTRACT: Default-value rules for Data::Sah
87              
88             __END__