1#!/usr/bin/env perl 2 3use strict; 4use warnings; 5no warnings 'redefine'; 6 7use Encode qw(encode); 8 9use URI::file; 10use Test::More; 11use File::Temp qw(tempfile); 12use Scalar::Util qw(blessed reftype); 13use Storable qw(dclone); 14use Algorithm::Combinatorics qw(permutations); 15use LWP::MediaTypes qw(add_type); 16use Text::CSV_XS; 17use Regexp::Common qw /URI/; 18 19add_type( 'application/rdf+xml' => qw(rdf xrdf rdfx) ); 20add_type( 'text/turtle' => qw(ttl) ); 21add_type( 'text/plain' => qw(nt) ); 22add_type( 'text/x-nquads' => qw(nq) ); 23add_type( 'text/json' => qw(json) ); 24add_type( 'text/html' => qw(html xhtml htm) ); 25 26use RDF::Query; 27use RDF::Query::Node qw(iri blank literal variable); 28use RDF::Trine qw(statement); 29use RDF::Trine::Error qw(:try); 30use RDF::Trine::Graph; 31use RDF::Trine::Namespace qw(rdf rdfs xsd); 32use RDF::Trine::Iterator qw(smap); 33use RDF::Endpoint 0.05; 34use Carp; 35use HTTP::Request; 36use HTTP::Response; 37use HTTP::Message::PSGI; 38 39$RDF::Query::Plan::PLAN_CLASSES{'service'} = 'Test::RDF::Query::Plan::Service'; 40 41################################################################################ 42# Log::Log4perl::init( \q[ 43# log4perl.category.rdf.query.plan.service = TRACE, Screen 44# # log4perl.category.rdf.query.plan.join.pushdownnestedloop = TRACE, Screen 45# log4perl.appender.Screen = Log::Log4perl::Appender::Screen 46# log4perl.appender.Screen.stderr = 0 47# log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout 48# ] ); 49################################################################################ 50 51our $debug = 0; 52our $STRICT_APPROVAL = 0; 53if ($] < 5.007003) { 54 plan skip_all => 'perl >= 5.7.3 required'; 55 exit; 56} 57 58use Data::Dumper; 59require XML::Simple; 60 61plan qw(no_plan); 62require "xt/dawg/earl.pl"; 63 64my $PATTERN = ''; 65my %args; 66 67while (defined(my $opt = shift)) { 68 if ($opt eq '-v') { 69 $debug++; 70 } elsif ($opt =~ /^-(.*)$/) { 71 $args{ $1 } = 1; 72 } else { 73 $PATTERN = $opt; 74 } 75} 76 77$ENV{RDFQUERY_THROW_ON_SERVICE} = 1; 78 79no warnings 'once'; 80 81if ($PATTERN) { 82# $debug = 1; 83} 84 85warn "PATTERN: ${PATTERN}\n" if ($PATTERN and $debug); 86 87my $model = RDF::Trine::Model->temporary_model; 88my @manifests = map { $_->as_string } map { URI::file->new_abs( $_ ) } map { glob( "xt/dawg/data-r2/$_/manifest.ttl" ) } 89 qw( 90 algebra 91 ask 92 basic 93 bnode-coreference 94 bound 95 cast 96 construct 97 dataset 98 distinct 99 expr-builtin 100 expr-equals 101 expr-ops 102 graph 103 i18n 104 open-world 105 optional 106 optional-filter 107 reduced 108 regex 109 solution-seq 110 sort 111 triple-match 112 type-promotion 113 ); 114foreach my $file (@manifests) { 115 warn "Parsing manifest $file\n" if $debug; 116 RDF::Trine::Parser->parse_url_into_model( $file, $model, canonicalize => 1 ); 117} 118warn "done parsing manifests" if $debug; 119 120my $earl = init_earl( $model ); 121my $rs = RDF::Trine::Namespace->new('http://www.w3.org/2001/sw/DataAccess/tests/result-set#'); 122my $mf = RDF::Trine::Namespace->new('http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#'); 123my $ut = RDF::Trine::Namespace->new('http://www.w3.org/2009/sparql/tests/test-update#'); 124my $rq = RDF::Trine::Namespace->new('http://www.w3.org/2001/sw/DataAccess/tests/test-query#'); 125my $dawgt = RDF::Trine::Namespace->new('http://www.w3.org/2001/sw/DataAccess/tests/test-dawg#'); 126 127{ 128 my @manifests = $model->subjects( $rdf->type, $mf->Manifest ); 129 foreach my $m (@manifests) { 130 warn "Manifest: " . $m->as_string . "\n" if ($debug); 131 my ($list) = $model->objects( $m, $mf->entries ); 132 unless (blessed($list)) { 133 warn "No mf:entries found for manifest " . $m->as_string . "\n"; 134 } 135 my @tests = $model->get_list( $list ); 136 foreach my $test (@tests) { 137 my $et = $model->count_statements($test, $rdf->type, $mf->QueryEvaluationTest); 138 my $ct = $model->count_statements($test, $rdf->type, $mf->CSVResultFormatTest); 139 if ($et + $ct) { 140 my ($name) = $model->objects( $test, $mf->name ); 141 unless ($test->uri_value =~ /$PATTERN/) { 142 next; 143 } 144 warn "### query eval test: " . $test->as_string . " >>> " . $name->literal_value . "\n" if ($debug); 145 query_eval_test( $model, $test, $earl ); 146 } 147 148 if ($model->count_statements($test, $rdf->type, $ut->UpdateEvaluationTest) or $model->count_statements($test, $rdf->type, $mf->UpdateEvaluationTest)) { 149 my ($name) = $model->objects( $test, $mf->name ); 150 unless ($test->uri_value =~ /$PATTERN/) { 151 next; 152 } 153 warn "### update eval test: " . $test->as_string . " >>> " . $name->literal_value . "\n" if ($debug); 154 update_eval_test( $model, $test, $earl ); 155 } 156 } 157 } 158} 159 160open( my $fh, '>', 'earl-eval-10.ttl' ) or die $!; 161print {$fh} earl_output( $earl ); 162close($fh); 163 164################################################################################ 165 166sub update_eval_test { 167 my $model = shift; 168 my $test = shift; 169 my $earl = shift; 170 171 my ($action) = $model->objects( $test, $mf->action ); 172 my ($result) = $model->objects( $test, $mf->result ); 173 my ($req) = $model->objects( $test, $mf->requires ); 174 my ($approved) = $model->objects( $test, $dawgt->approval ); 175 my ($queryd) = $model->objects( $action, $ut->request ); 176 my ($data) = $model->objects( $action, $ut->data ); 177 my @gdata = $model->objects( $action, $ut->graphData ); 178 179 if ($STRICT_APPROVAL) { 180 unless ($approved) { 181 warn "- skipping test because it isn't approved\n" if ($debug); 182 return; 183 } 184 if ($approved->equal( $dawgt->NotClassified)) { 185 warn "- skipping test because its approval is dawgt:NotClassified\n" if ($debug); 186 return; 187 } 188 } 189 190 my $uri = URI->new( $queryd->uri_value ); 191 my $filename = $uri->file; 192 my (undef,$base,undef) = File::Spec->splitpath( $filename ); 193 $base = "file://${base}"; 194 warn "Loading SPARQL query from file $filename" if ($debug); 195 my $sparql = do { local($/) = undef; open(my $fh, '<', $filename) or do { fail("$!: $filename; " . $test->as_string); return }; binmode($fh, ':utf8'); <$fh> }; 196 197 my $q = $sparql; 198 $q =~ s/\s+/ /g; 199 if ($debug) { 200 warn "### test : " . $test->as_string . "\n"; 201 warn "# sparql : $q\n"; 202 warn "# data : " . $data->as_string . "\n" if (blessed($data)); 203 warn "# graph data : " . $_->as_string . "\n" for (@gdata); 204 warn "# result : " . $result->as_string . "\n"; 205 warn "# requires : " . $req->as_string . "\n" if (blessed($req)); 206 } 207 208 print STDERR "constructing model... " if ($debug); 209 my ($test_model) = RDF::Trine::Model->temporary_model; 210 try { 211 if (blessed($data)) { 212 add_to_model( $test_model, $data->uri_value ); 213 } 214 } catch Error with { 215 my $e = shift; 216 fail($test->as_string); 217 earl_fail_test( $earl, $test, $e->text ); 218 print "# died: " . $test->as_string . ": $e\n"; 219 return; 220 } except { 221 my $e = shift; 222 die $e->text; 223 } otherwise { 224 warn '*** failed to construct model'; 225 }; 226 227 foreach my $gdata (@gdata) { 228 my ($data) = ($model->objects( $gdata, $ut->data ))[0] || ($model->objects( $gdata, $ut->graph ))[0]; 229 my ($graph) = $model->objects( $gdata, $rdfs->label ); 230 my $uri = $graph->literal_value; 231 try { 232 warn "test data file: " . $data->uri_value . "\n" if ($debug); 233 RDF::Trine::Parser->parse_url_into_model( $data->uri_value, $test_model, context => RDF::Trine::Node::Resource->new($uri), canonicalize => 1 ); 234 } catch Error with { 235 my $e = shift; 236 fail($test->as_string); 237 earl_fail_test( $earl, $test, $e->text ); 238 print "# died: " . $test->as_string . ": $e\n"; 239 return; 240 }; 241 } 242 243 my ($result_status) = $model->objects( $result, $ut->result ); 244 my @resgdata = $model->objects( $result, $ut->graphData ); 245 my $expected_model = RDF::Trine::Model->temporary_model; 246 my ($resdata) = $model->objects( $result, $ut->data ); 247 try { 248 if (blessed($resdata)) { 249 RDF::Trine::Parser->parse_url_into_model( $resdata->uri_value, $expected_model, canonicalize => 1 ); 250 } 251 } catch Error with { 252 my $e = shift; 253 fail($test->as_string); 254 earl_fail_test( $earl, $test, $e->text ); 255 print "# died: " . $test->as_string . ": $e\n"; 256 return; 257 }; 258 foreach my $gdata (@resgdata) { 259 my ($data) = ($model->objects( $gdata, $ut->data ))[0] || ($model->objects( $gdata, $ut->graph ))[0]; 260 my ($graph) = $model->objects( $gdata, $rdfs->label ); 261 my $uri = $graph->literal_value; 262 my $return = 0; 263 if ($data) { 264 try { 265 warn "expected result data file: " . $data->uri_value . "\n" if ($debug); 266 RDF::Trine::Parser->parse_url_into_model( $data->uri_value, $expected_model, context => RDF::Trine::Node::Resource->new($uri), canonicalize => 1 ); 267 } catch Error with { 268 my $e = shift; 269 fail($test->as_string); 270 earl_fail_test( $earl, $test, $e->text ); 271 print "# died: " . $test->as_string . ": $e\n"; 272 $return = 1; 273 }; 274 return if ($return); 275 } 276 } 277 278 if ($debug) { 279 warn "Dataset before update operation:\n"; 280 warn $test_model->as_string; 281 } 282 my $ok = 0; 283 eval { 284 my $query = RDF::Query->new( $sparql, { lang => 'sparql11', update => 1, canonicalize => 1 } ); 285 unless ($query) { 286 warn 'Query error: ' . RDF::Query->error; 287 fail($test->as_string); 288 return; 289 } 290 291 my ($plan, $ctx) = $query->prepare( $test_model ); 292 $query->execute_plan( $plan, $ctx ); 293 294 my $test_graph = RDF::Trine::Graph->new( $test_model ); 295 my $expected_graph = RDF::Trine::Graph->new( $expected_model ); 296 297 298 my $eq = $test_graph->equals( $expected_graph ); 299 $ok = is( $eq, 1, $test->as_string ); 300 unless ($ok) { 301 warn $test_graph->error; 302 warn "Got model:\n" . $test_model->as_string; 303 warn "Expected model:\n" . $expected_model->as_string; 304 } 305 }; 306 if ($@ or not($ok)) { 307 if ($@) { 308 fail($test->as_string); 309 } 310 earl_fail_test( $earl, $test, $@ ); 311 print "# failed: " . $test->as_string . "\n"; 312 } else { 313 earl_pass_test( $earl, $test ); 314 } 315 316 print STDERR "ok\n" if ($debug); 317} 318 319sub query_eval_test { 320 my $model = shift; 321 my $test = shift; 322 my $earl = shift; 323 324 my ($action) = $model->objects( $test, $mf->action ); 325 my ($result) = $model->objects( $test, $mf->result ); 326 my ($req) = $model->objects( $test, $mf->requires ); 327 my ($approved) = $model->objects( $test, $dawgt->approval ); 328 my ($queryd) = $model->objects( $action, $rq->query ); 329 my ($data) = $model->objects( $action, $rq->data ); 330 my @gdata = $model->objects( $action, $rq->graphData ); 331 my @sdata = $model->objects( $action, $rq->serviceData ); 332 333 if ($STRICT_APPROVAL) { 334 unless ($approved) { 335 warn "- skipping test because it isn't approved\n" if ($debug); 336 return; 337 } 338 if ($approved->equal($dawgt->NotClassified)) { 339 warn "- skipping test because its approval is dawgt:NotClassified\n" if ($debug); 340 return; 341 } 342 } 343 344 my $uri = URI->new( $queryd->uri_value ); 345 my $filename = $uri->file; 346 my (undef,$base,undef) = File::Spec->splitpath( $filename ); 347 $base = "file://${base}"; 348 warn "Loading SPARQL query from file $filename" if ($debug); 349 my $sparql = do { local($/) = undef; open(my $fh, '<', $filename) or do { warn("$!: $filename; " . $test->as_string); return }; binmode($fh, ':utf8'); <$fh> }; 350 351 my $q = $sparql; 352 $q =~ s/\s+/ /g; 353 if ($debug) { 354 warn "### test : " . $test->as_string . "\n"; 355 warn "# sparql : $q\n"; 356 warn "# data : " . $data->as_string if (blessed($data)); 357 warn "# graph data : " . $_->as_string for (@gdata); 358 warn "# result : " . $result->as_string; 359 warn "# requires : " . $req->as_string if (blessed($req)); 360 } 361 362 363# warn 'service data: ' . Dumper(\@sdata); 364 foreach my $sd (@sdata) { 365 my ($url) = $model->objects( $sd, $rq->endpoint ); 366 print STDERR "setting up remote endpoint $url...\n" if ($debug); 367 my ($data) = $model->objects( $sd, $rq->data ); 368 my @gdata = $model->objects( $sd, $rq->graphData ); 369 if ($debug) { 370 warn "- data : " . $data->as_string if (blessed($data)); 371 warn "- graph data : " . $_->as_string for (@gdata); 372 } 373 my $model = RDF::Trine::Model->new(); 374 if ($data) { 375 RDF::Trine::Parser->parse_url_into_model( $data->uri_value, $model ); 376 } 377 $Test::RDF::Query::Plan::Service::service_ctx{ $url->uri_value } = $model; 378 } 379 380 381 382 383 384 385 print STDERR "constructing model... " if ($debug); 386 my ($test_model) = RDF::Trine::Model->temporary_model; 387 try { 388 if (blessed($data)) { 389 add_to_model( $test_model, $data->uri_value ); 390 } 391 } catch Error with { 392 my $e = shift; 393 fail($test->as_string); 394 earl_fail_test( $earl, $test, $e->text ); 395 print "# died: " . $test->as_string . ": $e\n"; 396 return; 397 } except { 398 my $e = shift; 399 die $e->text; 400 } otherwise { 401 warn '*** failed to construct model'; 402 }; 403 print STDERR "ok\n" if ($debug); 404 405 my $resuri = URI->new( $result->uri_value ); 406 my $resfilename = $resuri->file; 407 408 TODO: { 409 local($TODO) = (blessed($req)) ? "requires " . $req->as_string : ''; 410 my $comment; 411 my $ok = eval { 412 if ($debug) { 413 my $q = $sparql; 414 $q =~ s/([\x{256}-\x{1000}])/'\x{' . sprintf('%x', ord($1)) . '}'/eg; 415 warn $q; 416 } 417 print STDERR "getting actual results... " if ($debug); 418 my ($actual, $type) = get_actual_results( $test_model, $sparql, $base, @gdata ); 419 print STDERR "ok\n" if ($debug); 420 421 print STDERR "getting expected results... " if ($debug); 422 my $expected = get_expected_results( $resfilename, $type ); 423 print STDERR "ok\n" if ($debug); 424 425 # warn "comparing results..."; 426 compare_results( $expected, $actual, $earl, $test->as_string, \$comment ); 427 }; 428 warn $@ if ($@); 429 if ($ok) { 430 earl_pass_test( $earl, $test ); 431 } else { 432 earl_fail_test( $earl, $test, $comment ); 433 print "# failed: " . $test->as_string . "\n"; 434 } 435 } 436} 437 438 439exit; 440 441###################################################################### 442 443 444sub add_to_model { 445 my $model = shift; 446 my @files = @_; 447 448 foreach my $file (@files) { 449 try { 450 RDF::Trine::Parser->parse_url_into_model( $file, $model, canonicalize => 1 ); 451 } catch Error with { 452 my $e = shift; 453 warn "Failed to load $file into model: " . $e->text; 454 }; 455 } 456} 457 458sub get_actual_results { 459 my $model = shift; 460 my $sparql = shift; 461 my $base = shift; 462 my @gdata = @_; 463 my $query = RDF::Query->new( $sparql, { base => $base, lang => 'sparql10', load_data => 1, canonicalize => 1 } ); 464 465 unless ($query) { 466 warn RDF::Query->error if ($debug or $PATTERN); 467 return; 468 } 469 470 my $testns = RDF::Trine::Namespace->new('http://example.com/test-results#'); 471 my $rmodel = RDF::Trine::Model->temporary_model; 472 473 my ($plan, $ctx) = $query->prepare_with_named_graphs( $model, @gdata ); 474 if ($args{plan}) { 475 warn $plan->explain(' ', 0); 476 } 477 my $results = $query->execute_plan( $plan, $ctx ); 478 if ($args{ results }) { 479 $results = $results->materialize; 480 warn "Actual results:\n"; 481 warn $results->as_string; 482 } 483 if ($results->is_bindings) { 484 return (binding_results_data( $results ), 'bindings'); 485 } elsif ($results->is_boolean) { 486 $rmodel->add_statement( statement( $testns->result, $testns->boolean, literal(($results->get_boolean ? 'true' : 'false'), undef, $xsd->boolean) ) ); 487 return ($rmodel->get_statements, 'boolean'); 488 } elsif ($results->is_graph) { 489 return ($results, 'graph'); 490 } else { 491 warn "unknown result type: " . Dumper($results); 492 } 493} 494 495sub get_expected_results { 496 my $file = shift; 497 my $type = shift; 498 499 my $testns = RDF::Trine::Namespace->new('http://example.com/test-results#'); 500 if ($type eq 'graph') { 501 my $model = RDF::Trine::Model->temporary_model; 502 RDF::Trine::Parser->parse_url_into_model( "file://$file", $model, canonicalize => 1 ); 503 my $results = $model->get_statements(); 504 if ($args{ results }) { 505 $results = $results->materialize; 506 warn "Expected results:\n"; 507 warn $results->as_string; 508 } 509 return $results; 510 } elsif ($file =~ /[.](srj|json)/) { 511 my $model = RDF::Trine::Model->temporary_model; 512 my $data = do { local($/) = undef; open(my $fh, '<', $file) or die $!; binmode($fh, ':utf8'); <$fh> }; 513 my $results = RDF::Trine::Iterator->from_json( $data, { canonicalize => 1 } ); 514 if ($results->isa('RDF::Trine::Iterator::Boolean')) { 515 my $value = $results->next; 516 my $bool = ($value ? 'true' : 'false'); 517 $model->add_statement( statement( $testns->result, $testns->boolean, literal($bool, undef, $xsd->boolean) ) ); 518 if ($args{ results }) { 519 warn "Expected result: $bool\n"; 520 } 521 return $model->get_statements; 522 } else { 523 if ($args{ results }) { 524 $results = $results->materialize; 525 warn "Expected results:\n"; 526 warn $results->as_string; 527 } 528 return binding_results_data( $results ); 529 } 530 } elsif ($file =~ /[.]srx/) { 531 my $model = RDF::Trine::Model->temporary_model; 532 my $data = do { local($/) = undef; open(my $fh, '<', $file) or die $!; binmode($fh, ':utf8'); <$fh> }; 533 my $results = RDF::Trine::Iterator->from_string( $data, { canonicalize => 1 } ); 534 if ($results->isa('RDF::Trine::Iterator::Boolean')) { 535 $model->add_statement( statement( $testns->result, $testns->boolean, literal(($results->next ? 'true' : 'false'), undef, $xsd->boolean) ) ); 536 return $model->get_statements; 537 } else { 538 if ($args{ results }) { 539 $results = $results->materialize; 540 warn "Expected results:\n"; 541 warn $results->as_string; 542 } 543 return binding_results_data( $results ); 544 } 545 } elsif ($file =~ /[.]csv/) { 546 my $csv = Text::CSV_XS->new({binary => 1}); 547 open( my $fh, "<:encoding(utf8)", $file ) or die $!; 548 my $header = $csv->getline($fh); 549 my @vars = @$header; 550 my @data; 551 while (my $row = $csv->getline($fh)) { 552 my %result; 553 foreach my $i (0 .. $#vars) { 554 my $var = $vars[$i]; 555 my $value = $row->[ $i ]; 556 # XXX @@ heuristics that won't always work. 557 # XXX @@ expected to work on the test suite, though 558 if ($value =~ /^_:(\w+)$/) { 559 $value = blank($1); 560 } elsif ($value =~ /$RE{URI}/) { 561 $value = iri($value); 562 } elsif (defined($value) and length($value)) { 563 $value = literal($value); 564 } 565 $result{ $var } = $value; 566 } 567 push(@data, \%result); 568 } 569 if ($args{ results }) { 570 warn "Expected results:\n"; 571 warn Dumper(\@data); 572 } 573 return \@data; 574 } elsif ($file =~ /[.]tsv/) { 575 open( my $fh, "<:encoding(utf8)", $file ) or die $!; 576 my $header = <$fh>; 577 chomp($header); 578 my @vars = split("\t", $header); 579 foreach (@vars) { s/[?]// } 580 581 my @data; 582 my $parser = RDF::Trine::Parser::Turtle->new(); 583 while (defined(my $line = <$fh>)) { 584 chomp($line); 585 my $row = [ split("\t", $line) ]; 586 my %result; 587 foreach my $i (0 .. $#vars) { 588 my $var = $vars[$i]; 589 my $value = $row->[ $i ]; 590 my $node = length($value) ? $parser->parse_node( $value ) : undef; 591 $result{ $var } = $node; 592 } 593 594 push(@data, RDF::Query::VariableBindings->new( \%result )); 595 } 596 my $iter = RDF::Trine::Iterator::Bindings->new(\@data); 597 return binding_results_data($iter); 598 } elsif ($file =~ /[.](ttl|rdf)/) { 599 my $model = RDF::Trine::Model->new(); 600 open( my $fh, "<:encoding(utf8)", $file ) or die $!; 601 my $base = 'file://' . File::Spec->rel2abs($file); 602 my $parser = RDF::Trine::Parser->new(($file =~ /[.]ttl/) ? 'turtle' : 'rdfxml'); 603 $parser->parse_file_into_model( $base, $file, $model ); 604 my ($res) = $model->subjects( $rdf->type, $rs->ResultSet ); 605 if (my($b) = $model->objects( $res, $rs->boolean )) { 606 my $bool = $b->literal_value; 607 my $rmodel = RDF::Trine::Model->new(); 608 $rmodel->add_statement( statement( $testns->result, $testns->boolean, literal($bool, undef, $xsd->boolean) ) ); 609 if ($args{ results }) { 610 warn "Expected result: $bool\n"; 611 } 612 return $rmodel->get_statements; 613 } else { 614 my @vars = $model->objects( $res, $rs->resultVariable ); 615 my @sols = $model->objects( $res, $rs->solution ); 616 my @names = map { $_->literal_value } @vars; 617 my @bindings; 618 foreach my $r (@sols) { 619 my %data; 620 my @b = $model->objects( $r, $rs->binding ); 621 foreach my $b (@b) { 622 my ($value) = $model->objects( $b, $rs->value ); 623 my ($var) = $model->objects( $b, $rs->variable ); 624 $data{ $var->literal_value } = $value; 625 } 626 push(@bindings, RDF::Trine::VariableBindings->new( \%data )); 627 } 628 my $iter = RDF::Trine::Iterator::Bindings->new( \@bindings, \@names ); 629 if ($args{ results }) { 630 $iter = $iter->materialize; 631 warn "Got expected results:\n"; 632 warn $iter->as_string; 633 } 634 return binding_results_data($iter); 635 } 636 } else { 637 die "Unrecognized type of expected results: $file"; 638 } 639} 640 641sub compare_results { 642 my $expected = shift; 643 my $actual = shift; 644 my $earl = shift; 645 my $test = shift; 646 my $comment = shift || do { my $foo; \$foo }; 647 my $TODO = shift; 648 649 650 651 my $lossy_cmp = 0; 652 if (reftype($expected) eq 'ARRAY') { 653 # comparison with expected results coming from a lossy format like csv/tsv 654 $lossy_cmp = 1; 655 my %data = (results => [], blank_identifiers => {}); 656 foreach my $row (@$expected) { 657 push(@{ $data{ results } }, $row ); 658 foreach my $key (keys %$row) { 659 my $node = $row->{$key}; 660 if (blessed($node) and $node->isa('RDF::Trine::Node::Blank')) { 661 $data{ blank_identifiers }{ $node->blank_identifier }++; 662 } 663 } 664 } 665 $data{ blanks } = scalar(@{ [ keys %{ $data{ blank_identifiers } } ] }); 666 $expected = \%data; 667 } 668 669 if (not(ref($actual))) { 670 my $ok = is( $actual, $expected, $test ); 671 return $ok; 672 } elsif (blessed($actual) and $actual->isa('RDF::Trine::Iterator::Graph')) { 673 die "Unexpected Graph result type (was expecting " . ref($expected) . ")" unless (blessed($expected) and $expected->isa('RDF::Trine::Iterator::Graph')); 674 675 my $act_graph = RDF::Trine::Graph->new( $actual ); 676 my $exp_graph = RDF::Trine::Graph->new( $expected ); 677 678# local($debug) = 1 if ($PATTERN); 679 if ($debug) { 680 warn ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n"; 681 my $actualxml = $act_graph->get_statements->as_string; 682 warn $actualxml; 683 warn "-------------------------------\n"; 684 my $expectxml = $exp_graph->get_statements->as_string; 685 warn $expectxml; 686 warn "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n"; 687 } 688 my $eq = $act_graph->equals( $exp_graph ); 689 unless ($eq) { 690 warn $act_graph->error; 691 } 692 return is( $eq, 1, $test ); 693 } elsif (reftype($actual) eq 'HASH' and reftype($expected) eq 'HASH') { 694 my @aresults = @{ $actual->{ results } }; 695 my @eresults = @{ $expected->{ results } }; 696 my $acount = scalar(@aresults); 697 my $ecount = scalar(@eresults); 698 if ($acount != $ecount) { 699 warn "Result count ($acount) didn't match expected ($ecount)" if ($debug); 700 return fail($test); 701 } 702 703# warn Data::Dumper->Dump([\@aresults, \@eresults], [qw(actual expected)]); 704 705 my ($awith, $awithout) = split_results_with_blank_nodes( @aresults ); 706 my ($ewith, $ewithout) = split_results_with_blank_nodes( @eresults ); 707 708 # for the results without blanks, just serialize, sort, and compare 709 my @astrings = sort map { result_to_string($_, $lossy_cmp) } @$awithout; 710 my @estrings = sort map { result_to_string($_, $lossy_cmp) } @$ewithout; 711 712 if ($actual->{ blanks } == 0 and $expected->{ blanks } == 0) { 713 return is_deeply( \@astrings, \@estrings, $test ); 714 } elsif (join("\xFF", @astrings) ne join("\xFF", @estrings)) { 715 warn "triples don't match: " . Dumper(\@astrings, \@estrings); 716 return fail($test); 717 } 718 719 # compare the results with bnodes 720 my @ka = keys %{ $actual->{blank_identifiers} }; 721 my @kb = keys %{ $expected->{blank_identifiers} }; 722 723 my $kbp = permutations( \@kb ); 724 MAPPING: while (my $mapping = $kbp->next) { 725 my %mapping; 726 @mapping{ @ka } = @$mapping; 727 warn "trying mapping: " . Dumper(\%mapping) if ($debug); 728 729 my %ewith = map { result_to_string($_, $lossy_cmp) => 1 } @$ewith; 730 foreach my $row (@$awith) { 731 my %row; 732 foreach my $k (keys %$row) { 733 my $n = $row->{ $k }; 734 next unless (blessed($n)); 735 if ($n->isa('RDF::Trine::Node::Blank')) { 736 my $id = $mapping{ $n->blank_identifier }; 737 warn "mapping " . $n->blank_identifier . " to $id\n" if ($debug); 738 $row{ $k } = RDF::Trine::Node::Blank->new( $id ); 739 } else { 740 $row{ $k } = $n; 741 } 742 } 743 my $mapped_row = result_to_string( RDF::Query::VariableBindings->new( \%row ), $lossy_cmp ); 744 warn "checking for '$mapped_row' in " . Dumper(\%ewith) if ($debug); 745 if ($ewith{ $mapped_row }) { 746 delete $ewith{ $mapped_row }; 747 } else { 748 next MAPPING; 749 } 750 } 751 warn "found mapping: " . Dumper(\%mapping) if ($debug); 752 return pass($test); 753 } 754 755 warn "failed to find bnode mapping: " . Dumper($awith, $ewith); 756 return fail($test); 757 } else { 758 die "Failed to compare actual and expected results: " . Dumper($actual, $expected); 759 } 760} 761 762sub binding_results_data { 763 my $iter = shift; 764 my %data = (results => [], blank_identifiers => {}); 765 while (my $row = $iter->next) { 766 push(@{ $data{ results } }, $row ); 767 foreach my $key (keys %$row) { 768 my $node = $row->{$key}; 769 if (blessed($node) and $node->isa('RDF::Trine::Node::Blank')) { 770 $data{ blank_identifiers }{ $node->blank_identifier }++; 771 } 772 } 773 } 774 $data{ blanks } = scalar(@{ [ keys %{ $data{ blank_identifiers } } ] }); 775 return \%data; 776} 777 778sub split_results_with_blank_nodes { 779 my (@with, @without); 780 ROW: foreach my $row (@_) { 781 my @keys = grep { ref($row->{ $_ }) } keys %$row; 782 foreach my $k (@keys) { 783 my $node = $row->{ $k }; 784 if (blessed($node) and $node->isa('RDF::Trine::Node::Blank')) { 785 push(@with, $row); 786 next ROW; 787 } 788 } 789 push(@without, $row); 790 } 791 return (\@with, \@without); 792} 793 794sub result_to_string { 795 my $row = shift; 796 my $lossy_cmp = shift; 797 my @keys = grep { ref($row->{ $_ }) } keys %$row; 798 my @results; 799 800 foreach my $k (@keys) { 801 my $node = $row->{ $k }; 802 if ($node->isa('RDF::Trine::Node::Literal') and $node->has_datatype) { 803 my ($value, $dt); 804 if ($lossy_cmp) { 805 $value = $node->literal_value; 806 $dt = undef; 807 } else { 808 $value = RDF::Trine::Node::Literal->canonicalize_literal_value( $node->literal_value, $node->literal_datatype ); 809 $dt = $node->literal_datatype; 810 } 811 $node = RDF::Query::Node::Literal->new( $value, undef, $dt ); 812 } 813 push(@results, join('=', $k, $node->as_string)); 814 } 815 return join(',', sort(@results)); 816} 817 818package Test::RDF::Query::Plan::Service; 819 820use strict; 821use warnings; 822use Data::Dumper; 823use Scalar::Util qw(refaddr); 824use base qw(RDF::Query::Plan::Service); 825 826our %ENDPOINTS; 827our %service_ctx; 828 829sub new { 830 my $class = shift; 831 my $endpoint = shift; 832 my $plan = shift; 833 my $silent = shift; 834 my $sparql = shift; 835 836 if ($endpoint->isa('RDF::Query::Node::Resource')) { 837 my $uri = $endpoint->uri_value; 838 warn "setting up mock endpoint for $uri" if ($debug); 839 } 840 841 my $self = $class->SUPER::new( $endpoint, $plan, $silent, $sparql, @_ ); 842 843 if ($endpoint->isa('RDF::Query::Node::Resource')) { 844 my $uri = $endpoint->uri_value; 845 my $e = URI->new($uri); 846 my $model = $service_ctx{ $uri }; 847# warn "model for $uri: $model"; 848 if ($model) { 849 my $end = RDF::Endpoint->new( $model, { endpoint => { endpoint_path => $e->path } } ); 850 $ENDPOINTS{ refaddr($self) } = $end; 851 } 852 } 853 854 return $self; 855} 856 857# sub mock { 858# my $self = shift; 859# return; 860# my $endpoint = shift; 861# my $data = shift; 862# my $e = URI->new($endpoint); 863# 864# my $model = RDF::Trine::Model->new(); 865# my ($default, $named) = @$data; 866# if ($default) { 867# RDF::Trine::Parser->parse_url_into_model( $default->uri_value, $model ); 868# my $end = RDF::Endpoint->new( $model, { endpoint => { endpoint_path => $e->path } } ); 869# $ENDPOINTS{ refaddr($self) } = $end; 870# } 871# } 872 873sub _request { 874 my $self = shift; 875 my $ua = shift; 876 my $req = shift; 877 my $env = $req->to_psgi; 878 my $end = $ENDPOINTS{ refaddr($self) }; 879 if ($end) { 880# warn "got mocked endpoint"; 881 my $app = sub { 882 my $env = shift; 883 my $req = Plack::Request->new($env); 884 my $resp = $end->run( $req ); 885 return $resp->finalize; 886 }; 887 my $data = $app->( $env ); 888 my $resp = HTTP::Response->from_psgi( $data ); 889 return $resp; 890 } else { 891# warn "no mocked endpoint available"; 892 return HTTP::Response->new(403); 893 } 894} 895 896sub DESTROY { 897 my $self = shift; 898 delete $ENDPOINTS{ refaddr($self) }; 899 $self->SUPER::DESTROY(); 900} 901