line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package XML::Tags; |
2
|
|
|
|
|
|
|
|
3
|
2
|
|
|
2
|
|
22289
|
use strict; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
64
|
|
4
|
2
|
|
|
2
|
|
7
|
use warnings FATAL => 'all'; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
68
|
|
5
|
|
|
|
|
|
|
|
6
|
2
|
|
|
2
|
|
8
|
use File::Glob (); |
|
2
|
|
|
|
|
7
|
|
|
2
|
|
|
|
|
751
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
require overload; |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
my $IN_SCOPE = 0; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
sub import { |
13
|
11
|
50
|
|
11
|
|
118
|
die "Can't import XML::Tags into a scope when already compiling one that uses it" |
14
|
|
|
|
|
|
|
if $IN_SCOPE; |
15
|
11
|
|
|
|
|
77
|
my ($class, @args) = @_; |
16
|
11
|
100
|
|
|
|
30
|
my $opts = shift(@args) if ref($args[0]) eq 'HASH'; |
17
|
11
|
|
|
|
|
29
|
my $target = $class->_find_target(0, $opts); |
18
|
11
|
|
|
|
|
26
|
my @tags = $class->_find_tags(@args); |
19
|
11
|
|
|
|
|
47
|
my $unex = $class->_export_tags_into($target => @tags); |
20
|
11
|
50
|
|
|
|
36
|
if ($INC{"bareword/filehandles.pm"}) { bareword::filehandles->import } |
|
0
|
|
|
|
|
0
|
|
21
|
11
|
|
|
|
|
39
|
$class->_install_unexporter($unex); |
22
|
11
|
|
|
|
|
237
|
$IN_SCOPE = 1; |
23
|
|
|
|
|
|
|
} |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
sub to_xml_string { |
26
|
|
|
|
|
|
|
map { # string == text -> HTML, scalarref == raw HTML, other == passthrough |
27
|
25
|
|
|
25
|
0
|
24
|
ref($_) |
28
|
|
|
|
|
|
|
? (ref $_ eq 'SCALAR' ? $$_ : $_) |
29
|
48
|
100
|
|
|
|
195
|
: do { local $_ = $_; # copy |
|
5
|
100
|
|
|
|
4
|
|
30
|
5
|
50
|
|
|
|
7
|
if (defined) { |
31
|
5
|
|
|
|
|
12
|
s/&/&/g; s/"/"/g; s/</g; s/>/>/g; $_; |
|
5
|
|
|
|
|
4
|
|
|
5
|
|
|
|
|
7
|
|
|
5
|
|
|
|
|
6
|
|
|
5
|
|
|
|
|
5
|
|
32
|
|
|
|
|
|
|
} else { |
33
|
0
|
|
|
|
|
0
|
'' |
34
|
|
|
|
|
|
|
} |
35
|
|
|
|
|
|
|
} |
36
|
|
|
|
|
|
|
} @_ |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
11
|
|
|
11
|
|
13
|
sub _find_tags { shift; @_ } |
|
11
|
|
|
|
|
137
|
|
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
sub _find_target { |
42
|
11
|
|
|
11
|
|
16
|
my ($class, $extra_levels, $opts) = @_; |
43
|
11
|
50
|
|
|
|
27
|
return $opts->{into} if defined($opts->{into}); |
44
|
11
|
|
100
|
|
|
36
|
my $level = ($opts->{into_level} || 1) + $extra_levels; |
45
|
11
|
|
|
|
|
72
|
return (caller($level))[0]; |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
sub _set_glob { |
49
|
|
|
|
|
|
|
# stupid insanity. delete anything already there so we disassociated |
50
|
|
|
|
|
|
|
# the *CORE::GLOBAL::glob typeglob. Then the string reference call |
51
|
|
|
|
|
|
|
# revivifies it - i.e. creates us a new glob, which we get a reference |
52
|
|
|
|
|
|
|
# to, which we can then assign to. |
53
|
|
|
|
|
|
|
# doing it without the quotes doesn't - it binds to the version in scope |
54
|
|
|
|
|
|
|
# at compile time, which means after a delete you get a nice warm segv. |
55
|
22
|
|
|
22
|
|
49
|
delete ${CORE::GLOBAL::}{glob}; |
56
|
2
|
|
|
2
|
|
10
|
no strict 'refs'; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
169
|
|
57
|
22
|
|
|
|
|
23
|
*{'CORE::GLOBAL::glob'} = $_[0]; |
|
22
|
|
|
|
|
90
|
|
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub _export_tags_into { |
61
|
11
|
|
|
11
|
|
74
|
my ($class, $into, @tags) = @_; |
62
|
11
|
|
|
|
|
16
|
foreach my $tag (@tags) { |
63
|
2
|
|
|
2
|
|
9
|
no strict 'refs'; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
306
|
|
64
|
624
|
|
|
|
|
501
|
tie *{"${into}::${tag}"}, 'XML::Tags::TIEHANDLE', \"<${tag}>"; |
|
624
|
|
|
|
|
3389
|
|
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
_set_glob(sub { |
67
|
15
|
|
|
15
|
|
16
|
local $XML::Tags::StringThing::IN_GLOBBERY = 1; |
68
|
15
|
|
|
|
|
19
|
\('<'."$_[0]".'>'); |
69
|
11
|
|
|
|
|
53
|
}); |
70
|
11
|
|
|
43
|
|
50
|
overload::constant(q => sub { XML::Tags::StringThing->from_constant(@_) }); |
|
43
|
|
|
|
|
90
|
|
71
|
|
|
|
|
|
|
return sub { |
72
|
11
|
|
|
11
|
|
16
|
foreach my $tag (@tags) { |
73
|
2
|
|
|
2
|
|
9
|
no strict 'refs'; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
560
|
|
74
|
624
|
|
|
|
|
405
|
delete ${"${into}::"}{$tag} |
|
624
|
|
|
|
|
1243
|
|
75
|
|
|
|
|
|
|
} |
76
|
11
|
|
|
|
|
26
|
_set_glob(\&File::Glob::csh_glob); |
77
|
11
|
|
|
|
|
1126
|
overload::remove_constant('q'); |
78
|
11
|
|
|
|
|
86
|
$IN_SCOPE = 0; |
79
|
11
|
|
|
|
|
266
|
}; |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
sub _install_unexporter { |
83
|
11
|
|
|
11
|
|
14
|
my ($class, $unex) = @_; |
84
|
11
|
|
|
|
|
19
|
$^H |= 0x20000; # localize %^H |
85
|
11
|
|
|
|
|
64
|
$^H{'XML::Tags::Unex'} = bless($unex, 'XML::Tags::Unex'); |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
package XML::Tags::TIEHANDLE; |
89
|
|
|
|
|
|
|
|
90
|
624
|
|
|
624
|
|
541
|
sub TIEHANDLE { my $str = $_[1]; bless \$str, $_[0] } |
|
624
|
|
|
|
|
1244
|
|
91
|
10
|
|
|
10
|
|
19
|
sub READLINE { ${$_[0]} } |
|
10
|
|
|
|
|
33
|
|
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
package XML::Tags::Unex; |
94
|
|
|
|
|
|
|
|
95
|
11
|
50
|
|
11
|
|
13
|
sub DESTROY { local $@; eval { $_[0]->(); 1 } || warn "ARGH: $@" } |
|
11
|
|
|
|
|
14
|
|
|
11
|
|
|
|
|
30
|
|
|
11
|
|
|
|
|
2020
|
|
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
package XML::Tags::StringThing; |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
use overload ( |
100
|
2
|
|
|
|
|
11
|
'.' => 'concat', |
101
|
|
|
|
|
|
|
'""' => 'stringify', |
102
|
|
|
|
|
|
|
fallback => 1 |
103
|
2
|
|
|
2
|
|
1381
|
); |
|
2
|
|
|
|
|
1211
|
|
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
sub stringify { |
106
|
|
|
|
|
|
|
join( |
107
|
|
|
|
|
|
|
'', |
108
|
|
|
|
|
|
|
((our $IN_GLOBBERY) |
109
|
16
|
|
|
|
|
24
|
? XML::Tags::to_xml_string(@{$_[0]}) |
110
|
17
|
50
|
|
17
|
|
23
|
: (map +(ref $_ ? $$_ : $_), @{$_[0]}) |
|
1
|
100
|
|
|
|
10
|
|
111
|
|
|
|
|
|
|
) |
112
|
|
|
|
|
|
|
); |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
sub from_constant { |
116
|
43
|
|
|
43
|
|
63
|
my ($class, $initial, $parsed, $type) = @_; |
117
|
43
|
100
|
|
|
|
205
|
return $parsed unless $type eq 'qq'; |
118
|
33
|
|
|
|
|
38
|
return $class->new($parsed); |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
sub new { |
122
|
33
|
|
|
33
|
|
39
|
my ($class, $string) = @_; |
123
|
33
|
|
|
|
|
440
|
bless([ \$string ], $class); |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
sub concat { |
127
|
2
|
|
|
2
|
|
3
|
my ($self, $other, $rev) = @_; |
128
|
2
|
|
|
|
|
2
|
my @extra = do { |
129
|
2
|
50
|
66
|
|
|
9
|
if (ref($other) && ($other =~ /[a-z]=[A-Z]/) && $other->isa(__PACKAGE__)) { |
|
|
|
33
|
|
|
|
|
130
|
0
|
|
|
|
|
0
|
@{$other} |
|
0
|
|
|
|
|
0
|
|
131
|
|
|
|
|
|
|
} else { |
132
|
2
|
|
|
|
|
5
|
$other; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
}; |
135
|
2
|
|
|
|
|
1
|
my @new = @{$self}; |
|
2
|
|
|
|
|
4
|
|
136
|
2
|
50
|
|
|
|
5
|
$rev ? unshift(@new, @extra) : push(@new, @extra); |
137
|
2
|
|
|
|
|
11
|
bless(\@new, ref($self)); |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
1; |