File Coverage

blib/lib/DBIx/Class/Candy/ResultSet.pm

Criterion	Covered	Total	%
statement	78	85	91.7
branch	9	18	50.0
condition	2	5	40.0
subroutine	16	16	100.0
pod	0	7	0.0
total	105	131	80.1

package DBIx::Class::Candy::ResultSet;
$DBIx::Class::Candy::ResultSet::VERSION = '0.005003';
use strict;
use warnings;

use MRO::Compat;
use Sub::Exporter 'build_exporter';
use Carp 'croak';

# ABSTRACT: Sugar for your resultsets

sub base { return $_[1] || 'DBIx::Class::ResultSet' }

sub perl_version { return $_[1] }

sub experimental { $_[1] }

sub import {
   my $self = shift;

   my $inheritor = caller(0);
   my $args         = $self->parse_arguments(\@_);
   my $perl_version = $self->perl_version($args->{perl_version});
   my $experimental = $self->experimental($args->{experimental});
   my @rest         = @{$args->{rest}};

   $self->set_base($inheritor, $args->{base});
   $inheritor->load_components(@{$args->{components}});

   @_ = ($self, @rest);
   my $import = build_exporter({
      installer  => $self->installer,
      collectors => [ INIT => $self->gen_INIT($perl_version, $inheritor, $experimental) ],
   });

   goto $import
}

sub parse_arguments {
  my $self = shift;
  my @args = @{shift @_};

  my $skipnext;
  my $base;
  my @rest;
  my $perl_version = undef;
  my $components   = [];
  my $experimental;

  for my $idx ( 0 .. $#args ) {
    my $val = $args[$idx];

    next unless defined $val;
    if ($skipnext) {
      $skipnext--;
      next;
    }

    if ( $val eq '-base' ) {
      $base = $args[$idx + 1];
      $skipnext = 1;
    } elsif ( $val eq '-perl5' ) {
      $perl_version = ord $args[$idx + 1];
      $skipnext = 1;
    } elsif ( $val eq '-experimental' ) {
      $experimental = $args[$idx + 1];
      $skipnext = 1;
    } elsif ( $val eq '-components' ) {
      $components = $args[$idx + 1];
      $skipnext = 1;
    } else {
      push @rest, $val;
    }
  }

  return {
    base         => $base,
    perl_version => $perl_version,
    components   => $components,
    rest         => \@rest,
    experimental => $experimental,
  };
}

sub installer {
  my ($self) = @_;
  sub {
    Sub::Exporter::default_installer @_;
  }
}

sub set_base {
   my ($self, $inheritor, $base) = @_;

   # inlined from parent.pm
   for ( my @useless = $self->base($base) ) {
      s{::|'}{/}g;
      require "$_.pm"; # dies if the file is not found
   }

   {
      no strict 'refs';
      # This is more efficient than push for the new MRO
      # at least until the new MRO is fixed
      @{"$inheritor\::ISA"} = (@{"$inheritor\::ISA"} , $self->base($base));
   }
}

sub gen_INIT {
  my ($self, $perl_version, $inheritor, $experimental) = @_;
  sub {
    my $orig = $_[1]->{import_args};
    $_[1]->{import_args} = [];

    strict->import;
    warnings->import;

    if ($perl_version) {
       require feature;
       feature->import(":5.$perl_version")
    }

    if ($experimental) {
       require experimental;
       die 'experimental arg must be an arrayref!'
          unless ref $experimental && ref $experimental eq 'ARRAY';
       # to avoid experimental referring to the method
       experimental::->import(@$experimental)
    }

    mro::set_mro($inheritor, 'c3');

    1;
  }
}

1;

__END__