view release on metacpan or  search on metacpan

lib/DBIO/Base.pm  view on Meta::CPAN

package DBIO::Base;
# ABSTRACT: Meta-infrastructure base for all DBIO internal classes

use strict;
use warnings;

use DBIO::Util;
use mro 'c3';

use DBIO::Optional::Dependencies;

use base qw/DBIO::Componentised Class::Accessor::Grouped/;
use Scalar::Util ();
use DBIO::Exception;

my $successfully_loaded_components;

sub get_component_class {
  my $class = $_[0]->get_inherited($_[1]);

  return $class if Scalar::Util::blessed($class);

  if (defined $class and ! $successfully_loaded_components->{$class} ) {
    $_[0]->ensure_class_loaded($class);

    no strict 'refs';
    $successfully_loaded_components->{$class}
      = ${"${class}::__LOADED__BY__DBIO__CAG__COMPONENT_CLASS__"}
        = do { \(my $anon = 'loaded') };
    Scalar::Util::weaken($successfully_loaded_components->{$class});
  }

  $class;
}

sub set_component_class {
  shift->set_inherited(@_);
}

__PACKAGE__->mk_group_accessors(inherited => '_skip_namespace_frames');
__PACKAGE__->_skip_namespace_frames('^DBIO|^SQL::Abstract|^Try::Tiny|^Class::Accessor::Grouped|^Context::Preserve');

sub mk_classdata {
  shift->mk_classaccessor(@_);
}

sub mk_classaccessor {
  my $self = shift;
  $self->mk_group_accessors('inherited', $_[0]);
  $self->set_inherited(@_) if @_ > 1;
}

sub component_base_class { 'DBIO' }

sub MODIFY_CODE_ATTRIBUTES {
  my ($class,$code,@attrs) = @_;
  $class->mk_classdata('__attr_cache' => {})
    unless $class->can('__attr_cache');
  $class->__attr_cache->{$code} = [@attrs];
  return ();
}

sub _attr_cache {
  my $self = shift;
  my $cache = $self->can('__attr_cache') ? $self->__attr_cache : {};

  return {
    %$cache,
    %{ $self->maybe::next::method || {} },
  };
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

DBIO::Base - Meta-infrastructure base for all DBIO internal classes

=head1 VERSION

version 0.900001

=head1 DESCRIPTION