view release on metacpan or  search on metacpan

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

package DBIO::Schema;
# ABSTRACT: Schema class and connection container for DBIO applications

use strict;
use warnings;

use base 'DBIO::Base';

use DBIO::Carp;
use Try::Tiny;
use Scalar::Util qw/weaken blessed/;
use DBIO::Util qw(refcount quote_sub is_exception scope_guard old_mro file_path);
use DBIO::Skills;
use DBIO::Storage::Composed;
use Devel::GlobalDestruction;
use namespace::clean;

__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{DBIO_TRACE} || 0));
__PACKAGE__->mk_classdata('default_resultset_attributes' => {});
# Optional per-schema overrides for DBIO::Skills. Keys are skill names (the
# leading dbio- is optional), values are markdown strings.
__PACKAGE__->mk_classdata('skills');
# Ordered list of storage extension layer packages registered for this schema
# (see L</register_storage_layer>). Defaults to an empty arrayref shared across
# subclasses via inherited class data, so register_storage_layer must copy
# before appending -- never mutate the arrayref in place.
__PACKAGE__->mk_classdata('storage_layers' => []);


# 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) = @_;
  $name =~ s/^\+// or $name = "${class}::${name}";
  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 {
  require Module::Find;
  return map
    { $_ =~ /(.+)/ }   # untaint result
    Module::Find::findallmod( $_[1] || ref $_[0] || $_[0] )
  ;
}

# 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 ($me, $namespaces) = @_;

  my %res;
  for my $ns (@$namespaces) {
    $res{ substr($_, length "${ns}::") } = $_
      for $me->_findallmod($ns);
  }

  \%res;
}

# returns the result_source_instance for the passed class/object,
# or dies with an informative message (used by load_namespaces)

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

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


sub freeze {
  return Storable::nfreeze($_[1]);
}


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


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;
}



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


sub register_source { shift->_register_source(@_) }


sub unregister_source { shift->_unregister_source(@_) }


sub register_extra_source { shift->_register_source(@_, { extra => 1 }) }

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

  $source = $source->new({ %$source, source_name => $source_name });

  $source->schema($self);
  weaken $source->{schema} if ref($self);

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

  return $source if $params->{extra};

  my $rs_class = $source->result_class;
  if ($rs_class and my $rsrc = try { $rs_class->result_source_instance } ) {
    my %map = %{$self->class_mappings};
    if (
      exists $map{$rs_class}
        and
      $map{$rs_class} ne $source_name
        and
      $rsrc ne $_[2]  # orig_source
    ) {
      carp
        "$rs_class already had a registered source which was replaced by this call. "
      . 'Perhaps you wanted register_extra_source(), though it is more likely you did '
      . 'something wrong.'
      ;
    }

    $map{$rs_class} = $source_name;
    $self->class_mappings(\%map);
  }

  return $source;
}


sub skill {
  my ($self, $name) = @_;
  my $want = DBIO::Skills->canonical_name($name);

  if (my $overrides = $self->skills) {
    for my $key (keys %$overrides) {
      return $overrides->{$key}
        if DBIO::Skills->canonical_name($key) eq $want;
    }
  }

  # Make sure this schema's own driver dist is exposed, then resolve.
  DBIO::Skills->register_class(ref $self->storage) if $self->storage;

  return DBIO::Skills->skill($name);
}

my $global_phase_destroy;
sub DESTROY {
  ### NO detected_reinvoked_destructor check
  ### This code very much relies on being called multuple times

  return if $global_phase_destroy ||= in_global_destruction;

  my $self = shift;
  my $srcs = $self->source_registrations;

  for my $source_name (keys %$srcs) {
    # find first source that is not about to be GCed (someone other than $self
    # holds a reference to it) and reattach to it, weakening our own link
    #
    # during global destruction (if we have not yet bailed out) this should throw
    # which will serve as a signal to not try doing anything else
    # however beware - on older perls the exception seems randomly untrappable
    # due to some weird race condition during thread joining :(((
    if (length ref $srcs->{$source_name} and refcount($srcs->{$source_name}) > 1) {
      local $@;
      eval {
        $srcs->{$source_name}->schema($self);
        weaken $srcs->{$source_name};
        1;
      } or do {
        $global_phase_destroy = 1;
      };

      last;
    }
  }
}

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

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



1;

__END__

=pod

=encoding UTF-8

=head1 NAME

DBIO::Schema - Schema class and connection container for DBIO applications

=head1 VERSION

version 0.900001

=head1 SYNOPSIS

  package Library::Schema;
  use base qw/DBIO::Schema/;

  # load all Result classes in Library/Schema/Result/
  __PACKAGE__->load_namespaces();

  package Library::Schema::Result::CD;
  use base qw/DBIO::Core/;

  __PACKAGE__->load_components(qw/InflateColumn::DateTime/); # for example
  __PACKAGE__->table('cd');

  # Elsewhere in your code:
  my $schema1 = Library::Schema->connect(
    $dsn,
    $user,
    $password,