librdf-trine-perl 1.019-1 / usr / share / perl5 / RDF / Trine / Serializer / Turtle.pm

# RDF::Trine::Serializer::Turtle
# -----------------------------------------------------------------------------

=head1 NAME

RDF::Trine::Serializer::Turtle - Turtle Serializer

=head1 VERSION

This document describes RDF::Trine::Serializer::Turtle version 1.019

=head1 SYNOPSIS

 use RDF::Trine::Serializer::Turtle;
 my $serializer	= RDF::Trine::Serializer::Turtle->new( namespaces => { ex => 'http://example/' } );
 print $serializer->serialize_model_to_string($model);

=head1 DESCRIPTION

The RDF::Trine::Serializer::Turtle class provides an API for serializing RDF
graphs to the Turtle syntax. XSD numeric types are serialized as bare literals,
and where possible the more concise syntax is used for rdf:Lists.

=head1 METHODS

Beyond the methods documented below, this class inherits methods from the
L<RDF::Trine::Serializer> class.

=over 4

=cut

package RDF::Trine::Serializer::Turtle;

use strict;
use warnings;
use base qw(RDF::Trine::Serializer);

use URI;
use Carp;
use Encode;
use Data::Dumper;
use Scalar::Util qw(blessed refaddr reftype);

use RDF::Trine qw(variable iri);
use RDF::Trine::Node;
use RDF::Trine::Statement;
use RDF::Trine::Error qw(:try);
use RDF::Trine::Namespace qw(rdf);

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

our ($VERSION, $debug);
BEGIN {
	$debug		= 0;
	$VERSION	= '1.019';
	$RDF::Trine::Serializer::serializer_names{ 'turtle' }	= __PACKAGE__;
	$RDF::Trine::Serializer::format_uris{ 'http://www.w3.org/ns/formats/Turtle' }	= __PACKAGE__;
	foreach my $type (qw(application/x-turtle application/turtle text/turtle text/rdf+n3)) {
		$RDF::Trine::Serializer::media_types{ $type }	= __PACKAGE__;
	}
}

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

=item C<< new ( namespaces => \%namespaces, base_uri => $base_uri ) >>

Returns a new Turtle serializer object.

=cut

sub new {
	my $class	= shift;
	my $ns	= {};
	my $base_uri;

	if (@_) {
		if (scalar(@_) == 1 and reftype($_[0]) eq 'HASH') {
			$ns	= shift;
		} else {
			my %args	= @_;
			if (exists $args{ base }) {
				$base_uri   = $args{ base };
			}
			if (exists $args{ base_uri }) {
				$base_uri   = $args{ base_uri };
			}
			if (exists $args{ namespaces }) {
				$ns	= $args{ namespaces };
			}
		}
	}

	my %rev;
    if (blessed($ns) and $ns->isa('RDF::Trine::NamespaceMap')) {
        for my $prefix ($ns->list_prefixes) {
            # way convoluted
            my $nsuri = $ns->namespace_uri($prefix)->uri->value;
            $rev{$nsuri} = $prefix;
        }
    }
    else {
        while (my ($ns, $uri) = each(%{ $ns })) {
            if (blessed($uri)) {
                $uri	= $uri->uri_value;
                if (blessed($uri)) {
                    $uri	= $uri->uri_value;
                }
            }
            $rev{ $uri }	= $ns;
        }
	}

	my $self = bless( {
		ns		=> \%rev,
		base_uri	=> $base_uri,
	}, $class );
	return $self;
}

=item C<< serialize_model_to_file ( $fh, $model ) >>

Serializes the C<$model> to Turtle, printing the results to the supplied
filehandle C<<$fh>>.

=cut

sub serialize_model_to_file {
	my $self	= shift;
	my $fh		= shift;
	my $model	= shift;
	my $sink	= RDF::Trine::Serializer::FileSink->new($fh);
	
	my $st		= RDF::Trine::Statement->new( map { variable($_) } qw(s p o) );
	my $pat		= RDF::Trine::Pattern->new( $st );
	my $stream	= $model->get_pattern( $pat, undef, orderby => [ qw(s ASC p ASC o ASC) ] );
	my $iter	= $stream->as_statements( qw(s p o) );
	
	$self->serialize_iterator( $sink, $iter, seen => {}, level => 0, tab => "\t", @_, model => $model );
	return 1;
}

=item C<< serialize_model_to_string ( $model ) >>

Serializes the C<$model> to Turtle, returning the result as a string.

=cut

sub serialize_model_to_string {
	my $self	= shift;
	my $model	= shift;
	my $sink	= RDF::Trine::Serializer::StringSink->new();

	my $st		= RDF::Trine::Statement->new( map { variable($_) } qw(s p o) );
	my $pat		= RDF::Trine::Pattern->new( $st );
	my $stream	= $model->get_pattern( $pat, undef, orderby => [ qw(s ASC p ASC o ASC) ] );
	my $iter	= $stream->as_statements( qw(s p o) );
	
	$self->serialize_iterator( $sink, $iter, seen => {}, level => 0, tab => "\t", @_, model => $model, string => 1 );
	return $sink->string;
}

=item C<< serialize_iterator_to_file ( $file, $iter ) >>

Serializes the iterator to Turtle, printing the results to the supplied
filehandle C<<$fh>>.

=cut

sub serialize_iterator_to_file {
	my $self	= shift;
	my $fh		= shift;
	my $iter	= shift;
	my %args	= @_;

	my $sink	= RDF::Trine::Serializer::FileSink->new($fh);
	$self->serialize_iterator( $sink, $iter, %args );
	return 1;
}

=item C<< serialize_iterator ( $sink, $iter ) >>

Serializes the iterator to Turtle, printing the results to the supplied
sink object.

=cut

sub serialize_iterator {
	my $self	= shift;
	my $sink	= shift;
	my $iter	= shift;
	my %args	= @_;
	
	my $seen	= $args{ seen } || {};
	my $level	= $args{ level } || 0;
	my $tab		= $args{ tab } || "\t";
	my $indent	= $tab x $level;
	
	my %ns		= reverse(%{ $self->{ns} });
	my @nskeys	= sort keys %ns;
	
	unless ($sink->can('prepend')) {
		if (@nskeys) {
			foreach my $ns (sort @nskeys) {
				my $uri	= $ns{ $ns };
				$sink->emit("\@prefix $ns: <$uri> .\n");
			}
			$sink->emit("\n");
		}
	}
	if ($self->{base_uri}) {
		$sink->emit("\@base <$self->{base_uri}> .\n\n");
	}
	
	my $last_subj;
	my $last_pred;
	
	my $open_triple	= 0;
	while (my $st = $iter->next) {
# 		warn "------------------\n";
# 		warn $st->as_string . "\n";
		my $subj	= $st->subject;
		my $pred	= $st->predicate;
		my $obj		= $st->object;
		
		# we're abusing the seen hash here as the key isn't really a node value,
		# but since it isn't a valid node string being used it shouldn't collide
		# with real data. we set this here so that later on when we check for
		# single-owner bnodes (when attempting to use the [...] concise syntax),
		# bnodes that have already been serialized as the 'head' of a statement
		# aren't considered as single-owner. This is because the output string
		# is acting as a second ownder of the node -- it's already been emitted
		# as something like '_:foobar', so it can't also be output as '[...]'.
		$seen->{ '  heads' }{ $subj->as_string }++;
		
		if (my $model = $args{model}) {
			if (my $head = $self->_statement_describes_list($model, $st)) {
				warn "found a rdf:List head " . $head->as_string . " for the subject in statement " . $st->as_string if ($debug);
				if ($model->count_statements(undef, undef, $head)) {
					# the rdf:List appears as the object of a statement, and so
					# will be serialized whenever we get to serializing that
					# statement
					warn "next" if ($debug);
					next;
				}
			}
		}
		
		if ($seen->{ $subj->as_string }) {
			warn "next on seen subject " . $st->as_string if ($debug);
			next;
		}
		
		if ($subj->equal( $last_subj )) {
			# continue an existing subject
			if ($pred->equal( $last_pred )) {
				# continue an existing predicate
				$sink->emit(qq[, ]);
				$self->_serialize_object_to_file( $sink, $obj, $seen, $level, $tab, %args );
			} else {
				# start a new predicate
				$sink->emit(qq[ ;\n${indent}$tab]);
				$self->_turtle( $sink, $pred, 1, $seen, $level, $tab, %args );
				$sink->emit(' ');
				$self->_serialize_object_to_file( $sink, $obj, $seen, $level, $tab, %args );
			}
		} else {
			# start a new subject
			if ($open_triple) {
				$sink->emit(qq[ .\n${indent}]);
			}
			$open_triple	= 1;
			$self->_turtle( $sink, $subj, 0, $seen, $level, $tab, %args );
			
			warn '-> ' . $pred->as_string if ($debug);
			$sink->emit(' ');
			$self->_turtle( $sink, $pred, 1, $seen, $level, $tab, %args );
			$sink->emit(' ');
			$self->_serialize_object_to_file( $sink, $obj, $seen, $level, $tab, %args );
		}
	} continue {
		if (blessed($last_subj) and not($last_subj->equal($st->subject))) {
# 			warn "marking " . $st->subject->as_string . " as seen";
			$seen->{ $last_subj->as_string }++;
		}
# 		warn "setting last subject to " . $st->subject->as_string;
		$last_subj	= $st->subject;
		$last_pred	= $st->predicate;
	}
	
	if ($open_triple) {
		$sink->emit(qq[ .\n]);
	}
	
	if ($sink->can('prepend')) {
		my @used_nskeys	= keys %{ $self->{used_ns} };
		if (@used_nskeys) {
			my $string	= '';
			foreach my $ns (sort @used_nskeys) {
				my $uri	= $ns{ $ns };
				$string	.= "\@prefix $ns: <$uri> .\n";
			}
			$string	.= "\n";
			$sink->prepend($string);
		}
	}
}

=item C<< serialize_iterator_to_string ( $iter ) >>

Serializes the iterator to Turtle, returning the result as a string.

=cut

sub serialize_iterator_to_string {
	my $self	= shift;
	my $iter	= shift;
	my $sink	= RDF::Trine::Serializer::StringSink->new();
	$self->serialize_iterator( $sink, $iter, seen => {}, level => 0, tab => "\t", @_, string => 1 );
	return $sink->string;
}

=item C<< serialize_node ( $node ) >>

Returns a string containing the Turtle serialization of C<< $node >>.

=cut

sub serialize_node {
	my $self	= shift;
	my $node	= shift;
	return $self->node_as_concise_string( $node );
}

sub _serialize_object_to_file {
	my $self	= shift;
	my $sink	= shift;
	my $subj	= shift;
	my $seen	= shift;
	my $level	= shift;
	my $tab		= shift;
	my %args	= @_;
	my $indent	= $tab x $level;
	
	if (my $model = $args{model}) {
		if ($subj->isa('RDF::Trine::Node::Blank')) {
			if ($self->_check_valid_rdf_list( $subj, $model )) {
# 				warn "node is a valid rdf:List: " . $subj->as_string . "\n";
				return $self->_turtle_rdf_list( $sink, $subj, $model, $seen, $level, $tab, %args );
			} else {
				my $count	= $model->count_statements( undef, undef, $subj );
				my $rec		= $model->count_statements( $subj, undef, $subj );
				warn "count=$count, rec=$rec for node " . $subj->as_string if ($debug);
				if ($count == 1 and $rec == 0) {
					unless ($seen->{ $subj->as_string }++ or $seen->{ '  heads' }{ $subj->as_string }) {
						my $pat		= RDF::Trine::Pattern->new( RDF::Trine::Statement->new($subj, variable('p'), variable('o')) );
						my $stream	= $model->get_pattern( $pat, undef, orderby => [ qw(p ASC o ASC) ] );
						my $iter	= $stream->as_statements( qw(s p o) );
						my $last_pred;
						my $triple_count	= 0;
						$sink->emit("[");
						while (my $st = $iter->next) {
							my $pred	= $st->predicate;
							my $obj		= $st->object;
							
							# continue an existing subject
							if ($pred->equal( $last_pred )) {
								# continue an existing predicate
								$sink->emit(qq[, ]);
								$self->_serialize_object_to_file( $sink, $obj, $seen, $level, $tab, %args );
#								$self->_turtle( $fh, $obj, 2, $seen, $level, $tab, %args );
							} else {
								# start a new predicate
								if ($triple_count == 0) {
									$sink->emit(qq[\n${indent}${tab}${tab}]);
								} else {
									$sink->emit(qq[ ;\n${indent}$tab${tab}]);
								}
								$self->_turtle( $sink, $pred, 1, $seen, $level, $tab, %args );
								$sink->emit(' ');
								$self->_serialize_object_to_file( $sink, $obj, $seen, $level+1, $tab, %args );
							}
							
							$last_pred	= $pred;
							$triple_count++;
						}
						if ($triple_count) {
							$sink->emit("\n${indent}${tab}");
						}
						$sink->emit("]");
						return;
					}
				}
			}
		}
	}
	
	$self->_turtle( $sink, $subj, 2, $seen, $level, $tab, %args );
}

sub _statement_describes_list {
	my $self	= shift;
	my $model	= shift;
	my $st		= shift;
	my $subj	= $st->subject;
	my $pred	= $st->predicate;
	my $obj		= $st->object;
	if ($model->count_statements($subj, $rdf->first) and $model->count_statements($subj, $rdf->rest)) {
# 		warn $subj->as_string . " looks like a rdf:List element";
		if (my $head = $self->_node_belongs_to_valid_list( $model, $subj )) {
			return $head;
		}
	}
	
	return;
}

sub _node_belongs_to_valid_list {
	my $self	= shift;
	my $model	= shift;
	my $node	= shift;
	while ($model->count_statements( undef, $rdf->rest, $node )) {
		my $iter		= $model->get_statements( undef, $rdf->rest, $node );
		my $s			= $iter->next;
		my $ancestor	= $s->subject;
		unless (blessed($ancestor)) {
# 			warn "failed to get an expected rdf:List element ancestor";
			return 0;
		}
		($node)	= $ancestor;
# 		warn "stepping back to rdf:List element ancestor " . $node->as_string;
	}
	if ($self->_check_valid_rdf_list( $node, $model )) {
		return $node;
	} else {
		return;
	}
}

sub _check_valid_rdf_list {
	my $self	= shift;
	my $head	= shift;
	my $model	= shift;
# 	warn '--------------------------';
# 	warn "checking if node " . $head->as_string . " is a valid rdf:List\n";
	
	my $headrest	= $model->count_statements( undef, $rdf->rest, $head );
	if ($headrest) {
# 		warn "\tnode " . $head->as_string . " seems to be the middle of an rdf:List\n";
		return 0;
	}
	
	my %list_elements;
	my $node	= $head;
	until ($node->equal( $rdf->nil )) {
		$list_elements{ $node->as_string }++;
		
		unless ($node->isa('RDF::Trine::Node::Blank')) {
# 			warn "\tnode " . $node->as_string . " isn't a blank node\n";
			return 0;
		}
		
		my $first	= $model->count_statements( $node, $rdf->first );
		unless ($first == 1) {
# 			warn "\tnode " . $node->as_string . " has $first rdf:first links when 1 was expected\n";
			return 0;
		}
		
		my $rest	= $model->count_statements( $node, $rdf->rest );
		unless ($rest == 1) {
# 			warn "\tnode " . $node->as_string . " has $rest rdf:rest links when 1 was expected\n";
			return 0;
		}
		
		my $in		= $model->count_statements( undef, undef, $node );
		unless ($in < 2) {
# 			warn "\tnode " . $node->as_string . " has $in incoming links when 2 were expected\n";
			return 0;
		}
		
		if (not($head->equal( $node ))) {
			# It's OK for the head of a list to have any outgoing links (e.g. (1 2) ex:p "o"
			# but internal list elements should have only the expected links of rdf:first, 
			# rdf:rest, and optionally an rdf:type rdf:List
			my $out		= $model->count_statements( $node );
			unless ($out == 2 or $out == 3) {
# 				warn "\tnode " . $node->as_string . " has $out outgoing links when 2 or 3 were expected\n";
				return 0;
			}
			
			if ($out == 3) {
				my $type	= $model->count_statements( $node, $rdf->type, $rdf->List );
				unless ($type == 1) {
# 					warn "\tnode " . $node->as_string . " has more outgoing links than expected\n";
					return 0;
				}
			}
		}
		
		
		
		my @links	= $model->objects_for_predicate_list( $node, $rdf->first, $rdf->rest );
		foreach my $l (@links) {
			if ($list_elements{ $l->as_string }) {
				warn $node->as_string . " is repeated in the list" if ($debug);
				return 0;
			}
		}
		
		($node)	= $model->objects_for_predicate_list( $node, $rdf->rest );
		unless (blessed($node)) {
# 			warn "\tno valid rdf:rest object found";
			return 0;
		}
# 		warn "\tmoving on to rdf:rest object " . $node->as_string . "\n";
	}
	
# 	warn "\tlooks like a valid rdf:List\n";
	return 1;
}

sub _turtle_rdf_list {
	my $self	= shift;
	my $sink	= shift;
	my $head	= shift;
	my $model	= shift;
	my $seen	= shift;
	my $level	= shift;
	my $tab		= shift;
	my %args	= @_;
	my $node	= $head;
	my $count	= 0;
	$sink->emit('(');
	until ($node->equal( $rdf->nil )) {
		if ($count) {
			$sink->emit(' ');
		}
		my ($value)	= $model->objects_for_predicate_list( $node, $rdf->first );
		$self->_serialize_object_to_file( $sink, $value, $seen, $level, $tab, %args );
		$seen->{ $node->as_string }++;
		($node)		= $model->objects_for_predicate_list( $node, $rdf->rest );
		$count++;
	}
	$sink->emit(')');
}

sub _node_concise_string {
	my $self	= shift;
	my $obj		= shift;
	if ($obj->is_literal and $obj->has_datatype) {
		my $dt	= $obj->literal_datatype;
		if ($dt =~ m<^http://www.w3.org/2001/XMLSchema#(integer|double|decimal)$> and $obj->is_canonical_lexical_form) {
			my $value	= $obj->literal_value;
			return $value;
		} else {
			my $dtr	= iri($dt);
			my $literal	= $obj->literal_value;
			my $qname;
			try {
				my ($ns,$local)	= $dtr->qname;
				if (blessed($self) and exists $self->{ns}{$ns}) {
					$qname	= join(':', $self->{ns}{$ns}, $local);
					$self->{used_ns}{ $self->{ns}{$ns} }++;
				}
			} catch RDF::Trine::Error with {};
			if ($qname) {
				my $escaped	= $obj->_unicode_escape( $literal );
				return qq["$escaped"^^$qname];
			}
		}
	} elsif ($obj->isa('RDF::Trine::Node::Resource')) {
		my $value;
		try {
			my ($ns,$local)	= $obj->qname;
			if (blessed($self) and exists $self->{ns}{$ns}) {
				$value	= join(':', $self->{ns}{$ns}, $local);
				$self->{used_ns}{ $self->{ns}{$ns} }++;
			}
		} catch RDF::Trine::Error with {} otherwise {};
		if ($value) {
			return $value;
		}
	}
	return;
}

=item C<< node_as_concise_string >>

Returns a string representation using common Turtle syntax shortcuts (e.g. for numeric literals).

=cut

sub node_as_concise_string {
	my $self	= shift;
	my $obj		= shift;
	my $str		= $self->_node_concise_string( $obj );
	if (defined($str)) {
		return $str;
	} else {
		return $obj->as_ntriples;
	}
}

sub _turtle {
	my $self	= shift;
	my $sink	= shift;
	my $obj		= shift;
	my $pos		= shift;
	my $seen	= shift;
	my $level	= shift;
	my $tab		= shift;
	my %args	= @_;
	
	if ($obj->isa('RDF::Trine::Node::Resource') and $pos == 1 and $obj->uri_value eq 'http://www.w3.org/1999/02/22-rdf-syntax-ns#type') {
		$sink->emit('a');
		return;
	} elsif ($obj->isa('RDF::Trine::Node::Blank') and $pos == 0) {
		if (my $model = $args{ model }) {
			my $count	= $model->count_statements( undef, undef, $obj );
			my $rec		= $model->count_statements( $obj, undef, $obj );
			# XXX if $count == 1, then it would be better to ignore this triple for now, since it's a 'single-owner' bnode, and better serialized as a '[ ... ]' bnode in the object position as part of the 'owning' triple
			if ($count < 1 and $rec == 0) {
				$sink->emit('[]');
				return;
			}
		}
	} elsif (defined(my $str = $self->_node_concise_string( $obj ))) {
		$sink->emit($str);
		return;
	}
	
	$sink->emit($obj->as_ntriples);
	return;
}

1;

__END__

=back

=head1 BUGS

Please report any bugs or feature requests to through the GitHub web interface
at L<https://github.com/kasei/perlrdf/issues>.

=head1 SEE ALSO

L<http://www.w3.org/TeamSubmission/turtle/>

=head1 AUTHOR

Gregory Todd Williams  C<< <gwilliams@cpan.org> >>

=head1 COPYRIGHT

Copyright (c) 2006-2012 Gregory Todd Williams. This
program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut