use 5.006;
use strict;
use warnings;
package Metabase::Librarian;
# ABSTRACT: Front-end interface to Metabase storage
our $VERSION = '1.001'; # VERSION
use Moose 1.00;
use Moose::Util::TypeConstraints;
use Class::MOP ();
use Carp ();
use CPAN::DistnameInfo;
use Data::Stream::Bulk::Filter ();
use Metabase::Archive;
use Metabase::Index;
use Data::GUID ();
use JSON 2 ();
has 'archive' => (
is => 'ro',
isa => 'Metabase::Archive',
required => 1,
);
has 'index' => (
is => 'ro',
isa => 'Metabase::Index',
required => 1,
);
sub BUILD {
my $self = shift;
$self->archive->initialize();
}
# given fact, store it and return guid;
sub store {
my ($self, $fact) = @_;
# Facts must be assigned GUID at source
unless ( $fact->guid ) {
Carp::confess "Can't store: no GUID set for fact\n";
}
# Don't store existing GUIDs; this should never happen, since we're just
# generating a new one, but... hey, can't be too safe, right?
# XXX maybe delegate this down to archive/index, because if they
# have unique constraint enforcement, then there's no reason to do
# this extra (negative) query
if ( $self->index->exists( $fact->guid ) ) {
Carp::confess("GUID conflicts with an existing object");
}
# Updated the "update_time" timestamp
$fact->touch;
my $fact_struct = $fact->as_struct;
# for Reports, store facts and replace content with GUID's
# XXX nasty tight coupling with as_struct() -- dagolden, 2009-04-09
if ( $fact->isa('Metabase::Report') ) {
my @fact_guids;
for my $f ( $fact->facts ) {
push @fact_guids, $self->store( $f );
}
$fact_struct->{content} = JSON->new->ascii->encode(\@fact_guids);
}
if ( $self->archive->store( $fact_struct )
&& $self->index ->add ( $fact ) ) {
return $fact->guid;
} else {
Carp::confess("Error storing or indexing fact with guid: " . $fact->guid);
}
}
sub search {
my ($self, %spec) = @_;
return $self->index->search( %spec );
}
sub extract {
my ($self, $guid) = @_;
my $fact_struct = $self->archive->extract( lc $guid );
Carp::confess "Fact $guid does not exist" unless $fact_struct;
return $self->_thaw_fact( $fact_struct );
}
sub _thaw_fact {
my ($self, $fact_struct) = @_;
my $fact;
# reconstruct fact meta and extract type to find the class
my $class = Metabase::Fact->class_from_type(
$fact_struct->{metadata}{core}{type}
);
Class::MOP::load_class( $class );
# XXX: The problem here is that what we get out of the librarian isn't
# exactly what we put in, it seems. We need to improve the specification
# for what goes in/out and then test it more thoroughly. *Clearly* the
# following block is a wretched hack. -- rjbs, 2009-06-24
if ($class->isa('Metabase::Report')) {
my @facts;
my $content = JSON->new->ascii->decode( $fact_struct->{content} );
for my $g ( @$content ) {
# XXX no error checking if extract() fails -- dagolden, 2009-04-09
push @facts, $self->extract( $g );
}
my $bogus_content = [ map { $_->as_struct } @facts ];
my $bogus_string = JSON->new->ascii->encode( $bogus_content );
$fact = $class->from_struct({
metadata => { core => $fact_struct->{metadata}{core} },
content => \$bogus_string,
});
$fact->close;
}
else {
$fact = $class->from_struct( $fact_struct );
}
return $fact;
}
sub exists {
my ($self, $guid) = @_;
return $self->index->exists( lc $guid );
}
sub iterator {
my ($self) = @_;
return Data::Stream::Bulk::Filter->new(
stream => $self->archive->iterator,
filter => sub {
return [ map { $self->_thaw_fact( $_ ) } @{ $_[0] } ];
},
);
}
# DO NOT lc() the GUID -- we must allow deletion of improperly cased GUIDS from source
sub delete {
my ($self, $guid) = @_;
$self->index->delete( $guid );
$self->archive->delete( $guid );
return 1;
}
1;
=pod
=head1 NAME
Metabase::Librarian - Front-end interface to Metabase storage
=head1 VERSION
version 1.001
=head1 SYNOPSIS
my $ml = Metabase::Librarian->new(
archive => $archive,
index => $index,
);
=head1 DESCRIPTION
The Metabase::Librarian class provides a front-end interface to user-defined
Metabase storage and indexing objects.
=for Pod::Coverage BUILD delete
=head1 USAGE
=head2 C<new>
my $ml = Metabase::Librarian->new(
archive => $archive,
index => $index,
);
Librarian constructor. Takes two required arguments
=over
=item *
C<archive> -- a Metabase::Archive subclass
=item *
C<index> -- a Metabase::Index subclass
=back
=head2 C<store>
$ml->store( $fact );
=head2 C<search>
$ml->search( %spec );
See L<Metabase::Index> for spec details.
=head2 C<extract>
$fact = $ml->extract( $guid );
=head2 C<exists>
if ( $ml->exists( $guid ) ) { do_stuff() }
=head2 C<iterator>
my $stream = $ml->iterator;
until ( $stream->is_done ) {
foreach my $fact ( $stream->items ) {
...
}
}
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=item *
Leon Brocard <acme@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is Copyright (c) 2012 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
__END__