RDF::Trine::Model - Model class

# RDF::Trine::Model
# -----------------------------------------------------------------------------

package RDF::Trine::Model;

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

our ($VERSION);
BEGIN {
	$VERSION	= '0.135';
}

use Scalar::Util qw(blessed);
use Log::Log4perl;

use RDF::Trine::Error qw(:try);
use RDF::Trine qw(variable);
use RDF::Trine::Node;
use RDF::Trine::Pattern;
use RDF::Trine::Store::DBI;
use RDF::Trine::Model::Dataset;

sub new {
	my $class	= shift;
	if (@_) {
		my $store	= shift;
		$store		= RDF::Trine::Store->new( $store ) unless (blessed($store));
		my %args	= @_;
		my $self	= bless({
			store		=> $store,
			temporary	=> 0,
			added		=> 0,
			threshold	=> -1,
			%args
		}, $class);
	} else {
		return $class->temporary_model;
	}
}

 
sub temporary_model {
	my $class	= shift;
	my $store	= RDF::Trine::Store::Memory->new();
# 	my $store	= RDF::Trine::Store::DBI->temporary_store();
	my $self	= $class->new( $store );
	$self->{temporary}	= 1;
	$self->{threshold}	= 25_000;
	return $self;
}

sub dataset_model {
	my $self	= shift;
	my $ds		= RDF::Trine::Model::Dataset->new( $self );
	$ds->push_dataset( @_ );
	return $ds;
}

sub begin_bulk_ops {
	my $self	= shift;
	my $store	= $self->_store;
	if (blessed($store) and $store->can('_begin_bulk_ops')) {
		$store->_begin_bulk_ops();
	}
}

sub end_bulk_ops {
	my $self	= shift;
	my $store	= $self->_store;
	if (blessed($store) and $store->can('_end_bulk_ops')) {
		$store->_end_bulk_ops();
	}
}

 
sub add_statement {
	my $self	= shift;
	if ($self->{temporary}) {
		if ($self->{added}++ >= $self->{threshold}) {
# 			warn "*** should upgrade to a DBI store here";
			my $store	= RDF::Trine::Store::DBI->temporary_store;
			my $iter	= $self->get_statements(undef, undef, undef, undef);
			if ($store->can('_begin_bulk_ops')) {
				$store->_begin_bulk_ops();
			}
			while (my $st = $iter->next) {
				$store->add_statement( $st );
			}
			if ($store->can('_end_bulk_ops')) {
				$store->_end_bulk_ops();
			}
			$self->{store}	= $store;
			$self->{temporary}	= 0;
# 			warn "*** upgraded to a DBI store";
		}
	}
	return $self->_store->add_statement( @_ );
}

sub add_hashref {
	my $self	   = shift;
	my $index   = shift;
	my $context = shift;
	
	foreach my $s (keys %$index) {
		my $ts = ( $s =~ /^_:(.*)$/ ) ?
					RDF::Trine::Node::Blank->new($1) :
					RDF::Trine::Node::Resource->new($s);
		
		foreach my $p (keys %{ $index->{$s} }) {
			my $tp = RDF::Trine::Node::Resource->new($p);
			
			foreach my $O (@{ $index->{$s}->{$p} }) {
				my $to;
				
				# $O should be a hashref, but we can do a little error-correcting.
				unless (ref $O) {
					if ($O =~ /^_:/) {
						$O = { 'value'=>$O, 'type'=>'bnode' };
					} elsif ($O =~ /^[a-z0-9._\+-]{1,12}:\S+$/i) {
						$O = { 'value'=>$O, 'type'=>'uri' };
					} elsif ($O =~ /^(.*)\@([a-z]{2})$/) {
						$O = { 'value'=>$1, 'type'=>'literal', 'lang'=>$2 };
					} else {
						$O = { 'value'=>$O, 'type'=>'literal' };
					}
				}
				
				if (lc $O->{'type'} eq 'literal') {
					$to = RDF::Trine::Node::Literal->new(
						$O->{'value'}, $O->{'lang'}, $O->{'datatype'});
				} else {
					$to = ( $O->{'value'} =~ /^_:(.*)$/ ) ?
						RDF::Trine::Node::Blank->new($1) :
						RDF::Trine::Node::Resource->new($O->{'value'});
				}
				
				if ($ts and $tp and $to) {
					my $st = RDF::Trine::Statement->new($ts, $tp, $to);
					$self->add_statement($st, $context);
				}
			}
		}
	}
}

sub add_list {
	my $self		= shift;
	my @elements	= @_;
	my $rdf		= RDF::Trine::Namespace->new('http://www.w3.org/1999/02/22-rdf-syntax-ns#');
	if (scalar(@elements) == 0) {
		return $rdf->nil;
	} else {
		my $head		= RDF::Query::Node::Blank->new();
		my $node		= shift(@elements);
		my $rest		= $self->add_list( @elements );
		$self->add_statement( RDF::Trine::Statement->new($head, $rdf->first, $node) );
		$self->add_statement( RDF::Trine::Statement->new($head, $rdf->rest, $rest) );
		return $head;
	}
}

sub get_list {
	my $self	= shift;
	my $head	= shift;
	my $rdf		= RDF::Trine::Namespace->new('http://www.w3.org/1999/02/22-rdf-syntax-ns#');
	my @elements;
	my %seen;
	while (blessed($head) and not($head->isa('RDF::Trine::Node::Resource') and $head->uri_value eq $rdf->nil->uri_value)) {
		if ($seen{ $head->as_string }++) {
			throw RDF::Trine::Error -text => "Loop found during rdf:List traversal";
		}
		my @n		= $self->objects( $head, $rdf->first );
		if (scalar(@n) != 1) {
			throw RDF::Trine::Error -text => "Invalid structure found during rdf:List traversal";
		}
		push(@elements, @n);
		($head)	= $self->objects( $head, $rdf->rest );
	}
	return @elements;
}

sub remove_list {
	my $self = shift;
	my $head = shift;
	my $rdf  = RDF::Trine::Namespace->new('http://www.w3.org/1999/02/22-rdf-syntax-ns#');
	my %args = @_;
	my %seen;
	
	while (blessed($head) and not($head->isa('RDF::Trine::Node::Resource') and $head->uri_value eq $rdf->nil->uri_value)) {
		if ($seen{ $head->as_string }++) {
			throw RDF::Trine::Error -text => "Loop found during rdf:List traversal";
		}
		my $stream = $self->get_statements($head, undef, undef);
		my %statements;
		while (my $st = $stream->next) {
			my $statement_type = {
				$rdf->first->uri  => 'rdf:first',
				$rdf->rest->uri   => 'rdf:rest',
				$rdf->type->uri   => 'rdf:type',
				}->{$st->predicate->uri} || 'other';
			$statement_type = 'other'
				if $statement_type eq 'rdf:type' && !$st->object->equal($rdf->List);
			push @{$statements{$statement_type}}, $st;
		}
		if ($args{orphan_check}) {
			return $head if defined $statements{other} && scalar(@{ $statements{other} }) > 0;
			return $head if $self->count_statements(undef, undef, $head) > 0;
		}
		unless (defined $statements{'rdf:first'} and defined $statements{'rdf:rest'} and scalar(@{$statements{'rdf:first'} })==1 and scalar(@{ $statements{'rdf:rest'} })==1) {
			throw RDF::Trine::Error -text => "Invalid structure found during rdf:List traversal";
		}
		$self->remove_statement($_)
			foreach (@{$statements{'rdf:first'}}, @{$statements{'rdf:rest'}}, @{$statements{'rdf:type'}});
		
		$head = $statements{'rdf:rest'}->[0]->object;
	}
	
	return;
}

sub get_sequence {
	my $self	= shift;
	my $head	= shift;
	my $rdf		= RDF::Trine::Namespace->new('http://www.w3.org/1999/02/22-rdf-syntax-ns#');
	my @elements;
	my $i		= 1;
	while (1) {
		my $method	= '_' . $i;
		my (@elem)	= $self->objects( $head, $rdf->$method() );
		unless (scalar(@elem)) {
			last;
		}
		if (scalar(@elem) > 1) {
			my $count	= scalar(@elem);
			throw RDF::Trine::Error -text => "Invalid structure found during rdf:Seq access: $count elements found for element $i";
		}
		my $elem	= $elem[0];
		last unless (blessed($elem));
		push(@elements, $elem);
		$i++;
	}
	return @elements;
}

sub remove_statement {
	my $self	= shift;
	return $self->_store->remove_statement( @_ );
}

sub remove_statements {
	my $self	= shift;
	return $self->_store->remove_statements( @_ );
}

sub size {
	my $self	= shift;
	$self->end_bulk_ops();
	return $self->count_statements();
}

sub etag {
	my $self	= shift;
	my $store	= $self->_store;
	if ($store) {
		return $store->etag;
	}
	return;
}

sub supports {
	my $self	= shift;
	my $store	= $self->_store;
	if ($store) {
		return $store->supports( @_ );
	}
	return;
}

sub count_statements {
	my $self	= shift;
	$self->end_bulk_ops();

	if (scalar(@_) >= 4) {
		my $graph	= $_[3];
		if (blessed($graph) and $graph->isa('RDF::Trine::Node::Resource') and $graph->uri_value eq 'tag:gwilliams@cpan.org,2010-01-01:RT:ALL') {
			$_[3]	= undef;
		}
	}
	return $self->_store->count_statements( @_ );
}

sub get_statements {
	my $self	= shift;
	$self->end_bulk_ops();
	
	if (scalar(@_) >= 4) {
		my $graph	= $_[3];
		if (blessed($graph) and $graph->isa('RDF::Trine::Node::Resource') and $graph->uri_value eq 'tag:gwilliams@cpan.org,2010-01-01:RT:ALL') {
			$_[3]	= undef;
		}
	}
	return $self->_store->get_statements( @_ );
}

sub get_pattern {
	my $self	= shift;
	my $bgp		= shift;
	my $context	= shift;
	my @args	= @_;
	
	$self->end_bulk_ops();
	my (@triples)	= ($bgp->isa('RDF::Trine::Statement') or $bgp->isa('RDF::Query::Algebra::Filter'))
					? $bgp
					: $bgp->triples;
	unless (@triples) {
		throw RDF::Trine::Error::CompilationError -text => 'Cannot call get_pattern() with empty pattern';
	}
	
	my $store	= $self->_store;
	# while almost all models will delegate get_pattern() to the underlying
	# store object, in some cases this isn't possible (union models don't have
	# a single store, so have to fall back to the model-specific get_pattern()
	# implementation).
	if (blessed($store) and $store->can('get_pattern')) {
		return $self->_store->get_pattern( $bgp, $context, @args );
	} else {
		return $self->_get_pattern( $bgp, $context, @args );
	}
}

sub get_sparql {
	my $self	= shift;
	return $self->_store->get_sparql( @_ );
}

sub _get_pattern {
	my $self	= shift;
	my $bgp		= shift;
	my $context	= shift;
	my @args	= @_;
	
	my (@triples)	= ($bgp->isa('RDF::Trine::Statement') or $bgp->isa('RDF::Query::Algebra::Filter'))
					? $bgp
					: $bgp->triples;
	if (1 == scalar(@triples)) {
		my $t		= shift(@triples);
		my @nodes	= $t->nodes;
		my %vars;
		my @names	= qw(subject predicate object context);
		foreach my $n (0 .. $#nodes) {
			if ($nodes[$n]->isa('RDF::Trine::Node::Variable')) {
				$vars{ $names[ $n ] }	= $nodes[$n]->name;
			}
		}
		my $iter	= $self->get_statements( @nodes, $context, @args );
		my @vars	= values %vars;
		my $sub		= sub {
			my $row	= $iter->next;
			return undef unless ($row);
			my %data	= map { $vars{ $_ } => $row->$_() } (keys %vars);
			return RDF::Trine::VariableBindings->new( \%data );
		};
		return RDF::Trine::Iterator::Bindings->new( $sub, \@vars );
	} else {
		my $t		= shift(@triples);
		my $rhs	= $self->get_pattern( RDF::Trine::Pattern->new( $t ), $context, @args );
		my $lhs	= $self->get_pattern( RDF::Trine::Pattern->new( @triples ), $context, @args );
		my @inner;
		while (my $row = $rhs->next) {
			push(@inner, $row);
		}
		my @results;
		while (my $row = $lhs->next) {
			RESULT: foreach my $irow (@inner) {
				my %keysa;
				my @keysa	= keys %$irow;
				@keysa{ @keysa }	= (1) x scalar(@keysa);
				my @shared	= grep { exists $keysa{ $_ } } (keys %$row);
				foreach my $key (@shared) {
					my $val_a	= $irow->{ $key };
					my $val_b	= $row->{ $key };
					next unless (defined($val_a) and defined($val_b));
					my $equal	= $val_a->equal( $val_b );
					unless ($equal) {
						next RESULT;
					}
				}
				
				my $jrow	= { (map { $_ => $irow->{$_} } grep { defined($irow->{$_}) } keys %$irow), (map { $_ => $row->{$_} } grep { defined($row->{$_}) } keys %$row) };
				push(@results, RDF::Trine::VariableBindings->new($jrow));
			}
		}
		my $result	= RDF::Trine::Iterator::Bindings->new( \@results, [ $bgp->referenced_variables ] );
		return $result;
	}
}

sub get_contexts {
	my $self	= shift;
	my $store	= $self->_store;
	$self->end_bulk_ops();
	my $iter	= $store->get_contexts( @_ );
	if (wantarray) {
		return $iter->get_all;
	} else {
		return $iter;
	}
}

sub as_stream {
	my $self	= shift;
	$self->end_bulk_ops();
	my $st		= RDF::Trine::Statement::Quad->new( map { variable($_) } qw(s p o g) );
	my $pat		= RDF::Trine::Pattern->new( $st );
	my $stream	= $self->get_pattern( $pat, undef, orderby => [ qw(s ASC p ASC o ASC) ] );
	return $stream->as_statements( qw(s p o g) );
}

sub as_hashref {
	my $self	= shift;
	$self->end_bulk_ops();
	my $stream	= $self->as_stream;
	my $index = {};
	while (my $statement = $stream->next) {
		
		my $s = $statement->subject->isa('RDF::Trine::Node::Blank') ? 
			('_:'.$statement->subject->blank_identifier) :
			$statement->subject->uri ;
		my $p = $statement->predicate->uri ;
		
		my $o = {};
		if ($statement->object->isa('RDF::Trine::Node::Literal')) {
			$o->{'type'}		= 'literal';
			$o->{'value'}		= $statement->object->literal_value;
			$o->{'lang'}		= $statement->object->literal_value_language
				if $statement->object->has_language;
			$o->{'datatype'}	= $statement->object->literal_datatype
				if $statement->object->has_datatype;
		} else {
			$o->{'type'}		= $statement->object->isa('RDF::Trine::Node::Blank') ? 'bnode' : 'uri';
			$o->{'value'}		= $statement->object->isa('RDF::Trine::Node::Blank') ? 
				('_:'.$statement->object->blank_identifier) :
				$statement->object->uri ;
		}

		push @{ $index->{$s}->{$p} }, $o;
	}
	return $index;
}

sub as_graphviz {
	my $self	= shift;
	require GraphViz;
	my $g	= GraphViz->new();
	my %seen;
	my $iter	= $self->as_stream;
	while (my $t = $iter->next) {
		my @nodes;
		foreach my $pos (qw(subject object)) {
			my $n	= $t->$pos();
			my $label	= ($n->isa('RDF::Trine::Node::Literal')) ? $n->literal_value : $n->as_string;
			push(@nodes, $label);
			unless ($seen{ $label }++) {
				$g->add_node( $label );
			}
		}
		$g->add_edge( @nodes, label => $t->predicate->as_string );
	}
	return $g;
}

sub subjects {
	my $self	= shift;
	my $pred	= shift;
	my $obj		= shift;
	my $graph	= shift;
	$self->end_bulk_ops();
	my $iter	= $self->get_statements( undef, $pred, $obj, $graph );
	my %nodes;
	while (my $st = $iter->next) {
		my $subj	= $st->subject;
		$nodes{ $subj->as_string }	= $subj;
	}
	if (wantarray) {
		return values(%nodes);
	} else {
		return RDF::Trine::Iterator->new( [values(%nodes)] );
	}
}

sub predicates {
	my $self	= shift;
	my $subj	= shift;
	my $obj		= shift;
	my $graph	= shift;
	$self->end_bulk_ops();
	my $iter	= $self->get_statements( $subj, undef, $obj, $graph );
	my %nodes;
	while (my $st = $iter->next) {
		my $pred	= $st->predicate;
		$nodes{ $pred->as_string }	= $pred;
	}
	if (wantarray) {
		return values(%nodes);
	} else {
		return RDF::Trine::Iterator->new( [values(%nodes)] );
	}
}

sub objects {
	my $self	= shift;
	my $subj	= shift;
	my $pred	= shift;
	my ($graph, %options)	= (@_ % 2 == 0) ? (undef, @_) : @_;
	my $type	= $options{type};
	$type = 'literal' if ($options{language} or $options{datatype});
	if ($options{datatype} and not blessed($options{datatype})) {
		$options{datatype} = RDF::Trine::Node::Resource->new($options{datatype});
	}
	
	if (defined $type) {
		if ($type =~ /^(node|nil|blank|resource|literal|variable)$/) {
			$type = "is_$type";
		} else {
			throw RDF::Trine::Error::CompilationError -text => "unknown type"
		}
	}
	$self->end_bulk_ops();
	my $iter	= $self->get_statements( $subj, $pred, undef, $graph );
	my %nodes;
	while (my $st = $iter->next) {
		my $obj = $st->object;
		if (defined $type) {
			next unless $obj->$type;
			if ($options{language}) {
				my $lang = $obj->literal_value_language;
				next unless ($lang and $lang eq $options{language});
			} elsif ($options{datatype}) {
				my $dt = $obj->literal_datatype;
				next unless ($dt and $dt eq $options{datatype}->uri_value);
			}
		}
		$nodes{ $obj->as_string }	= $obj;
	}
	if (wantarray) {
		return values(%nodes);
	} else {
		return RDF::Trine::Iterator->new( [values(%nodes)] );
	}
}

sub objects_for_predicate_list {
	my $self	= shift;
	my $node	= shift;
	my @preds	= @_;
	$self->end_bulk_ops();
	my @objects;
	foreach my $p (@preds) {
		my $iter	= $self->get_statements( $node, $p );
		while (my $s = $iter->next) {
			if (not(wantarray)) {
				return $s->object;
			} else {
				push( @objects, $s->object );
			}
		}
	}
	return @objects;
}

sub bounded_description {
	my $self	= shift;
	my $node	= shift;
	$self->end_bulk_ops();
	my %seen;
	my @nodes	= $node;
	my @statements;
	my $sub		= sub {
		return if (not(@statements) and not(@nodes));
		while (1) {
			if (not(@statements)) {
				my $l = Log::Log4perl->get_logger("rdf.trine.model");
				return unless (scalar(@nodes));
				my $n	= shift(@nodes);
# 				warn "CBD handling node " . $n->sse . "\n";
				next if ($seen{ $n->sse });
				try {
					my $sts	= $self->get_statements( $n );
					my @s	= grep { not($seen{$_->object->sse}) } $sts->get_all;
# 					warn "+ " . $_->sse . "\n" for (@s);
					push(@statements, @s);
				} catch RDF::Trine::Error::UnimplementedError with {
					$l->debug('[model] Ignored UnimplementedError in bounded_description: ' . $_[0]->{'-text'});
				};
				try {
					my $sts	= $self->get_statements( undef, undef, $n );
					my @s	= grep { not($seen{$_->subject->sse}) and not($_->subject->equal($n)) } $sts->get_all;
# 					warn "- " . $_->sse . "\n" for (@s);
					push(@statements, @s);
				} catch RDF::Trine::Error::UnimplementedError with {
					$l->debug('[model] Ignored UnimplementedError in bounded_description: ' . $_[0]->{'-text'});
				};
				$seen{ $n->sse }++
			}
			last if (scalar(@statements));
		}
		return unless (scalar(@statements));
		my $st	= shift(@statements);
		if ($st->object->isa('RDF::Trine::Node::Blank') and not($seen{ $st->object->sse })) {
# 			warn "+ CBD pushing " . $st->object->sse . "\n";
			push(@nodes, $st->object);
		}
		if ($st->subject->isa('RDF::Trine::Node::Blank') and not($seen{ $st->subject->sse })) {
# 			warn "- CBD pushing " . $st->subject->sse . "\n";
			push(@nodes, $st->subject);
		}
		return $st;
	};
	return RDF::Trine::Iterator::Graph->new( $sub );
}

sub as_string {
	my $self	= shift;
	$self->end_bulk_ops();
	my $iter	= $self->get_statements( undef, undef, undef, undef );
	my @rows;
	my @names	= qw[subject predicate object context];
	while (my $row = $iter->next) {
		push(@rows, [map {$row->$_()->as_string} @names]);
	}
	my @rule			= qw(- +);
	my @headers			= (\q"| ");
	push(@headers, map { $_ => \q" | " } @names);
	pop	@headers;
	push @headers => (\q" |");
	my $table = Text::Table->new(@names);
	$table->rule(@rule);
	$table->body_rule(@rule);
	$table->load(@rows);
	my $size	= scalar(@rows);
	return join('',
			$table->rule(@rule),
			$table->title,
			$table->rule(@rule),
			map({ $table->body($_) } 0 .. @rows),
			$table->rule(@rule)
		) . "$size statements\n";
}

sub _store {
	my $self	= shift;
	return $self->{store};
}

sub _debug {
	my $self	= shift;
	my $warn	= shift;
	my $stream	= $self->get_statements( undef, undef, undef, undef );
	my $l		= Log::Log4perl->get_logger("rdf.trine.model");
	$l->debug( 'model statements:' );
	if ($warn) {
		warn "Model $self:\n";
	}
	my $count	= 0;
	while (my $s = $stream->next) {
		$count++;
		if ($warn) {
			warn $s->as_string . "\n";
		}
		$l->debug('[model]' . $s->as_string);
	}
	if ($warn) {
		warn "$count statements\n";
	}
}

1;

__END__