#!/usr/bin/perl

use strict;
use warnings;
no warnings 'redefine';

use URI::file;
use RDF::Query;
use Test::More;
use Scalar::Util qw(blessed);
use RDF::Trine::Iterator qw(smap);
use RDF::Query::Node qw(iri);
use LWP::Simple;
use LWP::MediaTypes qw(add_type);

add_type( 'application/rdf+xml' => qw(rdf xrdf rdfx) );
add_type( 'text/turtle' => qw(ttl) );
add_type( 'text/plain' => qw(nt) );
add_type( 'text/x-nquads' => qw(nq) );
add_type( 'text/json' => qw(json) );
add_type( 'text/html' => qw(html xhtml htm) );

our $debug	= 0;
if ($] < 5.007003) {
	plan skip_all => 'perl >= 5.7.3 required';
	exit;
}

require Encode;
require Data::Dumper;

plan qw(no_plan);
require "xt/dawg/earl.pl";

my $PATTERN		= shift(@ARGV) || '';


my @manifests;
my $model	= new_model( map { glob( "xt/dawg11/$_/manifest.ttl" ) }
	qw(
		aggregates
		construct
		delete-insert
		grouping
		syntax-query
		syntax-fed
		syntax-update-1
		syntax-update-2
	) );

my $earl		= init_earl( $model );
my $type		= iri( "http://www.w3.org/1999/02/22-rdf-syntax-ns#type" );
my $pos_query	= iri( "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#PositiveSyntaxTest11" );
my $pos_update	= iri( "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#PositiveUpdateSyntaxTest11" );
my $neg_query	= iri( "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#NegativeSyntaxTest11" );
my $neg_update	= iri( "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#NegativeUpdateSyntaxTest11" );
my $mfname		= iri( "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#name" );
my $mfaction	= iri( "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#action" );
my $mf			= RDF::Trine::Namespace->new('http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#');

{
# 	print "# Positive Syntax Tests\n";
	my @manifests	= $model->subjects( $type, $mf->Manifest );
	foreach my $m (@manifests) {
		warn "Manifest: " . $m->as_string . "\n" if ($debug);
		my ($list)	= $model->objects( $m, $mf->entries );
		my @tests	= $model->get_list( $list );
		foreach my $test (@tests) {
			unless ($test->uri_value =~ /$PATTERN/) {
				next;
			}
			my $is_pos_query	= $model->count_statements($test, $type, $pos_query);
			my $is_pos_update	= $model->count_statements($test, $type, $pos_update);
			my $is_neg_query	= $model->count_statements($test, $type, $mf->NegativeSyntaxTest) + $model->count_statements($test, $type, $mf->NegativeSyntaxTest11);
			my $is_neg_update	= $model->count_statements($test, $type, $mf->NegativeUpdateSyntaxTest) + $model->count_statements($test, $type, $mf->NegativeUpdateSyntaxTest11);
			if ($is_pos_query or $is_pos_update) {
				my $name		= get_first_literal( $model, $test, $mfname );
				my $ok			= positive_syntax_test( $model, $test, $is_pos_update );
				ok( $ok, $name );
				if ($ok) {
					earl_pass_test( $earl, globalize_uri_filename($test) );
				} else {
					earl_fail_test( $earl, globalize_uri_filename($test) );
					warn RDF::Query->error;
				}
			} elsif ($is_neg_query or $is_neg_update) {
				my $name		= get_first_literal( $model, $test, $mfname );
				my $ok			= negative_syntax_test( $model, $test, $is_neg_update );
				ok( $ok, $name );
				if ($ok) {
					earl_pass_test( $earl, globalize_uri_filename($test) );
				} else {
					earl_fail_test( $earl, globalize_uri_filename($test) );
				}
			}
		}
	}
}

# {
# 	print "# Negative Syntax Tests\n";
# 	my @manifests	= $model->subjects( $type, $mf->Manifest );
# 	foreach my $m (@manifests) {
# 		warn "Manifest: " . $m->as_string . "\n" if ($debug);
# 		my ($list)	= $model->objects( $m, $mf->entries );
# 		my @tests	= $model->get_list( $list );
# 		foreach my $test (@tests) {
# 			my $is_neg_query	= $model->count_statements($test, $type, $mf->NegativeSyntaxTest) + $model->count_statements($test, $type, $mf->NegativeSyntaxTest11);
# 			my $is_neg_update	= $model->count_statements($test, $type, $mf->NegativeUpdateSyntaxTest) + $model->count_statements($test, $type, $mf->NegativeUpdateSyntaxTest11);
# 			if ($is_neg_query or $is_neg_update) {
# 				my $name		= get_first_literal( $model, $test, $mfname );
# 				unless ($test->uri_value =~ /$PATTERN/) {
# 					next;
# 				}
# 				my $ok			= negative_syntax_test( $model, $test );
# 				ok( $ok, $name );
# 				if ($ok) {
# 					earl_pass_test( $earl, globalize_uri_filename($test) );
# 				} else {
# 					earl_fail_test( $earl, globalize_uri_filename($test) );
# 					warn RDF::Query->error;
# 				}
# 			}
# 		}
# 	}
# }

open( my $fh, '>', 'earl-syntax-11.ttl' );
print {$fh} earl_output( $earl );
close($fh);


################################################################################


sub positive_syntax_test {
	my $model	= shift;
	my $test	= shift;
	my $update	= shift;
	my $action	= iri( "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#action" );
	my $file	= get_first_obj( $model, $test, $action );
	my $url		= $file->uri_value;
	my $uri		= URI->new( relativeize_url( $url ) );
	my $filename	= localize_uri_filename( $uri->file );
	my $sparql	= do { local($/) = undef; open(my $fh, '<', $filename); <$fh> };
	my @uargs	= $update ? (update => 1) : ();
	my $query	= eval { RDF::Query->new( $sparql, { lang => 'sparql11', @uargs } ) };
	return 0 if ($@);
	return blessed($query) ? 1 : 0;
}

sub negative_syntax_test {
	my $model	= shift;
	my $test	= shift;
	my $update	= shift;
	my $action	= iri( "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#action" );
	my $file	= get_first_obj( $model, $test, $action );
	my $url		= $file->uri_value;
	my $uri		= URI->new( relativeize_url( $url ) );
	my $filename	= $uri->file;
	my $sparql	= do { local($/) = undef; open(my $fh, '<', $filename); <$fh> };
	my @uargs	= $update ? (update => 1) : ();
	my $query	= eval { RDF::Query->new( $sparql, { lang => 'sparql11', @uargs } ) };
#	warn RDF::Query->error;
	return 1 if ($@);
	warn 'Test expected failure but successfully parsed: ' . Data::Dumper::Dumper($query->{parsed}) if (blessed($query));
#	warn $query->error if (blessed($query));
	return blessed($query) ? 0 : 1;
}


exit;

######################################################################


sub new_model {
	my @files		= @_;
	my $model		= RDF::Trine::Model->temporary_model;
	add_to_model( $model, file_uris(@files) );
	return ($model);
}

sub add_to_model {
	my $model	= shift;
	my @files	= @_;
	foreach my $file (@files) {
		my $pclass	= RDF::Trine::Parser->guess_parser_by_filename( $file );
		my $parser	= $pclass->new();
		my $rdf		= get($file);
		$parser->parse_into_model( $file, $rdf, $model );
	}
}

sub localize_uri_filename {
	my $uri	= shift;
	$uri	=~ s{^http://www.w3.org/2009/sparql/docs/tests/data-sparql11/}{xt/dawg11/};
	return $uri;
}

sub globalize_uri_filename {
	my $uri	= shift;
	$uri	= $uri->uri_value;
	$uri	=~ s{^.*xt/dawg11/}{http://www.w3.org/2009/sparql/docs/tests/data-sparql11/};
	return RDF::Trine::Node::Resource->new($uri);
}

sub file_uris {
	my @files	= @_;
	my @uris	= map { "$_" } map { URI::file->new_abs( $_ ) } @files;
	return @uris;
}

######################################################################


sub get_first_as_string  {
	my $node	= get_first_obj( @_ );
	return unless $node;
	return node_as_string( $node );
}

sub node_as_string {
	my $node	= shift;
	if ($node) {
		no warnings 'once';
		if ($node->isa('RDF::Trine::Node::Resource')) {
			return $node->uri_value;
		} elsif ($node->isa_literal) {
			return Encode::decode('utf8', $node->literal_value);
		} else {
			return $node->blank_identifier;
		}
	} else {
		return;
	}
}


sub get_first_literal {
	my $node	= get_first_obj( @_ );
	return $node ? $node->literal_value : undef;
}

sub get_all_literal {
	my @nodes	= get_all_obj( @_ );
	return map { $_->literal_value } grep { $_->isa('RDF::Trine::Node::Literal') } @nodes;
}

sub get_first_uri {
	my $node	= get_first_obj( @_ );
	return $node ? $node->uri_value : undef;
}

sub get_all_uri {
	my @nodes	= get_all_obj( @_ );
	return map { $_->uri_value } grep { defined($_) and $_->isa('RDF::Trine::Node::Resource') } @nodes;
}

sub get_first_obj {
	my $model	= shift;
	my $node	= shift;
	my $uri		= shift;
	my @uris	= UNIVERSAL::isa($uri, 'ARRAY') ? @{ $uri } : ($uri);
	my @preds	= map { ref($_) ? $_ : iri( $_ ) } @uris;
	foreach my $pred (@preds) {
		my $stream	= $model->get_statements( $node, $pred, undef );
		while (my $st = $stream->next) {
			my $node	= $st->object;
			return $node if ($node);
		}
	}
}

sub get_all_obj {
	my $model	= shift;
	my $node	= shift;
	my $uri		= shift;
	my @uris	= UNIVERSAL::isa($uri, 'ARRAY') ? @{ $uri } : ($uri);
	my @preds	= map { ref($_) ? $_ : iri( $_ ) } @uris;
	my @objs;
	
	my @streams;
	foreach my $pred (@preds) {
		push(@streams, $model->get_statements( $node, $pred, undef ));
	}
	my $stream	= shift(@streams);
	while (@streams) {
		$stream	= $stream->concat( shift(@streams) );
	}
	return map { $_->object } $stream->get_all();
}

sub relativeize_url {
	my $uri	= shift;
	if ($uri =~ /^http:/) {
		$uri	=~ s{^http://www.w3.org/2001/sw/DataAccess/tests/}{xt/dawg/data-r2/};
		$uri	= 'file://' . File::Spec->rel2abs( $uri );
	}
	return $uri;
}


__END__