File Coverage

blib/lib/Data/Context/Instance.pm

Criterion	Covered	Total	%
statement	93	98	94.9
branch	24	32	75.0
condition	16	27	59.2
subroutine	22	22	100.0
pod	4	4	100.0
total	159	183	86.8

package Data::Context::Instance;

# Created on: 2012-04-09 05:58:42
# Create by:  Ivan Wills
# $Id$
# $Revision$, $HeadURL$, $Date$
# $Revision$, $Source$, $Date$

use Moose;
use namespace::autoclean;
use warnings;
use version;
use Carp;
use Scalar::Util;
use List::Util;
use List::MoreUtils qw/pairwise/;
use Data::Dumper qw/Dumper/;
use English qw/ -no_match_vars /;
use Hash::Merge;
use Clone qw/clone/;
use Data::Context::Util qw/lol_path lol_iterate do_require/;
use Class::Inspector;
use Moose::Util::TypeConstraints qw/duck_type/;

our $VERSION = version->new('0.1.8');

has path => (
    is       => 'rw',
    isa      => 'Str',
    required => 1,
);
has loader => (
    is       => 'rw',
    isa      => 'Data::Context::Loader',
    required => 1,
);
has dc => (
    is       => 'rw',
    isa      => 'Data::Context',
    required => 1,
    weak_ref => 1,
);
has raw => (
    is  => 'rw',
    isa => 'Any',
);
has actions => (
    is      => 'rw',
    isa     => 'HashRef[HashRef]',
    default => sub {{}},
);
has merger => (
    is      => 'rw',
    isa     => duck_type( [qw/merge/] ),
    builder => '_merger',
    handles => [qw/merge/],
);

sub init {
    my ($self) = @_;

    return $self if !$self->changed;

    my $raw = $self->loader->load();

    # merge in any inherited data
    if ( $raw->{PARENT} ) {
        $self->raw({});
        my $parent = $self->dc->get_instance( $raw->{PARENT} )->init;
        $raw = $self->merge( $raw, $parent->raw );
    }

    # save complete raw data
    $self->raw($raw);

    # get data actions
    my $count = 0;
    lol_iterate( $raw, sub { $self->process_data(\$count, @_) } );

    return $self;
}

sub changed {
    my ($self) = @_;

    # considered changed if not data has been read
    return 1 if !$self->raw;

    # considered changed if this file has changed
    return 1 if $self->loader->changed;

    if ( $self->raw->{PARENT} ) {
        my $parent = $self->dc->get_instance( $self->raw->{PARENT} );

        # considered changed if the parent instance has changed
        return $parent->changed;
    }

    # when all else fails the data is considered unchanged
    return 0;
}

sub get_data {
    my ( $self, $vars ) = @_;
    $self->init;

    my $data = clone $self->raw;
    my @events;

    # process the data in order
    for my $path ( _sort_optional( $self->actions ) ) {
        my ($value, $replacer) = lol_path( $data, $path );
        my $module = $self->actions->{$path}{module};
        my $method = $self->actions->{$path}{method};
        my $new = $module->$method( $value, $vars, $path, $self );

        if ( blessed($new) && $new->isa('AnyEvent::CondVar') ) {
            push @events, [ $replacer, $new ];
        }
        else {
            $replacer->($new);
        }
    }

    for my $event ( @events ) {
        $event->[0]->($event->[1]->recv);
    }

    return $data;
}

sub process_data {
    my ( $self, $count, $data, $path ) = @_;

    if ( !ref $data ) {
        if ( defined $data && $data =~ /^\# (.*) \#$/xms ) {
            my $data_path = $1;
            do_require( $self->dc->action_class );
            $self->actions->{$path} = {
                module => $self->dc->action_class,
                method => 'expand_vars',
                found  => $$count++,
                path   => $data_path,
            };
        }
    }
    elsif ( ref $data eq 'HASH' && ( $data->{MODULE} || $data->{METHOD} ) ) {
        $self->actions->{$path} = {
            module => $data->{MODULE} || $self->dc->action_class,
            method => $data->{METHOD} || $self->dc->action_method,
            order  => $data->{ORDER},
            found  => $$count++,
        };
        do_require( $self->actions->{$path}{module} );
    }

    return;
}

sub _sort_optional {
    my ($hash) = @_;

    my @sorted = sort {
        return $hash->{$a}->{found} <=> $hash->{$b}->{found} if ! defined $hash->{$a}->{order} && ! defined $hash->{$b}->{order};
        return $hash->{$b}->{order} >= 0 ? 1 : -1            if !defined $hash->{$a}->{order};
        return $hash->{$a}->{order} >= 0 ? -1 : 1            if !defined $hash->{$b}->{order};
        return -1                                            if $hash->{$a}->{order} >= 0 && $hash->{$b}->{order} < 0;
        return  1                                            if $hash->{$a}->{order} < 0 && $hash->{$b}->{order} >= 0;
        return $hash->{$a}->{order} <=> $hash->{$b}->{order};
    } keys %$hash;

    return @sorted;
}

sub _merger {
    return Hash::Merge->new('LEFT_PRECEDENT');
}

__PACKAGE__->meta->make_immutable;

1;

__END__

=head1 NAME

Data::Context::Instance - The in memory instance of a data context config file

=head1 VERSION

This documentation refers to Data::Context::Instance version 0.1.8.

=head1 SYNOPSIS

   use Data::Context::Instance;

   # create a new object
   my $dci = Data::Context::Instance->new(
        path => 'dir/file',
        file => Path::Class::file('path/to/dir/file.dc.js'),
        type => 'js',
        dc   => $dc,
   );

   # Initialise the object (done by get normally)
   $dci->init;

   # get the data (with the context of $vars)
   my $data = $dci->get_data($vars);

=head1 DESCRIPTION

=head1 SUBROUTINES/METHODS

=head2 C<init()>

Initialises the instance ie it reads the config file and merges in the parent if found

=head2 C<changed ()>

Returns true if any of the files that go into this instance have changed (or
if they haven't yet been processed) and returns false if this instance is still
valid.

=head2 C<get_data ( $vars )>

Returns the data from the config file processed with the context of $vars

=head2 C<process_data( $count, $data, $path )>

This does the magic of processing the data, and in the future handling of the
data event loop.

=head1 DIAGNOSTICS

=head1 CONFIGURATION AND ENVIRONMENT

=head1 DEPENDENCIES

=head1 INCOMPATIBILITIES

=head1 BUGS AND LIMITATIONS

There are no known bugs in this module.

Please report problems to Ivan Wills ([e-mail]).

Patches are welcome.

=head1 AUTHOR

Ivan Wills - ([e-mail])

=head1 LICENSE AND COPYRIGHT

Copyright (c) 2012 Ivan Wills (14 Mullion Close, Hornsby Heights, NSW Australia 2077).
All rights reserved.

This module is free software; you can redistribute it and/or modify it under
the same terms as Perl itself. See L<perlartistic>.  This program is
distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.

=cut