File Coverage

blib/lib/XML/Invisible.pm

Criterion	Covered	Total	%
statement	100	119	84.0
branch	48	68	70.5
condition	11	16	68.7
subroutine	14	15	93.3
pod	3	3	100.0
total	176	221	79.6

package XML::Invisible;

use strict;
use warnings;
use Exporter qw(import);
use Pegex::Grammar;
use Pegex::Parser;
use XML::Invisible::Receiver;

our $VERSION = '0.07';
our @EXPORT_OK = qw(make_parser ast2xml make_canonicaliser);

use constant DEBUG => $ENV{XML_INVISIBLE_DEBUG};

sub make_parser {
  my ($grammar) = @_;
  $grammar = Pegex::Grammar->new(text => $grammar) if !ref $grammar;
  my $parser = Pegex::Parser->new(
    grammar => $grammar,
    receiver => XML::Invisible::Receiver->new,
    debug => DEBUG,
  );
  sub {
    my ($ixml_text) = @_;
    $parser->parse($ixml_text);
  };
}

sub make_canonicaliser {
  my ($grammar_text) = @_;
  require Pegex::Compiler;
  require Pegex::Grammar::Atoms;
  my $grammar_tree = Pegex::Compiler->new->parse($grammar_text)->tree;
  my $toprule = $grammar_tree->{'+toprule'};
  my $atoms = _atoms2canonical(Pegex::Grammar::Atoms->atoms);
  sub {
    my ($ast) = @_;
    my @results = _extract_canonical($atoms, $ast, $grammar_tree, $toprule);
    return undef if grep !defined, @results;
    join '', @results;
  };
}

my %ATOM2SPECIAL = (
  ALL => "",
  BLANK => " ",
  BREAK => "\n",
  BS => "\x08",
  CONTROL => "\x00",
  CR => "\r",
  DOS => "\r\n",
  EOL => "\n",
  EOS => "",
  FF => "\x0C",
  HICHAR => "\x7f",
  NL => "\n",
  TAB => "\t",
  WORD => "a",
  WS => " ",
  _ => "",
  __ => " ",
  ws => "",
  ws1 => "",
  ws2 => " ",
);
sub _atoms2canonical {
  my ($atoms) = @_;
  my %lookup;
  for my $atom (keys %$atoms) {
    my $c = $atoms->{$atom};
    if (exists $ATOM2SPECIAL{$atom}) {
      $c = $ATOM2SPECIAL{$atom};
    } elsif ($c =~ s/^\\//) {
      # all good
    } elsif ($c =~ s/^\[//) {
      $c = substr $c, 0, 1;
    }
    $lookup{$atom} = $c;
  }
  \%lookup;
}

sub _extract_canonical {
  my ($atoms, $elt, $grammar_tree, $elt_sought, $grammar_frag, $attrs) = @_;
  $grammar_frag ||= $grammar_tree->{$elt_sought};
  $attrs ||= {};
  $attrs = { %$attrs, %{ $elt->{attributes} || {} } } if ref $elt;
  if (defined($elt)) {
    return $elt if !ref $elt; # just text node - trust here for good reason
    return undef if defined($elt_sought) and $elt_sought ne $elt->{nodename};
  } else {
    if (defined($elt_sought) and defined(my $value = $attrs->{$elt_sought})) {
      return $value;
    }
  }
  if (my $rgx = $grammar_frag->{'.rgx'}) {
    # RE, so parent of text nodes
    if (defined $elt) {
      return join('', @{$elt->{children}}) if $elt->{children};
      return $elt->{nodename};
    }
    # or just a bare regex, which is a literal "canonical" representation
    return undef if $rgx =~ /^\(/; # out of our league
    $rgx =~ s#\\##g;
    return $rgx;
  }
  if (my $all = $grammar_frag->{'.all'}) {
    # sequence of productions
    my ($childcount, @results) = (0);
    for my $i (0..$#$all) {
      my $child = $elt->{children}[$childcount];
      my $all_frag = $all->[$i];
      my $new_elt_sought = undef;
      if ($all_frag->{'-skip'}) {
        $child = undef;
      } elsif ($all_frag->{'-wrap'}) {
        $child = undef;
        $new_elt_sought = $all_frag->{'.ref'};
      } else {
        $childcount++;
      }
      my @partial = _extract_canonical(
        $atoms, $child, $grammar_tree, $new_elt_sought, $all_frag, $attrs,
      );
      return undef if grep !defined, @partial; # any non-match
      push @results, @partial;
    }
    return @results;
  } elsif (my $ref = $grammar_frag->{'.ref'}) {
    return $atoms->{$ref} if exists $atoms->{$ref};
    return undef if defined($elt) and $elt->{nodename} ne $ref;
    my $new_frag = $grammar_tree->{$ref};
    if (my $new_ref = $new_frag->{'.ref'}) {
      my $child;
      my $new_attrs = { %$attrs };
      if (!defined($elt)) {
        $child = undef;
      } elsif ($elt->{children}) {
        return undef if @{$elt->{children}} != 1;
        $child = $elt->{children}[0];
      } elsif ($new_frag->{'-wrap'}) {
        $new_attrs = { %$new_attrs, %{ $elt->{attributes} } };
      }
      return _extract_canonical(
        $atoms, $child, $grammar_tree, $new_ref, $new_frag, $new_attrs,
      );
    }
    # treat ourselves as if we're the ref-ed to thing
    return _extract_canonical(
      $atoms, $elt, $grammar_tree, $ref, $new_frag, $attrs,
    );
  } elsif (my $any = $grammar_frag->{'.any'}) {
    # choice, pick first successful
    for my $i (0..$#$any) {
      my $any_frag = $any->[$i];
      my @partial = _extract_canonical(
        $atoms, $elt, $grammar_tree,
        (defined($elt) ? $elt->{nodename} : $elt),
        $any_frag, $attrs,
      );
      next if grep !defined, @partial; # any non-match
      return @partial;
    }
    return undef;
  }
}

my $xml_loaded = 0;
sub ast2xml {
  do { require XML::LibXML; $xml_loaded = 1 } unless $xml_loaded;
  my ($ast) = @_;
  my $doc = XML::LibXML->createDocument("1.0", "UTF-8");
  $doc->addChild(_item2elt($ast));
  $doc;
}

sub _item2elt {
  my ($item) = @_;
  die "Unknown item '$item' passed" if ref $item ne 'HASH';
  my $elt = XML::LibXML::Element->new($item->{nodename});
  my $attrs = $item->{attributes} || {};
  $elt->setAttribute($_, $attrs->{$_}) for keys %$attrs;
  for (@{ $item->{children} || [] }) {
    if (!ref) {
      $elt->appendTextNode($_);
    } else {
      $elt->addChild(_item2elt($_));
    }
  }
  $elt;
}

1;

__END__