File Coverage

blib/lib/XML/Simple/DTDReader.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

#!/usr/bin/perl -w -- -*-cperl-*-
package XML::Simple::DTDReader;
use strict;
use warnings;

use XML::Parser;
use Carp;
use Cwd;
use File::Basename;
use Data::Dumper;

use vars qw($VERSION @ISA @EXPORT);

$VERSION = '0.04';

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(XMLin);

sub new {
  my ($class,%opts) = @_;
  my $self = {%opts};
  my %h =
    (
     Doctype    => sub {$self->Doctype(@_)},
     DoctypeFin => sub {$self->DoctypeFin(@_)},
     Element    => sub {$self->Element(@_)},
     Attlist    => sub {$self->Attlist(@_)},
     Start      => sub {$self->Start(@_)},
     End        => sub {$self->End(@_)},
     Char       => sub {$self->Char(@_)},
    );
  $self->{Handlers} = \%h;
  return bless $self, $class;
}

sub XMLin {
  my $self;
  if(@_ and $_[0] and  UNIVERSAL::isa($_[0], __PACKAGE__)) {
    $self = shift;
  } else {
    $self = __PACKAGE__->new;
  }

  my ($source) = @_;

  $self->{DTD} = undef;
  $self->{Data} = {};
  $self->{Element} = [$self->{Data}];
  $self->{Expected} = undef;
  $self->{Parser} = XML::Parser->new(
				     Handlers => $self->{Handlers},
				     ParseParamEnt => 1,
				    );
  if (not defined $source) {
    my($base, $path) = File::Basename::fileparse($0, '\.[^\.]+');
    $source = "$base.xml";
    my $cwd = getcwd();
    chdir $path;
    open(XML, $source) or croak "Can't open $source: $!";
    $Carp::CarpLevel = 2;
    eval {
      $self->{Parser}->parse(*XML);
    };
    chdir $cwd;
    die $@ if $@;
    close(XML) or croak "Can't close $source: $!";
  } elsif ($source =~ /<.*>/ or UNIVERSAL::isa($source, "IO::Handle")) {
    $Carp::CarpLevel = 2;
    $self->{Parser}->parse($source);
  } elsif ($source eq "-") {
    local $/;
    $Carp::CarpLevel = 2;
    $self->{Parser}->parse();
  } else {
    open(XML, $source) or croak "Can't open $source: $!";
    my $cwd = getcwd();
    chdir dirname($source);
    $Carp::CarpLevel = 2;
    eval {
      $self->{Parser}->parse(*XML);
    };
    chdir $cwd;
    die $@ if $@;
    close(XML) or croak "Can't close $source: $!";
  }

  $self->{Data} = unref($self->{Data});
  return $self->{Data};
}

sub unref {
  if (ref $_[0] eq "ARRAY") {
    $_[0][$_] = unref($_[0][$_]) for (0..(@{$_[0]}-1));
    return $_[0];
  } elsif (ref $_[0] eq "HASH") {
    $_[0]{$_} = unref($_[0]{$_}) for keys %{$_[0]};
    return $_[0];
  } elsif (ref $_[0] eq "SCALAR") {
    return ${$_[0]};
  } else {
    return $_[0];
  }
}

sub Doctype {
  my $self = shift;
  my ($parser,$base) = @_;
  $self->{Expected} = $base;
}

sub DoctypeFin {
  local $Carp::CarpLevel = 3;
  my $self = shift;
  my $parser = shift;
  unless (defined $self->{DTD}{$self->{Expected}}) {
    croak "Your DTD claimed the root element would be '$self->{Expected}', but failed to define that element type."
  }
}

sub Element {
  local $Carp::CarpLevel = 3;
  my $self = shift;
  my $parser = shift;
  my ($name, $element) = @_;
  if ($element->ismixed and $element->asString ne "(#PCDATA)") {
    croak "XML::Simple::DTDReader cannot handle mixed content ('$name' tag)";
  } elsif ($element->isany) {
    croak "XML::Simple::DTDReader cannot handle 'ANY' content ('$name' tag)";
  }
  $self->{DTD}{$name}{Element} = $element;
}

sub Attlist {
  local $Carp::CarpLevel = 3;
  my $self = shift;
  my $parser = shift;
  $self->{DTD}{$_[0]}{Attlist}{$_[1]} = {type => $_[2], default => $_[3]};
}

sub choice {
  local $Carp::CarpLevel = 4;
  my ($element, $tag) = @_;
  if ($element->isname) {
    return $element->name eq $tag;
  } elsif ($element->isseq) {
    return choice(($element->children)[0],$tag);
  } elsif ($element->ischoice) {
    for ($element->children) {
      return 1 if choice($_,$tag);
    }
    return 0;
  } else {
    croak "XML::Simple::DTDReader cannot deal with mixed or ANY tags ($element)";
  }
}

sub Start {
  local $Carp::CarpLevel = 3;
  my $self = shift;
  croak "XML::Simple::DTDReader can only work on XML with a DTD" unless defined $self->{DTD};

  my($parser,$tag, %atts) = @_;
  unless ($parser->current_element) {
    # Top level element
    croak "Root element <$tag> and DTD <", $self->{Expected}, "> do not match" if $tag ne $self->{Expected};
    $self->{Expected} = [[$self->{DTD}{$self->{Expected}}{Element}]];
    return;
  }

  my $expected;
#  warn "\n\nSTART $tag\n";
 STACK: {
#    warn Dumper($self->{Expected});
    while (@{$self->{Expected}} and @{$self->{Expected}[0]} == 0) {
      shift @{$self->{Expected}};
    }
    croak "Unexpected element <$tag> found (column ".$parser->current_column.", line ".$parser->current_line.")" unless @{$self->{Expected}};
    $expected = shift @{$self->{Expected}[0]};
    if ($expected->isname) {
      if ($expected->name ne $tag) {
	redo STACK if $expected->quant and
	  ($expected->quant eq "?" or $expected->quant eq "*");
	croak "Unexpected element <$tag> (column ".$parser->current_column.", line ".$parser->current_line."), expecting <".$expected->name.">";
      } elsif ($expected->quant and
	       ($expected->quant eq "+" or $expected->quant eq "*")) {
	$expected->{Quant} = "*";
	unshift @{$self->{Expected}[0]}, $expected;
      }
    } elsif ($expected->ischoice) {
      for ($expected->children) {
	next unless choice($_,$tag);
        if ($expected->quant and
            ($expected->quant eq "+" or $expected->quant eq "*")) {
          $expected->{Quant} = "*";
          unshift @{$self->{Expected}[0]}, $expected;
        }
	unshift @{$self->{Expected}[0]}, $_;
	redo STACK;
      }
      redo STACK if $expected->quant and
        ($expected->quant eq "?" or $expected->quant eq "*");
      croak "Unexpected element $tag in ".Dumper($expected);
    } elsif ($expected->isseq) {
      unshift @{$self->{Expected}}, [$expected->children];
      redo STACK;
    } else {
      croak "XML::Simple::DTDReader cannot deal with mixed or ANY tags ($expected)";
    }
  }

  unless (defined $self->{DTD}{$tag}) {
    croak "Definition of element <$tag> (column ".$parser->current_column.", line ".$parser->current_line.") missing from DTD";
  }

  if ($self->{DTD}{$tag}{Element}->isseq) {
    unshift @{$self->{Expected}}, [$self->{DTD}{$tag}{Element}->children];
  } elsif ($self->{DTD}{$tag}{Element}->ischoice) {
    unshift @{$self->{Expected}[0]}, $self->{DTD}{$tag}{Element};
  }

  if ($self->{DTD}{$tag}{Attlist}) {
    for (keys %{$self->{DTD}{$tag}{Attlist}}) {
      croak "Element <$tag> (column ".$parser->current_column.", line ".$parser->current_line.") missing required attribute $_"
        if $self->{DTD}{$tag}{Attlist}{$_}{default} eq "#REQUIRED" and not defined $atts{$_};
    }
  }
  for (keys %atts) {
    croak "Attribute $_ on <$tag> (column ".$parser->current_column.", line ".$parser->current_line.")  missing from DTD"
      unless defined $self->{DTD}{$tag}{Attlist} and $self->{DTD}{$tag}{Attlist}{$_};
  }

  my $me = undef;
  if ($self->{DTD}{$tag}{Element}->children
      or keys %{$self->{DTD}{$tag}{Attlist} || {}}) {
    $me = {%atts};
  } elsif ($self->{DTD}{$tag}{Element}->isempty){
    $me = %atts ? {%atts} : \1;
  } else {
    my $m = "";
    $me = \$m;
  }

  if ($expected->quant and
      ($expected->quant eq "*" or $expected->quant eq "+")) {
    my @ids = grep {$self->{DTD}{$tag}{Attlist}{$_}{type} eq "ID"}
      keys %{$self->{DTD}{$tag}{Attlist}};
    if (@ids) {
      $self->{Element}[0]{$tag}{$atts{$_}} = $me
	for @ids;
    } else {
      push @{$self->{Element}[0]{$tag}}, $me;
    }
  } else {
    $self->{Element}[0]{$tag} = $me;
  }
  unshift @{$self->{Element}}, $me;
}

sub Char {
  local $Carp::CarpLevel = 3;
  my $self = shift;
  my($parser,$string) = @_;

  if (ref $self->{Element}[0] eq "SCALAR") {
    eval { ${$self->{Element}[0]} .= $string; };
    if ($@ =~ /read-only/) {
      carp "Character data '$string' (column ".$parser->current_column.", line ".$parser->current_line.") in EMPTY element ignored";
    }
  } elsif (ref $self->{Element}[0] eq "HASH" and not $self->{DTD}{$parser->current_element}{Element}->children) {
    $self->{Element}[0]{content} .= $string;
  } else {
    carp "Character data '$string' (column ".$parser->current_column.", line ".$parser->current_line.") ignored" if $string =~ /\S/;
  }
}

sub empty {
  my ($element) = @_;
  if ($element->isname) {
    return $element->quant and ($element->quant eq "*" or $element->quant eq "?");
  } elsif ($element->isseq) {
    for ($element->children) {
      return 0 unless empty($_);
    }
    return 1;
  } elsif ($element->ischoice) {
    for ($element->children) {
      return 1 if empty($_);
    }
    return 0;
  } else {
    croak "XML::Simple::DTDReader cannot deal with mixed or ANY tags ($element)";
  }
}

sub End {
  local $Carp::CarpLevel = 3;
  my $self = shift;
  my($parser,$tag) = @_;
  shift @{$self->{Element}};
  if ($self->{DTD}{$tag}{Element}->isseq) {
    my @blocking = grep {not empty($_)} @{$self->{Expected}[0]};
    if (@blocking) {
      croak "Unexpected end of element <$tag> found (column ".$parser->current_column.", line ".$parser->current_line."), expecting <", $blocking[0]->name, ">";
    }
    shift @{$self->{Expected}};
  }
}

__END__