File Coverage

blib/lib/CHI/Cascade.pm

Criterion	Covered	Total	%
statement	181	224	80.8
branch	74	124	59.6
condition	34	80	42.5
subroutine	26	31	83.8
pod	6	19	31.5
total	321	478	67.1

package CHI::Cascade;

use strict;
use warnings;

our $VERSION = 0.300_003;

use Carp;

use CHI::Cascade::Value ':state';
use CHI::Cascade::Rule;
use CHI::Cascade::Target;
use Time::HiRes ();
use POSIX ();

sub min ($$) { $_[0] < $_[1] ? $_[0] : $_[1] }

sub new {
    my ($class, %opts) = @_;

    my $self = bless {
            %opts,
            plain_targets       => {},
            qr_targets          => [],
            stats               => { recompute => 0, run => 0, dependencies_lookup => 0 }

        }, ref($class) || $class;

    $self->{target_chi} ||= $self->{chi};

    $self;
}

sub rule {
    my ($self, %opts) = @_;

    my $rule = CHI::Cascade::Rule->new( cascade => $self, %opts );

    if (ref($rule->{target}) eq 'Regexp') {
        push @{ $self->{qr_targets} }, $rule;
    }
    elsif (! ref($rule->{target})) {
        $self->{plain_targets}{$rule->{target}} = $rule;
    }
    else {
        croak qq{The rule's target "$rule->{target}" is unknown type};
    }
}

sub target_computing {
    my $trg_obj;

    ( $trg_obj = $_[0]->{target_chi}->get("t:$_[1]") )
      ? ( ( ${ $_[2] } = $trg_obj->ttl ), $trg_obj->locked ? 1 : 0 )
      : 0;
}

sub target_is_actual {
    my ( $self, $target, $actual_term ) = @_;

    my $trg_obj;

    ( $trg_obj = $self->{target_chi}->get("t:$target") )
      ? $trg_obj->is_actual( $actual_term )
      : 0;
}

sub target_time {
    my ($self, $target) = @_;

    my $trg_obj;

    return ( ( $trg_obj = $self->{target_chi}->get("t:$target") )
      ? $trg_obj->time
      : 0
    );
}

sub get_value {
    my ($self, $target) = @_;

    my $value = $self->{chi}->get("v:$target");

    return $value->state( CASCADE_FROM_CACHE )
      if ($value);

    CHI::Cascade::Value->new( state => CASCADE_NO_CACHE );
}

sub target_lock {
    my ( $self, $rule ) = @_;

    my $target = $rule->target;

    # If target is already locked - a return
    return
      if ( $self->target_locked( $rule ) );

    my $trg_obj;
    $trg_obj = CHI::Cascade::Target->new
      unless ( ( $trg_obj = $self->{target_chi}->get("t:$target") ) );

    $trg_obj->lock;
    $self->{target_chi}->set( "t:$target", $trg_obj, $rule->target_expires( $trg_obj ) );

    $rule->{run_instance}{target_locks}{$target} = 1;
}

sub target_unlock {
    my ( $self, $rule, $value ) = @_;

    my $target = $rule->target;

    if ( my $trg_obj = $self->{target_chi}->get( "t:$target" ) ) {
        $trg_obj->unlock;

        if ( $value && $value->state & CASCADE_RECOMPUTED ) {
            $trg_obj->touch;
            $trg_obj->actual_stamp
              if $rule->{run_instance}{run_opts}{actual_term} && $rule->{run_instance}{orig_target} eq $target;
        }

        $self->{target_chi}->set( "t:$target", $trg_obj, $rule->target_expires( $trg_obj ) );
    }

    delete $rule->{run_instance}{target_locks}{$target};
}

sub target_actual_stamp {
    my ( $self, $rule, $value ) = @_;

    my $target = $rule->target;

    if ( $value && $value->state & CASCADE_ACTUAL_VALUE && ( my $trg_obj = $self->{target_chi}->get( "t:$target" ) ) ) {
        $trg_obj->actual_stamp;
        $self->{target_chi}->set( "t:$target", $trg_obj, $rule->target_expires( $trg_obj ) );
    }
}

sub target_start_ttl {
    my ( $self, $rule, $start_time ) = @_;

    my $target = $rule->target;

    if ( my $trg_obj = $self->{target_chi}->get( "t:$target" ) ) {
        $trg_obj->ttl( $rule->ttl, $start_time );
        $self->{target_chi}->set( "t:$target", $trg_obj, $rule->target_expires( $trg_obj ) );
    }
}

sub target_remove {
    my ($self, $target) = @_;

    $self->{target_chi}->remove("t:$target");
}

sub touch {
    my ( $self, $target ) = @_;

    if ( my $trg_obj = $self->{target_chi}->get("t:$target") ) {
        $trg_obj->touch;
        $self->{target_chi}->set( "t:$target", $trg_obj, $self->find( $target )->target_expires( $trg_obj ) );
    }
}

sub target_locked {
    my ( $self, $rule ) = @_;

    exists $rule->{run_instance}{target_locks}{ $rule->target };
}

sub recompute {
    my ( $self, $rule, $target, $dep_values) = @_;

    die CHI::Cascade::Value->new( state => CASCADE_DEFERRED )
      if $rule->{run_instance}{run_opts}{defer};

    my $ret = eval { $rule->{code}->( $rule, $target, $rule->{dep_values} = $dep_values ) };

    $self->{stats}{recompute}++;

    if ($@) {
        my $error = $@;
        die( ( eval { $error->isa('CHI::Cascade::Value') } ) ? $error->thrown_from_code(1) : "CHI::Cascade: the target $target - error in the code: $error" );
    }

    my $value;

    # For performance a value should not expire in anyway (only target marker if need)
    $self->{chi}->set( "v:$target", $value = CHI::Cascade::Value->new->value($ret), 'never' );

    $value->state( CASCADE_ACTUAL_VALUE | CASCADE_RECOMPUTED );

    $rule->{recomputed}->( $rule, $target, $value )
      if ( ref $rule->{recomputed} eq 'CODE' );

    return $value;
}

sub value_ref_if_recomputed {
    my ( $self, $rule, $target, $only_from_cache ) = @_;

    return undef
      unless defined $rule;

    my $run_instance = $rule->{run_instance};

    my @qr_params = $rule->qr_params;

    my ( $ret_state, $ttl, $should_be_recomputed ) = ( CASCADE_ACTUAL_VALUE );

    if ( $self->target_computing( $target, \$ttl ) ) {
        # If we have any target as a being computed (dependencie/original)
        # there is no need to compute anything - trying to return original target value
        die CHI::Cascade::Value->new->state( CASCADE_COMPUTING );
    }

    my ( %dep_values, $dep_name );

    if ( $only_from_cache ) {

        # Trying to get value from cache
        my $value = $self->get_value($target);

        return $value
          if $value->is_value;

        # If no in cache - we should recompute it again
        $self->target_lock($rule);
    }

    push @{ $run_instance->{target_stack} }, $target;

    my $ret = eval {
        my $dep_target;

        my $catcher =  sub {
            my $sub = shift;

            my $ret = eval { $sub->() };

            if ($@) {
                my $exception = $@;

                $rule->{depends_catch}->( $rule, $exception, $dep_values{$dep_target}->[0], $dep_target )
                  if (   exists $rule->{depends_catch}
                      && ref $rule->{depends_catch} eq 'CODE'
                      && eval { $exception->isa('CHI::Cascade::Value') }
                      && $exception->thrown_from_code );

                die $exception;
            }

            return $ret;
        };

        $self->target_lock($rule)
          if ! $self->target_time($target);

        $should_be_recomputed = $self->target_locked($rule);

        if ( defined $ttl && $ttl > 0 && ! $should_be_recomputed ) {
            $ret_state = CASCADE_TTL_INVOLVED;
            $run_instance->{ttl} = $ttl;
        }
        else {
            my (
                $rule_ttl,
                $circle_hash,
                $start_time,
                $min_start_time
            ) = (
                $rule->ttl,
                $only_from_cache ? 'only_cache_chain' : 'chain'
            );

            foreach my $depend (@{ $rule->depends }) {
                $dep_target = ref($depend) eq 'CODE' ? $depend->( $rule, @qr_params ) : $depend;

                $dep_values{$dep_target}->[0] = $self->find( $dep_target, $rule->{run_instance} );

                die "Found circle dependencies (trace: " . join( '->', @{ $run_instance->{target_stack} }, $dep_target ) . ") - aborted!"
                  if ( exists $run_instance->{ $circle_hash }{$target}{$dep_target} );

                $run_instance->{ $circle_hash }{$target}{$dep_target} = 1;

                $catcher->( sub {
                    if (   ! $only_from_cache
                        && ( $start_time = ( $self->{stats}{dependencies_lookup}++,
                             ( $dep_values{$dep_target}->[1] = $self->value_ref_if_recomputed( $dep_values{$dep_target}->[0], $dep_target ) )->state & CASCADE_RECOMPUTED && Time::HiRes::time
                        || ( $start_time = $self->target_time($dep_target) ) > $self->target_time($target) && $start_time ) ) )
                    {
                        if (    ! $should_be_recomputed
                             && ! defined $ttl
                             && defined $rule_ttl
                             && $rule_ttl > 0
                             && ( $start_time + $rule_ttl ) > Time::HiRes::time )
                        {
                            $min_start_time = defined $min_start_time ? min( $start_time, $min_start_time ) : $start_time;
                        }
                        else {
                            $self->target_lock($rule);
                        }
                    }
                } );

                delete $run_instance->{ $circle_hash }{$target}{$dep_target};
            }

            if ( defined $min_start_time ) {
                $ret_state = CASCADE_TTL_INVOLVED;
                $self->target_start_ttl( $rule, $min_start_time );
                $run_instance->{ttl} = $min_start_time + $rule_ttl - Time::HiRes::time;
            }
        }

        if ( $self->target_locked($rule) ) {
            # We should recompute this target
            # So we should recompute values for other dependencies
            foreach $dep_target (keys %dep_values) {
                if (   ! defined $dep_values{$dep_target}->[1]
                    || ! $dep_values{$dep_target}->[1]->is_value )
                {
                    $self->{stats}{dependencies_lookup}++;
                    $catcher->( sub {
                        if ( ! ( $dep_values{$dep_target}->[1] = $self->value_ref_if_recomputed( $dep_values{$dep_target}->[0], $dep_target, 1 ) )->is_value ) {
                            $self->target_remove($dep_target);
                            return 1;
                        }
                        return 0;
                    } ) == 1 && return undef;
                }
            }
        }

        return $self->recompute( $rule, $target, { map { $_ => $dep_values{$_}->[1]->value } keys %dep_values } )
          if $self->target_locked($rule);

        return CHI::Cascade::Value->new( state => $ret_state );
    };

    pop @{ $run_instance->{target_stack} };

    my $e = $@;

    if ( $self->target_locked($rule) ) {
        $self->target_unlock( $rule, $ret );
    }
    elsif ( $run_instance->{run_opts}{actual_term} && ! $only_from_cache && $run_instance->{orig_target} eq $target ) {
        $self->target_actual_stamp( $rule, $ret );
    }

    die $e if $e;

    return $ret || CHI::Cascade::Value->new;
}

sub stash { exists $_[0]->{stash} && $_[0]->{stash} || die "The stash method from outside run method!" }

sub run {
    my ( $self, $target, %opts ) = @_;

    my $view_dependencies = 1;

    # The run's instance parameters. This instance to be needed to give ability to run the run method from deep inside run calls.
    # It's for internal using.
    my $run_instance = {};

    $run_instance->{stash} = $opts{stash} && ref $opts{stash} eq 'HASH' && $opts{stash} || {};

    $run_instance->{run_opts}     = \%opts;
    $run_instance->{ttl}          = undef;
    $run_instance->{target_locks} = {};

    $opts{actual_term} ||= $self->find($target)->{actual_term};
    $self->{stats}{run}++;


    # FIXME to delete in future. Now it's depricated
    $self->{stash} = $run_instance->{stash};

    $view_dependencies = ! $self->target_is_actual( $target, $opts{actual_term} )
      if ( $opts{actual_term} );

    my $res = $self->_run( ! $view_dependencies, $target, $run_instance );

    $res->state( CASCADE_ACTUAL_TERM )
      if ( $opts{actual_term} && ! $view_dependencies );

    if ( defined $run_instance->{ttl} && $run_instance->{ttl} > 0 ) {
        $res->state( CASCADE_TTL_INVOLVED );
    }

    ${ $opts{ttl} } = $run_instance->{ttl}
      if ( $opts{ttl} );

    ${ $opts{state} } = $res->state
      if ( $opts{state} );

    $res->value;
}

sub _run {
    my ( $self, $only_from_cache, $target, $run_instance ) = @_;

    croak qq{The target ($target) for run should be string} if ref($target);
    croak qq{The target for run is empty} if $target eq '';

    $run_instance->{chain}            = {};
    $run_instance->{only_cache_chain} = {};
    $run_instance->{target_stack}     = [];

    my $ret = eval {
        $run_instance->{orig_target} = $target;

        return $self->value_ref_if_recomputed( $run_instance->{orig_rule} = $self->find( $target, $run_instance ), $target, $only_from_cache );
    };

    my $terminated;

    if ( $terminated = $@ ) {
        $ret = $@;

        die $ret
          unless eval { $ret->isa('CHI::Cascade::Value') };

        $ret->state( CASCADE_CODE_EXCEPTION )
          unless $ret->state;
    }

    if ( ! $ret->is_value ) {
        my $from_cache = $self->get_value( $target );

        return $from_cache->state( $ret->state )
          if ( $terminated || $from_cache->is_value );

        return $self->_run( 1, $target )
          if ! $only_from_cache;
    }

    return $ret;
}

sub find {
    my ($self, $plain_target, $run_instance) = @_;

    die "CHI::Cascade::find : got empty target\n" if $plain_target eq '';

    my $new_rule;

    # If target is flat text
    if (exists $self->{plain_targets}{$plain_target}) {
        return $self->{plain_targets}{$plain_target}
          unless $run_instance;
        ( $new_rule = $self->{plain_targets}{$plain_target}->new( run_instance => $run_instance ) )->{matched_target} = $plain_target;
        return $new_rule;
    }

    # If rule's target is Regexp type
    foreach my $rule (@{$self->{qr_targets}}) {
        my @qr_params;

        if (@qr_params = $plain_target =~ $rule->{target}) {
            return $rule
              unless $run_instance;
            ( $new_rule = $rule->new( run_instance => $run_instance ) )->qr_params(@qr_params);
            $new_rule->{matched_target} = $plain_target;
            return $new_rule;
        }
    }

    die "CHI::Cascade::find : cannot find the target $plain_target\n";
}


1;
__END__