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