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); |
cb5717ef |
17 | $class->_setup_glob_override; |
afe60e53 |
18 | my $unex = $class->_export_tags_into($target => @tags); |
19 | $class->_install_unexporter($unex); |
20 | $IN_SCOPE = 1; |
21 | } |
22 | |
cc050137 |
23 | sub sanitize { |
24 | map { # string == text -> HTML, scalarref == raw HTML, other == passthrough |
25 | ref($_) |
26 | ? (ref $_ eq 'SCALAR' ? $$_ : $_) |
27 | : do { local $_ = $_; # copy |
28 | s/&/&/g; s/"/"/g; s/</</g; s/>/>/g; $_; |
29 | } |
30 | } @_ |
31 | } |
32 | |
43a70ddb |
33 | sub _glob_glob { eval '\*CORE::GLOBAL::glob' } |
34 | |
afe60e53 |
35 | sub _find_tags { shift; @_ } |
36 | |
37 | sub _find_target { |
38 | my ($class, $extra_levels, $opts) = @_; |
39 | return $opts->{into} if defined($opts->{into}); |
40 | my $level = ($opts->{into_level} || 1) + $extra_levels; |
41 | return (caller($level))[0]; |
42 | } |
43 | |
43a70ddb |
44 | sub _setup_glob_override { |
45 | no warnings 'redefine'; |
46 | delete ${CORE::GLOBAL::}{glob}; |
47 | *{_glob_glob()} = sub { |
48 | return \('<'.$_[0].'>'); |
49 | }; |
afe60e53 |
50 | } |
51 | |
52 | sub _export_tags_into { |
53 | my ($class, $into, @tags) = @_; |
54 | foreach my $tag (@tags) { |
55 | no strict 'refs'; |
5f44889f |
56 | tie *{"${into}::${tag}"}, 'XML::Tags::TIEHANDLE', \"<${tag}>"; |
afe60e53 |
57 | } |
afe60e53 |
58 | return sub { |
59 | foreach my $tag (@tags) { |
60 | no strict 'refs'; |
61 | delete ${"${into}::"}{$tag} |
62 | } |
43a70ddb |
63 | delete ${CORE::GLOBAL::}{glob}; |
64 | *{_glob_glob()} = \&File::Glob::glob; |
afe60e53 |
65 | $IN_SCOPE = 0; |
66 | }; |
67 | } |
68 | |
69 | sub _install_unexporter { |
70 | my ($class, $unex) = @_; |
71 | $^H |= 0x120000; # localize %^H |
72 | $^H{'XML::Tags::Unex'} = bless($unex, 'XML::Tags::Unex'); |
73 | } |
74 | |
75 | package XML::Tags::TIEHANDLE; |
76 | |
77 | sub TIEHANDLE { my $str = $_[1]; bless \$str, $_[0] } |
78 | sub READLINE { ${$_[0]} } |
79 | |
80 | package XML::Tags::Unex; |
81 | |
82 | sub DESTROY { local $@; eval { $_[0]->(); 1 } || warn "ARGH: $@" } |
83 | |
84 | 1; |