DBIx::Class::Schema - composable schemas

  package Library::Schema;
  use base qw/DBIx::Class::Schema/;

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

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

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

  # Elsewhere in your code:
  my $schema1 = Library::Schema->connect(
    $dsn,
    $user,
    $password,
    { AutoCommit => 1 },
  );

  my $schema2 = Library::Schema->connect($coderef_returning_dbh);

  # fetch objects using Library::Schema::Result::DVD
  my $resultset = $schema1->resultset('DVD')->search( ... );
  my @dvd_objects = $schema2->resultset('DVD')->search( ... );

  __PACKAGE__->load_namespaces();

  __PACKAGE__->load_namespaces(
     result_namespace => 'Res',
     resultset_namespace => 'RSet',
     default_resultset_class => '+MyDB::Othernamespace::RSet',
  );

  load_namespaces found ResultSet class $classname with no corresponding Result class

  We found ResultSet class '$rs_class' for '$result', but it seems
  that you had already set '$result' to use '$rs_set' instead

  # load My::Schema::Result::CD, My::Schema::Result::Artist,
  #    My::Schema::ResultSet::CD, etc...
  My::Schema->load_namespaces;

  # Override everything to use ugly names.
  # In this example, if there is a My::Schema::Res::Foo, but no matching
  #   My::Schema::RSets::Foo, then Foo will have its
  #   resultset_class set to My::Schema::RSetBase
  My::Schema->load_namespaces(
    result_namespace => 'Res',
    resultset_namespace => 'RSets',
    default_resultset_class => 'RSetBase',
  );

  # Put things in other namespaces
  My::Schema->load_namespaces(
    result_namespace => '+Some::Place::Results',
    resultset_namespace => '+Another::Place::RSets',
  );

  My::Schema->load_namespaces(
    # My::Schema::Results_C::Foo takes precedence over My::Schema::Results_B::Foo :
    result_namespace => [ 'Results_A', 'Results_B', 'Results_C' ],
    resultset_namespace => [ '+Some::Place::RSets', 'RSets' ],
  );

   Failed to load $comp_class. Can't find source_name method. Is
   $comp_class really a full DBIC result class? Fix it, move it elsewhere,
   or make your load_classes call more specific.

  My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist,
                              # etc. (anything under the My::Schema namespace)

  # loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but
  # not Other::Namespace::LinerNotes nor My::Schema::Track
  My::Schema->load_classes(qw/ CD Artist #Track /, {
    Other::Namespace => [qw/ Producer #LinerNotes /],
  });

   package My::Schema;
   use base qw/DBIx::Class::Schema/;
   use My::ExceptionClass;
   __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) });
   __PACKAGE__->load_classes;

   # or:
   my $schema_obj = My::Schema->connect( .... );
   $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });

  my $rs = $schema->resultset('DVD');

  my @source_names = $schema->sources;

  my $source = $schema->source('Book');

  my $class = $schema->class('CD');

  my $storage = $schema->storage;

  $schema->populate('Artist', [
    [ qw/artistid name/ ],
    [ 1, 'Popular Band' ],
    [ 2, 'Indie Band' ],
    ...
  ]);

  $schema->compose_namespace('My::DB', 'Base::Class');
  print join (', ', @My::DB::CD::ISA) . "\n";
  print join (', ', @My::DB::Artist::ISA) ."\n";

  My::Schema::CD, Base::Class
  My::Schema::Artist, Base::Class

  my $filename = $table->ddl_filename($type, $version, $dir, $preversion)

 WARNING

 Prior to DBIx::Class version 0.08100 this method had a different signature:

    my $filename = $table->ddl_filename($type, $dir, $version, $preversion)

 In recent versions variables $dir and $version were reversed in order to
 bring the signature in line with other Schema/Storage methods. If you
 really need to maintain backward compatibility, you can do the following
 in any overriding methods:

    ($dir, $version) = ($version, $dir) if ($DBIx::Class::VERSION < 0.08100);

  $schema->register_source($moniker, $component_class->result_source_instance);

package DBIx::Class::Schema;

use strict;
use warnings;

use DBIx::Class::Exception;
use DBIx::Class::Carp;
use Try::Tiny;
use Scalar::Util 'weaken';
use Sub::Name 'subname';
use B 'svref_2object';
use namespace::clean;

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' => {});

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

  require Module::Find;
  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,
# or dies with an informative message (used by load_namespaces)
sub _ns_get_rsrc_instance {
  my $class = shift;
  my $rs = ref ($_[0]) || $_[0];

  if ($rs->can ('result_source_instance') ) {
    return $rs->result_source_instance;
  }
  else {
    $class->throw_exception (
      "Attempt to load_namespaces() class $rs failed - are you sure this is a real Result Class?"
    );
  }
}

sub load_namespaces {
  my ($class, %args) = @_;

  my $result_namespace = delete $args{result_namespace} || 'Result';
  my $resultset_namespace = delete $args{resultset_namespace} || 'ResultSet';
  my $default_resultset_class = delete $args{default_resultset_class};

  $class->throw_exception('load_namespaces: unknown option(s): '
    . join(q{,}, map { qq{'$_'} } keys %args))
      if scalar keys %args;

  $default_resultset_class
    = $class->_expand_relative_name($default_resultset_class);

  for my $arg ($result_namespace, $resultset_namespace) {
    $arg = [ $arg ] if !ref($arg) && $arg;

    $class->throw_exception('load_namespaces: namespace arguments must be '
      . 'a simple string or an arrayref')
        if ref($arg) ne 'ARRAY';

    $_ = $class->_expand_relative_name($_) for (@$arg);
  }

  my %results = $class->_map_namespaces(@$result_namespace);
  my %resultsets = $class->_map_namespaces(@$resultset_namespace);

  my @to_register;
  {
    no warnings qw/redefine/;
    local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
    use warnings qw/redefine/;

    # ensure classes are loaded and attached in inheritance order
    for my $res (values %results) {
      $class->ensure_class_loaded($res);
    }
    my %inh_idx;
    my @subclass_last = sort {

      ($inh_idx{$a} ||=
        scalar @{mro::get_linear_isa( $results{$a} )}
      )

          <=>

      ($inh_idx{$b} ||=
        scalar @{mro::get_linear_isa( $results{$b} )}
      )

    } keys(%results);

    foreach my $result (@subclass_last) {
      my $result_class = $results{$result};

      my $rs_class = delete $resultsets{$result};
      my $rs_set = $class->_ns_get_rsrc_instance ($result_class)->resultset_class;

      if($rs_set && $rs_set ne 'DBIx::Class::ResultSet') {
        if($rs_class && $rs_class ne $rs_set) {
          carp "We found ResultSet class '$rs_class' for '$result', but it seems "
             . "that you had already set '$result' to use '$rs_set' instead";
        }
      }
      elsif($rs_class ||= $default_resultset_class) {
        $class->ensure_class_loaded($rs_class);
        if(!$rs_class->isa("DBIx::Class::ResultSet")) {
            carp "load_namespaces found ResultSet class $rs_class that does not subclass DBIx::Class::ResultSet";
        }

        $class->_ns_get_rsrc_instance ($result_class)->resultset_class($rs_class);
      }

      my $source_name = $class->_ns_get_rsrc_instance ($result_class)->source_name || $result;

      push(@to_register, [ $source_name, $result_class ]);
    }
  }

  foreach (sort keys %resultsets) {
    carp "load_namespaces found ResultSet class $_ with no "
      . 'corresponding Result class';
  }

  Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;

  $class->register_class(@$_) for (@to_register);

  return;
}

sub load_classes {
  my ($class, @params) = @_;

  my %comps_for;

  if (@params) {
    foreach my $param (@params) {
      if (ref $param eq 'ARRAY') {
        # filter out commented entries
        my @modules = grep { $_ !~ /^#/ } @$param;

        push (@{$comps_for{$class}}, @modules);
      }
      elsif (ref $param eq 'HASH') {
        # more than one namespace possible
        for my $comp ( keys %$param ) {
          # filter out commented entries
          my @modules = grep { $_ !~ /^#/ } @{$param->{$comp}};

          push (@{$comps_for{$comp}}, @modules);
        }
      }
      else {
        # filter out commented entries
        push (@{$comps_for{$class}}, $param) if $param !~ /^#/;
      }
    }
  } else {
    my @comp = map { substr $_, length "${class}::"  }
                 $class->_findallmod;
    $comps_for{$class} = \@comp;
  }

  my @to_register;
  {
    no warnings qw/redefine/;
    local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
    use warnings qw/redefine/;

    foreach my $prefix (keys %comps_for) {
      foreach my $comp (@{$comps_for{$prefix}||[]}) {
        my $comp_class = "${prefix}::${comp}";
        $class->ensure_class_loaded($comp_class);

        my $snsub = $comp_class->can('source_name');
        if(! $snsub ) {
          carp "Failed to load $comp_class. Can't find source_name method. Is $comp_class really a full DBIC result class? Fix it, move it elsewhere, or make your load_classes call more specific.";
          next;
        }
        $comp = $snsub->($comp_class) || $comp;

        push(@to_register, [ $comp, $comp_class ]);
      }
    }
  }
  Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;

  foreach my $to (@to_register) {
    $class->register_class(@$to);
    #  if $class->can('result_source_instance');
  }
}

sub connect { shift->clone->connection(@_) }

sub resultset {
  my ($self, $moniker) = @_;
  $self->throw_exception('resultset() expects a source name')
    unless defined $moniker;
  return $self->source($moniker)->resultset;
}

sub sources { return keys %{shift->source_registrations}; }

sub source {
  my $self = shift;

  $self->throw_exception("source() expects a source name")
    unless @_;

  my $moniker = shift;

  my $sreg = $self->source_registrations;
  return $sreg->{$moniker} if exists $sreg->{$moniker};

  # if we got here, they probably passed a full class name
  my $mapped = $self->class_mappings->{$moniker};
  $self->throw_exception("Can't find source for ${moniker}")
    unless $mapped && exists $sreg->{$mapped};
  return $sreg->{$mapped};
}

sub class {
  my ($self, $moniker) = @_;
  return $self->source($moniker)->result_class;
}

sub txn_do {
  my $self = shift;

  $self->storage or $self->throw_exception
    ('txn_do called on $schema without storage');

  $self->storage->txn_do(@_);
}

sub txn_scope_guard {
  my $self = shift;

  $self->storage or $self->throw_exception
    ('txn_scope_guard called on $schema without storage');

  $self->storage->txn_scope_guard(@_);
}

sub txn_begin {
  my $self = shift;

  $self->storage or $self->throw_exception
    ('txn_begin called on $schema without storage');

  $self->storage->txn_begin;
}

sub txn_commit {
  my $self = shift;

  $self->storage or $self->throw_exception
    ('txn_commit called on $schema without storage');

  $self->storage->txn_commit;
}

sub txn_rollback {
  my $self = shift;

  $self->storage or $self->throw_exception
    ('txn_rollback called on $schema without storage');

  $self->storage->txn_rollback;
}

sub populate {
  my ($self, $name, $data) = @_;
  if(my $rs = $self->resultset($name)) {
    if(defined wantarray) {
        return $rs->populate($data);
    } else {
        $rs->populate($data);
    }
  } else {
      $self->throw_exception("$name is not a resultset");
  }
}

sub connection {
  my ($self, @info) = @_;
  return $self if !@info && $self->storage;

  my ($storage_class, $args) = ref $self->storage_type ?
    ($self->_normalize_storage_type($self->storage_type),{}) : ($self->storage_type, {});

  $storage_class = 'DBIx::Class::Storage'.$storage_class
    if $storage_class =~ m/^::/;
  try {
    $self->ensure_class_loaded ($storage_class);
  }
  catch {
    $self->throw_exception(
      "No arguments to load_classes and couldn't load ${storage_class} ($_)"
    );
  };
  my $storage = $storage_class->new($self=>$args);
  $storage->connect_info(\@info);
  $self->storage($storage);
  return $self;
}

sub _normalize_storage_type {
  my ($self, $storage_type) = @_;
  if(ref $storage_type eq 'ARRAY') {
    return @$storage_type;
  } elsif(ref $storage_type eq 'HASH') {
    return %$storage_type;
  } else {
    $self->throw_exception('Unsupported REFTYPE given: '. ref $storage_type);
  }
}

# this might be oversimplified
# sub compose_namespace {
#   my ($self, $target, $base) = @_;

#   my $schema = $self->clone;
#   foreach my $moniker ($schema->sources) {
#     my $source = $schema->source($moniker);
#     my $target_class = "${target}::${moniker}";
#     $self->inject_base(
#       $target_class => $source->result_class, ($base ? $base : ())
#     );
#     $source->result_class($target_class);
#     $target_class->result_source_instance($source)
#       if $target_class->can('result_source_instance');
#     $schema->register_source($moniker, $source);
#   }
#   return $schema;
# }

sub compose_namespace {
  my ($self, $target, $base) = @_;
  my $schema = $self->clone;
  {
    no warnings qw/redefine/;
    local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
    use warnings qw/redefine/;

    no strict qw/refs/;
    foreach my $moniker ($schema->sources) {
      my $source = $schema->source($moniker);
      my $target_class = "${target}::${moniker}";
      $self->inject_base(
        $target_class => $source->result_class, ($base ? $base : ())
      );
      $source->result_class($target_class);
      if ($target_class->can('result_source_instance')) {

        # since the newly created classes are registered only with
        # the instance of $schema, it should be safe to weaken
        # the ref (it will GC when $schema is destroyed)
        $target_class->result_source_instance($source);
        weaken ${"${target_class}::__cag_result_source_instance"};
      }
     $schema->register_source($moniker, $source);
    }
  }
  Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
  {
    no strict 'refs';
    no warnings 'redefine';
    foreach my $meth (qw/class source resultset/) {
      *{"${target}::${meth}"} = subname "${target}::${meth}" =>
        sub { shift->schema->$meth(@_) };
    }
  }
  return $schema;
}

sub setup_connection_class {
  my ($class, $target, @info) = @_;
  $class->inject_base($target => 'DBIx::Class::DB');
  #$target->load_components('DB');
  $target->connection(@info);
}

sub svp_begin {
  my ($self, $name) = @_;

  $self->storage or $self->throw_exception
    ('svp_begin called on $schema without storage');

  $self->storage->svp_begin($name);
}

sub svp_release {
  my ($self, $name) = @_;

  $self->storage or $self->throw_exception
    ('svp_release called on $schema without storage');

  $self->storage->svp_release($name);
}

sub svp_rollback {
  my ($self, $name) = @_;

  $self->storage or $self->throw_exception
    ('svp_rollback called on $schema without storage');

  $self->storage->svp_rollback($name);
}

sub clone {
  my ($self) = @_;
  my $clone = { (ref $self ? %$self : ()) };
  bless $clone, (ref $self || $self);

  $clone->class_mappings({ %{$clone->class_mappings} });
  $clone->source_registrations({ %{$clone->source_registrations} });
  foreach my $moniker ($self->sources) {
    my $source = $self->source($moniker);
    my $new = $source->new($source);
    # we use extra here as we want to leave the class_mappings as they are
    # but overwrite the source_registrations entry with the new source
    $clone->register_extra_source($moniker => $new);
  }
  $clone->storage->set_schema($clone) if $clone->storage;
  return $clone;
}

my $false_exception_action_warned;
sub throw_exception {
  my $self = shift;

  if (my $act = $self->exception_action) {
    if ($act->(@_)) {
      DBIx::Class::Exception->throw(
          "Invocation of the exception_action handler installed on $self did *not*"
        .' result in an exception. DBIx::Class is unable to function without a reliable'
        .' exception mechanism, ensure that exception_action does not hide exceptions'
        ." (original error: $_[0])"
      );
    }
    elsif(! $false_exception_action_warned++) {
      carp (
          "The exception_action handler installed on $self returned false instead"
        .' of throwing an exception. This behavior has been deprecated, adjust your'
        .' handler to always rethrow the supplied error.'
      );
    }
  }

  DBIx::Class::Exception->throw($_[0], $self->stacktrace);
}

sub deploy {
  my ($self, $sqltargs, $dir) = @_;
  $self->throw_exception("Can't deploy without storage") unless $self->storage;
  $self->storage->deploy($self, undef, $sqltargs, $dir);
}

sub deployment_statements {
  my $self = shift;

  $self->throw_exception("Can't generate deployment statements without a storage")
    if not $self->storage;

  $self->storage->deployment_statements($self, @_);
}

sub create_ddl_dir {
  my $self = shift;

  $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
  $self->storage->create_ddl_dir($self, @_);
}

sub ddl_filename {
  my ($self, $type, $version, $dir, $preversion) = @_;

  require File::Spec;

  my $filename = ref($self);
  $filename =~ s/::/-/g;
  $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql");
  $filename =~ s/$version/$preversion-$version/ if($preversion);

  return $filename;
}

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

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

sub dclone {
  my ($self, $obj) = @_;
  local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
  require Storable;
  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, $moniker, $to_register) = @_;
  $self->register_source($moniker => $to_register->result_source_instance);
}

sub register_source {
  my $self = shift;

  $self->_register_source(@_);
}

sub unregister_source {
  my $self = shift;

  $self->_unregister_source(@_);
}

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

{
  my $global_phase_destroy;

  # SpeedyCGI runs END blocks every cycle but keeps object instances
  # hence we have to disable the globaldestroy hatch, and rely on the
  # eval trap below (which appears to work, but is risky done so late)
  END { $global_phase_destroy = 1 unless $CGI::SpeedyCGI::i_am_speedy }

  sub DESTROY {
    return if $global_phase_destroy;

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

    for my $moniker (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 will throw
      # which will serve as a signal to not try doing anything else
      if (ref $srcs->{$moniker} and svref_2object($srcs->{$moniker})->REFCNT > 1) {
        local $@;
        eval {
          $srcs->{$moniker}->schema($self);
          1;
        } or do {
          $global_phase_destroy = 1;
          last;
        };

        weaken $srcs->{$moniker};
        last;
      }
    }
  }
}

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

{
  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';
    try {
      eval "require ${base};"
    }
    catch {
      $self->throw_exception
        ("No arguments to load_classes and couldn't load ${base} ($_)")
    };

    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;
        $self->inject_base($class, $base);
        $class->mk_classdata(resultset_instance => $source->resultset);
        $class->mk_classdata(class_resolver => $self);
      }
      $self->connection(@info);
      return $self;
    }

    my $schema = $self->compose_namespace($target, $base);
    {
      no strict 'refs';
      my $name = join '::', $target, 'schema';
      *$name = subname $name, sub { $schema };
    }

    $schema->connection(@info);
    foreach my $moniker ($schema->sources) {
      my $source = $schema->source($moniker);
      my $class = $source->result_class;
      #warn "$moniker $class $source ".$source->storage;
      $class->mk_classdata(result_source_instance => $source);
      $class->mk_classdata(resultset_instance => $source->resultset);
      $class->mk_classdata(class_resolver => $schema);
    }
    return $schema;
  }
}

1;