view release on metacpan or  search on metacpan

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

package DBIO::ResultSource;
# ABSTRACT: Metadata object describing a table, view, or query source

use strict;
use warnings;

use base qw/DBIO::ResultSource::RowParser DBIO::Base/;

use DBIO::ResultSet;
use DBIO::ResultSourceHandle;

use DBIO::Carp;
use DBIO::Util 'UNRESOLVABLE_CONDITION';
use DBIO::Util qw(is_literal_value);
use Devel::GlobalDestruction;
use Try::Tiny;
use Scalar::Util qw/blessed weaken isweak/;

use namespace::clean;

__PACKAGE__->mk_group_accessors(simple => qw/
  source_name name source_info
  _ordered_columns _columns _primaries _unique_constraints
  _relationships resultset_attributes
  column_info_from_storage
/);

__PACKAGE__->mk_group_accessors(component_class => qw/
  resultset_class
  result_class
/);

__PACKAGE__->mk_classdata( sqlt_deploy_callback => 'default_sqlt_deploy_hook' );


sub new {
  my ($class, $attrs) = @_;
  $class = ref $class if ref $class;

  my $new = bless { %{$attrs || {}} }, $class;
  $new->{resultset_class} ||= 'DBIO::ResultSet';
  $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
  $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
  $new->{_columns} = { %{$new->{_columns}||{}} };
  $new->{_relationships} = { %{$new->{_relationships}||{}} };
  $new->{name} ||= "!!NAME NOT SET!!";
  $new->{_columns_info_loaded} ||= 0;
  return $new;
}



sub add_columns {
  my ($self, @cols) = @_;
  $self->_ordered_columns(\@cols) unless $self->_ordered_columns;

  my @added;
  my $columns = $self->_columns;
  while (my $col = shift @cols) {
    my $column_info = {};
    if ($col =~ s/^\+//) {
      $column_info = $self->column_info($col);
    }

    # If next entry is { ... } use that for the column info, if not
    # use an empty hashref
    if (ref $cols[0]) {
      my $new_info = shift(@cols);
      %$column_info = (%$column_info, %$new_info);
    }
    push(@added, $col) unless exists $columns->{$col};
    $columns->{$col} = $column_info;
  }
  push @{ $self->_ordered_columns }, @added;
  return $self;
}

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

  # if we are not registered with a schema - just use the prototype
  # however if we do have a schema - ask for the source by name (and
  # throw in the process if all fails)
  if (my $schema = try { $self->schema }) {
    $schema->source($self->relationship_info($rel)->{source});
  }
  else {
    my $class = $self->relationship_info($rel)->{class};
    $self->ensure_class_loaded($class);
    $class->result_source_instance;
  }
}


sub related_class {
  my ($self, $rel) = @_;
  if( !$self->has_relationship( $rel ) ) {
    $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
  }
  return $self->schema->class($self->relationship_info($rel)->{source});
}


sub handle {
  return DBIO::ResultSourceHandle->new({
    source_moniker => $_[0]->source_name,

    # so that a detached thaw can be re-frozen
    $_[0]->{_detached_thaw}
      ? ( _detached_source  => $_[0]          )
      : ( schema            => $_[0]->schema  )
    ,
  });
}

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;

######
# !!! ACHTUNG !!!!
######
#
# Under no circumstances shall $_[0] be stored anywhere else (like copied to
# a lexical variable, or shifted, or anything else). Doing so will mess up
# the refcount of this particular result source, and will allow the $schema
# we are trying to save to reattach back to the source we are destroying.
# The relevant code checking refcounts is in ::Schema::DESTROY()

  # if we are not a schema instance holder - we don't matter
  return if(
    ! ref $_[0]->{schema}
      or
    isweak $_[0]->{schema}
  );

  # weaken our schema hold forcing the schema to find somewhere else to live
  # during global destruction (if we have not yet bailed out) this will 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 :(((
  local $@;
  eval {
    weaken $_[0]->{schema};

    # if schema is still there reintroduce ourselves with strong refs back to us
    if ($_[0]->{schema}) {
      my $srcregs = $_[0]->{schema}->source_registrations;
      for (keys %$srcregs) {
        next unless $srcregs->{$_};
        $srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0];
      }
    }

    1;
  } or do {
    $global_phase_destroy = 1;
  };

  return;
}

sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) }

sub STORABLE_thaw {
  my ($self, $cloning, $ice) = @_;
  %$self = %{ (Storable::thaw($ice))->resolve };
}


sub throw_exception {
  my $self = shift;

  $self->{schema}
    ? $self->{schema}->throw_exception(@_)
    : DBIO::Exception->throw(@_)
  ;
}


1;

__END__

=pod

=encoding UTF-8

=head1 NAME

DBIO::ResultSource - Metadata object describing a table, view, or query source

=head1 VERSION

version 0.900001

=head1 SYNOPSIS

  # Create a table based result source, in a result class.

  package MyApp::Schema::Result::Artist;
  use base qw/DBIO::Core/;

  __PACKAGE__->table('artist');