File Coverage

blib/lib/DBICx/Shortcuts.pm

Criterion	Covered	Total	%
statement	42	54	77.7
branch	11	20	55.0
condition	3	9	33.3
subroutine	8	10	80.0
pod	3	3	100.0
total	67	96	69.7

package DBICx::Shortcuts;
our $VERSION = '0.007';

use strict;
use warnings;
use Carp qw( croak );

my %schemas;

sub setup {
  my ($class, $schema_class, @methods) = @_;

  eval "require $schema_class";
  die if $@;
  local $ENV{DBIC_NO_VERSION_CHECK} = 1;
  my $schema = $schema_class->connect;

SOURCE: for my $source ($schema->sources) {
    my $info = $schema->source($source)->source_info;
    next SOURCE if exists $info->{skip_shortcut} && $info->{skip_shortcut};

    my $method;
    if (exists $info->{shortcut}) {
      $method = $info->{shortcut};
      next SOURCE unless defined $method;
    }
    else {
      $method = $source;
      $method =~ s/.+::(.+)$/$1/;              ## deal with nested sources
      $method =~ s/([a-z])([A-Z])/${1}_$2/g;
      $method = lc($method);
    }

    croak("Shortcut failed, '$method' already defined in '$class', ")
      if $class->can($method);

    no strict 'refs';
    *{__PACKAGE__ . "::$method"} = sub {
      my $rs = shift->schema->resultset($source);

      ## No arguments, return empty result set;
      return $rs unless @_;

      ## first argument not a reference, assume find by PK
      return $rs->find(@_) if defined($_[0]) && !ref($_[0]);

      ## first argument is a scalar ref, assume unique constraint name,
      ## use find
      return $rs->find(@_[1 .. $#_], {key => ${$_[0]}})
        if defined($_[0]) && ref($_[0]) eq 'SCALAR';

      ## otherwise, its a search
      return $rs->search(@_);
    };
  }

  ## Enable set of schema shortcuts
  for my $meth (@methods) {
    no strict 'refs';
    *{__PACKAGE__ . "::$meth"} = sub { return shift->schema->$meth(@_) };
  }

  $schemas{$class} = {class => $schema_class};

  return;
}

sub schema {
  my ($class) = @_;

  croak("Class '$class' did not call 'setup()'")
    unless exists $schemas{$class};

  my $info   = $schemas{$class};
  my $schema = $info->{schema};
  return $schema if $schema;

  my @connect_args = $class->connect_info();
  return $info->{schema} = $info->{class}->connect(@connect_args);
}

sub connect_info {
  croak("Class '$_[0]' needs to override 'connect_info()', ");
}

1;

__END__