XML::Checker - A perl module for validating XML

 # Using a local variable to temporarily override the fail handler (preferred)
 { # new block - start of local scope
   local $XML::Checker::FAIL = \&my_fail;
   ... your code here ...
 } # end of block - the previous fail handler is restored

 # Globally setting the fail handler (not recommended)
 $XML::Checker::FAIL = \&my_fail;
 ... rest of your code ...

 Element - tag name of Element node (if applicable)
 Attr - attribute name (if applicable)
 ChildElementIndex - if applicable (see error 157)
 line - only when parsing
 column - only when parsing
 byte - only when parsing (-1 means: end of file)

 # Don't print info messages
 sub my_fail
 {
     my $code = shift;
     print STDERR XML::Checker::error_message ($code, @_)
         if $code < 300;
 }

 # Die when the first error is encountered - this will stop
 # the parsing process. Ignore information messages.
 sub my_fail
 {
     my $code = shift;
     die XML::Checker::error_message ($code, @_) if $code < 300;
 }

 # Count the number of undefined NOTATION references
 # and print the error as usual
 sub my_fail
 {
     my $code = shift;
     $count_undef_notations++ if $code == 100;
     XML::Checker::print_error ($code, @_);
 }

 # Die when an error is encountered.
 # Don't die if a warning or info message is encountered, just print a message.
 sub my_fail {
     my $code = shift;
     die XML::Checker::error_string ($code, @_) if $code < 200;
     XML::Checker::print_error ($code, @_);
 }

  { # new block - start of local scope
    local $XML::Checker::INSIGNIF_WS = 0;
    ... insert your code here ...
  } # end of scope

 $checker->{RootElement} - root element name as found in the DOCTYPE
 $checker->{NOTATION}->{$notation} - is 1 if the NOTATION was defined
 $checker->{ENTITY}->{$name} - contains the (first) ENTITY value if defined
 $checker->{Unparsed}->{$entity} - is 1 if the unparsed ENTITY was defined
 $checker->{ID}->{$id} - is 1 if the ID was defined
 $checker->{IDREF}->{$id} - number of times the ID was referenced

 # Less useful:
 $checker->{ERule}->{$tag} - the ELEMENT rules by Element tag name
 $checker->{ARule}->{$tag} - the ATTLIST rules by Element tag name
 $checker->{Context} - context stack used internally
 $checker->{CurrARule} - current ATTLIST rule for the current Element

 $checker->Start($tagName);

use warnings;
use strict;
#
#
# 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};

    # length of token, in a content model all tokens are the same length
    my $len = 0;		
    my %s = ();
    while (my ($key, $val) = each %$name)
    {
      $len = length($val->{S}) unless $len;
      $s{$val->{S}} = $key;
    }
    # ex. $key = C_31 and $name = 01
    #use warnings;
    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};

    unless ( $self->{Buf} =~ /\S/ ) {
      unless ( $self->{Buf} =~ /^$re$/ ) {
	$checker->fail (170, "Element can't be empty " . $self->decode);
	return;
      }
    }
    unless ( $self->{Buf} =~ /^$re$/ ) {
      $checker->fail (154, "bad order of Elements " . $self->decode);
    }
}

sub Char
{
    my ($self, $checker, $str) = @_;
    $checker->fail (149, "Element should only contain sub elements, found text [$str]")
      unless ($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 
	# e.g. "03d". Calculate needed length of hex string first.
	my $len = 0;
	for (my $n = $_n - 1; $n > 0; $len++) {
	  $n = $n >> 4; 
	}
	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
	{
	    $self->{ID} = $attr;
	}
	$c2 = 'ID';
    }
    elsif ($type =~ /^(IDREF|IDREFS|ENTITY|ENTITIES|NMTOKEN|NMTOKENS)$/)
    {
	my $def = $self->{Default}->{$attr};
	if (defined $def)
	{
	    my $re = ($type =~ /^[IE]/) ? $XML::RegExp::Name : $XML::RegExp::NmToken;
	    if ($type =~ /S$/)
	    {
		for (split (/\s+/, $def))
		{
		    $self->fail ($attr, 121,
				 "invalid default [$_] in $type [$def]")
			unless $_ =~ /^$re$/;
		}
	    }
	    else	# singular
	    {
		$self->fail ($attr, 120, "invalid default $type [$def]")
			unless $def =~ /^$re$/;
	    }
	}
	$c2 = $type;
    }
    elsif ($type ne 'CDATA')	# Enumerated := NotationType | Enumeration
    {
	if ($type =~ /^\s*NOTATION\s*\(\s*($XML::RegExp::Name(\s*\|\s*$XML::RegExp::Name)*)\s*\)\s*$/)
	{
	    $self->fail ($attr, 135, "empty NOTATION list in ATTLIST")
		unless defined $1;

	    my @tok = split (/\s*\|\s*/, $1);
	    for (@tok)
	    {
		$self->fail ($attr, 100, "undefined NOTATION [$_] in ATTLIST")
			unless exists $checker->{NOTATION}->{$_};
	    }

	    my $re = join ("|", @tok);
	    $self->{NotationRE} = "^($re)\$";
	    $c2 = 'NotationType';
	}
	elsif ($type =~ /^\s*\(\s*($XML::RegExp::NmToken(\s*\|\s*$XML::RegExp::NmToken)*)\s*\)\s*$/)
	{
	    # Enumeration

	    $self->fail ($attr, 136, "empty Enumeration list in ATTLIST")
		    unless defined $1;

	    my @tok = split (/\s*\|\s*/, $1);
	    for (@tok)
	    {
		$self->fail ($attr, 134,
			     "invalid Enumeration value [$_] in ATTLIST")
		unless $_ =~ /^$XML::RegExp::NmToken$/;
	    }
	    $self->{EnumRE}->{$attr} = '^(' . join ("|", @tok) . ')$'; #';
	    $c2 = 'Enumeration';
	}
	else
	{
	    $self->fail ($attr, 137, "invalid ATTLIST type [$type]");
	}
    }

    $self->{Check1}->{$attr} = $c1 if $c1;
    $self->{Check2}->{$attr} = $c2 if $c2;
}

sub fail
{
    my $self = shift;
    my $attr = shift;
    $self->{Checker}->fail (@_, Element => $self->{Elem}, Attr => $attr);
}

sub check
{
    my ($self, $attr) = @_;
    my $func1 = $self->{Check1}->{$attr};
    my $func2 = $self->{Check2}->{$attr};
#    print "check func1=$func1 func2=$func2 @_\n";

    if (exists $self->{ReqNotSeen}->{$attr})
    {
	delete $self->{ReqNotSeen}->{$attr};
    }
    no strict;

    &$func1 (@_) if defined $func1;
    &$func2 (@_) if defined $func2;
}

# Copies the list of all required attributes from $self->{Required} to
# $self->{ReqNotSeen}. 
# When check() encounters a required attribute, it is removed from ReqNotSeen. 
# In EndAttr we look at which attribute names are still in ReqNotSeen - those
# are the ones that were not specified and are, therefore, in error.
sub StartAttr
{
    my $self = shift;
    my %not_seen = %{ $self->{Required} };
    $self->{ReqNotSeen} = \%not_seen;
}

# Checks which of the #REQUIRED attributes were not specified
sub EndAttr
{
    my $self = shift;

    for my $attr (keys %{ $self->{ReqNotSeen} })
    {
	$self->fail ($attr, 159, 
		     "unspecified value for \#REQUIRED attribute [$attr]");
    }
}

sub FIXED
{
    my ($self, $attr, $val, $specified) = @_;

    my $default = $self->{Default}->{$attr};
    $self->fail ($attr, 150, 
		 "bad \#FIXED attribute value [$val], it should be [$default]")
	unless ($val eq $default);
}

sub IMPLIED
{
    my ($self, $attr, $val, $specified) = @_;

#?? should #IMPLIED be specified?
    $self->fail ($attr, 158, 
		 "unspecified value for \#IMPLIED attribute [$attr]")
	unless $specified;

#?? Implied handler ?
}

# This is called when an attribute is passed to the check() method by
# XML::Checker::Attr(), i.e. when the attribute was specified explicitly
# or defaulted by the parser (which should never happen), *NOT* when the 
# attribute was omitted. (The latter is checked by StartAttr/EndAttr)
sub REQUIRED
{
    my ($self, $attr, $val, $specified) = @_;
#    print "REQUIRED attr=$attr val=$val spec=$specified\n";

    $self->fail ($attr, 159, 
		 "unspecified value for \#REQUIRED attribute [$attr]")
	unless $specified;
}

sub ID		# must be #IMPLIED or #REQUIRED
{
    my ($self, $attr, $val, $specified) = @_;

    $self->fail ($attr, 131, "invalid ID [$val]")
	unless $val =~ /^$XML::RegExp::Name$/;

    $self->fail ($attr, 111, "ID [$val] already defined")
	if $self->{Checker}->{ID}->{$val}++;
}

sub IDREF
{
    my ($self, $attr, $val, $specified) = @_;
    
    $self->fail ($attr, 132, "invalid IDREF [$val]")
	unless $val =~ /^$XML::RegExp::Name$/;

    $self->{Checker}->{IDREF}->{$val}++;
}

sub IDREFS
{
    my ($self, $attr, $val, $specified) = @_;
    for (split /\s+/, $val)
    {
	$self->IDREF ($attr, $_);
    }
}

sub ENTITY
{
    my ($self, $attr, $val, $specified) = @_;
#?? should it be specified?

    $self->fail ($attr, 133, "invalid ENTITY name [$val]")
	unless $val =~ /^$XML::RegExp::Name$/;

    $self->fail ($attr, 102, "undefined unparsed ENTITY [$val]")
	unless exists $self->{Checker}->{Unparsed}->{$val};
}

sub ENTITIES
{
    my ($self, $attr, $val, $specified) = @_;
    for (split /\s+/, $val)
    {
	$self->ENTITY ($attr, $_);
    }
}

sub NMTOKEN
{
    my ($self, $attr, $val, $specified) = @_;
    $self->fail ($attr, 130, "invalid NMTOKEN [$val]")
	unless $val =~ /^$XML::RegExp::NmToken$/;
}

sub NMTOKENS
{
    my ($self, $attr, $val, $specified) = @_;
    for (split /\s+/, $val)
    {
	$self->NMTOKEN ($attr, $_, $specified);
    }
}

sub Enumeration
{
    my ($self, $attr, $val, $specified) = @_;
    my $re = $self->{EnumRE}->{$attr};
    
    $self->fail ($attr, 160, "invalid Enumeration value [$val]")
	unless $val =~ /$re/;
}

sub NotationType
{
    my ($self, $attr, $val, $specified) = @_;
    my $re = $self->{NotationRE};

    $self->fail ($attr, 161, "invalid NOTATION value [$val]")
	unless $val =~ /$re/;

    $self->fail ($attr, 162, "undefined NOTATION [$val]")
	unless exists $self->{Checker}->{NOTATION}->{$val};
}

package XML::Checker;
use vars qw ( $VERSION $FAIL $INSIGNIF_WS );

BEGIN 
{ 
    $VERSION = '0.13'; 
}

$FAIL = \&print_error;

# Whether the last seen Char data was insignicant whitespace
$INSIGNIF_WS = 0;

sub new
{
    my ($class, %args) = @_;

    $args{ERule} = {};
    $args{ARule} = {};
    $args{InCDATA} = 0;

    #$args{Debug} = 1;
    bless \%args, $class;
}

# PerlSAX API
sub element_decl
{
    my ($self, $hash) = @_;
    $self->Element ($hash->{Name}, $hash->{Model});
}

# Same parameter order as the Element handler in XML::Parser module
sub Element
{
    my ($self, $name, $model) = @_;
    
    if (defined $self->{ERule}->{$name})
    {
	$self->fail (115, "ELEMENT [$name] already defined",
		     Element => $name);
    }

    if ($model eq "EMPTY")
    {
	$self->{ERule}->{$name} = new XML::Checker::ERule::EMPTY;
    }
    elsif ($model eq "ANY")
    {
	$self->{ERule}->{$name} = new XML::Checker::ERule::ANY;
    }
    elsif ($model =~ /#PCDATA/)
    {
        my $rule = new XML::Checker::ERule::Mixed;
	if ($rule->setModel ($model))
        {
	    $self->{ERule}->{$name} = $rule;
	}
        else
        {
	    $self->fail (124, "bad model [$model] for ELEMENT [$name]",
			 Element => $name);
	}
    }
    else
    {
        my $rule = new XML::Checker::ERule::Children;
	if ($rule->setModel ($model))
        {
	    $self->{ERule}->{$name} = $rule;
	}
        else
        {
	    $self->fail (124, "bad model [$model] for ELEMENT [$name]",
			 Element => $name);
	}
    }
    my $rule = $self->{ERule}->{$name};
    print "added ELEMENT model for $name: " . $rule->debug . "\n"
	   if $rule and $self->{Debug};
}

# PerlSAX API
sub attlist_decl
{
    my ($self, $hash) = @_;
    $self->Attlist ($hash->{ElementName}, $hash->{AttributeName},
		    $hash->{Type}, $hash->{Default}, $hash->{Fixed});
}

sub Attlist
{ 
    my ($self, $tag, $attrName, $type, $default, $fixed) = @_;
    my $arule = $self->{ARule}->{$tag} ||= 
	new XML::Checker::ARule ($tag, $self);

    $arule->Attlist ($attrName, $type, $default, $fixed, $self);
}

# Initializes the context stack to check an XML::DOM::Element
sub InitDomElem
{
    my $self = shift;

    # initialize Context stack
    $self->{Context} = [ new XML::Checker::Context::ANY ($self) ];
    $self->{InCDATA} = 0;
}

# Clears the context stack after checking an XML::DOM::Element
sub FinalDomElem
{
    my $self = shift;
    delete $self->{Context};
}

# PerlSAX API
sub start_document
{
    shift->Init;
}

sub Init
{
    my $self = shift;

    # initialize Context stack
    $self->{Context} = [ new XML::Checker::DocContext ($self) ];
    $self->{InCDATA} = 0;
}

# PerlSAX API
sub end_document
{
    shift->Final;
}

sub Final
{
    my $self = shift;
#?? could add more statistics: unreferenced Unparsed, ID

    for (keys %{ $self->{IDREF} })
    {
	my $n = $self->{IDREF}->{$_};
	$self->fail (200, "undefined ID [$_] was referenced [$n] times")
	    unless defined $self->{ID}->{$_};
    }

    for (keys %{ $self->{ID} })
    {
	my $n = $self->{IDREF}->{$_} || 0;
	$self->fail (300, "[$n] references to ID [$_]");
    }

    delete $self->{Context};
}

sub getRootElement
{
    my $self = shift;
#    print "getRoot $self " . $self->{RootElement} . "\n";
    $_[0]->{RootElement};
}

# PerlSAX API
sub doctype_decl
{
    my ($self, $hash) = @_;
    $self->Doctype ($hash->{Name}, $hash->{SystemId},
		    $hash->{PublicId}, $hash->{Internal});
}

sub Doctype
{
    my ($self, $name, $sysid, $pubid, $internal) = @_;
    $self->{RootElement} = $name;

    my $context = $self->{Context}->[0];
    $context->setRootElement ($name);

#?? what else
}

sub Attr
{
    my ($self, $tag, $attr, $val, $specified) = @_;

#print "Attr for tag=$tag attr=$attr val=$val spec=$specified\n";

    my $arule = $self->{ARule}->{$tag};
    if (defined $arule && $arule->{Defined}->{$attr})
    {
	$arule->check ($attr, $val, $specified);
    }
    else
    {
	$self->fail (103, "undefined attribute [$attr]", Element => $tag);
    }
}

sub EndAttr
{
    my $self = shift;

    my $arule = $self->{CurrARule};
    if (defined $arule)
    {
	$arule->EndAttr;
    }
}

# PerlSAX API
sub start_element
{
    my ($self, $hash) = @_;
    my $tag = $hash->{Name};
    my $attr = $hash->{Attributes};

    $self->Start ($tag);

    if (exists $hash->{AttributeOrder})
    {
	my $defaulted = $hash->{Defaulted};
	my @order = @{ $hash->{AttributeOrder} };

	# Specified attributes
	for (my $i = 0; $i < $defaulted; $i++)
	{
	    my $a = $order[$i];
	    $self->Attr ($tag, $a, $attr->{$a}, 1);
	}

	# Defaulted attributes
	for (my $i = $defaulted; $i < @order; $i++)
	{
	    my $attr = $order[$i];
	    $self->Attr ($tag, $a, $attr->{$a}, 0);
	}
    }
    else
    {
	# Assume all attributes were specified
	my @attr = %$attr;
	my ($key, $val);
	while ($key = shift @attr)
	{
	    $val = shift @attr;
	    
	    $self->Attr ($tag, $key, $val, 1);
	}
    }
    $self->EndAttr;
}

sub Start
{
    my ($self, $tag) = @_;
#?? if first tag, check with root element - or does expat check this already?

    my $context = $self->{Context};
    $context->[0]->Start ($self, $tag);

    my $erule = $self->{ERule}->{$tag};
    if (defined $erule)
    {
	unshift @$context, $erule->context;
    }
    else
    {
	# It's not a real error according to the XML Spec.
	$self->fail (101, "undefined ELEMENT [$tag]");
	unshift @$context, new XML::Checker::Context::ANY;
    }

#?? what about ARule ??
    my $arule = $self->{ARule}->{$tag};
    if (defined $arule)
    {
	$self->{CurrARule} = $arule;
	$arule->StartAttr;
    }
}

# PerlSAX API
sub end_element
{
    shift->End;
}

sub End
{
    my ($self) = @_;
    my $context = $self->{Context};

    $context->[0]->End ($self);
    shift @$context;
}

# PerlSAX API
sub characters
{
    my ($self, $hash) = @_;
    my $data = $hash->{Data};

    if ($self->{InCDATA})
    {
	$self->CData ($data);
    }
    else
    {
	$self->Char ($data);
    }
}

# PerlSAX API
sub start_cdata
{
    $_[0]->{InCDATA} = 1;
}

# PerlSAX API
sub end_cdata
{
    $_[0]->{InCDATA} = 0;
}

sub Char
{
    my ($self, $text) = @_;
    my $context = $self->{Context};

    # NOTE: calls to isWS may set this to 1.
    $INSIGNIF_WS = 0;

    $context->[0]->Char ($self, $text);
}

# Treat CDATASection same as Char (Text)
sub CData
{
    my ($self, $cdata) = @_;
    my $context = $self->{Context};

    $context->[0]->Char ($self, $cdata);

    # CDATASection can never be insignificant whitespace
    $INSIGNIF_WS = 0;
#?? I'm not sure if this assumption is correct
}

# PerlSAX API
sub comment
{
    my ($self, $hash) = @_;
    $self->Comment ($hash->{Data});
}

sub Comment
{
# ?? what can be checked here?
}

# PerlSAX API
sub entity_reference
{
    my ($self, $hash) = @_;
    $self->EntityRef ($hash->{Name}, 0);
#?? parameter entities (like %par;) are NOT supported!
# PerlSAX::handle_default should be fixed!
}

sub EntityRef
{
    my ($self, $ref, $isParam) = @_;

    if ($isParam)
    {
	# expand to "%name;"
	print STDERR "XML::Checker::Entity -  parameter Entity (%ent;) not implemented\n";
    }
    else
    {
	# Treat same as Char - for now
	my $context = $self->{Context};
	$context->[0]->Char ($self, "&$ref;");
	$INSIGNIF_WS = 0;
#?? I could count the number of times each Entity is referenced
    }
}

# PerlSAX API
sub unparsed_entity_decl
{
    my ($self, $hash) = @_;
    $self->Unparsed ($hash->{Name});
#?? what about Base, SytemId, PublicId ?
}

sub Unparsed
{
    my ($self, $entity) = @_;
#    print "ARule::Unparsed $entity\n";
    if ($self->{Unparsed}->{$entity})
    {
	$self->fail (112, "unparsed ENTITY [$entity] already defined");
    }
    else
    {
	$self->{Unparsed}->{$entity} = 1;
    }
}

# PerlSAX API
sub notation_decl
{
    my ($self, $hash) = @_;
    $self->Notation ($hash->{Name});
#?? what about Base, SytemId, PublicId ?
}

sub Notation
{
    my ($self, $notation) = @_;
    if ($self->{NOTATION}->{$notation})
    {
	$self->fail (113, "NOTATION [$notation] already defined");
    }
    else
    {
	$self->{NOTATION}->{$notation} = 1;
    }
}

# PerlSAX API
sub entity_decl
{
    my ($self, $hash) = @_;

    $self->Entity ($hash->{Name}, $hash->{Value}, $hash->{SystemId},
		   $hash->{PublicId}, $hash->{'Notation'});
}

sub Entity
{
    my ($self, $name, $val, $sysId, $pubId, $ndata) = @_;

    if (exists $self->{ENTITY}->{$name})
    {
	$self->fail (114, "ENTITY [$name] already defined");
    }
    else
    {
	$self->{ENTITY}->{$name} = $val;
    }    
}

# PerlSAX API
#sub xml_decl {} $hash=> Version, Encoding, Standalone
# Don't implement resolve_entity() which is called by ExternEnt!
#sub processing_instruction {} $hash=> Target, Data

# Returns whether the Char data is whitespace and also updates the
# $INSIGNIF_WS variable to indicate whether it is insignificant whitespace.
# Note that this method is only called in places where potential whitespace
# can be insignificant (i.e. when the ERule is Children or EMPTY)
sub isWS
{
  # pverdret: why not /\A\s+\Z/ ???
  $INSIGNIF_WS = ($_[1] =~ /^\s*$/);
}

sub isInsignifWS
{
    $INSIGNIF_WS;
}

sub fail
{
    my $self = shift;
    &$FAIL (@_);
}

sub print_error		# static
{
    my $str = error_string (@_);
    print STDERR $str;
}

sub error_string	# static
{
    my $code = shift;
    my $msg = shift;

    my @a = ();
    my ($key, $val);
    while ($key = shift)
    {
	$val = shift;
	push @a, ("$key " . (defined $val ? $val : "(undef)"));
    }

    my $cat = $code >= 200 ? ($code >= 300 ? "INFO" : "WARNING") : "ERROR";
    my $str = join (", ", @a);
    $str = length($str) ? "\tContext: $str\n" : "";

    "XML::Checker $cat-$code: $msg\n$str";
}

sub debug
{
    my ($self) = @_;
    my $context = $self->{Context}->[0];
    my $c = $context ? $context->debug : "no context";
    my $root = $self->{RootElement};

    "Checker[$c,RootElement=$root]";
}

1; # package return code

__END__