File Coverage

blib/lib/RDF/AllegroGraph/Catalog4.pm

Criterion	Covered	Total	%
statement	30	76	39.4
branch	0	32	0.0
condition	0	5	0.0
subroutine	10	15	66.6
pod	4	5	80.0
total	44	133	33.0

package RDF::AllegroGraph::Catalog4;

use strict;
use warnings;

require Exporter;
use base qw(RDF::AllegroGraph::Catalog);

=pod

=head1 NAME

RDF::AllegroGraph::Catalog4 - AllegroGraph catalog handle for AGv4

=cut

use RDF::AllegroGraph::Repository4;
use RDF::AllegroGraph::Utils;

use JSON;
use HTTP::Status;
use Fcntl;
use Data::Dumper;

=pod

=head1 INTERFACE

=head2 Constructor

The constructor will try to connect to the server and will C if fetching the repositories (even
the empty list) fails.

=cut

sub new {
    my $class   = shift;
    my %options = @_;
    die "no NAME"   unless $options{NAME};
    die "no SERVER" unless $options{SERVER};
    my $self = bless \%options, $class;
    eval {                                                          # test whether it exists, by probing the repositories (could be anything else for that matter)
	$self->repositories unless $self->{NAME} eq '/';            # for non-root catalogs we check whether they exist
    }; if ($@) {                                                    # if something weird happened here
	die "catalog '".$self->{NAME}."' does not exist on the server";
    }
    return $self;                                                   # otherwise we continue with normal business
}

=pod


=head2 Methods

=over

=item B

Removes the named catalog from the server.

B: I have no idea what happens with any repositories in there.

=cut

sub disband {
    my $self = shift;
    my $requ = HTTP::Request->new (DELETE => $self->{SERVER}->{ADDRESS} . '/catalogs' . $self->{NAME});
    my $resp = $self->{SERVER}->{ua}->request ($requ);
    die "protocol error: ".$resp->status_line.' ('.$resp->content.')' unless $resp->is_success;
}

=pod

=item B

I<@repos> = I<$cat>->repositories

This method returns a list of L objects of this catalog.

=cut

sub repositories {
    my $self = shift;
    my $resp = $self->{SERVER}->{ua}->get ($self->{SERVER}->{ADDRESS} . ($self->{NAME} eq '/'
                                                                            ? ''
                                                                            : '/catalogs' . $self->{NAME} ) . '/repositories');
    die "protocol error: ".$resp->status_line unless $resp->is_success;
    my $repo = from_json ($resp->content);
    return
	map { RDF::AllegroGraph::Repository4->new (%$_, CATALOG => $self) }
	map { RDF::AllegroGraph::Utils::_hash_to_perl ($_) }
        @$repo;
}

=pod

=item B

I<$repo> = I<$cat>->repository (I<$repo_id> [, I<$mode> ])

This method returns an L object for the repository with
the provided id. That id always has the form C.

If that repository does not exist in the catalog, then an exception C will be
raised. That is, unless the optional I is provided having the POSIX value C. Then the
repository will be created.

=cut

sub repository {
    my $self = shift;
    my $id   = shift;
    my $mode = shift || O_RDONLY;

    if (my ($repo) = grep { $_->id eq $id } $self->repositories) {
	return $repo;
    } elsif ($mode == O_CREAT) {
	my $uri;
	if ($id =~ m{^(/[^/]+)$}) {  # root catalog repo
	    my $repoid = $1;
	    die "do not want to open root catalog repository within non-root catalog" unless $self->{NAME} eq '/'; # we are not inside the root catalog?
	    $uri = $self->{SERVER}->{ADDRESS} . '/repositories' . $repoid;                                   # create the uri for below
	} elsif ($id =~ m{^(/[^/]+?)(/.+)$}) {
	    my $catid  = $1;
	    my $repoid = $2;
	    die "do not want to open non-root repository in named catalog" unless $self->{NAME} eq $1;
	    $uri = $self->{SERVER}->{ADDRESS} . '/catalogs' . $catid . '/repositories' . $repoid;
	} else {
	    die "cannot handle repository id '$id'";
	}
        use HTTP::Request;
	my $requ = HTTP::Request->new (PUT => $uri);
	my $resp = $self->{SERVER}->{ua}->request ($requ);
	die "protocol error: ".$resp->status_line unless $resp->code == RC_NO_CONTENT;
	return $self->repository ($id);                                                    # recursive, but without forced create
    } else {
	die "cannot open repository '$id'";
    }
}

=pod

=item B

This method returns the protocol version the catalog supports.

=cut

sub protocol {
    my $self = shift;
    my $resp = $self->{SERVER}->{ua}->get ($self->{SERVER}->{ADDRESS} . ($self->{NAME} eq '/'
                                                                            ? '/protocol'
                                                                            : '/catalogs' . $self->{NAME} . '/protocol'));
    die "protocol error: ".$resp->status_line unless $resp->is_success;
    return $resp->content =~ m/^"?(.*?)"?$/ && $1;
}

=pod

=back

=head1 AUTHOR

Robert Barta, C<<  >>

=head1 COPYRIGHT & LICENSE

Copyright 20(09|10|11) Robert Barta, all rights reserved.

This program is free software; you can redistribute it and/or modify it under the same terms as Perl
itself.

L

=cut

our $VERSION  = '0.04';

1;

__END__