1 #

     2 #

     3 # TO DO

     4 # - update docs regarding PerlSAX interface

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

     6 # - add parsed Entity to test XML files

     7 # - free circular references

     8 # - Implied handler?

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

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

    11 

    12 package XML::Checker::Term;

    13 use strict;

    14 

    15 sub new     

    16 { 

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

    18     bless \%h, $class;

    19 }

    20 

    21 sub str     

    22 { 

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

    24 }

    25 

    26 sub re

    27 { 

    28     $_[0]->{S} 

    29 }

    30 

    31 sub rel 

    32 { 

    33     my $self = shift;

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

    35 }

    36 

    37 sub debug

    38 {

    39     my $t = shift;

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

    41     my @sl = $t->rel;

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

    43 }

    44 

    45 #-------------------------------------------------------------------------

    46 

    47 package XML::Checker::Context;

    48 

    49 sub new

    50 {

    51     my ($class) = @_;

    52     my $scalar;

    53     bless \$scalar, $class;

    54 }

    55 

    56 sub Start {}

    57 sub End   {}

    58 sub Char  {}

    59 

    60 #

    61 # The initial Context when checking an entire XML Document

    62 #

    63 package XML::Checker::DocContext;

    64 use vars qw( @ISA );

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

    66 

    67 sub new

    68 {

    69 #??checker not used

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

    71     bless { }, $class;

    72 }

    73 

    74 sub setRootElement

    75 {

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

    77 }

    78 

    79 sub Start 

    80 {

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

    82     if (exists $self->{Elem})

    83     {

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

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

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

    87     }

    88     else

    89     {

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

    91     }

    92 

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

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

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

    96 }

    97 

    98 sub debug

    99 {

   100     my $self = shift;

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

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

   103 }

   104 

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

   106 use vars qw( @ISA );

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

   108 

   109 # No overrides, because everything is accepted

   110 

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

   112 

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

   114 use vars qw( @ISA $ALLOW_WHITE_SPACE );

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

   116 

   117 $ALLOW_WHITE_SPACE = 0;

   118 

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

   120 

   121 sub Start

   122 {

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

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

   125 }

   126 

   127 sub Char

   128 {

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

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

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

   132 

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

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

   135     # might be insignificant whitespace

   136 }

   137 

   138 #?? what about Comments

   139 

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

   141 use vars qw( @ISA );

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

   143 

   144 sub new

   145 {

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

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

   148 }

   149 

   150 sub phash

   151 {

   152     my $href = shift;

   153     my $str = "";

   154     for (keys %$href)

   155     {

   156 	$str .= ' ' if $str;

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

   158     }

   159     $str;

   160 }

   161 

   162 sub debug

   163 {

   164     my $self = shift;

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

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

   167 }

   168 

   169 sub Start

   170 {

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

   172 

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

   174 

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

   176     {

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

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

   179     }

   180     else

   181     {

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

   183 			ChildElementIndex => $self->{N})

   184     }

   185     $self->{N}++;

   186 }

   187 

   188 sub decode

   189 {

   190     my ($self) = @_;

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

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

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

   194 

   195     my %s = ();

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

   197     {

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

   199     }

   200 

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

   202     $len = length $len;

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

   204 

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

   206     chop $buf;

   207 

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

   209 

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

   211 }

   212 

   213 sub End

   214 {

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

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

   217 

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

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

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

   221 }

   222 

   223 sub Char

   224 {

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

   226 

   227     # Inform the checker that this might be insignificant whitespace

   228     $checker->isWS ($str);

   229 }

   230 

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

   232 use vars qw( @ISA );

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

   234 

   235 sub new

   236 {

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

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

   239 }

   240 

   241 sub debug

   242 {

   243     my $self = shift;

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

   245 }

   246 

   247 sub Start

   248 {

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

   250 

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

   252 		    ChildElementIndex => $self->{N})

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

   254     $self->{N}++;

   255 }

   256 

   257 package XML::Checker::ERule;

   258 

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

   260 use vars qw( @ISA );

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

   262 

   263 sub new

   264 {

   265     my ($class) = @_;

   266     bless {}, $class;

   267 }

   268 

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

   270 sub context { $context }	# share the context

   271 

   272 sub debug { "EMPTY" }

   273 

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

   275 use vars qw( @ISA );

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

   277 

   278 sub new

   279 {

   280     my ($class) = @_;

   281     bless {}, $class;

   282 }

   283 

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

   285 sub context { $any_context }	# share the context

   286 

   287 sub debug { "ANY" }

   288 

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

   290 use vars qw( @ISA );

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

   292 

   293 sub new

   294 {

   295     my ($class) = @_;

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

   297 }

   298 

   299 sub context 

   300 {

   301     my ($self) = @_;

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

   303 }

   304 

   305 sub setModel

   306 {

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

   308     my $rule = $model;

   309 

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

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

   312     {

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

   314          return 1;

   315     }

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

   317     {

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

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

   320 

   321 	my %names = ();

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

   323 	{

   324 	    $names{$1} = 1;

   325 	}

   326 	if ($rule eq "")

   327 	{

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

   329 	    return 1;

   330 	}

   331     }

   332     return 0;

   333 }

   334 

   335 sub debug

   336 {

   337     my ($self) = @_;

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

   339 }

   340 

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

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

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

   344 

   345 sub new

   346 {

   347     my ($class) = @_;

   348     bless {}, $class;

   349 }

   350 

   351 sub context 

   352 {

   353     my ($self) = @_;

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

   355 }

   356 

   357 sub _add	# static

   358 {

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

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

   361     $exp->str;

   362 }

   363 

   364 my $IDS = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789";

   365 

   366 sub _tokenize

   367 {

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

   369 

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

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

   372     # 

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

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

   375 	{

   376 	    $_name{$1}->str;

   377 	}

   378         else

   379 	{

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

   381 					      Name => $1);

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

   383 	    $exp->str;

   384 	}

   385     /eg;

   386 

   387     if ($_n < length $IDS)

   388     {

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

   390 	# a single character from $IDS

   391 	my $i = 0;

   392 	for (values %_name)

   393 	{

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

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

   396 	}

   397     }

   398     else

   399     {

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

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

   402 	my $len = 1;

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

   404 

   405 	my $i = 0;

   406 	for (values %_name)

   407 	{

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

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

   410 	}

   411     }

   412 }

   413 

   414 sub setModel

   415 {

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

   417 

   418     local $_n = 0;

   419     local %_map = ();

   420     local %_name = ();

   421     

   422     $self->_tokenize (\$rule);

   423 

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

   425 

   426     for ($rule)

   427     {

   428 	my $n = 1;

   429 	while ($n)

   430 	{

   431 	    $n = 0;

   432 

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

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

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

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

   437 

   438 	    # choice := '(' ch_l ')'

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

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

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

   442 	

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

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

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

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

   447 

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

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

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

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

   452 

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

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

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

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

   457 	}

   458     }

   459 

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

   461 

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

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

   464 

   465     return 1;

   466 }

   467 

   468 sub debug

   469 {

   470     my ($self) = @_;

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

   472 }

   473 

   474 

   475 package XML::Checker::ARule;

   476 use XML::RegExp;

   477 

   478 sub new

   479 {

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

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

   482 }

   483 

   484 sub Attlist

   485 {

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

   487     my ($c1, $c2);

   488 

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

   490     {

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

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

   493     }

   494     else

   495     {

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

   497     }

   498 

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

   500     {

   501 	$c1 = $1;

   502 

   503 	# Keep list of all required attributes

   504 	if ($default eq '#REQUIRED')

   505 	{

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

   507 	}

   508     }

   509     else

   510     {

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

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

   513 				   

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

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

   516 	$c1 = 'FIXED' if $fixed;

   517     }

   518 

   519     if ($type eq 'ID')

   520     {

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

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

   523 

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

   525 	{

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

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

   528 	}

   529 	else

   530 	{

   531 	    $self->{ID} = $attr;

   532 	}

   533 	$c2 = 'ID';

   534     }

   535     elsif ($type =~ /^(IDREF|IDREFS|ENTITY|ENTITIES|NMTOKEN|NMTOKENS)$/)

   536     {

   537 	my $def = $self->{Default}->{$attr};

   538 	if (defined $def)

   539 	{

   540 	    my $re = ($type =~ /^[IE]/) ? $XML::RegExp::Name : $XML::RegExp::NmToken;

   541 	    if ($type =~ /S$/)

   542 	    {

   543 		for (split (/\s+/, $def))

   544 		{

   545 		    $self->fail ($attr, 121,

   546 				 "invalid default [$_] in $type [$def]")

   547 			unless $_ =~ /^$re$/;

   548 		}

   549 	    }

   550 	    else	# singular

   551 	    {

   552 		$self->fail ($attr, 120, "invalid default $type [$def]")

   553 			unless $def =~ /^$re$/;

   554 	    }

   555 	}

   556 	$c2 = $type;

   557     }

   558     elsif ($type ne 'CDATA')	# Enumerated := NotationType | Enumeration

   559     {

   560 	if ($type =~ /^\s*NOTATION\s*\(\s*($XML::RegExp::Name(\s*\|\s*$XML::RegExp::Name)*)\s*\)\s*$/)

   561 	{

   562 	    $self->fail ($attr, 135, "empty NOTATION list in ATTLIST")

   563 		unless defined $1;

   564 

   565 	    my @tok = split (/\s*\|\s*/, $1);

   566 	    for (@tok)

   567 	    {

   568 		$self->fail ($attr, 100, "undefined NOTATION [$_] in ATTLIST")

   569 			unless exists $checker->{NOTATION}->{$_};

   570 	    }

   571 

   572 	    my $re = join ("|", @tok);

   573 	    $self->{NotationRE} = "^($re)\$";

   574 	    $c2 = 'NotationType';

   575 	}

   576 	elsif ($type =~ /^\s*\(\s*($XML::RegExp::NmToken(\s*\|\s*$XML::RegExp::NmToken)*)\s*\)\s*$/)

   577 	{

   578 	    # Enumeration

   579 

   580 	    $self->fail ($attr, 136, "empty Enumeration list in ATTLIST")

   581 		    unless defined $1;

   582 

   583 	    my @tok = split (/\s*\|\s*/, $1);

   584 	    for (@tok)

   585 	    {

   586 		$self->fail ($attr, 134,

   587 			     "invalid Enumeration value [$_] in ATTLIST")

   588 		unless $_ =~ /^$XML::RegExp::NmToken$/;

   589 	    }

   590 	    $self->{EnumRE}->{$attr} = '^(' . join ("|", @tok) . ')$'; #';

   591 	    $c2 = 'Enumeration';

   592 	}

   593 	else

   594 	{

   595 	    $self->fail ($attr, 137, "invalid ATTLIST type [$type]");

   596 	}

   597     }

   598 

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

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

   601 }

   602 

   603 sub fail

   604 {

   605     my $self = shift;

   606     my $attr = shift;

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

   608 }

   609 

   610 sub check

   611 {

   612     my ($self, $attr) = @_;

   613     my $func1 = $self->{Check1}->{$attr};

   614     my $func2 = $self->{Check2}->{$attr};

   615 #    print "check func1=$func1 func2=$func2 @_\n";

   616 

   617     if (exists $self->{ReqNotSeen}->{$attr})

   618     {

   619 	delete $self->{ReqNotSeen}->{$attr};

   620     }

   621     no strict;

   622 

   623     &$func1 (@_) if defined $func1;

   624     &$func2 (@_) if defined $func2;

   625 }

   626 

   627 # Copies the list of all required attributes from $self->{Required} to

   628 # $self->{ReqNotSeen}. 

   629 # When check() encounters a required attribute, it is removed from ReqNotSeen. 

   630 # In EndAttr we look at which attribute names are still in ReqNotSeen - those

   631 # are the ones that were not specified and are, therefore, in error.

   632 sub StartAttr

   633 {

   634     my $self = shift;

   635     my %not_seen = %{ $self->{Required} };

   636     $self->{ReqNotSeen} = \%not_seen;

   637 }

   638 

   639 # Checks which of the #REQUIRED attributes were not specified

   640 sub EndAttr

   641 {

   642     my $self = shift;

   643 

   644     for my $attr (keys %{ $self->{ReqNotSeen} })

   645     {

   646 	$self->fail ($attr, 159, 

   647 		     "unspecified value for \#REQUIRED attribute [$attr]");

   648     }

   649 }

   650 

   651 sub FIXED

   652 {

   653     my ($self, $attr, $val, $specified) = @_;

   654 

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

   656     $self->fail ($attr, 150, 

   657 		 "bad \#FIXED attribute value [$val], it should be [$default]")

   658 	unless ($val eq $default);

   659 }

   660 

   661 sub IMPLIED

   662 {

   663     my ($self, $attr, $val, $specified) = @_;

   664 

   665 #?? should #IMPLIED be specified?

   666     $self->fail ($attr, 158, 

   667 		 "unspecified value for \#IMPLIED attribute [$attr]")

   668 	unless $specified;

   669 

   670 #?? Implied handler ?

   671 }

   672 

   673 # This is called when an attribute is passed to the check() method by

   674 # XML::Checker::Attr(), i.e. when the attribute was specified explicitly

   675 # or defaulted by the parser (which should never happen), *NOT* when the 

   676 # attribute was omitted. (The latter is checked by StartAttr/EndAttr)

   677 sub REQUIRED

   678 {

   679     my ($self, $attr, $val, $specified) = @_;

   680 #    print "REQUIRED attr=$attr val=$val spec=$specified\n";

   681 

   682     $self->fail ($attr, 159, 

   683 		 "unspecified value for \#REQUIRED attribute [$attr]")

   684 	unless $specified;

   685 }

   686 

   687 sub ID		# must be #IMPLIED or #REQUIRED

   688 {

   689     my ($self, $attr, $val, $specified) = @_;

   690 

   691     $self->fail ($attr, 131, "invalid ID [$val]")

   692 	unless $val =~ /^$XML::RegExp::Name$/;

   693 

   694     $self->fail ($attr, 111, "ID [$val] already defined")

   695 	if $self->{Checker}->{ID}->{$val}++;

   696 }

   697 

   698 sub IDREF

   699 {

   700     my ($self, $attr, $val, $specified) = @_;

   701     

   702     $self->fail ($attr, 132, "invalid IDREF [$val]")

   703 	unless $val =~ /^$XML::RegExp::Name$/;

   704 

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

   706 }

   707 

   708 sub IDREFS

   709 {

   710     my ($self, $attr, $val, $specified) = @_;

   711     for (split /\s+/, $val)

   712     {

   713 	$self->IDREF ($attr, $_);

   714     }

   715 }

   716 

   717 sub ENTITY

   718 {

   719     my ($self, $attr, $val, $specified) = @_;

   720 #?? should it be specified?

   721 

   722     $self->fail ($attr, 133, "invalid ENTITY name [$val]")

   723 	unless $val =~ /^$XML::RegExp::Name$/;

   724 

   725     $self->fail ($attr, 102, "undefined unparsed ENTITY [$val]")

   726 	unless exists $self->{Checker}->{Unparsed}->{$val};

   727 }

   728 

   729 sub ENTITIES

   730 {

   731     my ($self, $attr, $val, $specified) = @_;

   732     for (split /\s+/, $val)

   733     {

   734 	$self->ENTITY ($attr, $_);

   735     }

   736 }

   737 

   738 sub NMTOKEN

   739 {

   740     my ($self, $attr, $val, $specified) = @_;

   741     $self->fail ($attr, 130, "invalid NMTOKEN [$val]")

   742 	unless $val =~ /^$XML::RegExp::NmToken$/;

   743 }

   744 

   745 sub NMTOKENS

   746 {

   747     my ($self, $attr, $val, $specified) = @_;

   748     for (split /\s+/, $val)

   749     {

   750 	$self->NMTOKEN ($attr, $_, $specified);

   751     }

   752 }

   753 

   754 sub Enumeration

   755 {

   756     my ($self, $attr, $val, $specified) = @_;

   757     my $re = $self->{EnumRE}->{$attr};

   758     

   759     $self->fail ($attr, 160, "invalid Enumeration value [$val]")

   760 	unless $val =~ /$re/;

   761 }

   762 

   763 sub NotationType

   764 {

   765     my ($self, $attr, $val, $specified) = @_;

   766     my $re = $self->{NotationRE};

   767 

   768     $self->fail ($attr, 161, "invalid NOTATION value [$val]")

   769 	unless $val =~ /$re/;

   770 

   771     $self->fail ($attr, 162, "undefined NOTATION [$val]")

   772 	unless exists $self->{Checker}->{NOTATION}->{$val};

   773 }

   774 

   775 package XML::Checker;

   776 use vars qw ( $VERSION $FAIL $INSIGNIF_WS );

   777 

   778 BEGIN 

   779 { 

   780     $VERSION = '0.09'; 

   781 }

   782 

   783 $FAIL = \&print_error;

   784 

   785 # Whether the last seen Char data was insignicant whitespace

   786 $INSIGNIF_WS = 0;

   787 

   788 sub new

   789 {

   790     my ($class, %args) = @_;

   791 

   792     $args{ERule} = {};

   793     $args{ARule} = {};

   794     $args{InCDATA} = 0;

   795 

   796 #    $args{Debug} = 1;

   797     bless \%args, $class;

   798 }

   799 

   800 # PerlSAX API

   801 sub element_decl

   802 {

   803     my ($self, $hash) = @_;

   804     $self->Element ($hash->{Name}, $hash->{Model});

   805 }

   806 

   807 # Same parameter order as the Element handler in XML::Parser module

   808 sub Element

   809 {

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

   811     

   812     if (defined $self->{ERule}->{$name})

   813     {

   814 	$self->fail (115, "ELEMENT [$name] already defined",

   815 		     Element => $name);

   816     }

   817 

   818     if ($model eq "EMPTY")

   819     {

   820 	$self->{ERule}->{$name} = new XML::Checker::ERule::EMPTY;

   821     }

   822     elsif ($model eq "ANY")

   823     {

   824 	$self->{ERule}->{$name} = new XML::Checker::ERule::ANY;

   825     }

   826     elsif ($model =~ /#PCDATA/)

   827     {

   828         my $rule = new XML::Checker::ERule::Mixed;

   829 	if ($rule->setModel ($model))

   830         {

   831 	    $self->{ERule}->{$name} = $rule;

   832 	}

   833         else

   834         {

   835 	    $self->fail (124, "bad model [$model] for ELEMENT [$name]",

   836 			 Element => $name);

   837 	}

   838     }

   839     else

   840     {

   841         my $rule = new XML::Checker::ERule::Children;

   842 	if ($rule->setModel ($model))

   843         {

   844 	    $self->{ERule}->{$name} = $rule;

   845 	}

   846         else

   847         {

   848 	    $self->fail (124, "bad model [$model] for ELEMENT [$name]",

   849 			 Element => $name);

   850 	}

   851     }

   852     my $rule = $self->{ERule}->{$name};

   853     print "added ELEMENT model for $name: " . $rule->debug . "\n"

   854 	   if $rule and $self->{Debug};

   855 }

   856 

   857 # PerlSAX API

   858 sub attlist_decl

   859 {

   860     my ($self, $hash) = @_;

   861     $self->Attlist ($hash->{ElementName}, $hash->{AttributeName},

   862 		    $hash->{Type}, $hash->{Default}, $hash->{Fixed});

   863 }

   864 

   865 sub Attlist

   866 { 

   867     my ($self, $tag, $attrName, $type, $default, $fixed) = @_;

   868     my $arule = $self->{ARule}->{$tag} ||= 

   869 	new XML::Checker::ARule ($tag, $self);

   870 

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

   872 }

   873 

   874 # Initializes the context stack to check an XML::DOM::Element

   875 sub InitDomElem

   876 {

   877     my $self = shift;

   878 

   879     # initialize Context stack

   880     $self->{Context} = [ new XML::Checker::Context::ANY ($self) ];

   881     $self->{InCDATA} = 0;

   882 }

   883 

   884 # Clears the context stack after checking an XML::DOM::Element

   885 sub FinalDomElem

   886 {

   887     my $self = shift;

   888     delete $self->{Context};

   889 }

   890 

   891 # PerlSAX API

   892 sub start_document

   893 {

   894     shift->Init;

   895 }

   896 

   897 sub Init

   898 {

   899     my $self = shift;

   900 

   901     # initialize Context stack

   902     $self->{Context} = [ new XML::Checker::DocContext ($self) ];

   903     $self->{InCDATA} = 0;

   904 }

   905 

   906 # PerlSAX API

   907 sub end_document

   908 {

   909     shift->Final;

   910 }

   911 

   912 sub Final

   913 {

   914     my $self = shift;

   915 #?? could add more statistics: unreferenced Unparsed, ID

   916 

   917     for (keys %{ $self->{IDREF} })

   918     {

   919 	my $n = $self->{IDREF}->{$_};

   920 	$self->fail (200, "undefined ID [$_] was referenced [$n] times")

   921 	    unless defined $self->{ID}->{$_};

   922     }

   923 

   924     for (keys %{ $self->{ID} })

   925     {

   926 	my $n = $self->{IDREF}->{$_} || 0;

   927 	$self->fail (300, "[$n] references to ID [$_]");

   928     }

   929 

   930     delete $self->{Context};

   931 }

   932 

   933 sub getRootElement

   934 {

   935     my $self = shift;

   936 #    print "getRoot $self " . $self->{RootElement} . "\n";

   937     $_[0]->{RootElement};

   938 }

   939 

   940 # PerlSAX API

   941 sub doctype_decl

   942 {

   943     my ($self, $hash) = @_;

   944     $self->Doctype ($hash->{Name}, $hash->{SystemId},

   945 		    $hash->{PublicId}, $hash->{Internal});

   946 }

   947 

   948 sub Doctype

   949 {

   950     my ($self, $name, $sysid, $pubid, $internal) = @_;

   951     $self->{RootElement} = $name;

   952 

   953     my $context = $self->{Context}->[0];

   954     $context->setRootElement ($name);

   955 

   956 #?? what else

   957 }

   958 

   959 sub Attr

   960 {

   961     my ($self, $tag, $attr, $val, $specified) = @_;

   962 

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

   964 

   965     my $arule = $self->{ARule}->{$tag};

   966     if (defined $arule && $arule->{Defined}->{$attr})

   967     {

   968 	$arule->check ($attr, $val, $specified);

   969     }

   970     else

   971     {

   972 	$self->fail (103, "undefined attribute [$attr]", Element => $tag);

   973     }

   974 }

   975 

   976 sub EndAttr

   977 {

   978     my $self = shift;

   979 

   980     my $arule = $self->{CurrARule};

   981     if (defined $arule)

   982     {

   983 	$arule->EndAttr;

   984     }

   985 }

   986 

   987 # PerlSAX API

   988 sub start_element

   989 {

   990     my ($self, $hash) = @_;

   991     my $tag = $hash->{Name};

   992     my $attr = $hash->{Attributes};

   993 

   994     $self->Start ($tag);

   995 

   996     if (exists $hash->{AttributeOrder})

   997     {

   998 	my $defaulted = $hash->{Defaulted};

   999 	my @order = @{ $hash->{AttributeOrder} };

  1000 

  1001 	# Specified attributes

  1002 	for (my $i = 0; $i < $defaulted; $i++)

  1003 	{

  1004 	    my $a = $order[$i];

  1005 	    $self->Attr ($tag, $a, $attr->{$a}, 1);

  1006 	}

  1007 

  1008 	# Defaulted attributes

  1009 	for (my $i = $defaulted; $i < @order; $i++)

  1010 	{

  1011 	    my $attr = $order[$i];

  1012 	    $self->Attr ($tag, $a, $attr->{$a}, 0);

  1013 	}

  1014     }

  1015     else

  1016     {

  1017 	# Assume all attributes were specified

  1018 	my @attr = %$attr;

  1019 	my ($key, $val);

  1020 	while ($key = shift @attr)

  1021 	{

  1022 	    $val = shift @attr;

  1023 	    

  1024 	    $self->Attr ($tag, $key, $val, 1);

  1025 	}

  1026     }

  1027     $self->EndAttr;

  1028 }

  1029 

  1030 sub Start

  1031 {

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

  1033 #?? if first tag, check with root element - or does expat check this already?

  1034 

  1035     my $context = $self->{Context};

  1036     $context->[0]->Start ($self, $tag);

  1037 

  1038     my $erule = $self->{ERule}->{$tag};

  1039     if (defined $erule)

  1040     {

  1041 	unshift @$context, $erule->context;

  1042     }

  1043     else

  1044     {

  1045 	# It's not a real error according to the XML Spec.

  1046 	$self->fail (101, "undefined ELEMENT [$tag]");

  1047 	unshift @$context, new XML::Checker::Context::ANY;

  1048     }

  1049 

  1050 #?? what about ARule ??

  1051     my $arule = $self->{ARule}->{$tag};

  1052     if (defined $arule)

  1053     {

  1054 	$self->{CurrARule} = $arule;

  1055 	$arule->StartAttr;

  1056     }

  1057 }

  1058 

  1059 # PerlSAX API

  1060 sub end_element

  1061 {

  1062     shift->End;

  1063 }

  1064 

  1065 sub End

  1066 {

  1067     my ($self) = @_;

  1068     my $context = $self->{Context};

  1069 

  1070     $context->[0]->End ($self);

  1071     shift @$context;

  1072 }

  1073 

  1074 # PerlSAX API

  1075 sub characters

  1076 {

  1077     my ($self, $hash) = @_;

  1078     my $data = $hash->{Data};

  1079 

  1080     if ($self->{InCDATA})

  1081     {

  1082 	$self->CData ($data);

  1083     }

  1084     else

  1085     {

  1086 	$self->Char ($data);

  1087     }

  1088 }

  1089 

  1090 # PerlSAX API

  1091 sub start_cdata

  1092 {

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

  1094 }

  1095 

  1096 # PerlSAX API

  1097 sub end_cdata

  1098 {

  1099     $_[0]->{InCDATA} = 0;

  1100 }

  1101 

  1102 sub Char

  1103 {

  1104     my ($self, $text) = @_;

  1105     my $context = $self->{Context};

  1106 

  1107     # NOTE: calls to isWS may set this to 1.

  1108     $INSIGNIF_WS = 0;

  1109 

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

  1111 }

  1112 

  1113 # Treat CDATASection same as Char (Text)

  1114 sub CData

  1115 {

  1116     my ($self, $cdata) = @_;

  1117     my $context = $self->{Context};

  1118 

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

  1120 

  1121     # CDATASection can never be insignificant whitespace

  1122     $INSIGNIF_WS = 0;

  1123 #?? I'm not sure if this assumption is correct

  1124 }

  1125 

  1126 # PerlSAX API

  1127 sub comment

  1128 {

  1129     my ($self, $hash) = @_;

  1130     $self->Comment ($hash->{Data});

  1131 }

  1132 

  1133 sub Comment

  1134 {