File Coverage

blib/arch/Panda/Config/Perl.pm
Criterion Covered Total %
statement 108 114 94.7
branch 41 54 75.9
condition 8 14 57.1
subroutine 12 12 100.0
pod 0 1 0.0
total 169 195 86.6


line stmt bran cond sub pod time code
1             package Panda::Config::Perl;
2 8     8   167856 use 5.012;
  8         21  
3 8     8   3143 use Panda::Lib(); # XS code needs xs::lib::merge
  8         135582  
  8         511  
4              
5             our $VERSION = '1.1.7';
6              
7             require Panda::XSLoader;
8             Panda::XSLoader::load();
9              
10             sub process {
11 8     8 0 2212 my ($class, $file, $initial_cfg) = @_;
12              
13 8         8 my ($mstash, $nsstash);
14             {
15 8     8   804 no strict 'refs';
  8         14  
  8         1474  
  8         8  
16 8         10 $mstash = \%{"::"};
  8         21  
17 8         27 delete $mstash->{'NS::'};
18 8         14 $nsstash = \%{"NS::"};
  8         29  
19             }
20              
21 8 100       95 _apply_initial_cfg('', Panda::Lib::fclone($initial_cfg)) if $initial_cfg;
22 8         23 _process_file($file);
23              
24 6         21 my $ret = {};
25              
26 6         9 my $cfg = {};
27 6 50       21 if(defined $nsstash->{'__CONFIG__'}){
28 0         0 $cfg = ${$nsstash->{'__CONFIG__'}};
  0         0  
29 0         0 delete $nsstash->{'__CONFIG__'};
30             }
31 6         25 _get_config($ret, $nsstash, $cfg, '');
32              
33             # remove garbage we've created
34 5         70 delete $mstash->{'NS::'};
35              
36 5         56 return $ret;
37             }
38              
39             sub _apply_initial_cfg {
40 4     4   8 my ($ns, $cfg) = @_;
41 4         15 foreach my $key (keys %$cfg) {
42 8 50       20 if (substr($key, -2, 2) eq '::') {
43 0         0 _apply_initial_cfg($ns.$key, $cfg->{$key});
44             } else {
45 8     8   33 no strict 'refs';
  8         13  
  8         1937  
46 8         10 *{"NS::$ns$key"} = \$cfg->{$key};
  8         27  
47             }
48             }
49             }
50              
51             sub _process_file {
52 14     14   18 my ($file, $ns) = @_;
53 14 100       530 open my $fh, '<', $file or die "Panda::Config::Perl: cannot open $file: $!";
54 13         17 my $content;
55             {
56 13         8 local $/ = undef;
  13         43  
57 13         221 $content = <$fh>;
58             }
59 13         69 close $fh;
60              
61 13         19 my $curdir = '';
62 13 50       49 if ((my $pos = rindex($file, '/')) >= 0) {
63 13         28 $curdir = substr($file, 0, $pos);
64             }
65              
66 13         67 $content =~ s/^[^\S\r\n]*#(namespace|namespace-abs|include)(?:[^\S\r\n]+(.+))?$/_process_directive($curdir, $ns, $1, $2)/gme;
  24         35  
67              
68 13 100       34 my $pkg = $ns ? "NS::$ns" : "NS";
69 13         31 $content = "package $pkg; sub { $content;\n }";
70 13         13 my $ok;
71             {
72 8     8   36 no strict;
  8         10  
  8         4855  
  13         29  
73 13         39 enable_op_tracking();
74 13         1495 my $sub = eval $content;
75 13         33 disable_op_tracking();
76 13 100       31 $ok = eval { $sub->(); 1 } if $sub;
  12         211  
  12         101  
77             }
78 13 100       29 unless ($ok) {
79 1         2 my $err = $@;
80 1 50       4 die $err if $err =~ /Error-prone code/;
81 1 50       4 $err =~ s/Panda::Config::Perl: //g unless ref $err;
82 1         6 die "Panda::Config::Perl: error while processing config $file: $err\n".
83             "================ Error-prone code ================\n".
84             _content_linno($content).
85             "==================================================";
86             }
87              
88 12         76 return;
89             }
90              
91             sub _process_directive {
92 24     24   56 my ($curdir, $ns, $directive, $rest) = @_;
93 24         30 $rest =~ s/\s+$//;
94 24   100     44 $rest //= '';
95 24 100       61 if (index($directive, 'namespace') == 0) {
    50          
96 19 100       30 $ns = '' if $directive eq 'namespace-abs';
97 19 100       25 my $pkg = $ns ? "NS::$ns" : 'NS';
98 19 100       56 $pkg .= "::$1" if $rest =~ /\s*(\S+)/;
99 19         82 return "package $pkg;";
100             }
101             elsif ($directive eq 'include') {
102 5         25 return "Panda::Config::Perl::_INCLUDE('$curdir', __PACKAGE__, $rest);";
103             }
104             }
105              
106             sub _INCLUDE {
107 5     5   6 my ($dir, $curpkg, $file) = @_;
108 5         5 my $ns = '';
109 5 50       10 if ($curpkg ne 'NS') {
110 5         4 $ns = $curpkg;
111 5         11 substr($ns, 0, 4, ''); # remove /^NS::/
112             }
113 5 50       10 unless (substr($file, 0, 1) eq '/') { $file = $dir ? "$dir/$file" : $file }
  5 50       13  
114 5 100       12 if (index($file, '*') >= 0) {
115 1         85 _process_file($_, $ns) for glob($file);
116             } else {
117 4         13 _process_file($file, $ns);
118             }
119             }
120              
121             sub _get_config {
122 23     23   33 my ($dest, $stash, $config, $ns) = @_;
123 23         18 my @ns_list;
124              
125             my $assign_proc;
126 23 50       43 $assign_proc = $config->{assign_proc} if defined $config->{assign_proc};
127 23         46 foreach my $key (keys %$stash) {
128 91 100 33     531 next if $key eq 'BEGIN' or $key eq 'DESTROY' or $key eq 'AUTOLOAD' or index($key, '__ANON__') == 0;
      33        
      66        
129 83 100       131 if (substr($key, -2, 2) eq '::') {
130 18         22 push @ns_list, $key;
131 18         17 next;
132             }
133 65 50       118 my $glob = $stash->{$key} or next;
134 65 50 66     117 next if !defined $$glob and defined *$glob{CODE};
135 65 50       72 if(defined $assign_proc){
136 0         0 $dest->{$key} = undef;
137 0         0 $assign_proc->($dest->{$key}, $$glob);
138             } else {
139 65         91 $dest->{$key} = $$glob;
140             }
141             }
142              
143 23         50 foreach my $subns (@ns_list) {
144 18         14 my $substash = \%{$stash->{$subns}};
  18         29  
145 18         26 substr($subns, -2, 2, '');
146 18 100       32 my $subns_full = $ns ? "${ns}::$subns" : $subns;
147 18 100       31 if (exists $dest->{$subns}) {
148 1         9 die "Panda::Config::Perl: conflict between variable '$subns' in namespace '$ns' and a namespace '$subns_full'. ".
149             "You shouldn't have variables that overlap with namespaces as they would merge into the same hash.\n";
150             }
151 17         81 _get_config($dest->{$subns} = {}, $substash, $config, $subns_full);
152             }
153             }
154              
155             sub _content_linno {
156 1     1   1 my $content = shift;
157 1         2 my $i = 0;
158 1         5 $content =~ s/^(.*)$/$i++; "$i: $1"/mge;
  7         5  
  7         16  
159 1         22 return $content;
160             }
161              
162             1;