package Class::DBI::Loader::Kinship;
use 5.008008;
use base 'Class::DBI::Loader';
our $VERSION = '0.01';
use Class::DBI::Loader::k_Pg ;
## Class::DBI::Loader::k_Pg is masquerading as Class::DBI::Loader::Pg
$INC{'Class/DBI/Loader/Pg.pm'} = '::k_Pg masquerades in its place';
# load Class::DBI::Loader::Generic here to prevent
# someone loading later (and redefine our subs) .
use Class::DBI::Loader::Generic;
package Class::DBI::Loader::Generic;
use strict;
use warnings;
no warnings 'redefine';
my %kinships ;
sub _has_a_many {
my ( $self, $fk_tn, $fk_cn, $uk_tn, $uk_cn ) = @_;
my $fk_class = $self->find_class($fk_tn) or return;
my $uk_class = $self->find_class($uk_tn) or return;
my $mn= lc $fk_class . 's';
warn qq/\# Has_a relationship\n/ if $self->debug;
my $hasa = "$fk_class ->has_a ( $fk_cn, $uk_class )";
warn "$hasa \n\n" if $self->debug;
push @{$kinships{ $fk_class }{has_a}} , $hasa ;
$fk_class -> has_a( $fk_cn, $uk_class );
warn qq/\# Has_many relationship\n/ if $self->debug;
my $many = "$uk_class ->has_many ( $mn,$fk_class,$fk_cn )";
warn "$many \n\n" if $self->debug;
push @{$kinships{ $uk_class }{has_many}} , $many ;
$uk_class -> has_many( $mn, $fk_class, $fk_cn ) ;
}
sub _relationships {
my $self = shift;
my $ns = $self->{_namespace}||'public' ;
foreach my $table ( $self->tables ) {
my $dbh = $self->find_class($table)->db_Main;
if ( my $sth = $dbh->foreign_key_info( '', $ns, '', '',$ns, $table) ) {
for my $res ( @{ $sth->fetchall_arrayref( {} ) } ) {
my $fk_tn = $res->{ FK_TABLE_NAME };
my $fk_cn = $res->{ FK_COLUMN_NAME };
my $uk_tn = $res->{ UK_TABLE_NAME };
my $uk_cn = $res->{ UK_COLUMN_NAME };
eval { $self->_has_a_many( $fk_tn, $fk_cn, $uk_tn, $uk_cn) };
warn qq/\# has_a_many failed "$@"\n\n/ if $@ && $self->debug;
}
}
}
}
sub kinships {
my ($self, $class, $kind) = @_ ;
return \%kinships unless $class;
{ all => $kinships{ $class } ,
has_a => $kinships{ $class }{ has_a },
has_many => $kinships{ $class }{ has_many },
'' => $kinships{ $class }
}->{lc $kind||''};
}
1;
__END__
=head1 NAME
Class::DBI::Loader::Kinship - Fixes to Class::DBI::Loader
=head1 SYNOPSIS
use Class::DBI::Loader::Kinship;
my $l = new Class::DBI::Loader::Kinship (
dsn => $ENV{ DBI_DSN },
user => $ENV{ DBI_USER },
password => $ENV{ DBI_PASS },
namespace => 'music',
exclude => '^pg_.*|sql_.*',
);
my @tables = $l->tables;
my @classes = $l->classes;
print Dumper $l->kinships;
print Dumper $l->kinships('music::Cd');
print Dumper $l->kinships('music::Cd', 'has_a');
print Dumper $l->kinships('music::Cd', 'has_many');
=head1 DESCRIPTION
A subclass of Class::DBI::Loader which introduces the 3rd argument to
has_many relations, adds support to schemas for Postgresql, and
provides a few additional fuctions. This package still dependends on its
subclass; and so far, I resisted to opt for cleaner code
and fork my own direction. The original Pg subclass is intentionally
prevented from loading so another can masquerade in its palace.
=head2 EXPORT
None by default.
=head1 SEE ALSO
L<Class::DBI::Loader>, L<Class::DBI::Loader::Pg>.
=head1 AUTHOR
Ioannis Tambouras, E<lt>ioannis@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2006 by Ioannis Tambouras
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.
=cut