File Coverage

blib/lib/Class/RDF.pm

Criterion	Covered	Total	%
statement	76	330	23.0
branch	0	130	0.0
condition	0	39	0.0
subroutine	26	66	39.3
pod			n/a
total	102	565	18.0

package Class::RDF::Store;

use base "Class::DBI";
use File::Temp;

our @Create_SQL = (<<'', <<'', <<'', <<'');
    create table ns (
	prefix char(16),
	uri char(255)
    );

    create table node (
	id integer primary key,
	created timestamp,
	value text,
	is_resource integer(1)
    );

    create table statement (
	id integer primary key,
	created timestamp,
	subject integer,
	predicate integer,
	object integer,
	context integer
    );

     create table metastatement (
        id integer primary key,
        created timestamp,
        subject integer,
        predicate integer,
        object integer
    );


sub is_transient {
    my $class = shift;
    my %args  = ( TEMPLATE => "crdfXXXX", SUFFIX => ".db", UNLINK => 1, @_ );
    my $tmp   = File::Temp->new( %args );

    $class->set_db( Main => "dbi:SQLite:".$tmp->filename, "", "" );

    for my $st (@Create_SQL) {
	$class->db_Main->do($st);
    }
}

package Class::RDF::NS;

use Carp;
use base 'Class::RDF::Store';
use vars '$AUTOLOAD';
use strict;
use warnings;
no warnings 'redefine';

__PACKAGE__->table( "ns" );
__PACKAGE__->columns( All => qw( prefix uri ) );

our (%Cache, $Prefix_RE);

sub define {
    my ($class, %uri) = @_;
    while (my ($prefix, $uri) = each %uri) {
	my $ns = $class->find_or_create({ prefix => $prefix });
	$Cache{$prefix} = $ns;
	$ns->uri( $uri );
	$ns->update;
    }
    $class->_build_prefix_re;
}

sub export {
    my ($class, @prefixes) = @_;
    for my $prefix (@prefixes)  {
	my $ns = $class->retrieve($prefix);
	croak "Can't find prefix $prefix" unless $ns;
	my $uri = $ns->uri;

	no strict;
	*{"$prefix\::AUTOLOAD"} = sub {
	    my $object = shift;
	    (my $prop = $AUTOLOAD) =~ s/^.*:://o;
	    if (ref($object)) {
		$object->get_or_set( "$uri$prop", @_ );
	    } else {
		return "$uri$prop";
	    }
	};
    }
}

sub retrieve {
    my ($class, $prefix) = @_;
    return $Cache{$prefix} if $Cache{$prefix};
    my $ns = $class->SUPER::retrieve($prefix);
    $Cache{$prefix} = $ns;
    $class->_build_prefix_re;
}

sub load {
    my $class = shift;
    my $iter = $class->retrieve_all;
    while (my $ns = $iter->next) {
	$Cache{$ns->prefix} = $ns
    }
    $class->_build_prefix_re;
}

sub expand {
    my ($class, $uri) = @_;
    $uri =~ s/$Prefix_RE/$Cache{$1}->uri/es;
    return $uri;
}

sub _build_prefix_re {
    my $class = shift;
    my $list = join("|", keys %Cache);
    $Prefix_RE = qr/^($list):/;
}

package Class::RDF::Node;

use base "Class::RDF::Store";
use overload '""' => \&as_string,
	eq  => \&_string_eq;

use warnings;
use strict;

__PACKAGE__->table( "node" );
__PACKAGE__->columns( All => qw( id created value is_resource ) );
__PACKAGE__->autoupdate(1);
our %Cache;

sub new {
    my $class = shift;
    my $value = shift || "";
    return $class if ref $class and $class->isa(__PACKAGE__);

    my $cached = $class->cache($value);
    return $cached if $cached;

    my $is_resource = ($value =~ /^\w+:\S+$/o ? 1 : 0);
    my $obj =$class->find_or_create({ value => $value, is_resource => $is_resource });
    return $class->cache($value, $obj);
}

sub find {
    my ($class,$value) = @_;
    return unless defined $value;

    my $cached = $class->cache($value);
    return $cached if $cached;

    my ($found) = $class->search({ value => $value });
    $class->cache($value, $found) if $found;
    return $found;
}

sub cache {
    my ($class, $value, $node) = @_;
    if ($node) {
	return ($Cache{$value} = $node);
    } elsif (exists $Cache{$value}) {
	return $Cache{$value}
    } else {
	return undef;
    }
}

sub as_string {
    my $self = shift;
    return $self->value;
}
sub _string_eq {
    my ($self,$other) = @_;
    $self->as_string eq $other;
}

package Class::RDF::Statement;

use base "Class::RDF::Store";
use warnings;
use strict;

use constant Node   => "Class::RDF::Node";
use constant Object => "Class::RDF::Object";

our @Quad = qw( subject predicate object context );

__PACKAGE__->table( "statement" );
__PACKAGE__->columns( All => "id", "created", @Quad );
__PACKAGE__->has_a( $_ => Node ) for @Quad;
__PACKAGE__->autoupdate(1);

__PACKAGE__->set_sql( RetrieveFull => <<"" );
    SELECT st.*, n.*
    FROM statement st, node n
    WHERE %s
	AND ( st.subject   = n.id
	    OR st.predicate = n.id
	    OR st.object    = n.id
	    OR st.context   = n.id )


__PACKAGE__->set_sql( RetrieveOrdered => <<"" );
    SELECT st.*, n.*
    FROM statement st, node n, node m
    WHERE %s
	AND ( st.subject   = n.id
	    OR st.predicate = n.id
	    OR st.object    = n.id
	    OR st.context   = n.id )
	AND m.id = object
    ORDER BY m.value %s

__PACKAGE__->set_sql( RetrieveObjects => <<"" );
    SELECT obj.*, n.*
    FROM statement st, statement obj, node n
    WHERE %s
	AND obj.subject = st.subject
	AND ( obj.subject   = n.id
	    OR obj.predicate = n.id
	    OR obj.object    = n.id
	    OR obj.context   = n.id )

sub new {
    my ($class, @nodes) = @_;

    my @triple;
    for my $node (@nodes) {
	$node = $class->Node->new($node) unless ref $node;
	push @triple, $node;
    }
    $class->find_or_create({ subject	=> $triple[0],
			     predicate	=> $triple[1],
			     object	=> $triple[2],
			     context	=> $triple[3] });

}

sub value {
    my $self = shift;
    my $obj  = $self->object;
    return $obj->is_resource ?
	$self->Object->new($obj->value) : $obj->value;
}

sub triples {
    my $self = shift;
    my @t;
    foreach (qw(subject predicate object)) {
	my $node = $self->$_;
	if ($node and $node->can('value')) {
	    push @t, $node->value;
	}
	else {
	    # XXX: why are we returning undef here?
	    return undef;
	}
    }
    return @t;
}

sub search {
    my $class = shift;
    my %args = ref($_[0]) ? %{$_[0]} : @_;

    $args{like} = delete $args{object} if $args{like};

    my ($where, $vals) = $class->compose_query(%args);
    return $class->no_match unless ref $where;

    if ( $args{like} ) {
	my @nodes = $class->Node->search_like( value => '%'.$args{like}.'%' );
	return $class->no_match unless @nodes;
	push @$where, "st.object IN (" . join(",", map($_->id, @nodes)) . ")";
    }

    my $sth;
    if ( $args{objects} ) {
	$sth = $class->sql_RetrieveObjects( join(" AND ", @$where) );
    } elsif ( $args{order} ) {
	$sth = $class->sql_RetrieveOrdered( join(" AND ", @$where), $args{order} );
    } else {
	$sth = $class->sql_RetrieveFull( join(" AND ", @$where) );
    }

    return $class->retrieve_from_sth($sth, @$vals);
}

sub no_match {
    my $class = shift;
    $class->_ids_to_objects([]);
}

sub compose_query {
    my ($class, %args) = @_;
    my (@where, @vals);

    $args{predicate} = Class::RDF::NS->expand( $args{predicate} )
	if exists $args{predicate} and not ref $args{predicate};

    for my $position (grep exists $args{$_}, @Quad) {
	push @where, "st.$position = ?";
	if ( ref $args{$position} ) {
	    push @vals, $args{$position};
	} else {
	    my $node = $class->Node->find( $args{$position} ) or return;
	    push @vals, $node;
	}
    }

    return (\@where, \@vals);
}

sub retrieve_from_sth {
    my ($class, $sth, @bind) = @_;

    my (@results, %nodes, %triples, %t, %n);
    eval {
	$sth->execute( map($_->id, @bind) );
	$sth->bind_columns(\(
	    @t{qw{ id created subject predicate object context }},
	    @n{qw{ id created value is_resource }} ));

	while ($sth->fetch) {
	    unless ( exists $nodes{$n{id}} ) {
		$nodes{$n{id}} = $class->Node->construct(\%n);
	    }
	    unless ( exists $triples{$t{id}} ) {
		push @results, ( $triples{$t{id}} = {%t} );
	    }
	}
    };

    return $class->_croak("$class can't $sth->{Statement}: $@", err => $@)
	if $@;

    for my $st (values %triples) {
	for my $which (@Quad) {
	    $st->{$which} = $nodes{$st->{$which}} if $st->{$which};
	}
    }

    return $class->_ids_to_objects(\@results);
}

# ... we need to figure out where this belongs ...
#
# use Time::Piece;
#
# sub ical_to_sql {
#     my ($class,$ical) = @_;
#     warn($ical);
#     my $t = Time::Piece->strptime($ical,"%Y%m%dT%H%M%SZ");
#     $t->strftime("%Y%m%d%H%M%S");
# }
#
# sub timeslice {
#     my ($self,%p) = @_;
#     my $start = $p{start};
#     my $end = $p{end};
#     my @where;
#     # SQL for timestamp
#     warn("time");
#     push @where, "created > " . $self->ical_to_sql($start) if $start;
#     push @where, "created < " . $self->ical_to_sql($end) if $end;
#     my $sql = join(" and ", @where); warn($sql);
#     my @o = $self->retrieve_from_sql($sql);
# }

package Class::RDF::Object;

use Carp;
use overload '""' => \&as_string,
	      eq  => sub { $_[0]->as_string eq $_[1] };
use vars '$AUTOLOAD';
use strict;
use warnings;

use constant Node      => "Class::RDF::Node";
use constant Statement => "Class::RDF::Statement";

sub new {
    my $class = shift;
    my ($uri, $context, $data, $base);
    $uri = shift unless ref $_[0] eq "HASH";
    $context = shift unless ref $_[0] eq "HASH";
    $data = shift if ref $_[0] eq "HASH";
    $base = shift if $_[0];
    $base ||= '_id:';
    $uri ||= $base.sprintf("%08x%04x", time, int rand(0xFFFF));
    unless (ref $uri) {
	$uri = $class->Node->new($uri);
    }

    $context = $class->Node->find($context)
    	if $context and not ref $context;

    my $self = bless {
		context => $context,
		uri => $uri,
		triples => {},
		stub => 1
	}, ref($class) || $class;

    while (my ($key, $vals) = each %$data) {
	for my $val (ref $vals eq 'ARRAY' ? @$vals : $vals) {
	    $val = $val->{uri}->value if ref($val) and $val->{'uri'};
	    my $st = $self->Statement->new( $uri, $key, $val );
	    $self->_add_statement($st);
	}
    }
    return $self;
}

sub _fetch_statements {
    my $self = shift;
    # warn "fetch_statements ", $self->uri->value, "\n";
    my $iter = $self->Statement->search( subject => $self->uri );
    while (my $st = $iter->next) {
	$self->_add_statement($st);
    }
    delete $self->{stub};
}

sub _add_statement {
    my ($self, $statement) = @_;
    push @{$self->{triples}{$statement->predicate->value} ||= []}, $statement;
}

sub statements {
    my $self = shift;
    $self->_fetch_statements if $self->{stub};
    return map( @$_, values %{$self->{triples}} );
}

sub triples {
    my $self = shift;
    $self->_fetch_statements if $self->{stub};
    return map( [$_->triples], $self->statements  );
}

sub uri {
    my $self = shift;
    # read only because Goddess help us if an object's URI
    # changes in mid-flight
    return $self->{uri};
}

sub as_string {
    my $self = shift;
    return $self->uri->as_string;
}
sub _string_eq {
    my ($self,$other) = @_;
    $self->as_string eq $other;
}

sub context {
    my $self = shift;
    $self->{context} = shift if @_;
    return $self->{context} if $self->{context};
}

sub get {
    my ($self, $prop) = @_;
    $self->_fetch_statements if $self->{stub};
    my $statements = $self->{triples}{$prop} or return;
    my @vals = map( $_->value, @$statements );
    return wantarray ? @vals : $vals[0];
}

sub set {
    my ($self, %args) = @_;
    $self->_fetch_statements if $self->{stub};
    while (my ($key, $val) = each %args) {
	if (exists $self->{triples}{$key}) {
	    $_->delete for @{$self->{triples}{$key}};
	    delete $self->{triples}{$key};
	}

	for my $value (ref($val) eq "ARRAY" ? @$val : $val) {
	    $value = $value->uri if ref($value) and $value->can('uri');
	    my $triple = $self->Statement->new(
			$self->uri->value, $key, $value, $self->context );
		    $self->_add_statement( $triple );
	}
    }
}

# delete forward and backward references to me
#
  sub delete {
	my $self = shift;
	my $uri =  $self->uri->value;
# triples that have my subject, and other predicate and object.
#
	my @triples = $self->statements;
	foreach (@triples) {
		$_->delete;
	}
# triples that have me as their object
	my @pointers = Class::RDF::Statement->search(object => $uri);
	foreach (@pointers) {
		$_->delete;
	}
# is that really it?
  }

sub get_or_set {
    my ($self, $prop, @vals) = @_;
    if (@vals) {
	$self->set($prop => shift @vals);
    } else {
	return $self->get($prop);
    }
}

sub add {
    my ($self, %args) = @_;
    $self->_fetch_statements if $self->{stub};
    while (my ($key, $val) = each %args) {
        for my $value (ref($val) eq "ARRAY" ? @$val : $val) {
	    $value = $value->{uri} if ref($value) and $value->{uri};

	    my $triple = $self->Statement->new(
		$self->uri, $key, $value, $self->context );
	    $self->_add_statement( $triple );
	}
    }
}

sub remove {
    my ($self, %args) = @_;
    $self->_fetch_statements if $self->{stub};
    while (my ($key, $vals) = each %args) {
        my %remove;
        my @v = ref($vals) eq 'ARRAY' ? @$vals : ($vals);
	foreach my $o (@v) {
	    $o = $o->{uri}->value if ref($o) and $o->{uri};
	    $remove{$o} = 1;
	}

	my $triples = $self->{triples}{$key};
	for (my $st = 0; $st < scalar(@$triples); $st++) {
	    if ($remove{$triples->[$st]->object->value}) {
		$triples->[$st]->delete;
		splice @$triples, $st--, 1;
	    }
	}
    }
}

sub contains {
    my ($self, $prop, $val) = @_;
    $self->_fetch_statements if $self->{stub};
    return scalar grep( $_ eq $val, @{$self->{triples}{$prop}} )
	if exists $self->{triples}{$prop};
    return;
}

sub find {
    my ($class, $uri) = @_;
    my $node = $class->Node->find($uri);
    return $node ? $class->new($node) : undef;
}

sub find_or_create {
    my $class = shift;
    my ($args) = @_;
    my $obj;

    if (ref $args eq "HASH") {
	($obj) = $class->search( %$args );
    } else { # $args is really a uri
	$obj = $class->new( $args );
    }

    $obj ||= $class->new( @_ );
    return $obj;
}

sub search {
    my ($class, $predicate, $object, $args) = @_;

    my %args = (ref($args) ? %$args : ());
    $args{predicate} = $predicate;
    $args{object} = $object if $object;
    my $iter = $class->Statement->search( %args, objects => 1 );

    my (@results, %seen);
    while (my $st = $iter->next) {
	my $id = $st->subject->id;
	unless ( $seen{$id} ) {
	    $seen{$id} = $class->new( $st->subject, {} );
	    delete $seen{$id}{stub};
	    push @results, $seen{$id};
	}
	$seen{$id}->_add_statement($st);
    }

    if (my $order = $args{order}) {
	@results =  map  { $_->[1] }
		    sort { $order eq "asc" ? $a->[0] cmp $b->[0] : $b->[0] cmp $a->[0] }
		    map	 { [($_->get($predicate))[0], $_] } @results;
    }

    return( wantarray ? @results : $results[0] );
}

package Class::RDF;

use RDF::Simple::Parser;
use RDF::Simple::Serialiser;
use LWP::Simple ();
use Carp;
use strict;
use warnings;

use constant Node	=> "Class::RDF::Node";
use constant Statement  => "Class::RDF::Statement";
use constant Object	=> "Class::RDF::Object";

our ($Parser, $Serializer);
our $VERSION = '0.20';

sub new {
    my $class = shift;
    $class->Object->new( @_ );
}

sub set_db {
    my $class = shift;
    Class::RDF::Store->set_db( Main => @_ );
    Class::RDF::NS->load;
    if ( $_[0] =~ /^dbi:Pg:/io ) {
	$class->Node->sequence( "node_id_seq" );
	$class->Statement->sequence( "statement_id_seq" );
    }
}

sub is_transient {
    my $class = shift;
    Class::RDF::Store->is_transient;
}

sub define {
    my $class = shift;
    Class::RDF::NS->define(@_);
}

sub parser {
    my $class = shift;
    $Parser ||= RDF::Simple::Parser->new;
    return $Parser;
}

sub serializer {
    my $class = shift;
    $Serializer ||= RDF::Simple::Serialiser->new;
    return $Serializer;
}

sub parse {
    my ($class, %args) = @_;
    my @triples = $args{uri} ?
	$class->parser->parse_uri($args{uri}) :
	$class->parser->parse_rdf($args{xml});
    my %output;

    return unless @triples;

    # we care about getting the root object back first
    my $root = $triples[0][0];

    $args{context} ||= $args{uri};
    for my $triple (@triples) {
	$class->Statement->new(@$triple, $args{context});
	$output{$triple->[0]}++;
     }

    $output{$_} = $class->new($_) for keys %output;

    my $first = delete $output{$root};
    return ($first, values %output);
}

sub serialize {
    my ($class, @objects) = @_;
    my @triples;
    for (@objects) {
	my @t = $_->triples;
	push @triples, @t;
    }
    $class->serializer->addns( $_->prefix, $_->uri )
	for Class::RDF::NS->retrieve_all;
    return $class->serializer->serialise(@triples);
}

*serialise = *serialise = \&serialize; # because I'm in love with her

1;

__END__