Commit | Line | Data |
afe60e53 |
1 | package XML::Tags; |
2 | |
3 | use strict; |
4 | use warnings FATAL => 'all'; |
5 | |
cb5717ef |
6 | use File::Glob (); |
7 | |
afe60e53 |
8 | my $IN_SCOPE = 0; |
9 | |
10 | sub import { |
11 | die "Can't import XML::Tags into a scope when already compiling one that uses it" |
12 | if $IN_SCOPE; |
13 | my ($class, @args) = @_; |
14 | my $opts = shift(@args) if ref($args[0]) eq 'HASH'; |
15 | my $target = $class->_find_target(0, $opts); |
16 | my @tags = $class->_find_tags(@args); |
17 | my $unex = $class->_export_tags_into($target => @tags); |
18 | $class->_install_unexporter($unex); |
19 | $IN_SCOPE = 1; |
20 | } |
21 | |
cc050137 |
22 | sub sanitize { |
23 | map { # string == text -> HTML, scalarref == raw HTML, other == passthrough |
24 | ref($_) |
25 | ? (ref $_ eq 'SCALAR' ? $$_ : $_) |
26 | : do { local $_ = $_; # copy |
27 | s/&/&/g; s/"/"/g; s/</</g; s/>/>/g; $_; |
28 | } |
29 | } @_ |
30 | } |
31 | |
afe60e53 |
32 | sub _find_tags { shift; @_ } |
33 | |
34 | sub _find_target { |
35 | my ($class, $extra_levels, $opts) = @_; |
36 | return $opts->{into} if defined($opts->{into}); |
37 | my $level = ($opts->{into_level} || 1) + $extra_levels; |
38 | return (caller($level))[0]; |
39 | } |
40 | |
06e0b420 |
41 | sub _set_glob { |
43a70ddb |
42 | delete ${CORE::GLOBAL::}{glob}; |
06e0b420 |
43 | *{eval '\*CORE::GLOBAL::glob'} = $_[0]; |
afe60e53 |
44 | } |
45 | |
46 | sub _export_tags_into { |
47 | my ($class, $into, @tags) = @_; |
48 | foreach my $tag (@tags) { |
49 | no strict 'refs'; |
5f44889f |
50 | tie *{"${into}::${tag}"}, 'XML::Tags::TIEHANDLE', \"<${tag}>"; |
afe60e53 |
51 | } |
06e0b420 |
52 | _set_glob(sub { \('<'.$_[0].'>'); }); |
afe60e53 |
53 | return sub { |
54 | foreach my $tag (@tags) { |
55 | no strict 'refs'; |
56 | delete ${"${into}::"}{$tag} |
57 | } |
06e0b420 |
58 | _set_glob(\&File::Glob::glob); |
afe60e53 |
59 | $IN_SCOPE = 0; |
60 | }; |
61 | } |
62 | |
63 | sub _install_unexporter { |
64 | my ($class, $unex) = @_; |
65 | $^H |= 0x120000; # localize %^H |
66 | $^H{'XML::Tags::Unex'} = bless($unex, 'XML::Tags::Unex'); |
67 | } |
68 | |
69 | package XML::Tags::TIEHANDLE; |
70 | |
71 | sub TIEHANDLE { my $str = $_[1]; bless \$str, $_[0] } |
72 | sub READLINE { ${$_[0]} } |
73 | |
74 | package XML::Tags::Unex; |
75 | |
76 | sub DESTROY { local $@; eval { $_[0]->(); 1 } || warn "ARGH: $@" } |
77 | |
78 | 1; |