view release on metacpan or  search on metacpan

lib/Data/Downloader/Config.pm  view on Meta::CPAN

use YAML::XS qw/Dump Load LoadFile/;
use Scalar::Util qw/looks_like_number/;
use Data::Dumper;

use strict;
use warnings;

=head1 METHODS

=over

=item init

Inserts information about repository and feeds
using a config file.

Parameters :

 filename: the name of a config file
 yaml: yaml content of the file (can be sent instead of file)
 update_ok: allow updates, not just initialization

=cut

sub init {
    my $self = shift;
    my $args = validate(@_, { file => 0, filename => 0, yaml => 0, update_ok => 0 } );
    my $file = $args->{file} || $args->{filename};
    DEBUG "initializing database from ".($file ? "file $file" : "yaml");

    my @repositories = $args->{yaml} ? Load($args->{yaml}) : LoadFile($file);
    DEBUG "Configuration has ".@repositories." repository(ies)";
    for my $repository_spec (@repositories) {
        TRACE "repository : ".$repository_spec->{name};
        my $repository = Data::Downloader::Repository->new(name => $repository_spec->{name});
        if ($repository->load(speculative => 1)) {
            if ($args->{update_ok}) {
                _recursive_object_update($repository,$repository_spec);
            } else {
                LOGDIE "Existing repository ".$repository->name." found. ".
                     "To re-initialize, remove ".$repository->db->database.
                     ".  To update, set update_ok to be true.";
            }
        } else {
            # XXX not bulletproof -- the new one may refer to existing feeds, etc.
            INFO "creating new repository $repository_spec->{name}";
            $repository = Data::Downloader::Repository->new(%$repository_spec);
            $repository->save or LOGDIE "Error saving repository $repository_spec->{name}: ".$repository->error;
        }
    }

    Data::Downloader::MetadataPivot->rebuild_pivot_view;
}

=item update

Update the config

=cut

sub update {
    my $self = shift;
    my %args = @_;
    $args{update_ok} = 1;
    $self->init(%args);
}

sub _p { defined($_[0]) ? "[$_[0]]" : '[undef]' };

sub _are_same {
    my ($x,$y) = @_;
    return 0 if defined($x) && !defined($y);
    return 0 if !defined($x) && defined($y);
    return 1 if !defined($x) && !defined($y);
    # ok, both are defined
    if (looks_like_number($x) && looks_like_number($y)) {
        return ($x==$y);
    }
    return ($x eq $y);
}

our %classDone; # prevent loops for one-one relationships
our %allowConfig = map { ($_ => 1) } qw/repository
        disk feed feed_parameter metadata_source file_source linktree metadata_transformation/;

sub _recursive_object_update {
    my $object = shift;
    my $spec = shift;
    # $object should have already been loaded
    # Update all attributes which are not objects.
    # Then find child objects and recursively update existing ones.
    TRACE "examining table ".$object->meta->table.($object->can('id') ? $object->id : $object);
    # one base case
    if (!defined($spec)) {
        INFO "Deleting ".$object->meta->table." ".($object->can('id') ? $object->id : $object);
        $object->delete or LOGDIE "error during delete : ".$object->error;
        return;
    }
    # other base cases
    for my $column_name (keys %$spec) {
        TRACE "column $column_name";
        my ($column) = grep { $_->accessor_method_name eq $column_name } $object->meta->columns;
        next unless $column; # not a column, must be a relationship
        next if $column->is_primary_key_member;
        next if $column_name =~ /^(root|name|order_key)$/; # primary keys, don't allow changing
        die "'$column' not defined, name is '$column_name' " unless exists($spec->{$column_name});
        TRACE "comparing ".($object->meta->table).".$column : "._p($object->$column)." vs "._p($spec->{$column_name});
        next if _are_same($object->$column,$spec->{$column_name});
        INFO "Changing ".$object->meta->table." $column_name from "._p($object->$column)." to "._p($spec->{$column_name});
        $object->$column($spec->{$column});
        $object->save or LOGDIE "error saving changes to ".$object->meta->table." : ".$object->error;
    }
    # recursive case
    for my $relationship ($object->meta->relationships) {
        my $method_name = $relationship->method_name('get_set_on_save');
        next if $classDone{$relationship->class}++;
        next unless $allowConfig{$relationship->class->meta->table};
        next unless $relationship->type eq 'one to many' || $relationship->type eq 'one to one';
        my $sub_object_spec = $spec->{$method_name};
        $sub_object_spec = [ $sub_object_spec ] if $sub_object_spec && ref($sub_object_spec) ne 'ARRAY';
        for my $sub_object ($object->$method_name) {