package DBIx::Class::LookupColumn::Auto;
use strict;
use warnings;
=head1 NAME
DBIx::Class::LookupColumn::Auto - A dbic component for installing LookupColumn relations on a whole schema at once.
=head1 VERSION
Version 0.05
=cut
our $VERSION = '0.05';
use base qw(DBIx::Class);
use Data::Dumper;
use Smart::Comments -ENV;
use Hash::Merge::Simple qw/merge/;
use Carp qw(confess);
use DBIx::Class::LookupColumn::LookupColumnComponent;
=head1 SYNOPSIS
package MySchema;
__PACKAGE__->load_components( qw/LookupColumn::Auto/ );
my @tables = __PACKAGE__->sources; # get all table names
my @candidates = grep { ! /Type$/ } @tables; # tables that do NOT end with Type
my @lookups = grep { /Type$/ } @tables; # tables that DO end with Type == the Lookup Tables !
__PACKAGE__->add_lookups(
targets => \@candidates,
lookups => \@lookups,
# function that will generate the relation names: here we build it from the Lookup Table
relation_name_builder => sub{
my ( $class, %args) = @_;
$args{lookup} =~ /^(.+)Type$/; # remove the end (Type) from the Lookup table name
lc( $1 );
},
# function that gives the name of the column that holds the definitions/values: here it is always 'name'
lookup_field_name_builder => sub { 'name' }
);
=head1 DESCRIPTION
This component automates the addition of the B<Lookup> (see L<DBIx::Class::LookupColumn/Lookup Tables>) relations to a whole set of tables.
Given a set of potential target tables (the tables on which to add the Lookup relations), and a set of Lookup tables,
the component will select all the I<belongs_to> relations defined in the target tables pointing to a Lookup table present in the set
and add a Lookup relation automatically.
It is also possible to add accessors manuall by doing a copy/paste of the code diplayed with the verbose option (See L<add_lookups>).
=head1 METHODS
=head2 add_lookups
__PACKAGE__->add_lookups( { targets => [], lookups => [], relation_name_builder? => sub {}, lookup_field_name_builder? => sub {}, verbose? => boolean } )
This will iterate through the set of B<targets> tables on all B<belongs_to> relations pointing to a table included in B<lookups>
and add a corresponding relation.
B<Arguments (hash keys) >:
=over 4
=item targets
An ArrayRef of the names of the tables on which to detect and install the Lookup relations.
=item lookups
An ArrayRef of the names of the Lookup tables.
=item relation_name_builder?
Optional. FuncRef for building the accessors base name. By default the name of the Lookup table in small caps.
Arguments (hash keys) : { target => ?, lookup => ?, foreign_key => ? }.
=item lookup_field_name_builder?
Optional. FuncRef for specifying the concerned column name in the Lookup table. By default the first I<varchar> type column in the Lookup table.
=item verbose?
Optional. Boolean for displaying the code for adding a Lookup relation. Copy/paste it the right place of your code. By default set to false, then non-verbose.
=back
=cut
sub add_lookups {
my ( $class, %args ) = @_;
my $targets_array_ref = exists ( $args{targets} ) ? $args{targets} : confess 'targets arg is missing';
my $lookups_array_ref = exists ( $args{lookups} ) ? $args{lookups} : confess 'lookups arg is missing';
my $options = {};
if ( exists ( $args{relation_name_builder} ) ) { $options->{relation_name_builder} = $args{relation_name_builder} ;}
if ( exists ( $args{lookup_field_name_builder})){ $options->{lookup_field_name_builder} = $args{lookup_field_name_builder};}
if ( exists ( $args{verbose} ) ) { $options->{verbose} = $args{verbose} ;}
my $defaults = {
relation_name_builder => \&_guess_relation_name,
lookup_field_name_builder => \&_guess_field_name,
verbose => 0
};
my $params = merge $defaults, $options;
my $verbose = $params->{verbose};
my $target2lkp_hash_ref = $class->_target2lookups( $targets_array_ref, $lookups_array_ref );
#### target2lookups returned: $target2lkp_hash_ref
my ( $target, $fk2lkp_hash_ref);
while ( ( $target, $fk2lkp_hash_ref ) = each ( %$target2lkp_hash_ref ) ) {
if($verbose) {
warn "adding to package $target\n";
warn "__PACKAGE__->load_components(LookupColumn)\n";
}
foreach my $fk (keys %$fk2lkp_hash_ref) {
my $lookup = $fk2lkp_hash_ref->{$fk};
my @args = (
$params->{relation_name_builder}->( $class, target => $target, lookup => $lookup, foreign_key => $fk ),
$fk, $lookup,
{
field_name => $params->{lookup_field_name_builder}->( $class, target => $target, lookup => $lookup, foreign_key => $fk )
}
);
if($verbose) {
my $s = Dumper(\@args);
$s =~ s/^[^\[]*\[(.+)\];.*/$1/s;
warn "__PACKAGE__->add_lookup($s)\n" ;
}
DBIx::Class::LookupColumn::LookupColumnComponent::add_lookup( $class->class( $target), @args );
}
}
}
sub _target2lookups {
my ( $class, $targets_array_ref, $lookups_array_ref ) = @_;
my %lookups = map { ($class->class( $_ ), $_) } @$lookups_array_ref;
my %relationships;
foreach my $target ( @$targets_array_ref ) {
#### processing target table: $target
my $target_class = $class->class( $target );
foreach my $rel ($target_class->relationships) {
#### processing relation : $rel
my $info = $target_class->relationship_info($rel);
#### relationship_info: $info
next unless exists $lookups{$info->{source}}; # is the relation to a lookup
my @fk_columns = keys %{$info->{attrs}->{fk_columns}};
next if @fk_columns > 1; # if multiple foreign keys, not a belongs_to ?
unless (@fk_columns) {
### skipping relation because there is no foreign key, for table and relation: $target, $rel
next;
}
my $fk = shift @fk_columns;
next unless $info->{attrs}->{accessor} eq 'single'; # heuristic to detect belongs_to relation
$relationships{$target}->{$fk} = $lookups{$info->{source}};
}
}
return \%relationships;
}
sub _guess_relation_name{
my ( $class, %args ) = @_;
return lc( $args{lookup});
}
sub _guess_field_name {
my ( $class, %args ) = @_;
my $schema = $class;
my $lookup = $args{lookup};
my @columns = $schema->source( $lookup )->columns;
my @primary_columns = $schema->source( $lookup )->primary_columns;
my @columns_without_primary_keys = grep{ !($_ ~~ @primary_columns) } @columns;
my $guessed_field;
# classic lookup table with only two columns
if ( @columns == 2 && @columns_without_primary_keys == 1){
$guessed_field = shift @columns_without_primary_keys;
}
# lookup table with more than two columns
else{
foreach my $column ( @columns_without_primary_keys ){
my $column_metas = $schema->source( $lookup )->column_info( $column );
if ( $column_metas->{data_type} =~ /varchar/ ){
#select the first varchar column
$guessed_field = $column;
last;
}
}
}
return $guessed_field;
}
=head1 AUTHORS
Karl Forner <karl.forner@gmail.com>
Thomas Rubattel <rubattel@cpan.org>
=head1 BUGS
Please report any bugs or feature requests to C<bug-dbix-class-lookupcolumn-auto at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=DBIx-Class-LookupColumn-Auto>. I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc DBIx::Class::LookupColumn::Auto
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker (report bugs here)
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-Class-LookupColumn-Auto>
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/DBIx-Class-LookupColumn-Auto>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/DBIx-Class-LookupColumn-Auto>
=item * Search CPAN
L<http://search.cpan.org/dist/DBIx-Class-LookupColumn-Auto/>
=back
=head1 LICENCE AND COPYRIGHT
Copyright 2012 Karl Forner and Thomas Rubattel, All Rights Reserved.
This program is free software; you can redistribute it and/or modify it
under the terms as Perl itself.
=cut
1; # End of DBIx::Class::LookupColumn::Auto