line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# -*- perl -*-
|
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
888
|
use strict;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
50
|
|
4
|
1
|
|
|
1
|
|
1031
|
use utf8;
|
|
1
|
|
|
|
|
11
|
|
|
1
|
|
|
|
|
6
|
|
5
|
1
|
|
|
1
|
|
33
|
use Fcntl ();
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
1579
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
package XML::EP::Processor::EmbPerl;
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
sub new {
|
10
|
0
|
|
|
0
|
0
|
|
my $proto = shift;
|
11
|
0
|
0
|
|
|
|
|
my $self = (@_ == 1) ? \%{ shift() } : { @_ };
|
|
0
|
|
|
|
|
|
|
12
|
0
|
|
0
|
|
|
|
bless($self, (ref($proto) || $proto));
|
13
|
|
|
|
|
|
|
}
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
sub Process {
|
16
|
0
|
|
|
0
|
0
|
|
my($self, $req, $xml) = @_;
|
17
|
|
|
|
|
|
|
|
18
|
0
|
0
|
|
|
|
|
die "Failed to create package: Producer did not set a path"
|
19
|
|
|
|
|
|
|
unless $req->{'path'};
|
20
|
0
|
|
|
|
|
|
my $package = $req->{'path'};
|
21
|
0
|
|
|
|
|
|
$package =~ s/\./_/g;
|
22
|
0
|
|
|
|
|
|
$package =~ s/[^\/\\a-zA-Z0-9_]//g;
|
23
|
0
|
|
|
|
|
|
$package =~ s/[\/\\]/\:\:/g;
|
24
|
0
|
|
|
|
|
|
$package = "XML::EP::Processor::EmbPerl::Compiled::$package";
|
25
|
|
|
|
|
|
|
|
26
|
0
|
0
|
0
|
|
|
|
my $basedir = $req->{'embperl_basedir'} ||
|
27
|
|
|
|
|
|
|
exists($ENV{'DOCUMENT_ROOT'}) ? $ENV{'DOCUMENT_ROOT'} : "/var/embperl";
|
28
|
|
|
|
|
|
|
|
29
|
0
|
|
|
|
|
|
my $basefile = "$req->{'path'}c";
|
30
|
0
|
|
|
|
|
|
my $exists = -f $basefile;
|
31
|
0
|
0
|
0
|
|
|
|
if ($exists && (stat _)[9] >= $req->{'path_mtime'}) {
|
32
|
|
|
|
|
|
|
# Slurp in the cached file.
|
33
|
0
|
|
|
|
|
|
require $basefile;
|
34
|
|
|
|
|
|
|
} else {
|
35
|
|
|
|
|
|
|
# Compile the file and try to save it
|
36
|
0
|
|
|
|
|
|
my $source = $self->Compile($req, $xml, $package);
|
37
|
|
|
|
|
|
|
|
38
|
0
|
|
|
|
|
|
local *FH;
|
39
|
0
|
0
|
0
|
|
|
|
if (open(FH, ">$basefile~") && (print FH $source) && close(FH)) {
|
|
|
|
0
|
|
|
|
|
40
|
0
|
|
|
|
|
|
unlink $basefile;
|
41
|
0
|
|
|
|
|
|
rename "$basefile~", $basefile;
|
42
|
|
|
|
|
|
|
}
|
43
|
0
|
|
|
|
|
|
eval $source;
|
44
|
0
|
0
|
|
|
|
|
die $@ if $@;
|
45
|
|
|
|
|
|
|
}
|
46
|
|
|
|
|
|
|
|
47
|
0
|
|
|
|
|
|
my $document = $package->Document();
|
48
|
|
|
|
|
|
|
}
|
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
sub Compile {
|
51
|
0
|
|
|
0
|
0
|
|
my($self, $req, $xml, $package) = @_;
|
52
|
|
|
|
|
|
|
|
53
|
0
|
|
|
|
|
|
$self->{'init'} = '';
|
54
|
0
|
|
|
|
|
|
my $source = $self->ProcessNode($xml);
|
55
|
|
|
|
|
|
|
|
56
|
0
|
|
|
|
|
|
$self->{'init'} =~ s/^/ /mg;
|
57
|
0
|
|
|
|
|
|
$source =~ s/^/ /mg;
|
58
|
|
|
|
|
|
|
|
59
|
0
|
|
|
|
|
|
qq[use strict;
|
60
|
|
|
|
|
|
|
package $package;
|
61
|
|
|
|
|
|
|
sub Document {
|
62
|
|
|
|
|
|
|
my \$self = shift;
|
63
|
|
|
|
|
|
|
my \$document = XML::DOM::Document->new();
|
64
|
|
|
|
|
|
|
my \$node = \$document;
|
65
|
|
|
|
|
|
|
my \$current;
|
66
|
|
|
|
|
|
|
my \@nodes;
|
67
|
|
|
|
|
|
|
$self->{'init'}
|
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
$source
|
70
|
|
|
|
|
|
|
\$document;
|
71
|
|
|
|
|
|
|
}
|
72
|
|
|
|
|
|
|
];
|
73
|
|
|
|
|
|
|
}
|
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
sub ProcessNode {
|
76
|
0
|
|
|
0
|
0
|
|
my($self, $node) = @_;
|
77
|
0
|
|
|
|
|
|
my $type = $node->getNodeType();
|
78
|
0
|
0
|
|
|
|
|
if ($type == XML::DOM::ELEMENT_NODE()) {
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
79
|
0
|
|
|
|
|
|
my $source = "push(\@nodes, \$node);\n" .
|
80
|
|
|
|
|
|
|
"\$current = \$document->createElement(" .
|
81
|
|
|
|
|
|
|
$self->QuoteString($node->getTagName()) . ");\n" .
|
82
|
|
|
|
|
|
|
"\$node->appendChild(\$current);\n" .
|
83
|
|
|
|
|
|
|
"\$node = \$current;\n";
|
84
|
0
|
0
|
|
|
|
|
if (my $attr = $node->getAttributes()) {
|
85
|
0
|
|
|
|
|
|
for (my $i = 0; $i < $attr->getLength(); $i++) {
|
86
|
0
|
|
|
|
|
|
my $a = $attr->item($i);
|
87
|
0
|
|
|
|
|
|
$source .= '$node->setAttribute(' .
|
88
|
|
|
|
|
|
|
$self->QuoteString($a->getName()) .
|
89
|
|
|
|
|
|
|
', ' . $self->QuoteString($a->getValue()) . ");\n";
|
90
|
|
|
|
|
|
|
}
|
91
|
|
|
|
|
|
|
}
|
92
|
0
|
|
|
|
|
|
for (my $child = $node->getFirstChild(); $child;
|
93
|
|
|
|
|
|
|
$child = $child->getNextSibling()) {
|
94
|
0
|
|
|
|
|
|
$source .= $self->ProcessNode($child);
|
95
|
|
|
|
|
|
|
}
|
96
|
0
|
|
|
|
|
|
$source . "\$node = pop \@nodes;\n";
|
97
|
|
|
|
|
|
|
} elsif ($type == XML::DOM::TEXT_NODE()) {
|
98
|
0
|
|
|
|
|
|
my $subs = "";
|
99
|
0
|
|
|
|
|
|
my $num = 0;
|
100
|
0
|
|
|
|
|
|
my $source = "{ my \$__result = '';\n";
|
101
|
|
|
|
|
|
|
|
102
|
0
|
|
|
|
|
|
my $text = $node->getData();
|
103
|
0
|
|
|
|
|
|
while ($text =~ s/(.*?)\[(?:\+(.*?)\+|\-(.*?)\-)\]//) {
|
104
|
0
|
|
|
|
|
|
my $prefix = $1;
|
105
|
0
|
|
|
|
|
|
my $plus_text = $2;
|
106
|
0
|
|
|
|
|
|
my $minus_text = $3;
|
107
|
0
|
0
|
|
|
|
|
if ($prefix ne "") {
|
108
|
0
|
|
|
|
|
|
$source .= " \$__result .= " .
|
109
|
|
|
|
|
|
|
$self->QuoteString($prefix) . ";\n";
|
110
|
|
|
|
|
|
|
}
|
111
|
0
|
0
|
|
|
|
|
if ($plus_text) {
|
112
|
0
|
|
|
|
|
|
$source .= " \$__result .= &{sub { $plus_text }};\n";
|
113
|
|
|
|
|
|
|
} else {
|
114
|
0
|
|
|
|
|
|
$source .= " $minus_text;\n";
|
115
|
|
|
|
|
|
|
}
|
116
|
|
|
|
|
|
|
}
|
117
|
|
|
|
|
|
|
$source .
|
118
|
0
|
0
|
|
|
|
|
($text eq "" ?
|
119
|
|
|
|
|
|
|
"" : " \$__result .= " . $self->QuoteString($text). ";\n") .
|
120
|
|
|
|
|
|
|
" \$node->appendChild(\$document->createTextNode(\$__result));\n}\n";
|
121
|
|
|
|
|
|
|
} elsif ($type == XML::DOM::CDATA_SECTION_NODE()) {
|
122
|
0
|
|
|
|
|
|
'$node->appendChild($document->createCDATASection(' .
|
123
|
|
|
|
|
|
|
$self->QuoteString($node->getData()) . "));\n";
|
124
|
|
|
|
|
|
|
} elsif ($type == XML::DOM::PROCESSING_INSTRUCTION_NODE()) {
|
125
|
0
|
|
|
|
|
|
'$node->appendChild($document->createProcessingInstruction(' .
|
126
|
|
|
|
|
|
|
$self->QuoteString($node->getTarget()) . ', ' .
|
127
|
|
|
|
|
|
|
$self->QuoteString($node->getData()) . "));\n";
|
128
|
|
|
|
|
|
|
} elsif ($type == XML::DOM::COMMENT_NODE()) {
|
129
|
0
|
|
|
|
|
|
'$node->appendChild($document->createComment(' .
|
130
|
|
|
|
|
|
|
$self->QuoteString($node->getData()) . "));\n";
|
131
|
|
|
|
|
|
|
} elsif ($type == XML::DOM::DOCUMENT_NODE()) {
|
132
|
0
|
|
|
|
|
|
my $source = "";
|
133
|
0
|
|
|
|
|
|
for (my $child = $node->getFirstChild(); $child;
|
134
|
|
|
|
|
|
|
$child = $child->getNextSibling()) {
|
135
|
0
|
|
|
|
|
|
$source .= $self->ProcessNode($child);
|
136
|
|
|
|
|
|
|
}
|
137
|
0
|
|
|
|
|
|
$source;
|
138
|
|
|
|
|
|
|
} elsif ($type == XML::DOM::DOCUMENT_TYPE_NODE()) {
|
139
|
0
|
|
|
|
|
|
my $source = "";
|
140
|
0
|
|
|
|
|
|
for (my $child = $node->getFirstChild(); $child;
|
141
|
|
|
|
|
|
|
$child = $child->getNextSibling()) {
|
142
|
0
|
|
|
|
|
|
$source .= $self->ProcessNode($child);
|
143
|
|
|
|
|
|
|
}
|
144
|
0
|
|
|
|
|
|
$source;
|
145
|
|
|
|
|
|
|
} elsif ($type == XML::DOM::NOTATION_NODE()) {
|
146
|
0
|
|
|
|
|
|
'$document->addNotation(' .
|
147
|
|
|
|
|
|
|
$self->QuoteString($node->getName()) . ", " .
|
148
|
|
|
|
|
|
|
$self->QuoteString($node->getBase()) . ", " .
|
149
|
|
|
|
|
|
|
$self->QuoteString($node->getSysId()) . ", " .
|
150
|
|
|
|
|
|
|
$self->QuoteString($node->getPubId()) . ");\n";
|
151
|
|
|
|
|
|
|
} else {
|
152
|
0
|
|
|
|
|
|
die("Failed to compile document: Unknown node type $type (",
|
153
|
|
|
|
|
|
|
ref($node), ")");
|
154
|
|
|
|
|
|
|
}
|
155
|
|
|
|
|
|
|
}
|
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
sub QuoteString {
|
158
|
0
|
|
|
0
|
0
|
|
my $self = shift; my $str = shift;
|
|
0
|
|
|
|
|
|
|
159
|
0
|
|
|
|
|
|
"\"" . quotemeta($str) . "\"";
|
160
|
|
|
|
|
|
|
}
|
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
1;
|