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