File Coverage

blib/lib/Gears/Config/Reader/PerlScript.pm
Criterion Covered Total %
statement 81 81 100.0
branch 4 4 100.0
condition n/a
subroutine 20 20 100.0
pod 2 2 100.0
total 107 107 100.0


line stmt bran cond sub pod time code
1             package Gears::Config::Reader::PerlScript;
2             $Gears::Config::Reader::PerlScript::VERSION = '0.101';
3 2     2   43 use v5.40;
  2         8  
4 2     2   13 use Mooish::Base -standard;
  2         6  
  2         200  
5              
6 2     2   30593 use Gears::X::Config;
  2         248  
  2         130  
7 2     2   2103 use Path::Tiny qw(path);
  2         27812  
  2         1212  
8              
9             extends 'Gears::Config::Reader';
10              
11             has param 'declared_vars' => (
12             isa => HashRef,
13             default => sub { {} },
14             );
15              
16             sub handled_extensions ($self)
17 4     4 1 7 {
  4         7  
  4         6  
18 4         13 return qw(pl);
19             }
20              
21             # declare no lexical vars other than $vars (visible in eval)
22             sub _clean_eval
23             {
24 4     4   4028 my $_result;
25 4         9 my $vars = $_[2];
26              
27             # avoid raising $@ when $@ is local
28 4         8 my $_err = do {
29 4         8 local $@;
30 4     1   480 $_result = eval $_[1];
  1     1   9  
  1     2   3  
  1     1   29  
  1     1   6  
  1     1   2  
  1     1   69  
  1     1   705  
  1     1   172  
  1     1   96  
  1     1   10  
  1     1   3  
  1         38  
  1         7  
  1         3  
  1         62  
  1         7  
  1         2  
  1         130  
  1         9  
  1         2  
  1         56  
  1         7  
  1         2  
  1         62  
  1         6  
  1         2  
  1         145  
  1         9  
  1         3  
  1         34  
  1         6  
  1         2  
  1         123  
  1         10  
  1         2  
  1         103  
31 4         18 $@;
32             };
33              
34 4 100       22 die $_err if $_err;
35 3         27 return $_result;
36             }
37              
38 5         12 sub parse ($self, $config, $filename)
  4         7  
39 4     4 1 9 {
  4         6  
  5         13  
40 4         20 my %vars = $self->declared_vars->%*;
41 1     2   3 $vars{include} = sub ($inc_filename) {
  1         3  
  1         2  
42 1         8 my $dir = path($filename)->parent;
43 1         160 $config->parse(file => $dir->child($inc_filename));
44 4         30 };
45              
46             my $vars_string = join '',
47             map {
48 4 100       14 if (ref $vars{$_} eq 'CODE') {
  6         19  
49 4         19 qq{sub $_ { \$vars->{$_}->(\@_) }};
50             }
51             else {
52 2         10 qq{sub $_ { \$vars->{$_} }};
53             }
54             }
55             keys %vars;
56              
57 4         9 state $id = 0;
58 4         7 ++$id;
59 4         51 my $eval = join ' ', split /\v/, <<~PERL;
60             package Gears::Config::Reader::PerlScript::Sandbox$id;
61             use strict;
62             use warnings;
63             use builtin qw(true false);
64             $vars_string
65             PERL
66              
67 4         39 try {
68 4         21 return $self->_clean_eval(
69             $eval . $self->_get_contents($filename),
70             \%vars,
71             );
72             }
73             catch ($ex) {
74 1         23 Gears::X::Config->raise("error in $filename: $ex");
75             }
76             }
77              
78             __END__