File Coverage

blib/lib/Class/Scaffold/Environment.pm

Criterion	Covered	Total	%
statement	87	131	66.4
branch	14	44	31.8
condition	8	36	22.2
subroutine	23	35	65.7
pod	19	19	100.0
total	151	265	56.9

use 5.008;
use warnings;
use strict;

package Class::Scaffold::Environment;
BEGIN {
  $Class::Scaffold::Environment::VERSION = '1.102280';
}

# ABSTRACT: Base class for framework environment classes
use Error::Hierarchy::Util 'load_class';
use Class::Scaffold::Factory::Type;
use Property::Lookup;
use Data::Storage;    # for AutoPrereq
use parent 'Class::Scaffold::Base';
Class::Scaffold::Base->add_autoloaded_package('Class::Scaffold::');

# ptags: /(\bconst\b[ \t]+(\w+))/
__PACKAGE__->mk_scalar_accessors(qw(test_mode context))
  ->mk_boolean_accessors(qw(rollback_mode))
  ->mk_class_hash_accessors(qw(storage_cache multiplex_transaction_omit))
  ->mk_object_accessors(
    'Property::Lookup' => {
        slot       => 'configurator',
        comp_mthds => [
            qw(
              get_config
              core_storage_name
              core_storage_args
              memory_storage_name
              )
        ]
    },
  );
use constant DEFAULTS =>
  (test_mode => (defined $ENV{TEST_MODE} && $ENV{TEST_MODE} == 1),);
Class::Scaffold::Factory::Type->register_factory_type(
    exception_container => 'Class::Scaffold::Exception::Container',
    result              => 'Data::Storage::DBI::Result',
    storage_statement   => 'Data::Storage::Statement',
    test_util_loader    => 'Class::Scaffold::Test::UtilLoader',
);
{    # closure over $env so that it really is private
    my $env;
    sub getenv { $env }

    sub setenv {
        my ($self, $newenv, @args) = @_;
        return $env = $newenv
          if ref $newenv
              && UNIVERSAL::isa($newenv, 'Class::Scaffold::Environment');
        unless (ref $newenv) {

            # it's a string containing the class name
            load_class $newenv, 1;
            return $env = $newenv->new(@args);
        }
        throw Error::Hierarchy::Internal::CustomMessage(
            custom_message => "Invalid environment specification [$newenv]",);
    }
}    # end of closure

sub setup {
    my $self = shift;
    $self->configurator->default_layer->hash(
        $self->every_hash('CONFIGURATOR_DEFAULTS'));
}

# ----------------------------------------------------------------------
# class name-related code
use constant STORAGE_CLASS_NAME_HASH => (

    # storage names
    STG_NULL     => 'Data::Storage::Null',
    STG_NULL_DBI => 'Data::Storage::DBI',    # for testing
);

sub make_obj {
    my $self = shift;
    Class::Scaffold::Factory::Type->make_object_for_type(@_);
}

sub get_class_name_for {
    my ($self, $object_type) = @_;
    Class::Scaffold::Factory::Type->get_factory_class($object_type);
}

sub isa_type {
    my ($self, $object, $object_type) = @_;
    return unless UNIVERSAL::can($object, 'get_my_factory_type');
    my $factory_type = $object->get_my_factory_type;
    defined $factory_type ? $factory_type eq $object_type : 0;
}

sub gen_class_hash_accessor (@) {
    for my $prefix (@_) {
        my $method = sprintf 'get_%s_class_name_for' => lc $prefix;
        my $every_hash_name = sprintf '%s_CLASS_NAME_HASH', $prefix;
        my $hash;    # will be cached here
        no strict 'refs';
        $::PTAGS && $::PTAGS->add_tag($method, __FILE__, __LINE__ + 1);
        *$method = sub {
            local $DB::sub = local *__ANON__ = sprintf "%s::%s", __PACKAGE__,
              $method
              if defined &DB::DB && !$Devel::DProf::VERSION;
            my ($self, $key) = @_;
            $hash ||= $self->every_hash($every_hash_name);
            $hash->{$key} || $hash->{_AUTO};
        };

        # so FOO_CLASS_NAME() will return the whole every_hash
        $method = sprintf '%s_CLASS_NAME' => lc $prefix;
        $::PTAGS && $::PTAGS->add_tag($method, __FILE__, __LINE__ + 1);
        *$method = sub {
            local $DB::sub = local *__ANON__ = sprintf "%s::%s", __PACKAGE__,
              $method
              if defined &DB::DB && !$Devel::DProf::VERSION;
            my $self = shift;
            $hash ||= $self->every_hash($every_hash_name);
            wantarray ? %$hash : $hash;
        };
        $method = sprintf 'release_%s_class_name_hash' => lc $prefix;
        $::PTAGS && $::PTAGS->add_tag($method, __FILE__, __LINE__ + 1);
        *$method = sub {
            local $DB::sub = local *__ANON__ = sprintf "%s::%s", __PACKAGE__,
              $method
              if defined &DB::DB && !$Devel::DProf::VERSION;
            undef $hash;
        };
    }
}
gen_class_hash_accessor('STORAGE');

sub load_cached_class_for_type {
    my ($self, $object_type_const) = @_;

    # Cache for efficiency reasons; the environment is the core of the whole
    # framework.
    our %cache;
    my $class = $self->get_class_name_for($object_type_const);
    unless (defined($class) && length($class)) {
        throw Error::Hierarchy::Internal::CustomMessage(custom_message =>
              "Can't find class for object type [$object_type_const]",);
    }
    load_class $class, $self->test_mode;
    $class;
}

sub storage_for_type {
    my ($self, $object_type) = @_;
    my $storage_type = $self->get_storage_type_for($object_type);
    $self->$storage_type;
}

# When running class tests in non-final distributions, which storage should we
# use? Ideally, every distribution (but especially the non-final ones like
# Registry-Core and Registry-Enum) should have a mock storage against which to
# test. Until then, the following mechanism can be used:
#
# Every storage notes whether it is abstract or an implementation. Class tests
# that need a storage will skip() the tests if the storage is abstract.
# Problem: we need to ask all the object types' storages used in a test code
# block, as different objects types could use different storages. For example:
#    skip(...) unless
#        $self->delegate->all_storages_are_implemented(qw/person command .../);
sub all_storages_are_implemented {
    my ($self, @object_types) = @_;
    for my $object_type (@object_types) {
        return 0 if $self->storage_for_type($object_type)->is_abstract;
    }
    1;
}

# Have a special method for making delegate objects, because delegates will be
# cached (i.e., pseudo-singletons) and don't need storages and extra args and
# such.
sub make_delegate {
    my ($self, $object_type_const, @args) = @_;
    our %cache;
    $cache{delegate}{$object_type_const} ||=
      $self->make_obj($object_type_const, @args);
}

# ----------------------------------------------------------------------
# storage-related code
use constant STORAGE_TYPE_HASH => (_AUTO => 'core_storage',);

sub get_storage_type_for {
    my ($self, $key) = @_;
    our %cache;
    return $cache{get_storage_type_for}{$key}
      if exists $cache{get_storage_type_for}{$key};
    my $storage_type_for = $self->every_hash('STORAGE_TYPE_HASH');
    $cache{get_storage_type_for}{$key} = $storage_type_for->{$key}
      || $storage_type_for->{_AUTO};
}

sub make_storage_object {
    my $self         = shift;
    my $storage_name = shift;
    my %args =
        @_ == 1
      ? defined $_[0]
          ? ref $_[0] eq 'HASH'
              ? %{ $_[0] }
              : @_
          : ()
      : @_;
    if (my $class = $self->get_storage_class_name_for($storage_name)) {
        load_class $class, $self->test_mode;
        return $class->new(%args);
    }
    throw Error::Hierarchy::Internal::CustomMessage(
        custom_message => "Invalid storage name [$storage_name]",);
}

sub core_storage {
    my $self = shift;
    $self->storage_cache->{core_storage} ||=
      $self->make_storage_object($self->core_storage_name,
        $self->core_storage_args);
}

sub memory_storage {
    my $self = shift;
    $self->storage_cache->{memory_storage} ||=
      $self->make_storage_object($self->memory_storage_name);
}

# Forward some special methods onto all cached storages. Some storages could
# be a bit special - we don't want to rollback or disconnect from them when
# calling the multiplexing rollback() and disconnect() methods below, so we
# ignore them when multiplexing. For example, mutex storages (see
# Data-Conveyor for the concept).
sub rollback {
    my $self = shift;
    while (my ($storage_type, $storage) = each %{ $self->storage_cache }) {
        next if $self->multiplex_transaction_omit($storage_type);
        $storage->rollback;
    }
}

sub commit {
    my $self = shift;
    while (my ($storage_type, $storage) = each %{ $self->storage_cache }) {
        next if $self->multiplex_transaction_omit($storage_type);
        $storage->commit;
    }
}

sub disconnect {
    my $self = shift;
    while (my ($storage_type, $storage) = each %{ $self->storage_cache }) {
        next if $self->multiplex_transaction_omit($storage_type);
        $storage->disconnect;

        # remove it from the cache so we'll reconnect next time
        $self->storage_cache_delete($storage_type);
        require Class::Scaffold::Storable;
        %Class::Scaffold::Storable::cache = ();
    }
    our %cache;
    $cache{get_storage_type_for} = {};
}

# Check configuration values for consistency. Empty, but it exists so
# subclasses can call SUPER::check()
sub check { }
1;


__END__