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