lib/XML/Tags.pm

   1 package XML::Tags;
   2
   3 use strict;
   4 use warnings FATAL => 'all';
   5
   6 use File::Glob ();
   7
   8 require overload;
   9
  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
  24 sub to_xml_string {
  25   map { # string == text -> HTML, scalarref == raw HTML, other == passthrough
  26     ref($_)
  27       ? (ref $_ eq 'SCALAR' ? $$_ : $_)
  28       : do { local $_ = $_; # copy
  29           if (defined) {
  30             s/&/&amp;/g; s/"/&quot;/g; s/</&lt;/g; s/>/&gt;/g; $_;
  31           } else {
  32             ''
  33           }
  34         }
  35   } @_
  36 }
  37
  38 sub to_zoom_events {
  39   my @events;
  40   while(my $raw = shift) {
  41     my $normalized_raw = ref $raw ? (ref $raw eq 'SCALAR' ? $$raw: "$raw") : $raw;
  42     my @info = (
  43       $normalized_raw =~m{
  44         (
  45           (?:[^<]*) < (?:
  46               ( / )? ( [^/!<>\s"'=]+ )
  47               ( (?:"[^"]*"|'[^']*'|[^"'<>])+? )?
  48           |
  49               (!-- .*? -- | ![^\-] .*? )
  50           ) (\s*/\s*)? >
  51         )
  52         ([^<]*)
  53       }x
  54     );
  55
  56     my (
  57       $whole,
  58       $is_close,
  59       $tag_name,
  60       $attrs,
  61       $comment_or_directive,
  62       $in_place_close
  63     ) = @info;
  64
  65     if($comment_or_directive) {
  66       if($events[-1] && $events[-1]->{type} eq 'SPECIAL') {
  67         $events[-1]->{raw} .= $normalized_raw;
  68       } else {
  69         push @events, { type => 'SPECIAL', raw => $normalized_raw };
  70       }
  71     } elsif(!scalar(@info)) {
  72       if($events[-1] && $events[-1]->{type} eq 'TEXT') {
  73         $events[-1]->{raw} .= $normalized_raw;
  74       } elsif(ref $raw && ref $raw eq 'SCALAR' && $events[-1] && $events[-1]->{type} eq 'SPECIAL') {
  75         $events[-1]->{raw} .= $normalized_raw;
  76       } elsif(ref $raw && ref $raw eq 'SCALAR') {
  77         push @events, { type => 'SPECIAL', raw => $normalized_raw };
  78       }
  79       else {
  80         push @events, { type => 'TEXT', raw => $normalized_raw };
  81       }
  82     } else {
  83       if($is_close) {
  84         $tag_name =~ tr/A-Z/a-z/;
  85         push @events, { type => 'CLOSE', name => $tag_name, raw => $normalized_raw};
  86       } else {
  87         $attrs = '' if !defined($attrs) or $attrs =~ /^ +$/;
  88         push @events, {
  89           type => 'OPEN',
  90           name => $tag_name,
  91           is_in_place_close => $in_place_close,
  92           HTML::Zoom::Parser::BuiltIn::_hacky_attribute_parser($attrs),
  93           raw_attrs => $attrs||'',
  94           raw => $whole,
  95         };
  96         if($in_place_close) {
  97           push @events, {
  98             type => 'CLOSE',
  99             name => $tag_name,
 100             raw => '',
 101             is_in_place_close => 1,
 102           }
 103         }
 104       }
 105     }
 106   }
 107   return @events;
 108 }
 109
 110 sub _find_tags { shift; @_ }
 111
 112 sub _find_target {
 113   my ($class, $extra_levels, $opts) = @_;
 114   return $opts->{into} if defined($opts->{into});
 115   my $level = ($opts->{into_level} || 1) + $extra_levels;
 116   return (caller($level))[0];
 117 }
 118
 119 sub _set_glob {
 120   # stupid insanity. delete anything already there so we disassociated
 121   # the *CORE::GLOBAL::glob typeglob. Then the string reference call
 122   # revivifies it - i.e. creates us a new glob, which we get a reference
 123   # to, which we can then assign to.
 124   # doing it without the quotes doesn't - it binds to the version in scope
 125   # at compile time, which means after a delete you get a nice warm segv.
 126   delete ${CORE::GLOBAL::}{glob};
 127   no strict 'refs';
 128   *{'CORE::GLOBAL::glob'} = $_[0];
 129 }
 130
 131 sub _export_tags_into {
 132   my ($class, $into, @tags) = @_;
 133   foreach my $tag (@tags) {
 134     no strict 'refs';
 135     tie *{"${into}::${tag}"}, 'XML::Tags::TIEHANDLE', \"<${tag}>";
 136   }
 137   _set_glob(sub {
 138     local $XML::Tags::StringThing::IN_GLOBBERY = 1;
 139     \('<'."$_[0]".'>');
 140   });
 141   overload::constant(q => sub { XML::Tags::StringThing->from_constant(@_) });
 142   return sub {
 143     foreach my $tag (@tags) {
 144       no strict 'refs';
 145       delete ${"${into}::"}{$tag}
 146     }
 147     _set_glob(\&File::Glob::glob);
 148     overload::remove_constant('q');
 149     $IN_SCOPE = 0;
 150   };
 151 }
 152
 153 sub _install_unexporter {
 154   my ($class, $unex) = @_;
 155   $^H |= 0x120000; # localize %^H
 156   $^H{'XML::Tags::Unex'} = bless($unex, 'XML::Tags::Unex');
 157 }
 158
 159 package XML::Tags::TIEHANDLE;
 160
 161 sub TIEHANDLE { my $str = $_[1]; bless \$str, $_[0] }
 162 sub READLINE { ${$_[0]} }
 163
 164 package XML::Tags::Unex;
 165
 166 sub DESTROY { local $@; eval { $_[0]->(); 1 } || warn "ARGH: $@" }
 167
 168 package XML::Tags::StringThing;
 169
 170 use overload (
 171   '.' => 'concat',
 172   '""' => 'stringify',
 173   fallback => 1
 174 );
 175
 176 sub stringify {
 177   join(
 178     '',
 179     ((our $IN_GLOBBERY)
 180       ? XML::Tags::to_xml_string(@{$_[0]})
 181       : (map +(ref $_ ? $$_ : $_), @{$_[0]})
 182     )
 183   );
 184 }
 185
 186 sub from_constant {
 187   my ($class, $initial, $parsed, $type) = @_;
 188   return $parsed unless $type eq 'qq';
 189   return $class->new($parsed);
 190 }
 191
 192 sub new {
 193   my ($class, $string) = @_;
 194   bless([ \$string ], $class);
 195 }
 196
 197 sub concat {
 198   my ($self, $other, $rev) = @_;
 199   my @extra = do {
 200     if (ref($other) && ($other =~ /[a-z]=[A-Z]/) && $other->isa(__PACKAGE__)) {
 201       @{$other}
 202     } else {
 203       $other;
 204     }
 205   };
 206   my @new = @{$self};
 207   $rev ? unshift(@new, @extra) : push(@new, @extra);
 208   bless(\@new, ref($self));
 209 }
 210
 211 1;