libkiokudb-perl 0.56-1 / usr / share / perl5 / KiokuDB / Util.pm

package KiokuDB::Util;
BEGIN {
  $KiokuDB::Util::AUTHORITY = 'cpan:NUFFIN';
}
{
  $KiokuDB::Util::VERSION = '0.56';
}
use strict;
use warnings;
# ABSTRACT: Utility functions for working with KiokuDB

use Path::Class;

use Carp qw(croak);
use MooseX::YAML 0.04;
use Scalar::Util qw(blessed);

use namespace::clean;

use Sub::Exporter -setup => {
    exports => [qw(set weak_set dsn_to_backend import_yaml deprecate)],
};

sub weak_set {
    require KiokuDB::Set::Transient;
    KiokuDB::Set::Transient->new( set => Set::Object::Weak->new(@_) )
}

sub set {
    require KiokuDB::Set::Transient;
    KiokuDB::Set::Transient->new( set => Set::Object->new(@_) );
}

my %monikers = (
    "hash"    => "Hash",
    "bdb"     => "BDB",
    "bdb-gin" => "BDB::GIN",
    "dbi"     => "DBI",
    "jspon"   => "JSPON",
    "files"   => "Files",
    "couchdb" => "CouchDB",
    "mongodb" => "MongoDB",
);

sub _try_json {
    my $json = shift;

    require JSON;
    JSON->new->decode($json);
}

sub dsn_to_backend {
    my ( $dsn, @args ) = @_;

    if ( my ( $moniker, $rest ) = ( $dsn =~ /^([\w-]+)(?::(.*))?$/ ) ) {
        $moniker = $monikers{$moniker} || $moniker;
        my $class = "KiokuDB::Backend::$moniker";

        Class::MOP::load_class($class);
        return $class->new_from_dsn($rest, @args);
    } elsif ( my $args = _try_json($dsn) ) {
        my $dsn;

        if ( ref $args eq 'ARRAY' ) {
            ( $dsn, $args ) = @$args;
        }

        if ( ref $args eq 'HASH' ) {
            $dsn ||= delete $args->{dsn};
            return dsn_to_backend($dsn, %$args, @args);
        }
    }

    croak "Malformed DSN: $dsn";
}

sub load_config {
    my ( $base ) = @_;

    my $config_file;
    if ( $base =~ /\.yml$/ ) {
        $config_file = $base;
    } else {
        $config_file = dir($base)->file("kiokudb.yml");
        $config_file->openr;
    }

    MooseX::YAML::LoadFile($config_file);
}

sub config_to_backend {
    my ( $config, %args ) = @_;

    my $base = delete($args{base});

    my $backend = $config->{backend};

    return $backend if blessed($backend);

    my $backend_class = $backend->{class};
    Class::MOP::load_class($backend_class);

    return $backend_class->new_from_dsn_params(
        ( defined($base) ? ( dir => $base->subdir("data") ) : () ),
        %$backend,
        %args,
    );
}

sub import_yaml {
    my ( $kiokudb, @src ) = @_;

    my @objects = load_yaml_files( find_yaml_files(@src) );

    $kiokudb->txn_do(sub {
        my $scope = $kiokudb->new_scope;
        $kiokudb->insert(@objects);
    });
}

sub find_yaml_files {
    my ( @src ) = @_;

    my @files;

    foreach my $src ( @src ) {
        if ( -d $src ) {
            dir($src)->recurse( callback => sub {
                my $file = shift;

                if ( -f $file && $file->basename =~ /\.yml$/ ) {
                    push @files, $file;
                }
            });
        } else {
            push @files, $src;
        }
    }

    return @files;
}

sub load_yaml_files {
    my ( @files ) = @_;

    my @objects;

    foreach my $file ( @files ) {
        my @data = MooseX::YAML::LoadFile($file);

        if ( @data == 1 ) {
            unless ( blessed $data[0] ) {
                if ( ref $data[0] eq 'ARRAY' ) {
                    @data = @{ $data[0] };
                } else {
                    @data = %{ $data[0] }; # with IDs
                }
            }
        }

        push @objects, @data;
    }

    return @objects;
}

my %seen_deprecation;

use constant HARNESS_ACTIVE => not not $ENV{HARNESS_ACTIVE};

sub deprecate ($$) {
    if ( HARNESS_ACTIVE ) {
        my ( $version, $reason ) = @_;

        # parts stolen from Devel::Deprecate, but we're doing version based
        # deprecation, not date based deprecation

        require KiokuDB;

        if ( $KiokuDB::VERSION >= $version ) {
            my ( $package, $filename, $line ) = caller(1);
            my ( undef, undef, undef, $subroutine ) = caller(2);

            return if $seen_deprecation{"${filename}:$line"}++; # no need to warn more than once

            $subroutine ||= 'n/a';
            my $padding = ' ' x 18;
            $reason =~ s/\n/\n#$padding/g;

            Carp::cluck(<<"END");
# DEPRECATION WARNING
#
#     Package:     $package
#     File:        $filename
#     Line:        $line
#     Subroutine:  $subroutine
#
#     Reason:      $reason
END
        }
    }
}

__PACKAGE__

__END__

=pod

=head1 NAME

KiokuDB::Util - Utility functions for working with KiokuDB

=head1 VERSION

version 0.56

=head1 SYNOPSIS

    use KiokuDB::Util qw(set weak_set);

    my $set = set(@objects); # create a transient set

    my $weak = weak_set(@objects); # to avoid circular refs

=head1 DESCRIPTION

This module provides various helper functions for working with L<KiokuDB>.

=head1 EXPORTS

=over 4

=item dsn_to_backend $dsn, %args

Tries to parse C<$dsn>, load the backend and invoke C<new> on it.

Used by L<KiokuDB/connect> and the various command line interfaces.

=item set

=item weak_set

Instantiate a L<Set::Object> or L<Set::Object::Weak> from the arguments, and
then creates a L<KiokuDB::Set::Transient> with the result.

=item import_yaml $kiokudb, @files_or_dirs

Loads YAML files with L<MooseX::YAML> (if given a directory it will be searched
recursively for files with a C<.yml> extension are) into the specified KiokuDB
directory in a single transaction.

The YAML files can contain multiple documents, with each document treated as an
object. If the YAML file contains a single non blessed array or hash then that
structure will be dereferenced as part of the arguments to C<insert>.

Here is an example of an array of objects, and a custom tag alias to ease
authoring of the YAML file:

    %YAML 1.1
    %TAG ! !MyFoo::
    ---
    - !User
      id:        foo
      real_name: Foo Bar
      email:     foo@myfoo.com
      password:  '{cleartext}test123'

You can use a hash to specify custom IDs:

    %YAML 1.1
    ---
    the_id: !Some::Class
        attr: moose

=back

=head1 AUTHOR

Yuval Kogman <nothingmuch@woobling.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2013 by Yuval Kogman, Infinity Interactive.

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

=cut