File Coverage

blib/lib/DBIx/Class/Candy.pm

Criterion	Covered	Total	%
statement	167	176	94.8
branch	23	36	63.8
condition	2	5	40.0
subroutine	33	33	100.0
pod	0	15	0.0
total	225	265	84.9

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

use namespace::clean;
require DBIx::Class::Candy::Exports;
use MRO::Compat;
use Sub::Exporter 'build_exporter';
use Carp 'croak';

# ABSTRACT: Sugar for your favorite ORM, DBIx::Class

my %aliases = (
   column            => 'add_columns',
   primary_key       => 'set_primary_key',
   unique_constraint => 'add_unique_constraint',
   relationship      => 'add_relationship',
);

my @methods = qw(
   resultset_class
   resultset_attributes
   remove_columns
   remove_column
   table
   source_name

   inflate_column

   belongs_to
   has_many
   might_have
   has_one
   many_to_many

   sequence
);

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

sub perl_version { return $_[1] }

sub autotable { $_[1] }

sub experimental { $_[1] }

sub _extract_part {
   my ($self, $class) = @_;
   if (my ( $part ) = $class =~ /(?:::Schema)?::Result::(.+)$/) {
      return $part
   } else {
      croak 'unrecognized naming scheme!'
   }
}

my $decamelize = sub {
   my $s = shift;
   $s =~ s{([^a-zA-Z]?)([A-Z]*)([A-Z])([a-z]?)}{
      my $fc = pos($s)==0;
      my ($p0,$p1,$p2,$p3) = ($1,lc$2,lc$3,$4);
      my $t = $p0 || $fc ? $p0 : '_';
      $t .= $p3 ? $p1 ? "${p1}_$p2$p3" : "$p2$p3" : "$p1$p2";
      $t;
   }ge;
   $s;
};

sub gen_table {
   my ( $self, $class, $version ) = @_;
   if ($version eq 'singular') {
      my $part = $self->_extract_part($class);
      $part =~ s/:://g;
      return $decamelize->($part);
   } elsif ($version == 1) {
      my $part = $self->_extract_part($class);
      require Lingua::EN::Inflect;
      $part =~ s/:://g;
      $part = $decamelize->($part);
      return join q{_}, split /\s+/, Lingua::EN::Inflect::PL(join q{ }, split /_/, $part);
   }
}

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}});
   my @custom_methods;
   my %custom_aliases;
   {
      my @custom = $self->gen_custom_imports($inheritor);
      @custom_methods = @{$custom[0]};
      %custom_aliases = %{$custom[1]};
   }

   my $set_table = sub {};
   if (my $v = $self->autotable($args->{autotable})) {
     my $table_name = $self->gen_table($inheritor, $v);
     my $ran = 0;
     $set_table = sub { $inheritor->table($table_name) unless $ran++ }
   }
   @_ = ($self, @rest);
   my $import = build_exporter({
      exports => [
         has_column => $self->gen_has_column($inheritor, $set_table),
         primary_column => $self->gen_primary_column($inheritor, $set_table),
         unique_column => $self->gen_unique_column($inheritor, $set_table),
         (map { $_ => $self->gen_proxy($inheritor, $set_table) } @methods, @custom_methods),
         (map { $_ => $self->gen_rename_proxy($inheritor, $set_table, %aliases, %custom_aliases) }
            keys %aliases, keys %custom_aliases),
      ],
      groups  => {
         default => [
            qw(has_column primary_column unique_column), @methods, @custom_methods, keys %aliases, keys %custom_aliases
         ],
      },
      installer  => $self->installer,
      collectors => [
         INIT => $self->gen_INIT($perl_version, \%custom_aliases, \@custom_methods, $inheritor, $experimental),
      ],
   });

   goto $import
}

sub gen_custom_imports {
  my ($self, $inheritor) = @_;
  my @methods;
  my %aliases;
  for (@{mro::get_linear_isa($inheritor)}) {
    if (my $a = $DBIx::Class::Candy::Exports::aliases{$_}) {
      %aliases = (%aliases, %$a)
    }
    if (my $m = $DBIx::Class::Candy::Exports::methods{$_}) {
      @methods = (@methods, @$m)
    }
  }
  return(\@methods, \%aliases)
}

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

  my $skipnext;
  my $base;
  my @rest;
  my $perl_version = undef;
  my $components   = [];
  my $autotable = 0;
  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 '-autotable' ) {
      $autotable = $args[$idx + 1];
      $autotable = ord $autotable if length $autotable == 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 {
    autotable    => $autotable,
    base         => $base,
    perl_version => $perl_version,
    components   => $components,
    rest         => \@rest,
    experimental => $experimental,
  };
}

sub gen_primary_column {
  my ($self, $inheritor, $set_table) = @_;
  sub {
    my $i = $inheritor;
    sub {
      my $column = shift;
      my $info   = shift;
      $set_table->();
      $i->add_columns($column => $info);
      $i->set_primary_key($i->primary_columns, $column);
    }
  }
}

sub gen_unique_column {
  my ($self, $inheritor, $set_table) = @_;
  sub {
    my $i = $inheritor;
    sub {
      my $column = shift;
      my $info   = shift;
      $set_table->();
      $i->add_columns($column => $info);
      $i->add_unique_constraint([ $column ]);
    }
  }
}

sub gen_has_column {
  my ($self, $inheritor, $set_table) = @_;
  sub {
    my $i = $inheritor;
    sub {
      my $column = shift;
      $set_table->();
      $i->add_columns($column => { @_ })
    }
  }
}

sub gen_rename_proxy {
  my ($self, $inheritor, $set_table, %aliases) = @_;
  sub {
    my ($class, $name) = @_;
    my $meth = $aliases{$name};
    my $i = $inheritor;
    sub { $set_table->(); $i->$meth(@_) }
  }
}

sub gen_proxy {
  my ($self, $inheritor, $set_table) = @_;
  sub {
    my ($class, $name) = @_;
    my $i = $inheritor;
    sub { $set_table->(); $i->$name(@_) }
  }
}

sub installer {
  my ($self) = @_;
  sub {
    Sub::Exporter::default_installer @_;
    my %subs = @{ $_[1] };
    namespace::clean->import( -cleanee => $_[0]{into}, keys %subs )
  }
}

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, $custom_aliases, $custom_methods, $inheritor, $experimental) = @_;
  sub {
    my $orig = $_[1]->{import_args};
    $_[1]->{import_args} = [];
    %$custom_aliases = ();
    @$custom_methods = ();

    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__