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

# $Id: DtdDB.pm,v 1.9 2004/06/06 21:20:13 eric Exp $

use strict;
require Exporter;
require AutoLoader;

use W3C::XML::SAXParseException;

$W3C::XML::DtdDB::REVISION = '$Id: DtdDB.pm,v 1.9 2004/06/06 21:20:13 eric Exp $ ';

package W3C::XML::decl;

sub new {
    my ($proto, $name) = @_;
    my $class = ref($proto) || $proto;
    my $self = {};
    bless ($self, $class);
    $self->{NAME} = $name;
    return $self;
}

sub getName {
    my ($self) = @_;
    return $self->{NAME};
}

package W3C::XML::elementdecl;
@W3C::XML::elementdecl::ISA = qw(W3C::XML::decl);

use W3C::Util::Exception;

sub new {
    my ($proto, $name, $empty, $any, $declStr) = (shift, shift, shift, shift, shift, shift);
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($name, @_);
    bless ($self, $class);
    ($self->{NAME}, $self->{EMPTY}, $self->{ANY}, $self->{DECL_STR}) = ($name, $empty, $any, $declStr);
    $self->parse if ($declStr);
    return $self;
}

# <!ELEMENT head ((script|object)*,
#      ((title, (script|object)*, (base, (script|object)*)?) |
#       (base, (script|object)*, (title, (script|object)*))))>
# 
# state := 0 -------------
# (:group0 state=0
#  (:group1 state=0
#   script: 0:script->1  <-- will be 0 after '*' is parsed
#         |:ignore 
#          object: 0:object->1  <-- will be 0...
#  ):now in group0, current object is group1 state=0
#   *:retarget curObject (group1) to 0 and flag next state to be be 0
#    ,:nextState is 0 (see previous flag)
#  (:group1 state=0
#   (:group2 state=0
#    title: 0:title->1
#         ,:nextState (1) -------------
#    (:group3 state=1
#     script: 1:script->2  <-- will be 1...
#           |:ignore
#            object: 1:object->2
#    ):now in group 2, curObject is group 3 state=1
#     *:retarget curObject (group4) to 1 and flag next state to be be 1
#      ,nextState is 1
#    (:group3 state=1
#     base: 1:base->2
#         ,:nextState (2) -----------
#          (:group4 state=2
#           script: 2:script->3
#                 |:ignore
#                  object: 2:object->3
#          ):now in group 3, curObject is group 4 state=2
#           *:retarget curObject (group4) to 2 and flag next state to be be 2
#            ,:nextState is 2
#    ):now in group 2, curObject is group3 state=1
#     ?:flag to fold next state into this one
#   ):now in group 1, curObject is group 2 state=0
#  ):now in group 0, curObject is group 1 state=0
#   |:ignore
#  (:group1 state=0
#   base: 0:base->3
#       ,:nextState (3) ----------
#        (:group2 state=3
#         script: 3:script->4
#               |:ignore
#                object: 3:object->4
#        ):now in group 1, curObject is group2 state=3
#         *:retarget curObject (group2) to 3 and flag next state to be be 3
#          ,:nextState is 3
#   (:group3 state=3
#    title: 3:title->4
#         ,:nextState (4) ----------
#          (:group4 state=4
#           script: 4:script->5
#                 |:ignore
#                  object: 4:object->5
#          ):now in group 3, curObject is group4 state=3
#           *:retarget curObject (group4) to 4 and flag next state to be be 4
#   ):now in group 2, curObject is group 3 state=3
#  ):now in group 1, curObject is group 2 state=0
# ):now in group 0, curObject is group 1 state=0
# 
# 
# stick /head -> -end-
# 
# title -> -end-
# title -> base -> -end-
# base -> title -> -end-
# 
# 0:
#   script -> 0
#   object -> 0
#   title -> 1
#   base -> 3
# 1:             via title
#   script -> 1
#   object -> 1
#   base -> 2
#   /head -> -end-
# 2:             via title -> base
#   script -> 2
#   object -> 2
#   /head -> -end-
# 3:             via base
#   script -> 3
#   object -> 3
#   title -> 4
# 4:             via base -> title -> -end-
#   script -> 4
#   object -> 4
#   /head -> -end-
#
# note: 2 and 4 can fold into the same state but how do I know that in advance?
# + copies forward into the next state
# ? copies back from the next state
# * re-uses the first state in the current list (or element) and copies re-points
#   the last in the list to the first.
# These will never conflict as they may not be combined. Therefor, it is safe to
# use the next state and have authority that it will be used as the next state
# regardlesss of intervening parens. Diving does not change the next state.
# Recursing restores the previous state, but does not change the next state. It
# is still the next state for the stuff in the parens (unless retargeted by an *)
# and the state immediately before the parens. A nested | collapses the following
# state unto the previous or, but still, the next state remains the same.

# Neeed to check a,((b,c),d),e

my ($FIRST, $LAST, $CUR_STATE, $NEXT_STATE, $GROUP_CONTENTS, $BASE, $UNIQUE_STATE) = (0, 1, 2, 3, 4, 5, 6);

sub parse {
    my ($self) = @_;
    my (%useState, %copyState, %referents, $reuse);
    $self->{COPY_STATE} = {}; $self->{REFERENTS} = {}; $self->{GROUP_STACK} = [];
    my ($base, $uniqueState) = ('S', 0);
    my $parseContextString = '';
    my $end;
    my $curState = $base.'.'.$uniqueState;
    my $nextState = $base.'.'.++$uniqueState;
    my $lost;

    while (pos $self->{DECL_STR} < length $self->{DECL_STR}) {
	# make an array of options, each an array of ordered elems
	my $start = pos $self->{DECL_STR};
	if ($self->{DECL_STR} =~ m/\G \s* \( /gcxi) {
	    $end = pos $self->{DECL_STR};
	    $parseContextString = substr($self->{DECL_STR}, 0, $start).'@'.substr($self->{DECL_STR}, $start, $end - $start).' ';
	    # ( create a group
	    my $nextStackEntry = [$curState, undef, $curState, $nextState, [], $base, $uniqueState];
	    push (@{$self->{GROUPSTACK}}, $nextStackEntry);
	    push (@{$self->{MESSAGES}}, 'push('.join (', ', @$nextStackEntry).') depth: '.@{$self->{GROUPSTACK}});
	    my $expectedNextState = $nextState;
	    $uniqueState = 0;
	    $base = $base.'.'.$uniqueState;
	    $curState = $parseContextString.$base.'.'.$uniqueState;
	    $nextState = $parseContextString.$base.'.'.($uniqueState+1);
	    $self->relink($expectedNextState, $nextState);
	} elsif ($self->{DECL_STR} =~ m/\G \s* ([\#\w\.\_\-]+) \s* (\?|\*|\+)? \s* (\,|\|)? /gcxi) {
	    $end = pos $self->{DECL_STR};
	    $parseContextString = substr($self->{DECL_STR}, 0, $start).'@'.substr($self->{DECL_STR}, $start, $end - $start).' ';
	    # * set next state entry to this state and retarget current 
	    #   object (or group) entries to this state
	    if ($2 eq '*') {
		if ($3 eq '|') {
		    # a*|b 0:a->1 b->2 1:a->1 b->2
		    $self->link($1, $curState, $nextState);
		    $self->link($1, $nextState, $nextState);
		    $self->pushCopyState($nextState, $curState);
		    $curState = $nextState;
		    $nextState = $parseContextString.$base.'.'.++$uniqueState;
		} else {
		    # a*,b and a*),b  0:a->0	# re-use state so next falls in 0: too.
		    $self->link($1, $curState, $curState);
		}
	    # ? copy next state entries to this state
	    } elsif ($2 eq '?') {
		if ($3 eq '|') {
		    # a?|b,c   0:a->1 b->1 c->2  1:c->2
		    $self->link($1, $curState, $nextState);
		} else {
		    # a?,b?,c  0:a->2 b->2 c->3  1:b->2 c->3  2:c->3
		    # a?,b  0:a->1 b->2  1:b->2
		    # a?),b 0:a->1
		    $self->link($1, $curState, $nextState);
		    $self->pushCopyState($nextState, $curState);
		}
	    # + copy this state entries to next state
	    } elsif ($2 eq '+') {
		if ($3 eq '|') {
		    # a+|b  0:a->1 b->2  1:a->1 b->2
		    $self->link($1, $curState, $nextState);
		    $self->link($1, $nextState, $nextState);
		    $self->pushCopyState($nextState, $curState);
		} else {
		    # a+,b  0:a->1  1:a->1 b->2
		    # a+),b  0:a->1  1:a->1
		    $self->link($1, $curState, $nextState);
		    $self->link($1, $nextState, $nextState);
		}
	    } else {
		# a|b
		$self->link($1, $curState, $nextState);
		if ($3 eq ',') {
		    # a,b and a),b
		    $curState = $nextState;
		    $nextState = $parseContextString.$base.'.'.++$uniqueState;
		}
	    }
	    $self->{PCDATA} = 1 if ($1 eq '#PCDATA');
	} elsif (0 && $self->{DECL_STR} =~ m/\G \s* (\,|\|) /gcxi && $1 eq ',') {
	    $end = pos $self->{DECL_STR};
	    $parseContextString = substr($self->{DECL_STR}, 0, $start).'@'.substr($self->{DECL_STR}, $start, $end - $start).' ';
	    # , assign next state
	    # | ignore (just put next entry in same state)

	    if (exists $useState{$nextState}) {
		push (@{$self->{MESSAGES}}, 'delete(\$useState{'.$nextState.'}: '.$useState{$nextState}.')');
		delete $useState{$nextState};
	    } else {
		$curState = $nextState;
		$nextState = $parseContextString.$base.'.'.++$uniqueState;
	    }
	} elsif ($self->{DECL_STR} =~ m/\G \s* \) \s* (\?|\*|\+)? \s* (\,|\|)? /gcxi) {
	    $end = pos $self->{DECL_STR};
	    $parseContextString = substr($self->{DECL_STR}, 0, $start).'@'.substr($self->{DECL_STR}, $start, $end - $start).' ';

	    my $expectedNextState = $nextState; my ($first, $last, $curState1, $nextState1, $tmp);
	    my $nextStackEntry = pop (@{$self->{GROUPSTACK}});
	    ($first, $last, $curState, $nextState, $tmp, $base, $uniqueState) = @$nextStackEntry;
	    push (@{$self->{MESSAGES}}, 'pop('.join (', ', @$nextStackEntry).') depth: '.@{$self->{GROUPSTACK}});
	    $self->relink($expectedNextState, $nextState);
#	    my $first1 = $tmp->[$GROUP_CONTENTS]->[0]; # $curState of 0th element

	    # * set next state entry to this state and retarget current 
	    #   object (or group) entries to this state
	    if ($1 eq '*') {
		if ($2 eq '|') {
		    # ((a,b)|(c,d))*|e  0:a->1  1:b->2  0:c->3 3:d->2  *:(1:b->0 3:d->0)  0:e->2
		    # analogous to: a*|b 0:a->1 b->2 1:a->1 b->2
		    die "unimplemented";
		    $self->relink($0, $curState, $nextState);
		    $self->copylink($0, $nextState, $nextState);
		    $self->pushCopyState($nextState, $curState);
		    $curState = $nextState;
		    $nextState = $parseContextString.$base.'.'.++$uniqueState;
		} else {
		    # ((a,b)|(c,d))*,e  0:a->1  1:b->2  0:c->3 3:d->2  *:(1:b->0 3:d->0)  0:e->2
		    # analogous to: a*,b and a*),b  0:a->0	# re-use state so next falls in 0: too.
		    $self->relink($nextState, $first); # $self->relink($expectedNextState, $curState);
		    $curState = $first;
		    # $self->link($0, $curState, $curState);
		}
	    # ? copy next state entries to this state
	    } elsif ($1 eq '?') {
		if ($2 eq '|') {
		    # a?|b,c   0:a->1 b->1 c->2  1:c->2
		    die "unimplemented";
		    $self->link($0, $curState, $nextState);
		} else {
		    # a?,b?,c  0:a->2 b->2 c->3  1:b->2 c->3  2:c->3
		    # a?,b  0:a->1 b->2  1:b->2
		    # a?),b 0:a->1
		    my @tmp = $self->{COPY_STATE}{$curState};
		    $self->pushCopyState($nextState, @tmp, $curState);
		}
	    # + copy this state entries to next state
	    } elsif ($1 eq '+') {
		if ($2 eq '|') {
		    # a+|b  0:a->1 b->2  1:a->1 b->2
		    die "unimplemented";
		    $self->link($0, $curState, $nextState);
		    $self->link($0, $nextState, $nextState);
		    $self->pushCopyState($nextState, $curState);
		} else {
		    # a+,b  0:a->1  1:a->1 b->2
		    # a+),b  0:a->1  1:a->1
		    $self->relink($expectedNextState, $nextState, $nextState);
		}
	    } else {
#		$self->relink($expectedNextState, $nextState);
#		die "$expectedNextState != $uniqueState" if ($expectedNextState != $uniqueState);
#		$uniqueState--;
		if ($2 eq ',') {
		    $curState = $nextState;
		    $nextState = $parseContextString.$base.'.'.++$uniqueState;
		} elsif ($2 eq '|') {
		    $self->pushCopyState($nextState, $curState);
		    $curState = $first;
		}
	    }
	    # ? copy next state entries to first element (nested) of this state
	    # * set next state entry to this state and retarget current 
	    #   object (or group) entries to this state
	    # + copy this state entries to next state
	    if (0 && $1 eq '*') {
		push (@{$useState{$nextState}}, $first);
		push (@{$self->{MESSAGES}}, 'push(\$useState{'.$nextState.'}: '.$useState{$nextState}.') depth: '.@{$useState{$nextState}});
		$reuse = [$curState, $nextState];
	    } elsif (0 && $1 eq '?') {
		$self->{COPY_STATE}{$nextState} = $first;
		push (@{$self->{MESSAGES}}, 'COPY_STATE{'.$nextState.'} = '.$first.' depth: '.@{$self->{COPY_STATE}});
	    } elsif (0 && $1 eq '+') {
		map {$self->link($1, $nextState, $nextState)} keys %{$self->{SM}->{$curState}};

		map {$self->{SM}->{$nextState}{$_} = $self->{SM}->{$first}{$_}} 
		    keys %{$self->{SM}->{$first}};
	    }
	} else {
	    $self->stuck;
	}
	print substr($self->{DECL_STR}, $start, $end - $start)."\n".join ("\n", @{$self->{MESSAGES}})."\n";
	$self->stuck if ($end - $start == 0);
    }
#		print ":$self->{NAME}:", new W3C::XML::elementdecl($self->{NAME}, 0, 0, $self->{PCDATA}, $base)->showRepeat($base, 0, 0),"\n\n";
    $self->link('/', $nextState, -1, 1);
#    $self->link1('/', $nextState, -1, 1);
#    map {$self->link1('/', $_, -1, 1)} @{$self->{COPY_STATE}{$curState}}; # if ($copyState{$to});

#    $self->relink($nextState, -1, 0);
#    $self->link('/', $curState, -1);
    undef $self->{COPY_STATE};
    undef $self->{REFERENTS};
    undef $self->{GROUP_STACK};
}

sub stuck {
    my ($self) = @_;
    my $offset = pos $self->{DECL_STR};
    my $length = length $self->{DECL_STR} - $offset;
    $length = 128 if ($length > 128);
    my $unparsed = substr($self->{DECL_STR}, $offset, $length);
    &throw(new W3C::Util::Exception("Error parsing at $offset - choked on \"$unparsed\""));
}

sub pushCopyState {
    my ($self, $nextState, @newState) = @_;
    push (@{$self->{COPY_STATE}{$nextState}}, @newState);
    push (@{$self->{MESSAGES}}, 'push COPY_STATE{'.$nextState.'} ('.join (', ', @newState).') depth: '.@{$self->{COPY_STATE}{$nextState}});
}

my ($FROM, $TOKEN) = (0, 1);

sub link1 {
    my ($self, $token, $from, $to, $watchAmbiguity) = @_;
    push (@{$self->{MESSAGES}}, 'push link1('.join (', ', $token, $from, $to, $watchAmbiguity).')');
    die "ambiguity: SM{$from}{$token} = ${$self->{SM}->{$from}{$token}}" if ($watchAmbiguity && $self->{SM}->{$from}{$token});
    $self->{SM}->{$from}{$token} = $to;
    push (@{$self->{REFERENTS}{$to}}, [$from, $token]);
}

sub link {
    my ($self, $token, $from, $to) = @_;
    $self->link1($token, $from, $to, 1);
    map {$self->link1($token, $_, $to, 1)} @{$self->{COPY_STATE}{$from}}; # if ($copyState{$to});
#    push (@{$self->{GROUPSTACK}[-1][$GROUP_CONTENTS]}, [$from, $token]);
}

sub relink {
    my ($self, $old, $new, $copyTo) = @_;
    map {$self->link1($_->[$TOKEN], $_->[$FROM], $new, 0);
	 $self->link1($_->[$TOKEN], $_->[$FROM], $copyTo, 0) if ($copyTo)} @{$self->{REFERENTS}{$old}};
    undef $self->{REFERENTS}{$old};
}

sub showElementdeclStatus {
    my ($self) = @_;
    my $ret = substr ($self->{DECL_STR}, 0, pos $self->{DECL_STR})." @ ".substr ($self->{DECL_STR}, pos $self->{DECL_STR}, 20)."\n";
    map {my $state = $_; $ret .= $state.":\n"; map {$ret .= '  '.$_.' -> '.$self->{SM}->{$state}{$_}."\n"} keys %{$self->{SM}->{$state}}} sort keys %{$self->{SM}};
    return $ret;
}

sub showOrdered {
    my ($self, $ordered, $parens, $parens1) = @_;
    my @ret;
    map {push (@ret, $self->showRepeat($_, $parens))} (@$ordered);
    return ($parens || $parens1 || $#ret>$[ ? '(' : '').join (' , ', @ret).($parens || $parens1 || $#ret>$[ ? ')' : '');
}

sub showOptions {
    my ($self, $options, $parens, $parens1) = @_;
    my @ret;
#    map {push (@ret, ref $_->[0] ? $self->showOrdered($_, $parens, $parens1) : $self->showRepeat($_, $parens))} (@$options);
    map {push (@ret, $self->showOrdered($_, $parens, $parens1))} (@$options);
    return ($parens || $#ret>$[ ? '[' : '').join (' | ', @ret).($parens || $#ret>$[ ? ']' : '');
}

sub showRepeat {
    my ($self, $repeats, $parens, $root) = @_;
    my $ret;
    $ret .= ref $repeats->[0] ? $self->showOptions($repeats->[0], $parens, $root) : $repeats->[0];
    $ret .= $repeats->[1];
    return $ret; # ($parens ? '<' : '').$ret.($parens ? '>' : '');
}

sub hasPcdata {
    my ($self) = @_;
    return $self->{PCDATA};
}

# makeContext - build a data structure for tracking progress through a DTD elementdecl
sub makeSubContext {
    my ($self, $options) = @_;
    my $ret = [];
    foreach my $option (@$options) {
	foreach my $order (@$options) {
	    if (ref $order->[0][0]) {
		foreach my $elem (@$order) {
		    my ($what, $repeat) = @$elem;
		    push (@$ret, $self->makeSubContext($what));
		}
	    } else {
		push (@$ret, 0);
	    }
	}
    }
    return $ret;
}

sub makeContext {
    my ($self) = @_;
    return $self->makeSubContext($self->{VOCAB}[0]);
}

sub findTagInSubContext {
    my ($self, $options, $name, $context) = @_;
    my $count = 0;
    my $lookAt = 0;
    foreach my $option (@$options) {
	foreach my $order (@$options) {
	    my $innerContext = $context->[$lookAt];
	    if (ref $order->[0][0]) {
		foreach my $elem (@$order) {
		    my ($what, $repeat) = @$elem;
		    $count += findTagInSubContext($what, $name, $innerContext);
		}
	    } else {
		my $outOf = $order->[0];
		$innerContext->[0]++;
	    }
	}
	$lookAt++;
    }
}

sub findTagInContext {
    my ($self, $name, $context) = @_;
    return $self->findTagInSubContext($self->{VOCAB}[0], $name, $context);
}

package W3C::XML::Attlistdecl;
@W3C::XML::Attlistdecl::ISA = qw(W3C::XML::decl);

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

package W3C::XML::Entitydecl;
@W3C::XML::Entitydecl::ISA = qw(W3C::XML::decl);

sub new {
    my ($proto, $name, $peDecl, $pubId, $sysId, $def, $ndataDecl) = (shift, shift, shift, shift, shift, shift, shift);
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new($name, @_);
    bless ($self, $class);
    ($self->{PEDECL}, $self->{PUBID}, $self->{SYSID}, $self->{DEF}, $self->{NDATADECL}) = 
	($peDecl, $pubId, $sysId, $def, $ndataDecl);
    return $self;
}

sub getDef {
    my ($self) = @_;
    return $self->{DEF};
}

sub getPubId {
    my ($self) = @_;
    return $self->{PUBID};
}

sub getSysId {
    my ($self) = @_;
    return $self->{SYSID};
}

sub isPeDecl {
    my ($self) = @_;
    return $self->{PEDECL};
}

package W3C::XML::Notationdecl;
@W3C::XML::Notationdecl::ISA = qw(W3C::XML::decl);

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

package W3C::XML::DtdDB;
use vars qw($VERSION $DSLI @ISA @EXPORT @EXPORT_OK @TODO);
@ISA = qw(Exporter AutoLoader);
@EXPORT = qw();
@EXPORT_OK = qw();
$VERSION = 0.52;
$DSLI = 'adpO';
@TODO = ('start a todo list');

sub new {
    my ($proto, $errorHandler, $locator) = @_;
    my $class = ref($proto) || $proto;
    my $self = {};
    bless ($self, $class);
    ($self->{ERROR_HANDLER}, $self->{LOCATOR}) = ($errorHandler, $locator);
    return $self;
}

sub addDecl {
    my ($self, $decl) = @_;
    my $name = $decl->getName;
    if ($decl->isa('W3C::XML::elementdecl')) {
	if ($self->{ELEMENTS}{$name}) {
	    $self->{ERROR_HANDLER}->warning(new W3C::XML::SAXParseException(-message => 'duplicate decl for "'.$name.'"', -locator => $self->{LOCATOR}));
	} else {
	    $self->{ELEMENTS}{$name} = $decl;
	}
    } elsif ($decl->isa('W3C::XML::Attlistdecl')) {
	if ($self->{ATTLISTS}{$name}) {
	    $self->{ERROR_HANDLER}->warning(new W3C::XML::SAXParseException(-message => 'duplicate Attlistdecl for "'.$name.'"', -locator => $self->{LOCATOR}));
	} else {
	    $self->{ATTLISTS}{$name} = $decl;
	}
    } elsif ($decl->isa('W3C::XML::Entitydecl')) {
	if ($self->{ENTITIES}{$name}) {
	    $self->{ERROR_HANDLER}->warning(new W3C::XML::SAXParseException(-message => 'duplicate Entitydecl for "'.$name.'"', -locator => $self->{LOCATOR}));
	} else {
	    $self->{ENTITIES}{$name} = $decl;
	}
    } elsif ($decl->isa('W3C::XML::Notationdecl')) {
	if ($self->{NOTATIONS}{$name}) {
	    $self->{ERROR_HANDLER}->warning(new W3C::XML::SAXParseException(-message => 'duplicate Notationdecl for "'.$name.'"', -locator => $self->{LOCATOR}));
	} else {
	    $self->{NOTATIONS}{$name} = $decl;
	}
    }
}

sub expandPERef {
    my ($self, $expandMe) = @_;
    if ($expandMe =~ m/\A\%([^\;]+)\;\Z/) {
	my $entity = $self->{ENTITIES}{$1};
	if (defined $entity) {
	    return $entity->getDef;
	} else {
	    $self->{ERROR_HANDLER}->warning(new W3C::XML::SAXParseException(-message => 'no Entitydecl for "%'.$1.';"', -locator => $self->{LOCATOR}));
	}
    }
    return $expandMe;
}

sub expandPERefs {
    my ($self, $expandMe) = @_;
    my $ret;
    while ($expandMe =~ m/\G (.*?) \% ([^\;]+) \; /gcxi) {
	$ret .= $1;
	my $entity = $self->{ENTITIES}{$2};
	if (defined $entity) {
	    $ret .= $self->expandPERefs($entity->getDef);
	} else {
	    $self->{ERROR_HANDLER}->warning(new W3C::XML::SAXParseException(-message => 'no Entitydecl for "%'.$2.';"', -locator => $self->{LOCATOR}));
	}
    }
    $ret .= $1 if ($expandMe =~ m/\G (.*?) \Z /gcxi);
}

sub importIds {
    my ($self, $expandMe) = @_;
    my $ret;
    while ($expandMe =~ m/\G (.*?) \% ([^\;]+) \; /gcxi) {
	$ret .= $1;
	my $entity = $self->{ENTITIES}{$2};
	if (defined $entity) {
	    $self->{PUBID}{$entity->getPubId} = $entity->getSysId;
	} else {
	    $self->{ERROR_HANDLER}->warning(new W3C::XML::SAXParseException(-message => 'no Entitydecl for "%'.$2.';"', -locator => $self->{LOCATOR}));
	}
    }
    $ret .= $1 if ($expandMe =~ m/\G (.*?) \Z /gcxi);
}

sub setExpectedRoot {
    my ($self, $expectedRoot) = @_;
    $self->{EXPECTED_ROOT} = $expectedRoot;
}

sub getExpectedRoot {
    my ($self) = @_;
    return $self->{EXPECTED_ROOT};
}

sub getElement {
    my ($self, $name) = @_;
    my $element = $self->{ELEMENTS}{$name};
    if ($element) {
	return $element;
    } else {
	$self->{ERROR_HANDLER}->error(new W3C::XML::SAXParseException ('DTD: Unknown tag: <'. $name.'>'.
								       $self->{DOCUMENT_LOCATOR}));
    }
}

sub hasPcdata {
    my ($self, $name) = @_;
    my $element = $self->{ELEMENTS}{$name};
    if ($element) {
	return $element->hasPcdata;
    } else {
	$self->{ERROR_HANDLER}->error(new W3C::XML::SAXParseException ('DTD: Unknown tag: <'. $name.'>'.
								       $self->{DOCUMENT_LOCATOR}));
    }
}

my $StandardXMLEntities = {'amp' => '&', 
			   'quot' => '"', 
			   'semi' => ';', 
			   'lt' => '<', 
			   'gt' => '>'};

# invoc: $characters = $self->{DTD_DB}->expand($characters) if ($self->{DTD_DB});
sub expandEntities {
    my ($self, $word) = @_;
    my @ret;
    while ($word =~ m/\G ([^\&]*) \& ([^\&]*) \; /gcxs) {
	my ($nonEntities, $name) = ($1, $2);
	my $value;
	if (exists $StandardXMLEntities->{$name}) {
	    $value = $StandardXMLEntities->{$name};
	} elsif (my $decl = $self->{ENTITIES}{$name}) {
	    $value = $decl->getDef;
	} else {
	    $value = "&${name};";
	}
	push (@ret, $nonEntities, $value);
    }
    return (join ('', @ret, $word =~ m/\G (.*)/gcxs));
}

package W3C::XML::DtdEnforcer;
@W3C::XML::DtdEnforcer::ISA = ("W3C::XML::HandlerStream");

sub new {
    my ($proto, $docHandler, $dtdDB) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(-documentHandler => $docHandler);
    ($self->{DTD_DB}) = ($dtdDB);
    $self->{TAG_STACK} = [];
    return $self;
}

sub setDocumentLocator {
    my ($self, $locator) = @_;
    $self->SUPER::setDocumentLocator($locator);
    $self->{SOURCE_ID} = $locator->getPublicId;
}

sub startElement {
    my ($self, $name, $attributeList) = @_;
    my $element = $self->{DTD_DB}->getElement($name);
    my $context = $element->makeContext;

    if (!$self->{TAG_STACK}[0]) {
	# first tag - look for expected root element
	$self->{ERROR_HANDLER}->warning(new W3C::XML::SAXParseException(-message => 'expected <'.$self->{DTD_DB}->getExpectedRoot.
									'>, not <'.$name.'> at root', -locator => $self->{LOCATOR})) 
	    if ($name ne $self->{DTD_DB}->getExpectedRoot);
    } else {
	# check new tag against parent context
	my ($parentTag, $checkElement, $checkContext) = @{$self->{TAG_STACK}[-1]};
	my $matches = 1; # !!! $checkElement->findTagInContext($name, $checkContext);
	if (!$matches) {
	    my @tags; map {push (@tags, $_->[0])} (@{$self->{TAG_STACK}});
	    $self->{ERROR_HANDLER}->warning(new W3C::XML::SAXParseException(-message => 'no matches for <'.$name.'> in <'.
									    join('><', @tags).'> context', -locator => $self->{LOCATOR})) 
	    }
    }
    push (@{$self->{TAG_STACK}}, [$name, $element, $context]);
    $self->SUPER::startElement($name, $attributeList);
}

sub endElement {
    my ($self, $name) = @_;
    my ($tag, $element, $context) = (pop (@{$self->{TAG_STACK}}));
    $self->SUPER::endElement($name);
}

sub characters {
    my ($self, $ch, $start, $length) = @_;
    my $data = substr($ch, $start, $start+$length);
    my $name = $self->{TAG_STACK}[-1] ? $self->{TAG_STACK}[-1][0] : undef;
    if (!$name || !$self->{DTD_DB}->hasPcdata($name)) {
	if ($data =~ m/ \S /x) {
	    $self->{DTD_DB}->{ERROR_HANDLER}->error(new W3C::XML::SAXParseException ('<'. $name.'> should not have #PCDATA "'.
										     $data.'"'.
										     $self->{DTD_DB}->{DOCUMENT_LOCATOR}));
	} else {
	    $self->SUPER::ignorableWhitespace($ch, $start, $length);
	}
    } else {
	$self->SUPER::characters($ch, $start, $length);
    }
}

package W3C::XML::DtdDB;

__END__

=head1 NAME

W3C::XML::DtdDB.pm - methods for parsing and enforcing a DTD

=head1 SYNOPSIS

  $decls = new W3C::XML::DtdDB($errorHandler, $documentLocator);
  $decls->importIds($doctypeDecl);
  $decls->setExpectedRoot('HTML');
  my $decl = new W3C::XML::elementdecl($name, $empty, $any, $declStr);
  $decls->addDecl($decl);
  $token = $decls->expandPERefs($token);
  $characters = $decls->expandEntities($characters);

=head1 DESCRIPTION

DtdDB is a DTD database.
DtdEnforcer is a document handler that enforces the rules in a DtdDB.
This is not yet in real use. More later...

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

=head1 AUTHOR

Eric Prud\'hommeaux <eric@w3.org>

=head1 SEE ALSO

perl(1).

=cut
