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