File Coverage

blib/lib/XMLNews/Meta.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package XMLNews::Meta;

use strict;
				# The second row consists of static
				# variables used during XML import.
				# These variables prevent the module
				# from being thread-safe or reentrant.
use vars qw($VERSION $XNNS $RDFNS $DCNS %NS_PREFIX_MAP
	    $SELF $DATA @DATA_STACK $READINGPROPS);
use XML::Parser;
use Carp;
use IO;

$VERSION = '0.01';

#
# Static class variables
#

				# Some well-known namespaces...
$XNNS = "http://www.xmlnews.org/namespaces/meta#";
$RDFNS = "http://www.w3.org/1999/02/22-rdf-syntax-ns#";
$DCNS = "http://www.purl.org/dc#";

				# Namespace/prefix map for exporting
				# some commonly-known namespaces
				# (all others will have auto-generated
				# prefixes).
%NS_PREFIX_MAP = ($XNNS => "xn",
		  $RDFNS => "rdf",
		  $DCNS => "dc");


#
# Constructor.
#
sub new {
  my $class = shift;

				# The namespaces will be the top-level
				# keys, mapped to buckets containing
				# the names in each namespace
  return bless {}, $class;
}


#
# Return an array of namespaces used in the metadata.
#
sub getNamespaces {
  my $self = shift;
  my @ns = keys(%{$self});
  my $ns;
  foreach $ns (@ns) {
    if ($ns eq $RDFNS) {
      return @ns;
    }
  }
  push @ns, $RDFNS;
  return @ns;
}


#
# Return an array of property names used in a namespace.
#
sub getProperties {
  my ($self, $namespace) = (@_);
  my $ns = $self->{$namespace};
  return () unless $ns;
  return keys(%{$ns});
}


#
# Assign a value to a property in a namespace.
#
sub addValue {
  my ($self, $namespace, $property, $value) = (@_);

				# Get the namespace.
  my $ns = $self->{$namespace};
  unless ($ns) {		# Create a new namespace if necessary.
    $ns = {};
    $self->{$namespace} = $ns;
  }

				# Get the bucket.
  my $bucket = $ns->{$property};
  unless ($bucket) {		# Create a new bucket if necessary.
    $bucket = [];
    $ns->{$property} = $bucket;
  }

				# Add the value to the bucket.
  push @{$bucket}, $value;
}


#
# Return an array of values for a property in a namespace.
#
sub getValues {
  my ($self, $namespace, $property) = (@_);

				# Get the namespace.
  my $ns = $self->{$namespace};
  return () unless $ns;

				# Get the bucket.
  my $bucket = $ns->{$property};
  if ($bucket) {
    return @{$bucket};
  } else {
    return ();
  }
}


#
# Return a single value for a property in a namespace.
# This method will croak if the property has more than one value.
#
sub getValue {
  my ($self, $namespace, $property) = (@_);

				# Get the values for this property
  my @values = $self->getValues($namespace, $property);

				# Enforce maximum of one value.
  if ($#values < 1) {
    return $values[0];
  } else {
    croak "Multiple values for $property in $namespace namespace";
  }
}


#
# Return true if the specified property has at least one value.
#
sub hasValue {
  my ($self, $namespace, $property) = (@_);
  my @values = $self->getValues($namespace, $property);

				# This is probably a little inefficient
				# for now, but it will do.
  if ($#values > -1) {
    return 1;
  } else {
    return undef;
  }
}


#
# Remove the first occurrence of a value from a property in a namespace.
# Carp (don't croak) if we don't find it.
#
sub removeValue {
  my ($self, $namespace, $property, $value);

				# Try to find the namespace
  my $ns = $self->{$namespace};
  unless ($ns) {
    return;
  }

				# Try to find the property
  my $bucket = $ns->{$property};
  unless ($bucket) {
    return;
  }

				# Remove the first
  my ($i, $len);
  LOOP: for ($i = 0, $len = $#{$bucket}; $i <= $len; $i++) {
      if ($bucket->[$i] eq $value) {
	splice(@{$bucket}, $i, 1);
	last LOOP;
      }
    }


				# Remove an empty bucket.
  if ($#{keys(%{$bucket})} == -1) {
    delete $ns->{$property};
  }

				# Remove an empty namespace.
  if ($#{keys(%{$ns})} == -1) {
    delete $self->{$namespace};
  }
}


#
# Export properties.
#
sub exportRDF {
  my ($self, $output) = (@_);
  my $counter = 0;
  my %nsmap = (%NS_PREFIX_MAP);	# local copy

				# If the $output argument is a string,
				# open a file and invoke this method
				# recursively.
  unless (ref($output)) {
    $output = new IO::File(">$output") || croak "Cannot write to file $output";
    $self->exportRDF($output);
    $output->close();
    return;
  }

				# Loop up all of the namespaces in use.
  my @namespaces = $self->getNamespaces();
  $output->print("\n\n

				# Make certain that we have a prefix
				# for every namespace.
  my $ns;
  foreach $ns (@namespaces) {
    if (!$nsmap{$ns}) {
      $nsmap{$ns} = "p" . $counter++;
    }
    $output->print("\n  xmlns:" . $nsmap{$ns} . "=\"$ns\"");
  }
  $output->print(">\n\n");

  foreach $ns (@namespaces) {
    my @properties = $self->getProperties($ns);
    my $prop;
    foreach $prop (@properties) {
      my $name = $nsmap{$ns} . ':' . $prop;
      my @values = $self->getValues($ns, $prop);
      my $value;
      foreach $value (@values) {
	$output->print("<$name>$value\n");
      }
    }
  }

  $output->print("\n\n");
}


#
# Import literal properties from an RDF document.
# This method is not thread-safe or reentrant.
#
sub importRDF {
  my ($self, $input) = (@_);
  my $parser = $self->_make_parser();

				# Initialise static variables used
				# during the parse.  It would be
				# better to use closures, but they
				# are causing serious memory leaks.
  $DATA = '';
  @DATA_STACK = ();
  $READINGPROPS = 0;

  unless (ref($input)) {
    $input = new IO::File("<$input") || croak "Cannot read file $input";
    $self->importRDF($input);
    $input->close();
    return;
  }
  $SELF = $self;
  $parser->parse($input);
  $SELF = undef;
}


#
# Internal method: handle the start of an element during import.
# (This should be a closure, but closures leak badly.)
#
sub _start {
  my ($expat, $name) = (@_);
  my $self = $SELF;
  my $ns = $expat->namespace($name);

			      # Start capturing data.
  push @DATA_STACK, $DATA;
  $DATA = "";

			      # Oops!  There is no namespace!
  unless (defined($ns)) {
    $expat->xpcarp ("Element $name has no declared namespace\n");
  }

  unless ($READINGPROPS) {
    if ($ns eq $RDFNS && $name eq 'RDF') {
      # no op!
    } elsif ($ns eq $RDFNS && $name eq 'Description') {
      $READINGPROPS = 1;
    } else {
      $READINGPROPS = 1;
      $self->addValue($RDFNS, "type", $ns . $name);
    }
  }
}


#
# Internal method: handle the end of an element during import.
# (This should be a closure, but closures leak badly.)
#
sub _end {
  my ($expat, $name) = (@_);
  my $self = $SELF;
  my $ns = $expat->namespace($name);

  if (!defined($ns)) {
    $expat->xpcarp("Element $name has no declared namespace\n");
  } elsif (($ns eq $XNNS && $name eq "Resource") ||
	   ($ns eq $RDFNS && $name eq "Description")){
    $READINGPROPS = 0;
  } elsif ($READINGPROPS) {
    $self->addValue($ns, $name, $DATA);
  }

			      # Finish capturing data.
  $DATA = pop @DATA_STACK;
}


#
# Internal method: handle character data during import.
# (This should be a closure, but closures leak badly.)
#
sub _char {
  my ($expat, $data) = (@_);
  my $self = $SELF;
  $DATA .= $data;
}


#
# Create an XML parser.
#
sub _make_parser {
  my $self = shift;

				# Create the actual parser.
  return new XML::Parser(Handlers => {Start => \&_start,
				      End => \&_end,
				      Char => \&_char},
				Namespaces => 1);
}


# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__