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 | |
afe60e53 |
33 | sub _find_tags { shift; @_ } |
34 | |
35 | sub _find_target { |
36 | my ($class, $extra_levels, $opts) = @_; |
37 | return $opts->{into} if defined($opts->{into}); |
38 | my $level = ($opts->{into_level} || 1) + $extra_levels; |
39 | return (caller($level))[0]; |
40 | } |
41 | |
42 | { |
43 | my $setup; |
44 | |
45 | sub _setup_glob_override { |
46 | return if $setup; |
47 | $setup = 1; |
48 | no warnings 'redefine'; |
49 | *CORE::GLOBAL::glob = sub { |
50 | for ($_[0]) { |
51 | # unless it smells like </foo> or <foo bar="baz"> |
cb5717ef |
52 | return File::Glob::glob($_[0]) unless (/^\/\w+$/ || /^\w+\s+\w+="/); |
afe60e53 |
53 | } |
5f44889f |
54 | return \('<'.$_[0].'>'); |
afe60e53 |
55 | }; |
56 | } |
57 | } |
58 | |
59 | sub _export_tags_into { |
60 | my ($class, $into, @tags) = @_; |
61 | foreach my $tag (@tags) { |
62 | no strict 'refs'; |
5f44889f |
63 | tie *{"${into}::${tag}"}, 'XML::Tags::TIEHANDLE', \"<${tag}>"; |
afe60e53 |
64 | } |
afe60e53 |
65 | return sub { |
66 | foreach my $tag (@tags) { |
67 | no strict 'refs'; |
68 | delete ${"${into}::"}{$tag} |
69 | } |
70 | $IN_SCOPE = 0; |
71 | }; |
72 | } |
73 | |
74 | sub _install_unexporter { |
75 | my ($class, $unex) = @_; |
76 | $^H |= 0x120000; # localize %^H |
77 | $^H{'XML::Tags::Unex'} = bless($unex, 'XML::Tags::Unex'); |
78 | } |
79 | |
80 | package XML::Tags::TIEHANDLE; |
81 | |
82 | sub TIEHANDLE { my $str = $_[1]; bless \$str, $_[0] } |
83 | sub READLINE { ${$_[0]} } |
84 | |
85 | package XML::Tags::Unex; |
86 | |
87 | sub DESTROY { local $@; eval { $_[0]->(); 1 } || warn "ARGH: $@" } |
88 | |
89 | 1; |