view release on metacpan or  search on metacpan

inc/DBIx/Class/Schema.pm  view on Meta::CPAN

#line 1
package DBIx::Class::Schema;

use strict;
use warnings;

use DBIx::Class::Exception;
use Carp::Clan qw/^DBIx::Class/;
use Scalar::Util qw/weaken/;
use File::Spec;
use Sub::Name ();
use Module::Find();

use base qw/DBIx::Class/;

__PACKAGE__->mk_classdata('class_mappings' => {});
__PACKAGE__->mk_classdata('source_registrations' => {});
__PACKAGE__->mk_classdata('storage_type' => '::DBI');
__PACKAGE__->mk_classdata('storage');
__PACKAGE__->mk_classdata('exception_action');
__PACKAGE__->mk_classdata('stacktrace' => $ENV{DBIC_TRACE} || 0);
__PACKAGE__->mk_classdata('default_resultset_attributes' => {});

#line 148

# Pre-pends our classname to the given relative classname or
#   class namespace, unless there is a '+' prefix, which will
#   be stripped.
sub _expand_relative_name {
  my ($class, $name) = @_;
  return if !$name;
  $name = $class . '::' . $name if ! ($name =~ s/^\+//);
  return $name;
}

# Finds all modules in the supplied namespace, or if omitted in the
# namespace of $class. Untaints all findings as they can be assumed
# to be safe
sub _findallmod {
  my $proto = shift;
  my $ns = shift || ref $proto || $proto;

  my @mods = Module::Find::findallmod($ns);

  # try to untaint module names. mods where this fails
  # are left alone so we don't have to change the old behavior
  no locale; # localized \w doesn't untaint expression
  return map { $_ =~ m/^( (?:\w+::)* \w+ )$/x ? $1 : $_ } @mods;
}

# returns a hash of $shortname => $fullname for every package
# found in the given namespaces ($shortname is with the $fullname's
# namespace stripped off)
sub _map_namespaces {
  my ($class, @namespaces) = @_;

  my @results_hash;
  foreach my $namespace (@namespaces) {
    push(
      @results_hash,
      map { (substr($_, length "${namespace}::"), $_) }
      $class->_findallmod($namespace)
    );
  }

  @results_hash;
}

# returns the result_source_instance for the passed class/object,

inc/DBIx/Class/Schema.pm  view on Meta::CPAN

}

#line 1185

sub dclone {
  my ($self, $obj) = @_;
  local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
  return Storable::dclone($obj);
}

#line 1197

sub schema_version {
  my ($self) = @_;
  my $class = ref($self)||$self;

  # does -not- use $schema->VERSION
  # since that varies in results depending on if version.pm is installed, and if
  # so the perl or XS versions. If you want this to change, bug the version.pm
  # author to make vpp and vxs behave the same.

  my $version;
  {
    no strict 'refs';
    $version = ${"${class}::VERSION"};
  }
  return $version;
}


#line 1236

sub register_class {
  my ($self, $moniker, $to_register) = @_;
  $self->register_source($moniker => $to_register->result_source_instance);
}

#line 1256

sub register_source {
  my $self = shift;

  $self->_register_source(@_);
}

#line 1275

sub register_extra_source {
  my $self = shift;

  $self->_register_source(@_, { extra => 1 });
}

sub _register_source {
  my ($self, $moniker, $source, $params) = @_;

  my $orig_source = $source;

  $source = $source->new({ %$source, source_name => $moniker });
  $source->schema($self);
  weaken($source->{schema}) if ref($self);

  my $rs_class = $source->result_class;

  my %reg = %{$self->source_registrations};
  $reg{$moniker} = $source;
  $self->source_registrations(\%reg);

  return if ($params->{extra});
  return unless defined($rs_class) && $rs_class->can('result_source_instance');

  my %map = %{$self->class_mappings};
  if (
    exists $map{$rs_class}
      and
    $map{$rs_class} ne $moniker
      and
    $rs_class->result_source_instance ne $orig_source
  ) {
    carp "$rs_class already has a source, use register_extra_source for additional sources";
  }
  $map{$rs_class} = $moniker;
  $self->class_mappings(\%map);
}

sub _unregister_source {
    my ($self, $moniker) = @_;
    my %reg = %{$self->source_registrations}; 

    my $source = delete $reg{$moniker};
    $self->source_registrations(\%reg);
    if ($source->result_class) {
        my %map = %{$self->class_mappings};
        delete $map{$source->result_class};
        $self->class_mappings(\%map);
    }
}


#line 1361

{
  my $warn;

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

    carp "compose_connection deprecated as of 0.08000"
      unless ($INC{"DBIx/Class/CDBICompat.pm"} || $warn++);

    my $base = 'DBIx::Class::ResultSetProxy';
    eval "require ${base};";
    $self->throw_exception
      ("No arguments to load_classes and couldn't load ${base} ($@)")
        if $@;

    if ($self eq $target) {
      # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
      foreach my $moniker ($self->sources) {
        my $source = $self->source($moniker);
        my $class = $source->result_class;