view release on metacpan or  search on metacpan

lib/Dallycot/Context.pm  view on Meta::CPAN

package Dallycot::Context;
our $AUTHORITY = 'cpan:JSMITH';

# ABSTRACT: Execution context with value mappings and namespaces

use strict;
use warnings;

use utf8;
use Moose;

use namespace::autoclean;

use Array::Utils qw(unique array_minus);
use Scalar::Util qw(blessed);

use MooseX::Types::Moose qw/ArrayRef/;

use Carp qw(croak cluck);

use experimental qw(switch);

use Promises qw(deferred);

#
# Contexts form a chain from the kernel on down
# The context for a statement has no parent, but is copied from the kernel's
#   context. Changes made are copied back to the kernel context info.
# Closures need to copy all of the info into a new context that is marked as
#   a closure.

has namespaces => ( is => 'ro', isa => 'HashRef', default => sub { +{} }, lazy => 1 );

has environment => ( is => 'ro', isa => 'HashRef', default => sub { +{} }, lazy => 1 );

has namespace_search_path => ( is => 'ro', isa => 'ArrayRef', default => sub { [] }, lazy => 1 );

has parent => ( is => 'ro', isa => 'Dallycot::Context', predicate => 'has_parent' );

has is_closure => ( is => 'ro', isa => 'Bool', default => 0 );

sub add_namespace {
  my ( $self, $ns, $href ) = @_;

  if ( ( $self->is_closure || $self->has_parent )
    && defined( $self->namespaces->{$ns} ) )
  {
    croak "Namespaces may not be defined multiple times in a sub-context or closure";
  }
  $self->namespaces->{$ns} = $href;

  return;
}

sub get_namespace {
  my ( $self, $ns ) = @_;

  if ( exists( $self->namespaces->{$ns} ) ) {
    return $self->namespaces->{$ns};
  }
  elsif ( $self->has_parent ) {
    return $self->parent->get_namespace($ns);
  }
}

sub has_namespace {
  my ( $self, $prefix ) = @_;

  return exists( $self->namespaces->{$prefix} )
    || $self->has_parent && $self->parent->has_namespace($prefix);
}

sub add_assignment {
  my ( $self, $identifier, $expr ) = @_;

  if ( ( $self->is_closure || $self->has_parent ) ) {
    my $d = $self->environment->{$identifier};
    if ( $d && $d->is_resolved ) {
      croak "Identifiers may not be redefined in a sub-context or closure";
    }
  }
  if ( defined $expr ) {
    if ( $expr->can('resolve') ) {
      return $self->environment->{$identifier} = $expr;
    }
    else {
      my $d = deferred;
      $d->resolve($expr);
      return $self->environment->{$identifier} = $d;
    }
  }
  else {
    return $self->environment->{$identifier} = deferred;
  }
}