package Xmldoom::Definition::PerlModuleParser;
use IO::File;
use XML::GDOME;
use XML::DOM;
use Exception::Class::TryCatch;
use Xmldoom::Definition::SAXHandler qw( $OBJECT_NS $OBJECT_PERL_NS );
use strict;
use Data::Dumper;
sub new
{
my $class = shift;
my $args = shift;
my $filename;
if ( ref($args) eq 'HASH' )
{
$filename = $args->{filename};
}
else
{
$filename = $args;
}
my $self = {
filename => $filename,
text => { },
docs => { }
};
bless $self, $class;
# read the text in
$self->_read();
return $self;
}
sub get_package_names { return keys %{shift->{text}}; };
sub get_text
{
my ($self, $name) = @_;
return $self->{text}->{$name};
}
sub get_document
{
my ($self, $name) = @_;
return $self->{docs}->{$name};
}
sub get_object_nodes
{
my $self = shift;
my @object_nodes;
while ( my ($package_name, $doc) = each %{$self->{docs}} )
{
my $node = $doc->getDocumentElement()->getFirstChild();
while ( $node )
{
if ( $node->getNodeType() == XML::DOM::ELEMENT_NODE and
$node->getTagName() eq 'object' )
{
push @object_nodes, $node;
}
$node = $node->getNextSibling();
}
}
return \@object_nodes;
}
sub _read
{
my $self = shift;
my $fd = IO::File->new( $self->{filename}, 'r' ) || die "$!: Cannot open $self->{filename}";
my $in_xmldoom = 0;
my $package_name = undef;
while ( my $line = <$fd> )
{
if ( $line =~ /^package (.*);$/ )
{
$package_name = $1;
}
if ( $line eq "=begin Xmldoom\n" )
{
$in_xmldoom = 1;
}
elsif ( $line eq "=end Xmldoom\n" )
{
$in_xmldoom = 0;
}
elsif ( $in_xmldoom )
{
$self->{text}->{$package_name} .= $line;
}
}
$fd->close();
}
sub create_documents
{
my $self = shift;
my $args = shift;
my $infer_perl_class = 1;
if ( ref($args) eq 'HASH' )
{
$infer_perl_class = $args->{infer_perl_class} if defined $args->{infer_perl_class};
}
while ( my ($package_name, $text) = each %{$self->{text}} )
{
my $xml_str = '';
# add the initial declarations
$xml_str .= "<?xml version='1.0'?>\n\n";
$xml_str .= "<objects ";
$xml_str .= "xmlns='$OBJECT_NS' ";
$xml_str .= "xmlns:perl='$OBJECT_PERL_NS'>\n";
# add the actual text
$xml_str .= $text;
# the footer
$xml_str .= "</objects>\n";
my $doc;
# parse the XML attempting to die with the filename as well as
# the error from the parser.
try eval
{
$doc = XML::GDOME->createDocFromString( $xml_str );
};
my $err = catch;
if ( $err )
{
my $fn = $self->{filename};
die "$fn: $err";
}
if ( $infer_perl_class )
{
my @object_nodes;
# get all the <object/> nodes that lack a perl:class attribute
my $node = $doc->getDocumentElement()->getFirstChild();
while ( $node )
{
if ( $node->getNodeType() == XML::DOM::ELEMENT_NODE and
$node->getTagName() eq 'object' and
not $node->hasAttributeNS($OBJECT_PERL_NS, 'class') )
{
push @object_nodes, $node;
}
$node = $node->getNextSibling();
}
if ( scalar @object_nodes > 1 )
{
die "Cannot infer perl:class='...' value because more than one <object/> defined in this package is missing such a declaration.";
}
if ( scalar @object_nodes == 1 )
{
$object_nodes[0]->setAttributeNS($OBJECT_PERL_NS, 'perl:class', $package_name);
}
}
$self->{docs}->{$package_name} = $doc;
}
}
1;