#

#

# TO DO

# - update docs regarding PerlSAX interface

# - add current node to error context when checking DOM subtrees

# - add parsed Entity to test XML files

# - free circular references

# - Implied handler?

# - Notation, Entity, Unparsed checks, Default handler?

# - check no root element (it's checked by expat) ?

package XML::Checker::Term;

use strict;

sub new     

{ 

    my ($class, %h) = @_;

    bless \%h, $class;

}

sub str     

{ 

    '<' . $_[0]->{C} . $_[0]->{N} . '>'

}

sub re

{ 

    $_[0]->{S} 

}

sub rel 

{ 

    my $self = shift;

    defined $self->{SL} ? @{ $self->{SL} } : ( $self->{S} );

}

sub debug

{

    my $t = shift;

    my ($c, $n, $s) = ($t->{C}, $t->{N}, $t->{S});

    my @sl = $t->rel;

    "{C=$c N=$n S=$s SL=@sl}";

}

#-------------------------------------------------------------------------

package XML::Checker::Context;

sub new

{

    my ($class) = @_;

    my $scalar;

    bless \$scalar, $class;

}

sub Start {}

sub End   {}

sub Char  {}

#

# The initial Context when checking an entire XML Document

#

package XML::Checker::DocContext;

use vars qw( @ISA );

@ISA = qw( XML::Checker::Context );

sub new

{

#??checker not used

    my ($class, $checker) = @_;

    bless { }, $class;

}

sub setRootElement

{

    $_[0]->{RootElement} = $_[1];

}

sub Start 

{

    my ($self, $checker, $tag) = @_;

    if (exists $self->{Elem})

    {

	my $tags = join (", ", @{$self->{Elem}});

	$checker->fail (155, "more than one root Element [$tags]");

	push @{$self->{Elem}}, $tag;

    }

    else

    {

	$self->{Elem} = [ $tag ];

    }

    my $exp_root = $self->{RootElement};

    $checker->fail (156, "unexpected root Element [$tag], expected [$exp_root]")

	if defined ($exp_root) and $tag ne $exp_root;

}

sub debug

{

    my $self = shift;

    "DocContext[Count=" . $self->{Count} . ",Root=" . 

	$self->{RootElement} . "]";

}

package XML::Checker::Context::ANY;

use vars qw( @ISA );

@ISA = qw( XML::Checker::Context );

# No overrides, because everything is accepted

sub debug { "XML::Checker::Context::ANY" }

package XML::Checker::Context::EMPTY;

use vars qw( @ISA $ALLOW_WHITE_SPACE );

@ISA = qw( XML::Checker::Context );

$ALLOW_WHITE_SPACE = 0;

sub debug { "XML::Checker::Context::EMPTY" }

sub Start

{

    my ($self, $checker, $tag) = @_;

    $checker->fail (152, "Element should be EMPTY, found Element [$tag]");

}

sub Char

{

    my ($self, $checker, $str) = @_;

    $checker->fail (153, "Element should be EMPTY, found text [$str]")

	unless ($ALLOW_WHITE_SPACE and $checker->isWS ($str));

    # NOTE: if $ALLOW_WHITE_SPACE = 1, the isWS call does not only check

    # whether it is whitespace, but it also informs the checker that this 

    # might be insignificant whitespace

}

#?? what about Comments

package XML::Checker::Context::Children;

use vars qw( @ISA );

@ISA = qw( XML::Checker::Context );

sub new

{

    my ($class, $rule) = @_;

    bless { Name => $rule->{Name}, RE => $rule->{RE}, Buf => "", N => 0 }, $class;

}

sub phash

{

    my $href = shift;

    my $str = "";

    for (keys %$href)

    {

	$str .= ' ' if $str;

	$str .= $_ . '=' . $href->{$_};

    }

    $str;

}

sub debug

{

    my $self = shift;

    "Context::Children[Name=(" . phash ($self->{Name}) . ",N=" . $self->{N} .

	",RE=" . $self->{RE} . ",Buf=[" . $self->{Buf} . "]";

}

sub Start

{

    my ($self, $checker, $tag) = @_;

#print "Children.Start tag=$tag rule=$checker drule=" . $checker->debug . "\n";

    if (exists $self->{Name}->{$tag})

    {

#print "Buf=[".$self->{Buf}. "] tag=[" . $self->{Name}->{$tag}->{S} . "]\n";

	$self->{Buf} .= $self->{Name}->{$tag}->{S};

    }

    else

    {

	$checker->fail (157, "unexpected Element [$tag]", 

			ChildElementIndex => $self->{N})

    }

    $self->{N}++;

}

sub decode

{

    my ($self) = @_;

    my $re = $self->{RE};

    my $name = $self->{Name};

    my $buf = $self->{Buf};

    my %s = ();

    while (my ($key, $val) = each %$name)

    {

	$s{$val->{S}} = $key;

    }

    my ($len) = scalar (keys %$name);

    $len = length $len;

    my $dots = "[^()*+?]" x $len;

    $buf =~ s/($dots)/$s{$1} . ","/ge;

    chop $buf;

    $re =~ s/($dots)/"(" . $s{$1} . ")"/ge;

    "Found=[$buf] RE=[$re]"

}

sub End

{

    my ($self, $checker) = @_;

    my $re = $self->{RE};

#print "End " . $self->debug . "\n";

    $checker->fail (154, "bad order of Elements " . $self->decode)

	unless $self->{Buf} =~ /^$re$/;

}

sub Char

{

    my ($self, $checker, $str) = @_;

    # Inform the checker that this might be insignificant whitespace

    $checker->isWS ($str);

}

package XML::Checker::Context::Mixed;

use vars qw( @ISA );

@ISA = qw( XML::Checker::Context );

sub new

{

    my ($class, $rule) = @_;

    bless { Name => $rule->{Name}, N => 0 }, $class;

}

sub debug

{

    my $self = shift;

    "Context::Mixed[Name=" . $self->{Name} . ",N=" , $self->{N} . "]";

}

sub Start

{

    my ($self, $checker, $tag) = @_;

    $checker->fail (157, "unexpected Element [$tag]",

		    ChildElementIndex => $self->{N})

	unless exists $self->{Name}->{$tag};

    $self->{N}++;

}

package XML::Checker::ERule;

package XML::Checker::ERule::EMPTY;

use vars qw( @ISA );

@ISA = qw( XML::Checker::ERule );

sub new

{

    my ($class) = @_;

    bless {}, $class;

}

my $context = new XML::Checker::Context::EMPTY;

sub context { $context }	# share the context

sub debug { "EMPTY" }

package XML::Checker::ERule::ANY;

use vars qw( @ISA );

@ISA = qw( XML::Checker::ERule );

sub new

{

    my ($class) = @_;

    bless {}, $class;

}

my $any_context = new XML::Checker::Context::ANY;

sub context { $any_context }	# share the context

sub debug { "ANY" }

package XML::Checker::ERule::Mixed;

use vars qw( @ISA );

@ISA = qw( XML::Checker::ERule );

sub new

{

    my ($class) = @_;

    bless { Name => {} }, $class;

}

sub context 

{

    my ($self) = @_;

    new XML::Checker::Context::Mixed ($self);

}

sub setModel

{

    my ($self, $model) = @_;

    my $rule = $model;

    # Mixed := '(' '#PCDATA' ')' '*'?

    if ($rule =~ /^\(\s*#PCDATA\s*\)(\*)?$/)

    {

#? how do we interpret the '*' ??

         return 1;

    }

    else	# Mixed := '(' '#PCDATA' ('|' Name)* ')*'

    {

	return 0 unless $rule =~ s/^\(\s*#PCDATA\s*//;

	return 0 unless $rule =~ s/\s*\)\*$//;

	my %names = ();

	while ($rule =~ s/^\s*\|\s*($XML::RegExp::Name)//)

	{

	    $names{$1} = 1;

	}

	if ($rule eq "")

	{

	    $self->{Name} = \%names;

	    return 1;

	}

    }

    return 0;

}

sub debug

{

    my ($self) = @_;

    "Mixed[Names=" . join("|", keys %{$self->{Name}}) . "]";

}

package XML::Checker::ERule::Children;

use vars qw( @ISA %_name %_map $_n );

@ISA = qw( XML::Checker::ERule );

sub new

{

    my ($class) = @_;

    bless {}, $class;

}

sub context 

{

    my ($self) = @_;

    new XML::Checker::Context::Children ($self);

}

sub _add	# static

{

    my $exp = new XML::Checker::Term (@_);

    $_map{$exp->{N}} = $exp;

    $exp->str;

}

my $IDS = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789";

sub _tokenize

{

    my ($self, $rule) = @_;

    # Replace names with Terms of the form "<n#>", e.g. "<n2>".

    # Lookup already used names and store new names in %_name.

    # 

    $$rule =~ s/($XML::RegExp::Name)(?!>)/

	if (exists $_name{$1})		# name already used?

	{

	    $_name{$1}->str;

	}

        else

	{

	    my $exp = new XML::Checker::Term (C => 'n', N => $_n++, 

					      Name => $1);

	    $_name{$1} = $_map{$exp->{N}} = $exp;

	    $exp->str;

	}

    /eg;

    if ($_n < length $IDS)

    {

	# Generate regular expression for the name Term, i.e.

	# a single character from $IDS

	my $i = 0;

	for (values %_name)

	{

	    $_->{S} = substr ($IDS, $i++, 1);

#print "tokenized " . $_->{Name} . " num=" . $_->{N} . " to " . $_->{S} . "\n";

	}

    }

    else

    {

	# Generate RE, convert Term->{N} to hex string a la "(#)", 

	# e.g. "(03d)". Calculate needed length of hex string first.

	my $len = 1;

	for (my $n = $_n - 1; ($n >> 4) > 0; $len++) {}

	my $i = 0;

	for (values %_name)

	{

	    $_->{S} = sprintf ("(0${len}lx)", $i++);

#print "tokenized " . $_->{Name} . " num=" . $_->{N} . " to " . $_->{S} . "\n";

	}

    }

}

sub setModel

{

    my ($self, $rule) = @_;

    local $_n = 0;

    local %_map = ();

    local %_name = ();

    $self->_tokenize (\$rule);

#?? check for single name - die "!ELEMENT contents can't be just a NAME" if $rule =~ /^$XML::RegExp::Name$/;

    for ($rule)

    {

	my $n = 1;

	while ($n)

	{

	    $n = 0;

	    # cp := ( name | choice | seq ) ('?' | '*' | '+')?

	    $n++ while s/<[ncs](\d+)>([?*+]?)/_add

	    (C => 'a', N => $_n++, 

	     S => ($_map{$1}->re . $2))/eg;

	    # choice := '(' ch_l ')'

	    $n++ while s/\(\s*<[ad](\d+)>\s*\)/_add

	    (C => 'c', N => $_n++, 

	     S => "(" . join ("|", $_map{$1}->rel) . ")")/eg;

	    # ch_l := ( cp | ch_l ) '|' ( cp | ch_l )

	    $n++ while s/<[ad](\d+)>\s*\|\s*<[ad](\d+)>/_add

	    (C => 'd', N => $_n++, 

	     SL => [ $_map{$1}->rel, $_map{$2}->rel ])/eg;

	    # seq := '(' (seq_l ')'

	    $n++ while s/\(\s*<[at](\d+)>\s*\)/_add

	    (C => 's', N => $_n++, 

	     S => "(".join("", $_map{$1}->rel).")")/eg;

	    # seq_l := ( cp | seq_l ) ',' ( cp | seq_l )

	    $n++ while s/<[at](\d+)>\s*,\s*<[at](\d+)>/_add

	    (C => 't', N => $_n++, 

	     SL => [ $_map{$1}->rel, $_map{$2}->rel ])/eg;

	}

    }

    return 0 if ($rule !~ /^<a(\d+)>$/);

    $self->{Name} = \%_name;

    $self->{RE} = $_map{$1}->re;

    return 1;

}

sub debug

{

    my ($self) = @_;

    "Children[RE=" . $self->{RE} . "]";

}

package XML::Checker::ARule;

use XML::RegExp;

sub new

{

    my ($class, $elem, $checker) = @_;

    bless { Elem => $elem, Checker => $checker, Required => {} }, $class;

}

sub Attlist

{

    my ($self, $attr, $type, $default, $fixed, $checker) = @_;

    my ($c1, $c2);

    if ($self->{Defined}->{$attr})

    {

	my $tag = $self->{Elem};

	$self->fail ($attr, 110, "attribute [$attr] of element [$tag] already defined");

    }

    else

    {

	$self->{Defined}->{$attr} = 1;

    }

    if ($default =~ /^\#(REQUIRED|IMPLIED)$/)

    {

	$c1 = $1;

	# Keep list of all required attributes

	if ($default eq '#REQUIRED')

	{

	    $self->{Required}->{$attr} = 1;

	}

    }

    else

    {

	$self->fail ($attr, 122, "invalid default attribute value [$default]")

	    unless $default =~ /^$XML::RegExp::AttValue$/;

	$default = substr ($default, 1, length($default)-2);

	$self->{Default}->{$attr} = $default;

	$c1 = 'FIXED' if $fixed;

    }

    if ($type eq 'ID')

    {

	$self->fail ($attr, 123, "invalid default ID [$default], must be #REQUIRED or #IMPLIED")

	    unless $default =~ /^#(REQUIRED|IMPLIED)$/;

	if (exists ($self->{ID}) && $self->{ID} ne $attr)

	{

	    $self->fail ($attr, 151, "only one ID allowed per ELEMENT " .

			 "first=[" . $self->{ID} . "]");

	}

	else