#Copyright Massachusetts Institute of technology, 2003.
#Written by Eric Prud'hommeaux for the World Wide Web Consortium

# $Id: SchemaValidatorDataTypes.pm,v 1.57 2004/06/07 02:43:34 eric Exp $

use strict;
require Exporter;

$W3C::XML::SchemaValidatorDataTypes::REVISION = '$Id: SchemaValidatorDataTypes.pm,v 1.57 2004/06/07 02:43:34 eric Exp $ ';

package W3C::XML::SchemaValidatorDataTypes;
use vars qw($VERSION $DSLI @ISA @TODO @EXPORT @EXPORT_OK);

use vars qw($COMP_NOT $COMP_MAY $COMP_MUST);
($COMP_NOT, $COMP_MAY, $COMP_MUST) = (-1, 0, 1);
my ($COMP_NOT, $COMP_MAY, $COMP_MUST) = ($COMP_NOT, $COMP_MAY, $COMP_MUST);

@ISA = qw(Exporter); # AutoLoader);
@TODO = qw();
@EXPORT = qw(&pt);
@EXPORT_OK = qw($COMP_NOT $COMP_MAY $COMP_MUST);
$VERSION = 0.1;
$DSLI = 'adpO';

# <Output Flags>
my $ShowExceptClauses = 0;
my $DfltNodeAttrs = {color => "Blue"};
my $StartAttrs = {color => "Green"};
# </Output Flags>

my ($ELEMENT, $ATTRIB, $NCNAME, $TEXT, $SOME_ELEMENT, $MIXED) = (1, 2, 4, 8, 16, 31);
my ($AND, $OR, $NOT) = ('and', 'or', 'not');

sub pt {&W3C::XML::SchemaValidator::Textual::pt()}

#<INTERRFACES>
package ProductionStackEntry;
use W3C::Util::Exception;
sub prodStackEnt_toString {&throw(new W3C::Util::NotImplementedException(-callingClass => $_[0]))}
sub prodStackEnt_getFollowAnnots {&throw(new W3C::Util::NotImplementedException(-callingClass => $_[0]))}
#</INTERRFACES>

package W3C::XML::SchemaValidator::Textual;
use W3C::Util::Exception;

sub new {
    my ($proto, $parser) = @_;
    my $class = ref($proto) || $proto;
    my $self = {PARSER => $parser, PARSE_STATE => $parser->ErrorStrArgs};
    bless ($self, $class);
    return $self;
}

sub print {
    my ($self, $toPrint, $out) = @_;
    &W3C::Util::Exception::printMessage($toPrint, $out);
}

# <Output Methods>
sub toRnc {
    my ($self, $hit, $out) = @_;
    return ("$self->toRnc not defined");
}

sub toDot {
    my ($self, $dotWriter) = @_;
    $self->_toDot({}, $dotWriter);
}

sub _toDot {
    my ($self, $visited, $dotWriter) = @_;
    $dotWriter->addComment("$self->_toDot not defined");
}

sub toPerl {
    my ($self, $hit, $out) = @_;
    return ("$self->toRnc not defined");
}

# default output method:
sub toString {
    my ($self, @args) = @_;
    return $self->toRnc(@args);
}

# Throw exception when trying to toString an inconsistent structure.
sub protect {
    my ($self, $evalMe, @args) = @_;
    my $ret = eval {&$evalMe};
    if ($@) {
	if (my $ex = &catch('W3C::Util::Exception')) {&throw($ex)}
	print $self->{PARSER}->ErrorStr(@{$self->{PARSE_STATE}}),"\n";
	&throw(new W3C::Util::Exception(-message => "$self could not evaluate \"".join (' | ', @args)."\"\n$@"));
    }
    return $ret;
}

sub pt {
    local $\ = '';

    my @ret;
    # Collect the actual trace information to be formatted.
    # This is an array of hashes of subroutine call info.
    my @calls = &DB::dump_trace(1, 0);

    # Run through the traceback info, format it, and print it.
    my $s;
    for (my $i = @calls - 1 ; $i >= 0 ; $i--) {

	if ($calls[$i]{sub} =~ m/^W3C::XML::SchemaValidator::([^\:]+)::_getReferers$/) {
	    my $class = $1;
	    my ($self, $template, $productions, $visited, $xslWriter) = (map {$_->[1]} @{$calls[$i]{args}});
	    my $name = $template->getName;
	    my $prodStr = join ('->', $name, map {$_->prodStackEnt->toString} @$productions);
	    push(@ret, "$class: $prodStr");
	}
    }
    return join("\n", @ret);
}

package W3C::XML::SchemaValidator::TreeMember;
@W3C::XML::SchemaValidator::TreeMember::ISA = qw(W3C::XML::SchemaValidator::Textual);
use W3C::Util::Exception;

sub new {
    my ($proto, $parser, @EXPRARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser);
    $self->{PREFIX_ANNOT} = undef;
    $self->{PARENT} = undef;
    return $self;
}

sub _setParent {$_[0]->{PARENT} = $_[1]}

sub checkRestrictions {
    my ($self, $context, $dad, $alpha) = @_;
    &throw(new W3C::Util::NotImplementedException(-callingClass => $_[0]));
}

sub addLeftPrefixAnnot {
    my ($self, $annot) = @_;
    $self->addRightPrefixAnnot($annot);
}

sub addRightPrefixAnnot {
    my ($self, $annot) = @_;
    $self->{PREFIX_ANNOT} = $annot;
}

sub prefixAnnotToString {
    my ($self, $hit, $out) = @_;
    $self->protect(sub {
	my @ret;
	if ($self->{PREFIX_ANNOT}) {
	    push (@ret, "\n      [");
	    foreach my $annot (@{$self->{PREFIX_ANNOT}}) {
		push (@ret, $annot->toRnc($hit, $out));
	    }
	    push (@ret, ']');
	}
	join ('', @ret);
    }, $self->{PREFIX_ANNOT});
}

sub _someGumProf {
    my ($self, $l) = @_;
    my $someElt = $l & $ELEMENT ? $SOME_ELEMENT : 0;
    return $l | $someElt;
}

package W3C::XML::SchemaValidator::TreeParent;
@W3C::XML::SchemaValidator::TreeParent::ISA = qw(W3C::XML::SchemaValidator::TreeMember);
use W3C::Util::Exception;

sub new {
    my ($proto, $parser, $children, @EXPRARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, @EXPRARGS);
    if (!defined $children) {
	&throw(new W3C::Util::Exception(-message => "$class constructor error"));
    }
    foreach my $child (@$children) {
	$child->_setParent($self);
    }
    return $self;
}

package W3C::XML::SchemaValidator::PatternQualifier;
@W3C::XML::SchemaValidator::PatternQualifier::ISA = qw(W3C::XML::SchemaValidator::TreeParent ProductionStackEntry);

sub new {
    my ($proto, $parser, $pattern, @EXPRARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, [$pattern], @EXPRARGS);
    $self->{PATTERN} = $pattern;
    return $self;
}

sub prodStackEnt_toString {
    my ($self) = @_;
    return $self->_getNamePrefix.$self->_getNamePostfix();
}

sub prodStackEnt_getFollowAnnots {}

sub _getReferers {
    my ($self, $caller, $productions, $visited, $xslWriter) = @_;
    return $self->{PATTERN}->_getReferers($caller, [@$productions, $self], $visited, $xslWriter); # !!!
}

sub _knownAttributes {
    my ($self, $elAttr, $mayMustNot) = @_;
    $self->{PATTERN}->_knownAttributes($elAttr, $self->_mayMustNot($mayMustNot));
}

sub _arcToDot {
    my ($self, $fromNode, $visited, $dotWriter) = @_;
    $self->{PATTERN}->_larcToDot($fromNode, $self->getPrefix.$self->getPostfix(), $visited, $dotWriter);
}

sub _larcToDot {
    my ($self, $fromNode, $label, $visited, $dotWriter) = @_;
    $self->{PATTERN}->_larcToDot($fromNode, $label.$self->getPrefix.$self->getPostfix(), $visited, $dotWriter);
}

sub _toSummary {
    my ($self, $smryCtx) = @_;
    my $patStr = $self->{PATTERN}->_toSummary($smryCtx);
    return $patStr ? $self->getPrefix.$patStr.$self->getPostfix() : '';
}

sub toRnc {
    my ($self, $hit, $out) = @_;
    return $self->protect(sub {$self->getPrefix.$self->{PATTERN}->toRnc($hit, $out).$self->getPostfix}, $self->{PATTERN});
}

sub getPrefix {''}
sub getPostfix {''}
sub _getNamePrefix {''}
sub _getNamePostfix {''}

sub addLeftPrefixAnnot {
    my ($self, $annot) = @_;
    $self->{PATTERN}->addLeftPrefixAnnot($annot);
}

sub addRightPrefixAnnot {
    my ($self, $annot) = @_;
    $self->{PATTERN}->addRightPrefixAnnot($annot);
}

package W3C::XML::SchemaValidator::PatternOpt;
@W3C::XML::SchemaValidator::PatternOpt::ISA = qw(W3C::XML::SchemaValidator::PatternQualifier);

sub getPostfix {return '?'}
sub _getNamePostfix {return 'opt'}
sub _mayMustNot {$COMP_MAY};

sub checkRestrictions {
    my ($self, $context, $dad, $alpha) = @_;
    my $newOpts = $self->{PATTERN}->checkRestrictions($context, $self, $alpha);
    if (!$newOpts) {
	return 1;
    }
    return $newOpts;
}

#sub _getUniqueMatch {} # ($SOME_ELEMENT, '')}
sub _getUniqueMatch {
    my ($self, $generation, $nextGeneration, $gumVisited, $gumCtx) = @_;
    my ($gunProf, $str) = $self->{PATTERN}->_getUniqueMatch($generation, $nextGeneration, $gumVisited, $gumCtx);
    ($self->_someGumProf($gunProf), '');
}

package W3C::XML::SchemaValidator::PatternStar;
@W3C::XML::SchemaValidator::PatternStar::ISA = qw(W3C::XML::SchemaValidator::PatternQualifier);

sub getPostfix {return '*'}
sub _getNamePostfix {return 'star'}
sub _mayMustNot {$COMP_MAY};

sub checkRestrictions {
    my ($self, $context, $dad, $alpha) = @_;
    my $newOpts = $self->{PATTERN}->checkRestrictions($context, $self, $alpha);
    if (!$newOpts) {
	return $self;
    }
    return ref $newOpts ? $newOpts : [$self];
}

#sub _getUniqueMatch {} # ($SOME_ELEMENT, '')}
sub _getUniqueMatch {
    my ($self, $generation, $nextGeneration, $gumVisited, $gumCtx) = @_;
    my ($gunProf, $str) = $self->{PATTERN}->_getUniqueMatch($generation, $nextGeneration, $gumVisited, $gumCtx);
    ($self->_someGumProf($gunProf), '');
}

package W3C::XML::SchemaValidator::NegatedPattern;
@W3C::XML::SchemaValidator::NegatedPattern::ISA = qw(W3C::XML::SchemaValidator::PatternQualifier);

sub getPrefix {return '- '}
sub _getNamePrefix {return 'Not'}
sub _mayMustNot {$_[0] == $COMP_MUST ? $COMP_NOT : $_[0] == $COMP_NOT ? $COMP_MUST : $COMP_MAY};

sub checkRestrictionsNEEDED {
    my ($self, $context, $dad, $alpha) = @_;
}

package W3C::XML::SchemaValidator::Text;
@W3C::XML::SchemaValidator::Text::ISA = qw(W3C::XML::SchemaValidator::TreeMember);

sub new {
    my ($proto, $parser, @EXPRARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, @EXPRARGS);
    return $self;
}

sub getMatches {
    my ($self) = @_;
    return [$self]
}

sub _getUniqueMatch {
    my ($self, $generation, $nextGeneration, $gumVisited, $gumCtx) = @_;
    return ($TEXT, 'text()');
}

sub _getReferers {
    my ($self, $caller, $productions, $visited, $xslWriter) = @_;
    return []; # !!! "Text: $caller, $visited".$self->_toSummary;
}

sub _knownAttributes {}

sub _arcToDot {
    my ($self, $fromNode, $visited, $dotWriter) = @_;
}

sub _toSummary {
    my ($self, $smryCtx) = @_;
    return '';
}

sub toRnc {
    my ($self, $hit, $out) = @_;
    return $self->protect(sub {'text'});
}

sub checkRestrictionsNEEDED {
    my ($self, $context, $dad, $alpha) = @_;
}

package W3C::XML::SchemaValidator::Empty;
@W3C::XML::SchemaValidator::Empty::ISA = qw(W3C::XML::SchemaValidator::Text);

package W3C::XML::SchemaValidator::ReferencePattern;
@W3C::XML::SchemaValidator::ReferencePattern::ISA = qw(W3C::XML::SchemaValidator::TreeMember);
# Does not participate in the TreeParent setParent 'cause it resolves parents later
# on in fixReference.

sub new {
    my ($proto, $parser, $id, @EXPRARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, @EXPRARGS);
    $self->{ID} = $id;
    return $self;
}

sub getMatches {
    my ($self) = @_;
    return $self->{REF}->getMatches();
}

sub _getUniqueMatch {
    my ($self, $generation, $nextGeneration, $gumVisited, $gumCtx) = @_;
    return $self->{REF}->_getUniqueMatch($generation, $nextGeneration, $gumVisited, $gumCtx);
}

sub _getReferers {
    my ($self, $caller, $productions, $visited, $xslWriter) = @_;
    return $self->{REF}->_getReferers($caller, $productions, $visited, $xslWriter);
}
    
sub _knownAttributes {
    my ($self, $elAttr, $mayMustNot) = @_;
    $self->{REF}->_knownAttributes($elAttr, $mayMustNot);
}

sub _arcToDot {
    my ($self, $fromNode, $visited, $dotWriter) = @_;
    $self->{REF}->_arcToDot($fromNode, $visited, $dotWriter);
}

sub _larcToDot {
    my ($self, $fromNode, $label, $visited, $dotWriter) = @_;
    $self->{REF}->_larcToDot($fromNode, $label, $visited, $dotWriter);
}
    
sub _toSummary {
    my ($self, $smryCtx) = @_;
    return $self->{REF}->_toSummary($smryCtx);
}

sub toRnc {
    my ($self, $hit, $out) = @_;
    if (!ref $hit eq 'ARRAY') {
	$hit = {};
    }
    if (exists $hit->{$self->{ID}}) {
	return $self->{ID}->toRnc($hit, $out);
    }
    $hit->{$self->{ID}} = undef;
    return $self->protect(sub {$self->prefixAnnotToString($out).($self->{REF} ? $self->{REF}->toRnc($hit, $out) : $self->{ID}->toRnc($hit, $out))}, $self->{ID}, $self->{REF});
}

sub checkRestrictions {
    my ($self, $context, $dad, $alpha) = @_;
    $self->{REF}->checkRestrictions($context, $dad, $alpha);
}

sub fixReference { # pass 2
    my ($self, $ref) = @_;
    $self->{REF} = $ref;
    $ref->_addParent($self);
}

#sub getOpts {$_[0]->{REF}->getOpts}

package W3C::XML::SchemaValidator::Mixed;
@W3C::XML::SchemaValidator::Mixed::ISA = qw(W3C::XML::SchemaValidator::TreeParent);

sub new {
    my ($proto, $parser, $pattern, $annotOpt, @EXPRARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, [$pattern], @EXPRARGS);
    $self->{PATTERN} = $pattern;
    $self->{PATTERN_ANNOT} = $annotOpt;
    return $self;
}

sub getMatch {}

sub getPatternAnnotation {
    my ($self) = @_;
    return $self->{PATTERN_ANNOT};
}

sub checkRestrictionsNEEDED {
    my ($self, $context, $dad, $alpha) = @_;
}

sub _getUniqueMatch {
    my ($self, $generation, $nextGeneration, $gumVisited, $gumCtx) = @_;
    return ($MIXED, "(text() $OR *)");
}

sub _getReferers {
    my ($self, $caller, $productions, $visited, $xslWriter) = @_;
    # my $label = join (' ', map {$_->prodStackEnt->toString} @$productions);
    $visited->{$self} = $self; # my $childTemplate = $xslWriter->getTemplate($self);

    $self->_addCaller($caller, $productions);
    return [$visited->{$self}]; # "Mixed: $template, $label, $visited".$self->_toSummary;
}

sub _knownAttributes {}

sub _larcToDot {
    my ($self, $fromNode, $label, $visited, $dotWriter) = @_;
}

sub _toSummary {
    my ($self, $smryCtx) = @_;
    return 'mixed {'.$self->{PATTERN}->_toSummary($smryCtx).'}';
}

sub toRnc {
    my ($self, $hit, $out) = @_;
    return $self->protect(sub {'mixed {'.$self->{PATTERN}->toRnc($hit, $out).'}'}, $self->{PATTERN});
}

package W3C::XML::SchemaValidator::NameOptDTV;
@W3C::XML::SchemaValidator::NameOptDTV::ISA = qw(W3C::XML::SchemaValidator::TreeMember);
# Don't bother telling $dtv about its parent.

sub new {
    my ($proto, $parser, $dtv, $annotOpt, @EXPRARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, @EXPRARGS);
    $self->{DTV} = $dtv;
    return $self;
}

sub checkRestrictionsNEEDED {
    my ($self, $context, $dad, $alpha) = @_;
}

sub getMatches {
    my ($self) = @_;
    return [$self]
}

sub _toSummary {
    my ($self, $smryCtx) = @_;
    return $self->toString();
}

sub toRnc {
    my ($self, $hit, $out) = @_;
    return $self->protect(sub {$self->{DTV}->toRnc($hit, $out)}, $self->{DTV});
}

package W3C::XML::SchemaValidator::ElAttr;
@W3C::XML::SchemaValidator::ElAttr::ISA = qw(W3C::XML::SchemaValidator::TreeParent);
use W3C::Util::Exception;

sub new {
    my ($proto, $parser, $nameClass, $pattern, $nameAnnotOpt, $patternAnnotOpt, @EXPRARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, [$nameClass, $pattern], @EXPRARGS);
    if ($patternAnnotOpt) {
	$pattern->addLeftPrefixAnnot($patternAnnotOpt);
    }
    $self->{NAME_CLASS} = $nameClass;
    $self->{PATTERN} = $pattern;
    $self->{NAME_ANNOT} = $nameAnnotOpt;
    $self->{PATTERN_ANNOT} = $patternAnnotOpt;
    return $self;
}

sub toRnc {
    my ($self, $hit, $out) = @_;
    return $self->protect(sub {$self->getPrefix.' '.$self->{NAME_CLASS}->toRnc($hit, $out)." {\n".$self->{PATTERN}->toRnc($hit, $out)."\n}"}, $self->{NAME_CLASS}, $self->{PATTERN});
}

sub getPatternAnnotation {
    my ($self) = @_;
    return $self->{PATTERN_ANNOT};
}

sub _nextGeneration {
    my ($self, $generation, $nextGeneration) = @_;
    return $generation eq 'self::' ? '' : $generation eq '' ? "$nextGeneration/" : "$generation$nextGeneration/";
}

#sub getOpts {()}

package W3C::XML::SchemaValidator::Element;
@W3C::XML::SchemaValidator::Element::ISA = qw(W3C::XML::SchemaValidator::ElAttr);
use W3C::Util::Exception;

sub checkRestrictions {
    my ($self, $context, $dad, $alpha) = @_;
    my ($namespace, $localName, $qName, $attributeList) = @$context;
    if ($self->{NAME_CLASS}->checkRestrictions($context, $dad, $alpha)) {
	return $self->{PATTERN}->checkRestrictions($context, $dad, $alpha);
    } else {
	return 0;
    }
}

sub getPrefix {return 'element'}

sub _getReferers {
    my ($self, $caller, $productions, $visited, $xslWriter) = @_;

    # The element we are expanding calls another element.
    if ($visited->{$self}) {
	$visited->{$self}->_addCaller($caller, $productions);
    } else {
	$visited->{$self} = $self; $xslWriter->getTemplate($productions, $self);

	$self->_addCaller($caller, $productions);
	$self->{NAME_CLASS}->_knownElements($self, $COMP_MUST);
	$self->{PATTERN}->_knownAttributes($self, $COMP_MUST);
	my $foo = $self->{PATTERN}->_getReferers($self, [], $visited, $xslWriter);
	$self->_setNext($foo);
    }
    return [$visited->{$self}];
}

sub _knownAttributes {} # LIMITER

sub toXPath {
    my ($self, $generation) = @_;
    return $self->{NAME_CLASS}->toXPath($generation);
}

# We shoot for a match constraint that will uniquely identify it.
# Implementation currently lags well behind the actual expressibility
# of RelaxNG.
sub getUniqueMatch {
    my ($self) = @_;
    my ($gunProf, $str) = $self->_getUniqueMatch1('self::', {}, {});
    return $str;
}

sub _getUniqueMatch {
    my ($self, $generation, $nextGeneration, $gumVisited, $gumCtx) = @_;
    return $self->_getUniqueMatch1($self->_nextGeneration($generation, $nextGeneration), $gumVisited, $gumCtx);
}

sub _getUniqueMatch1 {
    my ($self, $generation, $gumVisited, $gumCtx) = @_;
    if (!exists $gumVisited->{$self}) {
	$gumVisited->{$self} = $self;
	my $nextGeneration = $self->{NAME_CLASS}->getMatch() || '*';
	my ($ncGunProf, $nc) = $self->{NAME_CLASS}->_getUniqueMatch($generation, $nextGeneration, $gumVisited, $gumCtx);
	my ($patGunProf, $pat) = $self->{PATTERN}->_getUniqueMatch($generation, $nextGeneration, $gumVisited, $gumCtx);
	my $noEltStr = $patGunProf & ($ELEMENT|$SOME_ELEMENT) ? '' : ''; # " $AND $NOT (".$self->_nextGeneration($generation, $nextGeneration).'*)';
	return ($ncGunProf, $nc && $pat ? "$nc$noEltStr $AND $pat" : $nc ? "$nc$noEltStr" : "$pat$noEltStr");
    }
    return (0, '')
}

sub _larcToDot {
    my ($self, $fromNode, $label, $visited, $dotWriter) = @_;
    $dotWriter->addNode($self, {%$DfltNodeAttrs,
				'label' => $self->_toSummary({-showExcept => $ShowExceptClauses, 
							      -interestingAttrs => $dotWriter->getInterestingAttrs})});
    $dotWriter->addArc($fromNode, $self, {'label' => $label, 'color' => 'Red'});
    if (!$visited->{$self}) {
	$visited->{$self} = 1;
	$self->{PATTERN}->_arcToDot($self, $visited, $dotWriter);
    }
}

sub _toSummary {
    my ($self, $smryCtx) = @_;
    $smryCtx ||= {};
    return $smryCtx->{-noElts} ? '' : '<'.$self->{NAME_CLASS}->_toSummary($smryCtx).'> '.
	$self->{PATTERN}->_toSummary({%$smryCtx, -noElts => 1});
}

package W3C::XML::SchemaValidator::Attribute;
@W3C::XML::SchemaValidator::Attribute::ISA = qw(W3C::XML::SchemaValidator::ElAttr);

sub checkRestrictions {
    my ($self, $context, $dad, $alpha) = @_;
    return $self->{NAME_CLASS}->checkRestrictions($context, $dad, $alpha);
#    my ($namespace, $localName, $qName, $attributeList) = @$context;
#    return defined $attributeList->getValue($self->{NAME_CLASS}->getNamespace, $self->{NAME_CLASS}->getLocalName);
}

sub getPrefix {return 'attribute'}

sub _getUniqueMatch {
    my ($self, $generation, $nextGeneration, $gumVisited, $gumCtx) = @_;
    my $value = $self->{PATTERN}->getMatches(); # @@@ do some conjunctive normal form arithmetic

    my $ncGumCtx = {%$gumCtx, -isAttr => 1};
    if ($value) {
	$ncGumCtx->{-attrValue} = $value; # ->[0]->toString();
    }
    my ($ncGumProf, $ncStr) = $self->{NAME_CLASS}->_getUniqueMatch($self->_nextGeneration($generation, $nextGeneration), $nextGeneration, $gumVisited, $ncGumCtx);
    return ($ATTRIB, $ncStr);

    my $t = $self->{NAME_CLASS}->getMatches(); # _toSummary({{}, -isAttr => 0}); # get nice NCName
    my $tStr = $t->[0]->toString();
    my $valueStr = $value ? '='.$value->[0]->toString() : '';
    $valueStr =~ s/\"/\'/g; # just to be stylin'
    return ($ATTRIB, "\@$tStr$valueStr");
}

sub _getReferers {
    my ($self, $caller, $productions, $visited, $xslWriter) = @_;
    my $value = $self->{PATTERN}->getMatches(); # @@@ do some conjunctive normal form arithmetic
    my $t = $self->{NAME_CLASS}->getMatches(); # _toSummary({{}, -isAttr => 0}); # get nice NCName
    $caller->_addPositive($t, $value, $productions);
    return []; # attributes present no targets
}

sub _knownAttributes {
    my ($self, $elAttr, $mayMustNot) = @_;
    $self->{NAME_CLASS}->_knownAttributes($elAttr, $mayMustNot);
}

sub _larcToDot {
    my ($self, $fromNode, $label, $visited, $dotWriter) = @_;
    # Don't render attributes in the Dot format.
}

sub _toSummary {
    my ($self, $smryCtx) = @_;
    $smryCtx ||= {};
    my $value = $self->{PATTERN}->_toSummary({%$smryCtx, -isAttr => 1});
    return $self->{NAME_CLASS}->_toSummary({%$smryCtx, -isAttr => 1}).($value ? "=$value" : '');
}

package W3C::XML::SchemaValidator::BinaryPattern;
@W3C::XML::SchemaValidator::BinaryPattern::ISA = qw(W3C::XML::SchemaValidator::TreeParent);
use W3C::Util::Exception;

sub new {
    my ($proto, $parser, $l, $r, @EXPRARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, [$l, $r], @EXPRARGS);
    $self->{L} = $l;
    $self->{R} = $r;
    return $self;
}

sub checkRestrictions {
    my ($self, $context, $dad, $alpha) = @_;
    my $newOpts = $self->{L}->checkRestrictions($context, $self, $alpha);
    if (!$newOpts || ref $newOpts eq 'ARRAY') {
	return $newOpts;
    }
    return $self->{R}->checkRestrictions($context, $self, $alpha);
}

sub _getUniqueMatch {
    my ($self, $generation, $nextGeneration, $gumVisited, $gumCtx) = @_;
    my ($lGumProf, $lStr) = $self->{L}->_getUniqueMatch($generation, $nextGeneration, $gumVisited, $gumCtx);
    my ($rGumProf, $rStr) = $self->{R}->_getUniqueMatch($generation, $nextGeneration, $gumVisited, $gumCtx);
    my $infix = $self->getInfixWord;
    my $gumProf = $self->_gumProf($lGumProf, $rGumProf);
    return $lStr && $rStr ? ($gumProf, "$lStr$infix$rStr") : ($gumProf, "$lStr$rStr");
}

sub _getReferers {
    my ($self, $caller, $productions, $visited, $xslWriter) = @_;
    my $l = $self->{L}->_getReferers($caller, $productions, $visited, $xslWriter);
    my $r = $self->{R}->_getReferers($caller, $productions, $visited, $xslWriter);
    return [@$l, @$r];
}

sub _knownElements {
    my ($self, $elAttr, $mayMustNot) = @_;
    $self->{L}->_knownElements($elAttr, $mayMustNot);
    $self->{R}->_knownElements($elAttr, $mayMustNot);
}

sub _knownAttributes {
    my ($self, $elAttr, $mayMustNot) = @_;
    $self->{L}->_knownAttributes($elAttr, $mayMustNot);
    $self->{R}->_knownAttributes($elAttr, $mayMustNot);
}

sub _arcToDot {
    my ($self, $fromNode, $visited, $dotWriter) = @_;
    $self->{L}->_arcToDot($fromNode, $visited, $dotWriter);
    $self->{R}->_arcToDot($fromNode, $visited, $dotWriter);
}

sub _larcToDot {
    my ($self, $fromNode, $label, $visited, $dotWriter) = @_;
    $self->{L}->_larcToDot($fromNode, $label, $visited, $dotWriter);
    $self->{R}->_larcToDot($fromNode, $label, $visited, $dotWriter);
}

sub toRnc {
    my ($self, $hit, $out) = @_;
    return $self->protect(sub {$self->{L}->toRnc($hit, $out).$self->getInfix.$self->{R}->toRnc($hit, $out)}, $self->{L}, $self->{R});
}

sub _toSummary {
    my ($self, $smryCtx) = @_;
    my $lStr = $self->{L}->_toSummary($smryCtx);
    my $rStr = $self->{R}->_toSummary($smryCtx);
    my $infix = $self->getInfix;
    return $lStr && $rStr ? "$lStr$infix$rStr" : "$lStr$rStr";
    return $self->protect(sub {$self->{L}->_toSummary().$self->getInfix.$self->{R}->_toSummary()}, $self->{L}, $self->{R});
}

sub getInfix {&throw(new W3C::Util::NotImplementedException(-callingClass => $_[0]))}

sub getInfixWord {&throw(new W3C::Util::NotImplementedException(-callingClass => $_[0]))}

sub _gumProf {&throw(new W3C::Util::NotImplementedException(-callingClass => $_[0]))}

package W3C::XML::SchemaValidator::BinaryPatternWithAnnot;
@W3C::XML::SchemaValidator::BinaryPatternWithAnnot::ISA = qw(W3C::XML::SchemaValidator::BinaryPattern);
use W3C::Util::Exception;

sub new {
    my ($proto, $parser, $l, $r, $annotOpt, @EXPRARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, $l, $r, @EXPRARGS);
    if ($annotOpt) {
	$r->addRightPrefixAnnot($annotOpt);
    }
    return $self;
}

sub addLeftPrefixAnnot {
    my ($self, $annot) = @_;
    $self->{L}->addLeftPrefixAnnot($annot);
}

sub addRightPrefixAnnot {
    my ($self, $annot) = @_;
    $self->{R}->addLeftPrefixAnnot($annot);
}

package W3C::XML::SchemaValidator::PatternSequence;
@W3C::XML::SchemaValidator::PatternSequence::ISA = qw(W3C::XML::SchemaValidator::BinaryPatternWithAnnot);
sub getInfix {return ', '}
sub getInfixWord {return " $AND "}
sub _gumProf {$_[1] | $_[2]}

package W3C::XML::SchemaValidator::PatternPipe;
@W3C::XML::SchemaValidator::PatternPipe::ISA = qw(W3C::XML::SchemaValidator::BinaryPatternWithAnnot);
sub getInfix {return ' | '}
sub getInfixWord {return " $OR "}
sub _gumProf {($_[1] & $_[2]) | $_[0]->_someGumProf($_[1] | $_[2]);}
sub getMatches {
    my ($self) = @_;
    return [@{$self->{L}->getMatches()}, @{$self->{R}->getMatches()}];
}

package W3C::XML::SchemaValidator::PatternGroup;
@W3C::XML::SchemaValidator::PatternGroup::ISA = qw(W3C::XML::SchemaValidator::TreeParent);
use W3C::Util::Exception;

sub new {
    my ($proto, $parser, $pattern, $annotOpt, @EXPRARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, [$pattern], @EXPRARGS);
    if ($annotOpt) {
	$pattern->addLeftPrefixAnnot($annotOpt);
    }
    $self->{PATTERN} = $pattern;
    return $self;
}

sub _getReferers {
    my ($self, $caller, $productions, $visited, $xslWriter) = @_;
    $self->{PATTERN}->_getReferers($caller, $productions, $visited, $xslWriter);
}

sub _knownAttributes {
    my ($self, $elAttr, $mayMustNot) = @_;
    $self->{PATTERN}->_knownAttributes($elAttr, $mayMustNot);
}

sub _larcToDot {
    my ($self, $fromNode, $label, $visited, $dotWriter) = @_;
    $self->{PATTERN}->_larcToDot($fromNode, $label, $visited, $dotWriter);
}

sub _toSummary {
    my ($self, $smryCtx) = @_;
    return '( '.$self->{PATTERN}->_toSummary($smryCtx).' )';
}

sub toRnc {
    my ($self, $hit, $out) = @_;
    return $self->protect(sub {'( '.$self->{PATTERN}->toRnc($hit, $out).' )'}, $self->{PATTERN});
}

sub checkRestrictions {
    my ($self, $context, $dad, $alpha) = @_;
    return $self->{PATTERN}->checkRestrictions($context, $dad, $alpha);
}

sub _getUniqueMatch {
    my ($self, $generation, $nextGeneration, $gumVisited, $gumCtx) = @_;
    return $self->{PATTERN}->_getUniqueMatch($generation, $nextGeneration, $gumVisited, $gumCtx);
}

package W3C::XML::SchemaValidator::OrphanStuff;
@W3C::XML::SchemaValidator::OrphanStuff::ISA = qw(W3C::XML::SchemaValidator::Textual);
sub _setParent {}

package W3C::XML::SchemaValidator::Grammar;
@W3C::XML::SchemaValidator::Grammar::ISA = qw(W3C::XML::SchemaValidator::Textual);

sub new {
    my ($proto, $parser, $decls, $pats, $start, @STUFFARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, @STUFFARGS);
    $self->{DECLS} = $decls;
    $self->{PATS} = $pats;
    $self->{START} = $start;
    $self->{NAMESPACES} = [];
    return $self;
}

sub getReferers {
    my ($self, $xslWriter) = @_;
    foreach my $decl (@{$self->{DECLS}}) {
	if ($decl->isa('W3C::XML::SchemaValidator::NsDecl')) {
	    $self->ns_decl($decl->_getDeclaration());
	}
    }
    return $self->{START}->getReferers($xslWriter);
}

sub ns_decl {
    my ($self, $prefix, $namespace) = @_;
    push (@{$self->{NAMESPACES}}, [$prefix, $namespace]);
}
sub ns_toXsl {
    my ($self) = @_;
    my $nsDeclsStr = join ("\n ", map {"xmlns:$_->[0]=\"$_->[1]\""} @{$self->{NAMESPACES}});
}

sub _toDot {
    my ($self, $visited, $dotWriter) = @_;
    $self->{START}->_toDot($visited, $dotWriter);
}

sub toRnc {
    my ($self, $hit, $out) = @_;
    my @ret;
    foreach my $decl (@{$self->{DECLS}}) {
	push (@ret, $decl->toRnc($hit, $out));
    }
    foreach my $pat (@{$self->{PATS}}) {
	my ($grammarContent, $followAnnnotStar) = @$pat;
	push (@ret, $grammarContent->toRnc($hit, $out));
	if ($followAnnnotStar) {
	    foreach my $followAnnot (@$followAnnnotStar) {
		push (@ret, $followAnnot->toRnc($hit, $out));
	    }
	}
    }
    return join ("\n", @ret);
}

package W3C::XML::SchemaValidator::NCName;
@W3C::XML::SchemaValidator::NCName::ISA = qw(W3C::XML::SchemaValidator::OrphanStuff);
use W3C::Util::Exception;

sub new {
    my ($proto, $parser, $ns, $prefix, $localName, @STUFFARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, @STUFFARGS);
    $self->{NS} = $ns;
    $self->{PREFIX} = $prefix;
    $self->{LOCALNAME} = $localName;
    return $self;
}

sub toXPath {
    my ($self, $generation) = @_;
    return $self->{PREFIX} ? "${generation}$self->{PREFIX}:$self->{LOCALNAME}" : "${generation}$self->{LOCALNAME}";
}

sub getMatches {
    my ($self) = @_;
    return [$self]; # "$self->{PREFIX}:$self->{LOCALNAME}"
}

sub _getUniqueMatch {
    my ($self, $generation, $nextGeneration, $gumVisited, $gumCtx) = @_;
    my $prefix = '';
    if ($gumCtx && $gumCtx->{-isAttr}) {
	$prefix = '@';
    }
    my $selfStr = $self->toString();
    if (exists $gumCtx->{-attrValue}) {
	if (@{$gumCtx->{-attrValue}} < 1) {
	    &throw();
	}
	my $specs = [];
	foreach my $val (@{$gumCtx->{-attrValue}}) {
	    if ($val->isa('W3C::XML::SchemaValidator::Text')) {
		# @@@ Make sure value is text.
		push (@$specs, "$generation$prefix$selfStr");
	    } elsif ($val->isa('W3C::XML::SchemaValidator::NCName')) {
		# @@@ Make sure value is some datatype.
		my $dtStr = $val->toString;
		push (@$specs, "$generation$prefix$selfStr"); # @@@ NCName ($dtStr)");
	    } elsif ($val->isa('W3C::XML::SchemaValidator::NameOptDTV')) {
		# @@@ Make sure value is some datatype.
		my $dtStr = $val->toString;
		$dtStr =~ s/\"/\'/g;
		push (@$specs, "$generation$prefix$selfStr=$dtStr");
	    } elsif ($val->isa('W3C::XML::SchemaValidator::String')) {
		# @@@ &throw(new W3C::Util::Exception(-message => "unused $val"));
		my $valStr = $val->toString;
		push (@$specs, "$generation$prefix$selfStr"); #  String ($valStr)");
	    } else {
		&throw(new W3C::Util::Exception(-message => "unhandled $val"));
	    }
	}
	if (@{$gumCtx->{-attrValue}} == 1) {
	    return ($NCNAME, $specs->[0]);
	} else {
	    my $specStr = join(" $OR ", @$specs);
	    return ($NCNAME, "($specStr)");
	}
    } else {
	return ($NCNAME, "$generation$prefix$selfStr");
    }
}

sub _getReferers {
    my ($self, $caller, $productions, $visited, $xslWriter) = @_;
    return [];
}

sub _knownElements {
    my ($self, $elAttr, $mayMustNot) = @_;
    $elAttr->_addKnownElement($self, $mayMustNot);
}

sub _knownAttributes {
    my ($self, $elAttr, $mayMustNot) = @_;
    $elAttr->_addKnownAttribute($self, $mayMustNot);
}

sub _toSummary {
    my ($self, $smryCtx) = @_;
    my $disinterest = 0;
    my $prefix = '';
    if ($smryCtx && $smryCtx->{-isAttr}) {
	$prefix = '@';
	if ($smryCtx->{-interestingAttrs}) {
	    $disinterest = 1;
	    my $lName = $self->getLocalName;
	    foreach my $attr (@{$smryCtx->{-interestingAttrs}}) {
		if ($attr eq $lName) {
		    $disinterest = 0;
		    last;
		}
	    }
	}
    }
    return $disinterest ? '' : $prefix.$self->toString();
}

sub toRnc {
    my ($self, $hit, $out) = @_;
    my $joinChar =  $self->{PREFIX} ? ':' : '';
    return $self->protect(sub {$self->{PREFIX} ? "$self->{PREFIX}$joinChar$self->{LOCALNAME}" : "$self->{LOCALNAME}"});
}

sub getNamespace {(ref ($_[0]->{NS}) eq 'SCALAR') ? $ {$_[0]->{NS}} : $_[0]->{NS}->getVal}
sub getLocalName {$_[0]->{LOCALNAME}}
sub _getDotName {$_[0]} # ->getNamespace.'::'.$_[0]->getLocalName
sub checkRestrictions {
    my ($self, $context, $dad, $alpha) = @_;
    my ($namespace, $localName, $qName, $attributeList) = @$context;
    return $self->{NS}->matches($namespace) && $self->{LOCALNAME} eq $localName;
}

package W3C::XML::SchemaValidator::Namespace;
@W3C::XML::SchemaValidator::Namespace::ISA = qw(W3C::XML::SchemaValidator::Textual);
use vars qw($NS_default);
($NS_default) = ($W3C::XML::SchemaValidatorDataTypes::NS_default) = (\ '::NS_default');
push (@W3C::XML::SchemaValidatorDataTypes::EXPORT_OK, qw($NS_default));

sub new {
    my ($proto, $parser, $ns, @STUFFARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, @STUFFARGS);
    $self->{NS} = $ns;
    return $self;
}

sub toRnc {
    my ($self, $hit, $out) = @_;
    return $self->protect(sub {$self->{NS} ? $self->{NS} : 'local'});
}

sub getNS {$_[0]->{NS}}

package W3C::XML::SchemaValidator::SimpleValue;
@W3C::XML::SchemaValidator::SimpleValue::ISA = qw(W3C::XML::SchemaValidator::OrphanStuff);
use W3C::Util::Exception;

sub new {
    my ($proto, $parser, $val, @STUFFARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, @STUFFARGS);
    $self->{VAL} = $val;
    return $self;
}

sub getMatches {
    my ($self) = @_;
    return [$self]
}

sub _toSummary {
    my ($self, $smryCtx) = @_;
    return '';
}

sub toRnc {
    my ($self, $hit, $out) = @_;
    return $self->protect(sub {$self->{VAL}});
}

package W3C::XML::SchemaValidator::String;
@W3C::XML::SchemaValidator::String::ISA = qw(W3C::XML::SchemaValidator::SimpleValue);
sub toRnc {'string'}

package W3C::XML::SchemaValidator::Token;
@W3C::XML::SchemaValidator::Token::ISA = qw(W3C::XML::SchemaValidator::SimpleValue);
sub toRnc {'token'}

package W3C::XML::SchemaValidator::AnyName;
@W3C::XML::SchemaValidator::AnyName::ISA = qw(W3C::XML::SchemaValidator::SimpleValue);
sub toRnc {'*'}
sub _toSummary {'@*'}
sub _knownElements {
    my ($self, $elAttr, $mayMustNot) = @_;
    $elAttr->_addKnownElement($self, $mayMustNot);
}
sub _knownAttributes {
    my ($self, $elAttr, $mayMustNot) = @_;
    $elAttr->_addKnownAttribute($self, $mayMustNot);
}


package W3C::XML::SchemaValidator::Assign;
@W3C::XML::SchemaValidator::Assign::ISA = qw(W3C::XML::SchemaValidator::TreeMember);
use W3C::Util::Exception;

sub new {
    my ($proto, $parser, $id, $val, @EXPRARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, @EXPRARGS);
    $self->{ID} = $id;
    $self->{VAL} = $val;
#    $self->toRnc($hit, $out)();
    return $self;
}

sub getId {return $_[0]->{ID}}

sub toRnc {&throw(new W3C::Util::NotImplementedException(-callingClass => $_[0]))}

sub checkRestrictions {
    my ($self, $context, $dad, $alpha) = @_;
    return $self->{VAL}->checkRestrictions($context, $dad, $alpha);
}

package W3C::XML::SchemaValidator::Define;
@W3C::XML::SchemaValidator::Define::ISA = qw(W3C::XML::SchemaValidator::Assign);
sub new {
    my ($proto, $parser, $id, $val, @EXPRARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, $id, $val, @EXPRARGS);
    $self->{FOLLOW_ANNOTS} = undef;

    # Move PARENTS code to common base class if ReferencePattern can reference
    # something besides a Define. The specification [1] doesn't specify the
    # connection between the "identifier"s in
    #   ref returns String  ::=
    #       identifier
    # and
    #   define returns Element  ::=
    #       identifierx  assignOpy  patternz
    #           { <define name=x y> z </define> }
    # as distinct from "identifier"s used in namespacePrefix, datatypePrefix,
    # optInherit, param, simpleNameClass, foreignElementName (annotations),
    # oreignElementNameNotKeyword (annotations), anyAttributeName,
    # anyElementName. Oh well, presume and proceed.
    # 
    # [1] http://www.relaxng.org/compact-20021121.html

    $self->{PARENTS} = [];
    return $self;
}

sub _addParent {push (@{$_[0]->{PARENTS}}, $_[1])}

sub setFollowAnnots {
    my ($self, $annots) = @_;
    $self->{FOLLOW_ANNOTS} = $annots;
}

sub getFollowAnnots {
    my ($self) = @_;
    return $self->{FOLLOW_ANNOTS};
}

sub getMatches {
    my ($self) = @_;
    return $self->{VAL}->getMatches();
}

sub _getUniqueMatch {
    my ($self, $generation, $nextGeneration, $gumVisited, $gumCtx) = @_;
    return $self->{VAL}->_getUniqueMatch($generation, $nextGeneration, $gumVisited, $gumCtx);
}

sub toRnc {
    my ($self, $hit, $out) = @_;
    return $self->protect(sub {$self->{ID}->toRnc($hit, $out)." =\n  ".$self->{VAL}->toRnc($hit, $out)."\n".($self->{FOLLOW_ANNOTS} ? join ('', map {'>> '.$_->toRnc} @{$self->{FOLLOW_ANNOTS}}) : '')}, $self->{ID}, $self->{VAL});
}

sub _getReferers {
    my ($self, $caller, $productions, $visited, $xslWriter) = @_;
    return $self->{VAL}->_getReferers($caller, [@$productions, $self], $visited, $xslWriter);
}

sub prodStackEnt_toString {$_[0]->{ID}->getLocalName()}
sub prodStackEnt_getFollowAnnots {$_[0]->{FOLLOW_ANNOTS}}

sub _knownAttributes {
    my ($self, $elAttr, $mayMustNot) = @_;
    $self->{VAL}->_knownAttributes($elAttr, $mayMustNot);
}

sub getReferers {
    my ($self, $xslWriter) = @_;
    # Don't include own name in production list when called to toXsl.
    $xslWriter->rootTemplate($self);
    $self->_setNext($self->{VAL}->_getReferers($self, [], {}, $xslWriter));
    # Instead, return own name to caller.
    return $self;
}

sub _arcToDot {
    my ($self, $fromNode, $visited, $dotWriter) = @_;
    $self->{VAL}->_larcToDot($fromNode, $self->{ID}->getLocalName(), $visited, $dotWriter);
}

sub _larcToDot {
    my ($self, $fromNode, $label, $visited, $dotWriter) = @_;
    my $lname = $self->{ID}->getLocalName();
    $self->{VAL}->_larcToDot($fromNode, "$label-$lname", $visited, $dotWriter);
}

sub _toDot {
    my ($self, $visited, $dotWriter) = @_;
    my $fromNode = $self; # $self->getId->_getDotName();
    $dotWriter->addNode($fromNode, {%$DfltNodeAttrs, 'label' => $self->getId->getLocalName});
    $self->{VAL}->_arcToDot($fromNode, $visited, $dotWriter);
}

sub _toSummary {
    my ($self, $smryCtx) = @_;
    return $self->{VAL}->_toSummary($smryCtx);
}

#sub getOpts {$_[0]->{VAL}->getOpts}

package W3C::XML::SchemaValidator::Start;
@W3C::XML::SchemaValidator::Start::ISA = qw(W3C::XML::SchemaValidator::Define);

sub _toDot {
    my ($self, $visited, $dotWriter) = @_;
    my $fromNode = $self; # $self->getId->_getDotName();
    $dotWriter->addNode($fromNode, {%$DfltNodeAttrs, %$StartAttrs, label => "start"});
    $self->{VAL}->_arcToDot($fromNode, $visited, $dotWriter);
}

sub getMatch {'.=/'} # fake for root element

sub _toSummary {
    my ($self, $smryCtx) = @_;
    return '/';
}

sub getPatternAnnotation {}

package W3C::XML::SchemaValidator::Decl;
@W3C::XML::SchemaValidator::Decl::ISA = qw(W3C::XML::SchemaValidator::Assign);
use W3C::Util::Exception;
sub toRnc {
    my ($self, $hit, $out) = @_;
    # return $self->protect(sub {$self->_getTypePrefix.' '.$self->{ID}.' = '.$self->{VAL}->toRnc($hit, $out)}, $self->{ID}, $self->{VAL});
    return $self->protect(sub {$self->_getTypePrefix.' '.$self->{ID}->toRnc($hit, $out).' = '.$self->{VAL}->toRnc($hit, $out)}, $self->{ID}, $self->{VAL});
}
sub _getTypePrefix {&throw(new W3C::Util::NotImplementedException(-callingClass => $_[0]))}

@W3C::XML::SchemaValidator::NsDecl::ISA = qw(W3C::XML::SchemaValidator::Decl);
sub W3C::XML::SchemaValidator::NsDecl::_getTypePrefix {return 'namespace'}
sub W3C::XML::SchemaValidator::NsDecl::_getDeclaration {($_[0]->{ID}->toString, $_[0]->{VAL}->getVal)}
@W3C::XML::SchemaValidator::DefaultNsDecl::ISA = qw(W3C::XML::SchemaValidator::NsDecl);
sub W3C::XML::SchemaValidator::DefaultNsDecl::_getTypePrefix {return 'default namespace'}
@W3C::XML::SchemaValidator::DatatypesDecl::ISA = qw(W3C::XML::SchemaValidator::Decl);
sub W3C::XML::SchemaValidator::DatatypesDecl::_getTypePrefix {return 'datatypes'}


# nameClass stuff -- cheesily re-using TreeParent stuff
package W3C::XML::SchemaValidator::NamePipe;
@W3C::XML::SchemaValidator::NamePipe::ISA = qw(W3C::XML::SchemaValidator::BinaryPattern);
sub getInfix {return ' | '}
sub getInfixWord {return " $OR "}
sub _gumProf {$_[1] | $_[2]}
sub getMatches {
    my ($self) = @_;
    return [@{$self->{L}->getMatches()}, @{$self->{R}->getMatches()}];
}

package W3C::XML::SchemaValidator::NameGroup;
@W3C::XML::SchemaValidator::NameGroup::ISA = qw(W3C::XML::SchemaValidator::TreeParent);
use W3C::Util::Exception;

sub new {
    my ($proto, $parser, $nameClass, $annotOpt, @EXPRARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, [$nameClass], @EXPRARGS);
    $self->{NAME_CLASS} = $nameClass;
    return $self;
}

sub getMatches {
    my ($self) = @_;
    return $self->{NAME_CLASS}->getMatches();
}

sub _getUniqueMatch {
    my ($self, $generation, $nextGeneration, $gumVisited, $gumCtx) = @_;
    my ($ncGumProf, $nameClassStr) = $self->{NAME_CLASS}->_getUniqueMatch($generation, $nextGeneration, $gumVisited, $gumCtx);
    return ($ncGumProf, "($nameClassStr)");
}

sub _knownElements {
    my ($self, $elAttr, $mayMustNot) = @_;
    $self->{NAME_CLASS}->_knownElements($elAttr, $COMP_NOT);
}

sub _knownAttributes {
    my ($self, $elAttr, $mayMustNot) = @_;
    $self->{NAME_CLASS}->_knownAttributes($elAttr, $COMP_NOT);
}

sub _toSummary {
    my ($self, $smryCtx) = @_;
    my $smryStr = $self->{NAME_CLASS}->_toSummary($smryCtx);
    return "($smryStr)";
}

sub toRnc {
    my ($self, $hit, $out) = @_;
    return $self->protect(sub {'( '.$self->{NAME_CLASS}->toRnc($hit, $out).' )'}, $self->{NAME_CLASS});
}

sub checkRestrictions {
    my ($self, $context, $dad, $alpha) = @_;
    return $self->{NAME_CLASS}->checkRestrictions($context, $dad, $alpha);
}

package W3C::XML::SchemaValidator::NegatedName;
@W3C::XML::SchemaValidator::NegatedName::ISA = qw(W3C::XML::SchemaValidator::PatternQualifier);

sub getPrefix {return '-'}
sub _mayMustNot {$_[0] == $COMP_MUST ? $COMP_NOT : $_[0] == $COMP_NOT ? $COMP_MUST : $COMP_MAY};

sub checkRestrictions {
    my ($self, $context, $dad, $alpha) = @_;
    my $newOpts = $self->{PATTERN}->checkRestrictions($context, $self, $alpha);
    if (ref $newOpts) {
	return $newOpts;
    }
    return !$newOpts;
}

sub _knownElements {
    my ($self, $elAttr, $mayMustNot) = @_;
    if ($mayMustNot == $COMP_NOT) {&throw()}
    $self->{PATTERN}->_knownElements($elAttr, $COMP_NOT);
}

sub _getUniqueMatch {
    my ($self, $generation, $nextGeneration, $gumVisited, $gumCtx) = @_;
    return $self->{PATTERN}->_getUniqueMatch($generation, $nextGeneration, $gumVisited, {%$gumCtx, -isNegated => 1});
}

package W3C::XML::SchemaValidator::AnyNameExcept;
@W3C::XML::SchemaValidator::AnyNameExcept::ISA = qw(W3C::XML::SchemaValidator::TreeParent);

sub new {
    my ($proto, $parser, $general, $exceptMe, @EXPRARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, $exceptMe ? [$general, $exceptMe] : [$general], @EXPRARGS);
    $self->{GENERAL} = $general;
    $self->{EXCEPT_ME} = $exceptMe; # @@@ NULL for "any = mixed { element * { attribute * { text }*, any }* }"

    return $self;
}

sub getMatches {
    my ($self) = @_;
    return [$self];
}

sub getMatch {
    my ($self) = @_;
    return undef;
}

sub _knownElements {
    my ($self, $elAttr, $mayMustNot) = @_;
    $self->{GENERAL}->_knownElements($elAttr, $mayMustNot);
    $self->{EXCEPT_ME}->_knownElements($elAttr, $mayMustNot);
}

sub _knownAttributes {
    my ($self, $elAttr, $mayMustNot) = @_;
    $self->{GENERAL}->_knownAttributes($elAttr, $mayMustNot);
    $self->{EXCEPT_ME}->_knownAttributes($elAttr, $mayMustNot);
}

sub _getUniqueMatch {
    my ($self, $generation, $nextGeneration, $gumVisited, $gumCtx) = @_;
    my $prefix = $gumCtx->{-isAttr} ? '@' : '';
    my ($exGumProf, $exceptionStr) = $self->{EXCEPT_ME}->_getUniqueMatch($generation, $nextGeneration, $gumVisited, $gumCtx);
    return ($exGumProf | $ELEMENT, "$generation$prefix*"); # $AND $NOT $exceptionStr");
}

sub _toSummary {
    my ($self, $smryCtx) = @_;
    $smryCtx ||= {};
    my $labelStr = $self->{GENERAL}->_toSummary({%$smryCtx});
    my $exceptStr = $smryCtx->{-showExcept} ? ' '.($self->{EXCEPT_ME} ? $self->{EXCEPT_ME}->_toSummary({%$smryCtx, -isAttr => 1}) : '!!noExcept!!') : '';
    return "$labelStr$exceptStr";
}

sub toRnc {
    my ($self, $hit, $out) = @_;
    return $self->protect(sub {$self->{GENERAL}->toRnc($hit, $out).($self->{EXCEPT_ME} ? ' '.$self->{EXCEPT_ME}->toRnc($hit, $out)."\n" : '')}, $self->{NAME_CLASS}, $self->{EXCEPT_ME});
}

sub checkRestrictions {
    my ($self, $context, $dad, $alpha) = @_;
    return $self->{EXCEPT_ME}->checkRestrictions($context, $self, $alpha);
    my $newOpts = $self->{EXCEPT_ME}->checkRestrictions($context, $self, $alpha);
    return ref $newOpts ? $newOpts : !$newOpts;
}

package W3C::XML::SchemaValidator::Annotation;
@W3C::XML::SchemaValidator::Annotation::ISA = qw(W3C::XML::SchemaValidator::Textual);
use vars qw($TYPE_unknown $TYPE_prefix $TYPE_follow);
($TYPE_unknown, $TYPE_prefix, $TYPE_follow) = ($W3C::XML::SchemaValidatorDataTypes::TYPE_unknown, $W3C::XML::SchemaValidatorDataTypes::TYPE_prefix, $W3C::XML::SchemaValidatorDataTypes::TYPE_follow) = (0..2);
push (@W3C::XML::SchemaValidatorDataTypes::EXPORT_OK, qw($TYPE_unknown $TYPE_prefix $TYPE_follow));

sub new {
    my ($proto, $parser, $name, $children, @EXPRARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser);
    $self->{NAME} = $name;
    $self->{CHILDREN} = $children;
    $self->{COMPILED} = [];
    $self->{TYPE} = $W3C::XML::SchemaValidatorDataTypes::TYPE_unknown;
    return $self;
}

sub getNamespace {$_[0]->{NAME}->getNamespace()}

sub getLocalName {$_[0]->{NAME}->getLocalName()}

sub getFirstChild {$_[0]->{CHILDREN}[0]}

sub setType {
    my ($self, $type) = @_;
    $self->{TYPE} = $type;
}

# Store the compile tree for the actions implied by the element tree.
sub setCompiled {
    my ($self, $compiled) = @_;
    $self->{COMPILED} = $compiled;
}

sub getCompiled {
    my ($self) = @_;
    return $self->{COMPILED};
}

sub toRnc {
    my ($self, $hit, $out) = @_;
    return $self->protect(sub {
	my $pre = $self->{TYPE} == $TYPE_follow ? "  >> " : '';
	my @ret;
	push (@ret, $pre.$self->{NAME}->toRnc($hit, $out).' [');
	foreach my $piece (@{$self->{CHILDREN}}) {
	    push (@ret, '    '.$piece->toRnc($hit, $out));
	}
	push (@ret, ']');
	join ("\n", @ret);
    }, $self->{NAME}, $self->{CHILDREN});
}

package W3C::XML::SchemaValidator::Literal;
@W3C::XML::SchemaValidator::Literal::ISA = qw(W3C::XML::SchemaValidator::SimpleValue);
use W3C::Util::Exception;

sub new {
    my ($proto, $parser, $val, @STUFFARGS) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($parser, @STUFFARGS);
    $val =~ s/\\x\{a\}/\n/g;
    $self->{VAL} = $val;
    return $self;
}

sub toRnc {
    my ($self, $hit, $out) = @_;
    return $self->protect(sub {
	my @lines = split(/(\n)/, $self->{VAL});
	my @ret;
	while (my $line = shift @lines) {
	    my $delim = shift @lines;
	    if ($delim eq "\n") {
		$delim = "\\x{a}";
	    }
	    if ($line =~ m/\"/) {
		if ($line =~ m/\'/) {
		    $line =~ s/\"/\\x{22}/g;
		    push (@ret, "\"$line$delim\"");
		} else {
		    push (@ret, "'$line$delim'");
		}
	    } else {
		push (@ret, "\"$line$delim\"");
	    }
	}
	return @ret ? join (" ~\n        ", @ret) : '""';
    }); # @@@ quotes!
}

sub getVal {$_[0]->{VAL}}

sub matches {$_[0]->{VAL} eq $_[1]}

package W3C::XML::SchemaValidator::StaticValue;
@W3C::XML::SchemaValidator::StaticValue::ISA = qw(W3C::XML::SchemaValidator::SimpleValue);
use W3C::Util::Exception;

sub toRnc {
    my ($self, $hit, $out) = @_;
    return $self->protect(sub {${$self->{VAL}}}, $self->{VAL});
}


# Now the tool to do traverse and keep state:

package W3C::XML::SchemaValidator::ParseState;
@W3C::XML::SchemaValidator::ParseState::ISA = qw();
use W3C::Util::Exception;

sub new {
    my ($proto, $parser, $start) = @_;
    my $class = ref($proto) || $proto;
    my $self = {PARSER => $parser, START => $start, STACKS => [[$start]], STATES => [], RULES => []};
    bless ($self, $class);
    # $self->_compile;
    return $self;
}

sub startElement {
    my ($self, $namespace, $localName, $qName, $attributeList) = @_;
    my $next = [];
    foreach my $stack (@{$self->{STACKS}}) {
	my $opt = $stack->[-1];
	my $p = $opt->{VAL};
#	print "checking to see if $qName matches ".$p->toString."\n";
	my ($context, $alpha) = ([$namespace, $localName, $qName, $attributeList], undef);
	if (my $newOpts = $p->checkRestrictions($context, $self, $alpha)) {
	    if (ref $newOpts eq 'ARRAY') {
		# come back to this context/these contexts
		foreach my $newOpt (@$newOpts) {
		    push (@$next, (@$stack, $newOpt));
		}
	    } else {
		# matched and completed; pop
	    }
	}
    }

    if (!@$next) {
	&throw(new W3C::Util::Exception(-message => "ran out of options"));
    }
}

sub endElement {
    my ($self, $namespace, $localName, $qName) = @_;
}

sub characters {
    my ($self, $shrunk) = @_;
}

sub _compile {
    my ($self) = @_;
    for (my $defns = [$self->{START}->getOpts]; @$defns;) {
	shift @$defns;
    }
}

package W3C::XML::SchemaValidatorDataTypes;

1;

__END__

=head1 NAME

SchemaValidatorDataTypes - Compile tree for RelaxNG Parser.

=head1 SYNOPSIS

  use W3C::XML::SchemaValidatorDataTypes qw($TYPE_prefix
					    $TYPE_follow $NS_default);
  new W3C::XML::SchemaValidator::NsDecl($parser, $prefix, $uri);
  new W3C::XML::SchemaValidator::Element($parser, $production, $pattern, 
					 $elAnnotations, $patAnnotations);

=head1 DESCRIPTION

B<SchemaValidatorDataTypes> provides a set of objects for storing XML document
schemas and, eventually, checking instance documents against the schema
constraints. It is undocumented. See RelaxNGParser.yp for example invocations.

=head1 CLASS HIERARCHY

    Textual
    /     \
 Pattern...  Stuff...

 <Pattern...>
 ReferencePattern, Mixed, NameOptDTV, 
 PatternGroup, NameGroup, AnyNameExcept, Annotation

       __________PatternQualifier___________
      /          /             \            \
 PatternOpt  PatternStar  NegatedPattern  NegatedName

 Text
   |
 Empty

      ElAttr
      /    \
 Element  Attribute

                 BinaryPattern
                /             \
     BinaryPatternWithAnnot  NamePipe
         /           \
 PatternSequence  PatternPipe

        Assign
       /      \
   Define    _Decl_
    /       /      \
 Start   NsDecl  DatatypesDecl
           |
        DefaultNsDecl
 </Pattern...>

 <Stuff...>
      _________...Stuff__________
     /       /       |           \
 Grammar  NCName  Namespace  SimpleValue
                             /    |    \
                        String  Token  AnyName  Literal  StaticValue
 </Stuff...>

The isa2dot program will produce a cool graphic for viewing this hierarchy:

  ./isa2dot -o TB -f s/W3C::XML::SchemaValidator:://ignore \
  -m allow ../../XML/SchemaValidatorDataTypes.pm > sv.dot

This module is part of the W3C::XML CPAN module.

=head1 AUTHOR

Eric Prud'hommeaux <eric@w3.org>

=head1 SEE ALSO

L<W3C::XML::RelaxNGParser>
L<W3C::XML::SAXParseException>

=cut
