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