package Test::RDF;

use warnings;
use strict;

use Carp;
use Test::Builder;
use RDF::Redland;
use base qw( Exporter );

our $VERSION = '0.0.2';
our @EXPORT  = qw( rdf_ok rdf_eq );

my $Test = Test::Builder->new();
RDF::Redland::set_log_handler(\&_log_handler);

sub rdf_ok {
    my ($format, $filename, $message) = @_;
    croak "RDF serialization format required"  if !$format;
    croak "RDF filename required"              if !$filename;
    croak "RDF file '$filename' doesn't exist" if !-e $filename;

    # try to parse the file
    eval {
        my $parser = RDF::Redland::Parser->new($format);
        my $uri = RDF::Redland::URI->new("file:$filename");
        my $stream = $parser->parse_as_stream($uri);
        while ( !$stream->end() ) {
            my $statement = $stream->current();
            $stream->next();
        }
    };

    # determine success or failure
    $Test->ok(!$@, $message);
    $Test->diag($@) if $@;
}

sub rdf_eq {

    # create two RDF models in memory
    my @models;
    for my $model_name (qw( a b )) {
        my $storage = RDF::Redland::Storage->new();
        my $model = RDF::Redland::Model->new($storage);
        push @models, $model;

        # validate the format and filename arguments
        my $format   = shift @_;
        my $filename = shift @_;

        croak "RDF serialization format required for part $model_name"
            if !$format;
        croak "RDF filename required for part $model_name"
            if !$filename;
        croak "RDF file '$filename' doesn't exist for part $model_name"
            if !-e $filename;

        # parse the file contents into the model
        my $parser = RDF::Redland::Parser->new($format);
        my $uri = RDF::Redland::URI->new("file:$filename");
        $parser->parse_into_model( $uri, $uri, $model );
    }

    my $message = shift @_;

    # are the models the same size?
    if ( $models[0]->size() != $models[1]->size() ) {
        $Test->ok(0, $message);
        $Test->diag(
            'Graphs differ in size: '
            . $models[0]->size() . ' vs. ' . $models[1]->size()
        );
        return;
    }

    # start the comparison with blank bnode maps
    _clear_bnode_mappings();

    # check all the statements for equivalence in the second model
    my $stream = $models[0]->as_stream();
    STATEMENT:
    while( !$stream->end() ) {
        my $stmt = $stream->current();
        next STATEMENT if _has_equivalent_statement($models[1], $stmt);
        $Test->ok(0, $message);
        $Test->diag(
            'Model B is missing the statement ' . $stmt->as_string()
        );
        return;
    }
    continue {
        $stream->next();
    }

    $Test->ok(1, $message);
}

sub _has_equivalent_statement {
    my ($model, $stmt) = @_;

    my $subject   = $stmt->subject();
    my $predicate = $stmt->predicate();
    my $object    = $stmt->object();
    my ($subject_is_floating, $object_is_floating) = (0)x2;

    # anchor the subject if possible
    if ( $subject->is_blank() ) {
        $subject_is_floating = 1;
        if ( my $mapped = _get_bnode_mapping($subject) ) {
            $subject = $mapped;
            $subject_is_floating = 0;
        }
    }

    # anchor the object if possible
    if ( $object->is_blank() ) {
        $object_is_floating = 1;
        if ( my $mapped = _get_bnode_mapping($object) ) {
            $object = $mapped;
            $object_is_floating = 0;
        }
    }

    if ( $subject_is_floating && $object_is_floating ) {
        my @candidates = $model->find_statements(
            RDF::Redland::Statement->new( undef, $predicate, undef )
        );
        for my $candidate (@candidates) {
            next if !$candidate->subject->is_blank();
            next if !$candidate->object->is_blank();
            # TODO what if $subject and $object are the same bnode?
            next if !_is_valid_mapping( $subject, $candidate->subject() );
            next if !_is_valid_mapping( $object, $candidate->object() );
            _create_bnode_mapping( $subject, $candidate->subject() );
            _create_bnode_mapping( $object, $candidate->object() );
            $model->remove_statement($candidate);
            return 1;
        }
    }
    elsif ( $subject_is_floating ) {
        my @sources = $model->sources( $predicate, $object );
        for my $source (@sources) {
            next if !$source->is_blank();
            next if !_is_valid_mapping( $subject, $source );
            _create_bnode_mapping( $subject, $source );
            $model->remove_statement( $source, $predicate, $object );
            return 1;
        }
    }
    elsif ( $object_is_floating ) {
        my @targets = $model->targets( $subject, $predicate );
        for my $target (@targets) {
            next if !$target->is_blank();
            next if !_is_valid_mapping( $object, $target );
            _create_bnode_mapping( $object, $target );
            $model->remove_statement( $subject, $predicate, $target );
            return 1;
        }
    }
    else {
        my $anchored_stmt
            = RDF::Redland::Statement->new( $subject, $predicate, $object );
        if ( $model->contains_statement($anchored_stmt) ) {
            $model->remove_statement($anchored_stmt);
            return 1;
        }
    }

    return;  # no equivalent statement found
}

{
    # map bnodes between models to insure that we get
    # a true bijection when calculating rdf_eq()
    my %a_to_b;
    my %b_to_a;
    sub _clear_bnode_mappings {
        %a_to_b = ();
        %b_to_a = ();
    }
    sub _get_bnode_mapping {
        my ($bnode_a) = @_;
        return $a_to_b{ $bnode_a->blank_identifier() };
    }
    sub _is_valid_mapping {
        my ( $bnode_a, $bnode_b ) = @_;
        return if $a_to_b{ $bnode_a->blank_identifier() };
        return if $b_to_a{ $bnode_b->blank_identifier() };
        return 1;
    }
    sub _create_bnode_mapping {
        my ( $bnode_a, $bnode_b ) = @_;
        die "Invalid mapping" if !_is_valid_mapping( $bnode_a, $bnode_b );
        $a_to_b{ $bnode_a->blank_identifier() } = $bnode_b;
        $b_to_a{ $bnode_b->blank_identifier() } = $bnode_a;
    }
}

# Handle error and warning messages from Redland, cleaning
# up the messages as necessary
sub _log_handler {
    my (
        $code,   $level, $facility, $message, $line,
        $column, $byte,  $file,     $uri
    ) = @_;

    die "$message\n";
}

1;

__END__

=head1 NAME
 
Test::RDF - Test RDF data for validity and equality
 
 
=head1 VERSION
 
This documentation refers to Test::RDF version 0.0.1
 
 
=head1 SYNOPSIS
 
    use Test::More tests => 1;
    use Test::RDF;
    
    rdf_ok( rdfxml => 'data.rdf', 'data validity' );
    rdf_eq( rdfxml => 'data.rdf', turtle => 'data.ttl', 'XML==Turtle' );

=head1 DESCRIPTION

Test::RDF is used for testing RDF data in various formats.  Currently,
Test::RDF exports a single function C<rdf_ok> which checks the validity of an
RDF file.  See L<rdf_ok> for details.

=head1 SUBROUTINES

=head2 rdf_eq $FORMAT, $FILENAME, $FORMAT, $FILENAME [, $MESSAGE]

Compares the RDF graphs created by the two RDF serializations for graph
equivalence.  RDF graph equivalence is defined by the RDF Concepts and
Abstract Syntax document here:
L<http://www.w3.org/TR/rdf-concepts/#section-graph-equality>.  If the two
graphs are equivalent, the test passes.  If the two graphs are not equivalent,
the test fails with a helpful diagnostic message.

C<rdf_eq> does not correctly handle reflexive statements involving bnodes.
That is, statements where subject and object are the same blank node.
 
=head2 rdf_ok $FORMAT, $FILENAME [, $MESSAGE]

C<$FORMAT> specifies the expected format of the RDF file.  It should be one
of: rdfxml, turtle or ntriples (actually, you can use any format allowed by
your version of L<RDF::Redland::Parser> but those three are the most commonly
useful).  C<$FILENAME> should be the path to a file containing RDF data in the
specified format.  C<$MESSAGE> is an optional message to use when displaying
the "ok" or "not ok" message.
 
=head1 CONFIGURATION AND ENVIRONMENT
 
Test::RDF requires no configuration files or environment variables.
 
=head1 DEPENDENCIES
 
=over

=item *

RDF::Redland

=back
 
=head1 INCOMPATIBILITIES
 
None known
 
=head1 BUGS AND LIMITATIONS

Please report any bugs or feature requests to
C<bug-test-rdf at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-RDF>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Test::RDF

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Test-RDF>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Test-RDF>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-RDF>

=item * Search CPAN

L<http://search.cpan.org/dist/Test-RDF>

=back

=head1 ACKNOWLEDGEMENTS

Dave Beckett for Redland.

=head1 AUTHOR

Michael Hendricks  <michael@palmcluster.org>

=head1 LICENSE AND COPYRIGHT
 
Copyright (c) 2006 Michael Hendricks (<michael@palmcluster.org>). All rights
reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
 
