XML::Doctype - A DTD object class

   # To parse an external DTD at compile time, useful when
   # using XML::ValidWriter
   use XML::Doctype NAME => 'FooML', SYSTEM_ID => 'FooML.dtd' ;
   use XML::Doctype NAME => 'FooML', DTD_TEXT  => $dtd ;

   # Parsing at run-time
   $doctype = XML::Doctype->new( 'FooML', SYSTEM_ID => 'FooML.dtd' ) ;

   # or
   $doctype = XML::Doctype->new() ;
   $doctype->parse( 'FooML', 'FooML.dtd' ) ;

   # Saving the parsed object
   open( PM, ">FooML/DTD/v1_000.pm" ) or die $! ;
   print PM $doctype->as_pm( 'FooML::DTD::v1_000' ) ;

   # Using a saved parsed DTD
   use FooML::DTD::v1_000 ;

   $doctype = FooML::DTD::v1_000->new() ;

   $doctype = XML::Doctype->new() ;
   $doctype = XML::Doctype->new( 'FooML', DTD_TEXT => $doctype_text ) ;
   $doctype = XML::Doctype->new( 'FooML', SYSTEM_ID => 'FooML.dtd' ) ;

   $name = $doctype->name() ;

   Sets/gets the name.

   $doctype->parse_dtd( $name, $doctype_text ) ;
   $doctype->parse_dtd( $name, $doctype_text, 'internal' ) ;

   $doctype->parse_dtd_file( $name, $system_id [, $public_id] ) ;
   $doctype->parse_dtd_file( $name, $system_id [, $public_id], 'internal' ) ;

   $doctype->parse_dtd_file( $name, $system_id, $p_id, 'internal' ) ;
   $doctype->parse_dtd_file( $name, $system_id, undef, 'internal' ) ;

   $system_id = $doctype->system_id() ;

   Sets/gets the system ID.

   $public_id = $doctype->public_id() ;

   Sets/gets the public_id.

   $elt_decl = $doctype->element_decl( $name ) ;

   open( PM, "FooML/DTD/v1_001.pm" )            or die $! ;
   print PM $doctype->as_pm( 'FooML::DTD::v1_001' ) or die $! ;
   close PM                                     or die $! ;

   use FooML::DTD::v1_001 ;   # Do *not* use () as a parameter list!

   use XML::Doctype NAME => 'FooML', SYSTEM_ID => 'dtds/FooML.dtd' ;

package XML::Doctype ;

use strict ;
use vars qw( $VERSION %_default_dtds ) ;
use fields (
   'ELTS',       # A hash of declared & undeclared elements, keyed by name
   'NAME',       # The root node (the name from the DOCTYPE decl).
   'SYSID',
   'PUBID',
) ;

use Carp ;
use XML::Doctype::ElementDecl ;
use XML::Doctype::AttDef ;

$VERSION = 0.11 ;

sub new {
   my XML::Doctype $self = fields::new( shift );

   return $self unless @_ ;

   my $name = shift ;

   if ( @_ == 1 ) {
      $self->parse_dtd_file( $name, shift ) ;
   }
   else {
      while ( @_ ) {
	 for ( shift ) {
	    if ( /^SYSTEM(?:_ID)?$/ ) {
	       $self->parse_dtd_file( $name, shift ) ;
	    }
	    elsif ( $_ eq 'DTD_TEXT' ) {
	       $self->parse_dtd( $name, shift ) ;
	    }
	    else {
	       croak "Unrecognized parameter '$_'" ;
	    }
	 }
      }
   }

   ## Do this here so subclass author won't be suprised when eventually
   ## calling save_as_pm.
   my $class = ref $self;
   no strict 'refs' ;
   croak "\$$class\::VERSION not defined" 
      unless defined ${"$class\::VERSION"} ;

   return $self ;
}

sub name {
   my XML::Doctype $self = shift ;
   $self->{NAME} = shift if @_ ;
   return $self->{NAME}
}


##
## Called to translate the XML::Parser::ContentModel passed by XML::Parser
## in to a tree of XML::Doctype::ChildDecl instances.
sub _import_ContentModel {
}


sub _do_parse {
   my XML::Doctype $self = shift ;
   my ( $fake_doc ) = @_ ;

   my $elts = $self->{ELTS} = {} ;

   ## Should maybe use libwww to fetch URLs, but will do files for now
   ## We require this lazily to save load time and allow it to be
   ## not present if it's not needed.
   require XML::Parser ;
   my $p = XML::Parser->new(
      ParseParamEnt => 1,
      Handlers => {
         Doctype => sub {
            my $expat = shift ;
	    my ( $name, $sysid, $pubid, $internal ) = @_ ;
	    $self->{NAME} = $name ;
	    $self->{SYSID} = $sysid ;
	    $self->{PUBID} = $pubid ;
	 },
	 
	 Element => sub {
	    my $expat = shift ;
	    my ( $name, $model ) = @_ ;

	    croak "ELEMENT '$name' already defined"
	       if exists $elts->{$name} && $elts->{$name}->is_declared ;

            my $elt = XML::Doctype::ElementDecl->new( $name, $model ) ;
	    $elt->is_declared( 1 ) ;
            $elts->{$name} = $elt ;

	    for ( $elt->child_names ) {
	       $elts->{$_} = XML::Doctype::ElementDecl->new( $_ )
	          unless $elts->{$_} ;
	    }
	 },

         Attlist => sub {
	    my $expat = shift ;
	    my ( $elt_name, $att_name, $type, $default, $fixed ) = @_ ;

	    $elts->{$elt_name} = XML::Doctype::ElementDecl->new()
	       unless exists $elts->{$elt_name} ;

	    $default =~ s/^'(.*)'$/$1/ || $default =~ s/^"(.*)"$/$1/ ;
	    
	    $elts->{$elt_name}->add_attdef(
	       XML::Doctype::AttDef->new( 
		  $att_name,
		  $type,
		  $fixed ? ( '#FIXED', $default ) : ( $default, undef ),
	       )
	    ) ;
	 },
      },
   ) ;

   $p->parse( $fake_doc ) ;

   croak "Doctype",
      defined $self->{SYSID} ? " SYSTEM_ID $self->{SYSID}" : (),
      " did not declare root node <$self->{NAME}>"
      unless exists $self->{ELTS}->{$self->{NAME}} ;

#   require Data::Dumper ; print Data::Dumper::Dumper( $elts ) ;
   ## TODO: Check that all elements referred-to by name in the element tree
   ## rooted at $self->{NAME} are actually declared.
}

sub parse_dtd {
   my XML::Doctype $self = shift ;
   my ( $name, $text, $internal ) = @_ ;

   $self->_do_parse( <<TOHERE ) ;
<?xml version="1.0" encoding="US-ASCII" standalone="yes"?>
<!DOCTYPE $name [
$text
]>
<$name></$name>
TOHERE
}

sub parse_dtd_file {
   my XML::Doctype $self = shift ;
   my ( $name, $system_id, undef, $internal ) = @_ ;

   $self->_do_parse( <<TOHERE ) ;
<?xml version="1.0" encoding="US-ASCII" standalone="no"?>
<!DOCTYPE $name SYSTEM "$system_id" >
<$name></$name>
TOHERE
}

sub system_id {
   my XML::Doctype $self = shift ;
   $self->{SYSID} = shift if @_ ;
   return $self->{SYSID}
}

sub public_id {
   my XML::Doctype $self = shift ;
   $self->{PUBID} = shift if @_ ;
   return $self->{PUBID}
}

sub element_decl {
   my XML::Doctype $self = shift ;
   my ( $name ) = @_ ;

   return $self->{ELTS}->{$name} if exists $self->{ELTS}->{$name} ;
   return ;
}

sub element_names {
   my XML::Doctype $self = shift ;
   my $h = {} ;
   for ( keys %{$self->{ELTS}} ) {
      $h->{$_} = 1 ;
      $h->{$_} = 1 for $self->{ELTS}->{$_}->child_names() ;
   }

   return keys %$h ;
}

## TODO: Save as pure, unblessed data structure that XML::Doctype can
## convert to internal format, to increase inter-version compatibility.

sub as_pm {
   my XML::Doctype $self = shift ;
   my ( $package ) = @_ ;

   my $date = localtime ;
   my $class = ref $self ;

   my $version ;
   if ( $class ne __PACKAGE__ ) {
      no strict 'refs' ;
      croak "\$$class\::VERSION not defined" 
         unless defined ${"$class\::VERSION"} ;
      $version = "$class, v" . ${"$class\::VERSION"} . ", (" ;
   }

   $version .= __PACKAGE__ . ", v$VERSION" ;
   $version .= ')'
      if $class ne __PACKAGE__ ;

   require Data::Dumper ;
   my $d = Data::Dumper->new( [$self], ['$doctype'],  ) ;
#   $d->Freezer( '_freeze' ) unless $d->can( 'Dumpperl' ) ;
   $d->Purity(1);     ## We really do want to dump executable code.
   $d->Indent(1);     ## Used fixed indent depth.  I find this more readable.

   return
      join( '', <<ENDPREAMBLE, $d->can( 'Dumpperl' ) ? $d->Dumpperl : $d->Dump, "\n 1 ;\n" );
package $package ;

##
## THIS FILE CREATED AUTOMATICALLY: YOU MAY LOSE ANY EDITS IF YOU MOFIFY IT.
##
## When: $date
## By:   $version
##

require XML::Doctype ;

sub import {
   my \$pkg = shift ;
   my \$callpkg = caller ;
   \$XML::Doctype::_default_dtds{\$callpkg} = \$doctype ;
}

ENDPREAMBLE
}


sub _freeze {
   my $self = shift ;
   $_->_freeze for values %{$self->{ELTS}} ;
   return $self ;
}

sub import {
   my $class = shift ;
   my $callpkg = caller ;

   my @others ;
   my @dtd_args ;
   while ( @_ ) {
      for ( shift ) {
	 if ( $_ eq 'NAME' ) {
	    push @dtd_args, shift ;
	 }
	 elsif ( /^[A-Z][A-Z_0-9]*$/ ) {
	    push @dtd_args, $_, shift ;
	 }
	 else {
	    push @others, $_ ;
	 }
      }
   }
   $_default_dtds{$callpkg} = $class->new( @dtd_args ) 
      if @dtd_args ;

   croak join( ', ', @others ), " not exported by $class" if @others ; 
}

1 ;