libtest-rdf-perl 1.16-2 / usr / share / perl5 / Test / RDF.pm

package Test::RDF;

use warnings;
use strict;

use Carp;
use RDF::Trine;
use RDF::Trine::Parser;
use RDF::Trine::Model;
use RDF::Trine::Graph;
use Scalar::Util qw/blessed/;

use base 'Test::Builder::Module';
our @EXPORT = qw/are_subgraphs is_rdf is_valid_rdf isomorph_graphs has_subject has_predicate has_object_uri has_uri hasnt_uri has_literal hasnt_literal pattern_target pattern_ok pattern_fail/;


=head1 NAME

Test::RDF - Test RDF data for content, validity and equality, etc.

=head1 VERSION

Version 1.16

=cut

our $VERSION = '1.16';


=head1 SYNOPSIS

 use Test::RDF;

 is_valid_rdf($rdf_string, $syntax,  'RDF string is valid according to selected syntax');
 is_rdf($rdf_string, $syntax1, $expected_rdf_string, $syntax2, 'The two strings have the same triples');
 isomorph_graphs($model, $expected_model, 'The two models have the same triples');
 are_subgraphs($model1, $model2, 'Model 1 is a subgraph of model 2' );
 has_uri($uri_string, $model, 'Has correct URI');
 hasnt_uri($uri_string, $model, "Hasn't correct URI");
 has_subject($uri_string, $model, 'Subject URI is found');
 has_predicate($uri_string, $model, 'Predicate URI is found');
 has_object_uri($uri_string, $model, 'Object URI is found');
 has_literal($string, $language, $datatype, $model, 'Literal is found');
 hasnt_literal($string, $language, $datatype, $model, 'Literal is not found');
 pattern_target($model);
 pattern_ok($pattern, '$pattern found in $model');
 pattern_fail($pattern, '$pattern not found in $model');

=head1 DESCRIPTION

This Perl module, Test::RDF, provides tools for testing code which
deals with RDF. It can test RDF for validity, check if two RDF graphs
are the same, or subgraphs of each other, if a URI is or is not in a
dataset, if it has certain subjects, predicates, objects or
literals. It can also test to see if a full pattern is present or
absent.


=head1 EXPORT

=head2 is_valid_rdf

Use to check if the input RDF string is valid in the chosen syntax

=cut

sub is_valid_rdf {
  my ($rdf, $syntax, $name) = @_;
  my $test = __PACKAGE__->builder;
  unless ($rdf) {
    $test->ok( 0, $name );
    $test->diag("No input was given.");
    return;
  }
  my $parser = RDF::Trine::Parser->new($syntax);
  eval {
    $parser->parse('http://example.org/', $rdf, sub {});
  };
  if ( my $error = $@ ) {
    $test->ok( 0, $name );
    $test->diag("Input was not valid RDF:\n\n\t$error");
    return;
  }
  else {
    $test->ok( 1, $name );
    return 1;
  }
}


=head2 is_rdf

Use to check if the input RDF strings are isomorphic (i.e. the same).

=cut


sub is_rdf {
  my ($rdf1, $syntax1, $rdf2, $syntax2, $name) = @_;
  my $test = __PACKAGE__->builder;
  unless ($rdf1) {
    $test->ok( 0, $name );
    $test->diag("No input was given.");
    return;
  }
  my $parser1 = RDF::Trine::Parser->new($syntax1);
  local $Test::Builder::Level = $Test::Builder::Level + 1;

  # First, test if the input RDF is OK
  my $model1 = RDF::Trine::Model->temporary_model;
  eval {
    $parser1->parse_into_model('http://example.org/', $rdf1, $model1);
  };
  if ( my $error = $@ ) {
    $test->ok( 0, $name );
    $test->diag("Input was not valid RDF:\n\n\t$error");
    return;
  }

  # If the expected RDF is non-valid, don't catch the exception
  my $parser2 = RDF::Trine::Parser->new($syntax2);
  my $model2 = RDF::Trine::Model->temporary_model;
  $parser2->parse_into_model('http://example.org/', $rdf2, $model2);
  return isomorph_graphs($model1, $model2, $name);
}


=head2 isomorph_graphs

Use to check if the input RDF::Trine::Models have isomorphic graphs.

=cut


sub isomorph_graphs {
  my ($model1, $model2, $name) = @_;
  my $g1 = RDF::Trine::Graph->new( $model1 );
  my $g2 = RDF::Trine::Graph->new( $model2 );
  my $test = __PACKAGE__->builder;

  if ($g1->equals($g2)) {
    $test->ok( 1, $name );
    return 1;
  } else {
    $test->ok( 0, $name );
    $test->diag('Graphs differ:');
    $test->diag($g1->error);
    return;
  }
}

=head2 are_subgraphs

Use to check if the first RDF::Trine::Models is a subgraph of the second.

=cut

sub are_subgraphs {
  my ($model1, $model2, $name) = @_;
  my $g1 = RDF::Trine::Graph->new( $model1 );
  my $g2 = RDF::Trine::Graph->new( $model2 );
  my $test = __PACKAGE__->builder;

  if ($g1->is_subgraph_of($g2)) {
    $test->ok( 1, $name );
    return 1;
  } else {
    $test->ok( 0, $name );
    $test->diag('Graph not subgraph: ' . $g1->error) if defined($g1->error);
    $test->diag('Hint: There are ' . $model1->size . ' statement(s) in model1 and ' . $model2->size . ' statement(s) in model2');
    return;
  }
}

=head2 has_subject

Check if the string URI passed as first argument is a subject in any
of the statements given in the model given as second argument.

=cut

sub has_subject {
  my ($uri, $model, $name) = @_;
  my $resource = _resource_uri_checked($uri, $name);
  return $resource unless ($resource);
  my $count = $model->count_statements($resource, undef, undef);
  return _single_uri_tests($count, $name);
}


=head2 has_predicate

Check if the string URI passed as first argument is a predicate in any
of the statements given in the model given as second argument.

=cut

sub has_predicate {
  my ($uri, $model, $name) = @_;
  my $resource = _resource_uri_checked($uri, $name);
  return $resource unless ($resource);
  my $count = $model->count_statements(undef, $resource, undef);
  return _single_uri_tests($count, $name);
}

=head2 has_object_uri

Check if the string URI passed as first argument is a object in any
of the statements given in the model given as second argument.

=cut

sub has_object_uri {
  my ($uri, $model, $name) = @_;
  my $resource = _resource_uri_checked($uri, $name);
  return $resource unless ($resource);
  my $count = $model->count_statements(undef, undef, $resource);
  return _single_uri_tests($count, $name);
}

=head2 has_literal

Check if the string passed as first argument, with corresponding
optional language and datatype as second and third respectively, is a
literal in any of the statements given in the model given as fourth
argument.

language and datatype may not occur in the same statement, so the test
fails if they are both set. If none are used, use C<undef>, like e.g.

 has_literal('A test', undef, undef, $model, 'Simple literal');

A test for a typed literal may be done like

 has_literal('42', undef, 'http://www.w3.org/2001/XMLSchema#integer', $model, 'Just an integer');

and a language literal like

 has_literal('This is a Another test', 'en', undef, $model, 'Language literal');


=cut

sub has_literal {
  my ($string, $lang, $datatype, $model, $name) = @_;
  my $literal;
  my $test = __PACKAGE__->builder;
  eval {
    $literal = RDF::Trine::Node::Literal->new($string, $lang, $datatype);
  };
  if ( my $error = $@ ) {
    $test->ok( 0, $name );
    $test->diag("Invalid literal:\n\n\t$error");
    return;
  }

  if ($model->count_statements(undef, undef, $literal) > 0) {
    $test->ok( 1, $name );
    return 1;
  } else {
    $test->ok( 0, $name );
    $test->diag('No matching literals found in model');
    return 0;
  }
}


=head2 hasnt_literal

This is like the above, only the opposite: It checks if a literal
doesn't exist. Like the above, the test will fail if the literal is
invalid, however.

=cut

sub hasnt_literal {
  my ($string, $lang, $datatype, $model, $name) = @_;
  my $literal;
  my $test = __PACKAGE__->builder;
  eval {
    $literal = RDF::Trine::Node::Literal->new($string, $lang, $datatype);
  };

  if ( my $error = $@ ) {
    $test->ok( 0, $name );
    $test->diag("Invalid literal:\n\n\t$error");
    return;
  }

  if ($model->count_statements(undef, undef, $literal) > 0) {
    $test->ok( 0, $name );
    $test->diag('Matching literals found in model');
    return 0;
  } else {
    $test->ok( 1, $name );
    return 1;
  }
}



=head2 has_uri

Check if the string URI passed as first argument is present in any of
the statements given in the model given as second argument.

=cut

sub has_uri {
  my ($uri, $model, $name) = @_;
  my $test = __PACKAGE__->builder;
  my $resource = _resource_uri_checked($uri, $name);
  return $resource unless ($resource);
  if ($model->count_statements(undef, undef, $resource) > 0
      || $model->count_statements(undef, $resource, undef) > 0
      || $model->count_statements($resource, undef, undef) > 0) {
    $test->ok( 1, $name );
    return 1;
  } else {
    $test->ok( 0, $name );
    $test->diag('No matching URIs found in model');
    return 0;
  }
}


=head2 hasnt_uri

Check if the string URI passed as first argument is not present in any
of the statements given in the model given as second argument.

=cut

sub hasnt_uri {
  my ($uri, $model, $name) = @_;
  my $test = __PACKAGE__->builder;
  my $resource;
  eval {
	  $resource = RDF::Trine::Node::Resource->new($uri);
  };
  if (($resource) && ($model->count_statements(undef, undef, $resource) > 0
      || $model->count_statements(undef, $resource, undef) > 0
      || $model->count_statements($resource, undef, undef)) > 0) {
    $test->ok( 0, $name );
    $test->diag('Matching URIs found in model');
    return 0;
  } else {
    $test->ok( 1, $name );
    return 1;
  }
}


sub _single_uri_tests {
  my ($count, $name) = @_;
  my $test = __PACKAGE__->builder;
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  if ($count > 0) {
    $test->ok( 1, $name );
    return 1;
  } else {
    $test->ok( 0, $name );
    $test->diag('No matching URIs found in model');
    return 0;
  }
}

sub _resource_uri_checked {
	my ($uri, $name) = @_;
	my $resource;
	eval {
		$resource = RDF::Trine::Node::Resource->new($uri);
	};
	if ( my $error = $@ ) {
		my $test = __PACKAGE__->builder;
		local $Test::Builder::Level = $Test::Builder::Level + 1;
		$test->ok( 0, $name );
		$test->diag("No matching URIs found in model");
		return 0;
	}
	return $resource;
}

		



=head2 pattern_target

Tests that the object passed as its parameter is an RDF::Trine::Model or
RDF::Trine::Store. That is, tests that it is a valid thing to match basic
graph patterns against.

Additionally, this test establishes the target for future C<pattern_ok> tests.

=head2 pattern_ok

Tests that the pattern passed matches against the target established by
C<pattern_target>. The pattern may be passed as an RDF::Trine::Pattern, or
a list of RDF::Trine::Statement objects.

 use Test::RDF;
 use RDF::Trine qw[iri literal blank variable statement];
 use My::Module;

 my $foaf = RDF::Trine::Namespace->new('http://xmlns.com/foaf/0.1/');
 pattern_target(My::Module->get_model); # check isa RDF::Trine::Model
 pattern_ok(
   statement(
     variable('who'),
     $foaf->name,
     literal('Kjetil Kjernsmo')
     ),
   statement(
     variable('who'),
     $foaf->page,
     iri('http://search.cpan.org/~kjetilk/')
     ),
   "Data contains Kjetil's details."
   );

B<Note:> C<pattern_target> must have been tested before any C<pattern_ok> tests.

=head2 pattern_fail

The same as above, but tests if the pattern returns no results instead.

=cut

{ # scope for $target
  my $target;
  sub pattern_target {
    my $t = shift;
    my $test = __PACKAGE__->builder;
    if (blessed($t) && $t->isa('RDF::Trine::Model')) {
      $target = $t;
      $test->ok(1, 'Data is an RDF::Trine::Model.');
      return 1;
    }
    elsif (blessed($t) && $t->isa('RDF::Trine::Store')) {
      $target = $t;
      $test->ok(1, 'Data is an RDF::Trine::Store.');
      return 1;
    }
    else {
      $test->ok(0, 'Data is not an RDF::Trine::Model or RDF::Trine::Store.');
      return 0;
    }
  }

  sub pattern_ok {
    my $message = undef;
    $message = pop @_ if !ref $_[-1];
    unless (defined $message and length $message) {
      $message = "Pattern match";
    }
    my $test = __PACKAGE__->builder;
    unless (blessed($target)) {
      $test->ok(0, $message);
      $test->diag("No target defined for pattern match. Call pattern_target test first.");
      return 0;
    }
    my $pattern = (blessed($_[0]) and $_[0]->isa('RDF::Trine::Pattern'))
                ? $_[0]
                : RDF::Trine::Pattern->new(@_);
	 my $s = RDF::Trine::Serializer::Turtle->new();

    my $iter    = $target->get_pattern($pattern);
    if ($iter->materialize->length > 0) {
      $test->ok(1, $message);
      return 1;
    }
	 # The test result is now known, return diagnostics
	 my $noreturns;
	 foreach my $triple ($pattern->triples) {
		 my @triple;
		 foreach my $node ($triple->nodes) {
			 if ($node->is_variable) {
				 push(@triple, undef);
			 } else {
				 push(@triple, $node);
			 }
		 }
		 next if ($target->count_statements(@triple));
		 $noreturns .= $triple->as_string . "\n";
	 }
    $test->ok(0, $message);
	 if ($noreturns) {
		 $test->diag("Triples that had no results:\n$noreturns");
	 } else {
		 $test->diag('Pattern as a whole did not match');
	 }
    return 0;
  }

  sub pattern_fail {
    my $message = undef;
    $message = pop @_ if !ref $_[-1];
    unless (defined $message and length $message) {
      $message = "Pattern doesn't match";
    }
    my $test = __PACKAGE__->builder;
    unless (blessed($target)) {
      $test->ok(0, $message);
      $test->diag("No target defined for pattern match. Call pattern_target test first.");
      return 0;
    }
    my $pattern = (blessed($_[0]) and $_[0]->isa('RDF::Trine::Pattern'))
                ? $_[0]
                : RDF::Trine::Pattern->new(@_);
    my $iter = $target->get_pattern($pattern)->materialize;

    if ($iter->length == 0) {
      $test->ok(1, $message);
      return 1;
    }
	 # The test result is now known, return diagnostics
    $test->ok(0, $message);
	 $test->diag("These triples had results:\n" . $iter->as_string);
    return 0;
  }
} # /scope for $target


=head1 NOTE

Graph isomorphism is a complex problem, so do not attempt to run the
isomorphism tests on large datasets. For more information see
L<http://en.wikipedia.org/wiki/Graph_isomorphism_problem>.


=head1 AUTHOR

Kjetil Kjernsmo, C<< <kjetilk at cpan.org> >>

=head1 BUGS

Please report any bugs using L<github|https://github.com/kjetilk/Test-RDF/issues>


=head1 SUPPORT

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

    perldoc Test::RDF

You may find the Perl and RDF community L<website|http://www.perlrdf.org/> useful.

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 * Search CPAN

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

=item * MetaCPAN

L<https://metacpan.org/module/Test::RDF>

=back


=head1 ACKNOWLEDGEMENTS

Michael Hendricks wrote the first Test::RDF. The present module is a
complete rewrite from scratch using Gregory Todd William's
L<RDF::Trine::Graph> to do the heavy lifting.

Toby Inkster has submitted the pattern_* functions.

=head1 LICENSE AND COPYRIGHT

Copyright 2010 ABC Startsiden AS and 2010-2013 Kjetil Kjernsmo.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1; # End of Test::RDF