—

              
package DBICx::MapMaker;
BEGIN {
  $DBICx::MapMaker::VERSION = '0.03';
}
# ABSTRACT: automatically create a DBIx::Class mapping table
use Moose;
our $VERSION;
our $AUTHORITY = 'CPAN:JROCKWAY';
# avoid clogging up our methods
my $other = sub { return 'right' if shift eq 'left'; return 'left' };
for my $direction (qw/left right/){
    my $other = $other->($direction);
    my $oname = "${other}_name";
    has "${direction}_class" => (
        is       => 'ro',
        isa      => 'Str',
        required => 1,
    );
    has "${direction}_name" => (
        is       => 'ro',
        isa      => 'Str',
        required => 1,
    );
    has "${direction}_to_map_relation" => (
        is      => 'ro',
        isa     => 'Str',
        lazy    => 1,
        default => sub {
            my $self = shift;
            return $self->$oname . '_map';
        }
    );
    has "${other}s_from_${direction}" => (
        is      => 'ro',
        isa     => 'Str',
        lazy    => 1,
        default => sub {
            my $self = shift;
            return $self->$oname . 's';
        },
    );
    # TODO support extra columns
    # XXX: hack
    has "suppress_${direction}_m2m" => (
        is      => 'ro',
        isa     => 'Bool',
        default => sub { undef },
    );
}
has tablename => (
    is      => 'ro',
    isa     => 'Str',
    lazy    => 1,
    default => sub {
        my $self = shift;
        my ($l,$r) = ($self->left_name, $self->right_name);
        return "map_${l}_${r}";
    },
);
# load up the classes
sub BUILD {
    my $self = shift;
    for my $class (map { $self->$_ } qw/left_class right_class/){
        Class::MOP::load_class($class);
    }
}
sub setup_table {
    my ($self, $class) = @_;
    $class->load_components(qw/Core/);
    $class->table($self->tablename);
    my ($left_class, $right_class) = ($self->left_class, $self->right_class);
    my ($left_name, $right_name) = ($self->left_name, $self->right_name);
    my $l_info = $left_class->column_info($left_class->primary_columns);
    my $r_info = $right_class->column_info($right_class->primary_columns);
    # NOTE:
    # we never want auto-incrementing
    # in a mapping table, so explicitly disable it
    $class->add_columns(
        $left_name  => { %$l_info, is_auto_increment => 0, is_nullable => 0, },
        $right_name => { %$r_info, is_auto_increment => 0, is_nullable => 0, },
    );
    $class->set_primary_key($left_name, $right_name);
    # us -> them
    $class->belongs_to( $left_name  => $left_class  );
    $class->belongs_to( $right_name => $right_class );
    # them -> us
    my $lmap = $self->left_to_map_relation;
    my $rmap = $self->right_to_map_relation;
    $left_class->has_many(  $lmap => $class, $left_name  );
    $right_class->has_many( $rmap => $class, $right_name );
    # many2many
    my $rights_from_left = $self->rights_from_left;
    my $lefts_from_right = $self->lefts_from_right;
    $left_class->many_to_many( $rights_from_left  => $lmap => $right_name )
      unless $self->suppress_left_m2m;
    $right_class->many_to_many( $lefts_from_right => $rmap => $left_name  )
      unless $self->suppress_right_m2m;
}
1;
HideShow 132 lines of Pod
=pod
=head1 NAME
DBICx::MapMaker - automatically create a DBIx::Class mapping table
=head1 VERSION
version 0.03
=head1 SYNOPSIS
A common SQL pattern is the "many to many" relationship; a row in the
"left table" may point to many rows in the "right table", and a row in
the "right table" may point to many rows in the "left table".  This
module automatically creates a L<DBIx::Class|DBIx::Class> result
source for that table, and sets up the six necessary relationships.
Here's how to use it.  Imagine you have some tables called
C<MySchema::A> and C<MySchema::B>, each with a primary key, that you'd
like to join.  To create the mapping table, you'll write a module like
this:
  package MySchema::MapAB;
  use DBICx::MapMaker;
  use base 'DBIx::Class';
  my $map = DBICx::MapMaker->new(
      left_class  => 'MySchema::A',
      right_class => 'MySchema::B',
      left_name   => 'a',
      right_name  => 'b',
  );
  $map->setup_table(__PACKAGE__);
Then, you can:
  my $a = $schema->resultset('A')->find(1);
  $a->b_map; # the mapping table
  $a->bs;    # a list of bs that this a has
  my $b = $schema->resultset('B')->find(42);
  $b->a_map; # the mapping table
  $b->as;    # a list of as that this b has
=head1 METHODS
=head2 new
Create a C<MapMaker>.  See L</ATTRIBUTES> below for a description of
the attributes you can pass to the constructor.
=head2 setup_table($class)
Makes C<$class> into the mapping table.  C<$class> should be a
subclass of C<DBIx::Class>.
=head1 ATTRIBUTES
Here are the attributes that you can pass to the constructor:
=head2 left_class right_class
The class name of the left/right table (the tables that have a m2m
relationship between them).
Required.
=head2 left_name right_name
The column name for the left/right table's primary key in the map
table.
Required.
=head2 left_to_map_relation right_to_map_relation
The name of the relationship from the left/right table to the map
table.
Optional.  Defaults to the name of the opposite table's name with
C<_map> appended.  (If C<right_name> is C<foo>, then
C<left_to_map_relation> will be C<foo_map>.)
=head2 rights_from_left lefts_from_right
The name of the m2m relationship.  C<rights_from_left> is the method
you'll call on a C<left> row to get the corresponding C<right>s.
(C<lefts_from_right> is the opposite.)
Optional.  Defaults to the name of the row returned with "s" appended.
If C<left_name> is "foo", then C<lefts_from_right> will be "foos" by
default.
=head2 tablename
The name of the created mapping table.
Optional.  Defaults to "map_C<left_name>_C<right_name>".  (With C<foo>
and C<bar>, C<map_foo_bar>.)
=head1 AUTHORS
Jonathan Rockway C<< <jrockway@cpan.org> >>
Stevan Little C<< <stevan.little@iinteractive.com> >>
Adam Herzog C<< <adam@adamherzog.com> >>
=head1 COPYRIGHT AND LICENSE
Copyright 2008 Infinity Interactive, Inc.
L<http://www.iinteractive.com>
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHOR
Jonathan Rockway <jrockway@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2011 by Jonathan Rockway.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__