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