From: Brandon Black Date: Sat, 21 Jan 2006 21:23:26 +0000 (+0000) Subject: Copying in DBIx::Class::Loader as a base to work from X-Git-Tag: 0.03000~56 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a78e3fed4e27d4e1b447ed425c14d82426e53e19;p=dbsrgits%2FDBIx-Class-Schema-Loader.git Copying in DBIx::Class::Loader as a base to work from --- diff --git a/DBIx-Class-Loader/Changes b/DBIx-Class-Loader/Changes new file mode 100644 index 0000000..bfd802e --- /dev/null +++ b/DBIx-Class-Loader/Changes @@ -0,0 +1,58 @@ +Revision history for Perl extension DBIx::Class::Loader + +0.14 Sat Jan 21 00:05:11 2006 + - Bugfix to pgsql tests + - Bugfix for pause/cpan module version parsing + +0.13 Thu Jan 19 06:40:11 2006 + - Test suite infrastructure overhauled + - New advanced relationship testing [chisel] + - Several relationship fixes + - some minor pod cleanup + - misc bugfixes + +0.12 Fri Jan 13 06:09:04 2006 + - Changed "comment" to "Comment" for mysql "SHOW TABLE STATUS" + - Added relationship tests for pg, mysql, and db2 + +0.11 Mon Jan 02 17:25:14 2006 + - use UNIVERSAL::require for loading the implementation class [Jason Kohles] + - docs fixes [Jason Kohles] + - fixed http://rt.cpan.org/NoAuth/Bug.html?id=16100 (implicit disconnects) [blblack] + - carp rather than croak if a table has no PKs [blblack] + - Added test for DB2 [blblack] + +0.10 Tue Dec 20 06:22:23 2005 + - Fixed foreign key relationships to columns other than primary keys [blblack] + - Fixed mysql test script [blblack] + - Some schema support added [castaway] + - DB2 support added [castaway] + +0.09 Mon Nov 07 18:00:00 2005 + - Updated mysql loader + +0.08 Mon Nov 07 18:00:00 2005 + - Fixed Pg loader + +0.07 Mon Nov 07 18:00:00 2005 + - Fixed mysql loader + +0.06 Thu Nov 03 18:00:00 2005 + - Fixed the _croak bug + +0.05 Wed Nov 02 18:00:00 2005 + - Fixed dump output + +0.04 Wed Nov 02 18:00:00 2005 + - Fixed Pg loader + +0.03 Wed Nov 02 18:00:00 2005 + - new version number :P + +0.02 Mon Oct 24 18:00:00 2005 + - Added $DBIx::Class::Loader::SCHEMA + - Fixed Pg loader + - Bumped version dependency. + +0.01 Mon Sep 19 00:00:00 2005 + - original version. diff --git a/DBIx-Class-Loader/Makefile.PL b/DBIx-Class-Loader/Makefile.PL new file mode 100644 index 0000000..bf05841 --- /dev/null +++ b/DBIx-Class-Loader/Makefile.PL @@ -0,0 +1,14 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + 'NAME' => 'DBIx::Class::Loader', + 'VERSION_FROM' => 'lib/DBIx/Class/Loader.pm', + 'PREREQ_PM' => { + Test::More => 0.32, + DBIx::Class => 0.03001, + DBI => 1.30, + Lingua::EN::Inflect => 0, + Text::Balanced => 0, + UNIVERSAL::require => 0.10, + }, +); diff --git a/DBIx-Class-Loader/lib/DBIx/Class/Loader.pm b/DBIx-Class-Loader/lib/DBIx/Class/Loader.pm new file mode 100644 index 0000000..1f434d4 --- /dev/null +++ b/DBIx-Class-Loader/lib/DBIx/Class/Loader.pm @@ -0,0 +1,120 @@ +package DBIx::Class::Loader; + +use strict; +use UNIVERSAL::require; + +our $VERSION = '0.14'; + +=head1 NAME + +DBIx::Class::Loader - Dynamic definition of DBIx::Class sub classes. + +=head1 SYNOPSIS + + use DBIx::Class::Loader; + + my $loader = DBIx::Class::Loader->new( + dsn => "dbi:mysql:dbname", + user => "root", + password => "", + namespace => "Data", + additional_classes => [qw/DBIx::Class::Foo/], + additional_base_classes => [qw/My::Stuff/], + left_base_classes => [qw/DBIx::Class::Bar/], + constraint => '^foo.*', + relationships => 1, + options => { AutoCommit => 1 }, + inflect => { child => 'children' }, + debug => 1, + ); + my $class = $loader->find_class('film'); # $class => Data::Film + my $obj = $class->find(1); + +use with mod_perl + +in your startup.pl + + # load all tables + use DBIx::Class::Loader; + my $loader = DBIx::Class::Loader->new( + dsn => "dbi:mysql:dbname", + user => "root", + password => "", + namespace => "Data", + ); + +in your web application. + + use strict; + + # you can use Data::Film directly + my $film = Data::Film->retrieve($id); + + +=head1 DESCRIPTION + +DBIx::Class::Loader automate the definition of DBIx::Class sub-classes by +scanning table schemas and setting up columns and primary keys. + +Class names are defined by table names and the namespace option, which is +required. + + +---------+-----------+--------------+ + | table | namespace | class | + +---------+-----------+--------------+ + | foo | Data | Data::Foo | + | foo_bar | MyDB | MyDB::FooBar | + +---------+-----------+--------------+ + +DBIx::Class::Loader supports MySQL, Postgres, SQLite and DB2. See +L for more, and L +for notes on writing your own db-specific subclass for an unsupported db. + +L and L are now obsolete, use L and this module instead. ;) + +=cut + +=head1 METHODS + +=head2 new + +Example in Synopsis above demonstrates the available arguments. For +detailed information on the arguments, see the +L documentation. + +=cut + +sub new { + my ( $class, %args ) = @_; + my $dsn = $args{dsn}; + my ($driver) = $dsn =~ m/^dbi:(\w*?)(?:\((.*?)\))?:/i; + $driver = 'SQLite' if $driver eq 'SQLite2'; + my $impl = "DBIx::Class::Loader::" . $driver; + $impl->require or + die qq/Couldn't require loader class "$impl", "$UNIVERSAL::require::ERROR"/; + return $impl->new(%args); +} + +=head1 AUTHOR + +Sebastian Riedel, C + +Based upon the work of IKEBE Tomohiro + +=head1 THANK YOU + +Adam Anderson, Andy Grundman, Autrijus Tang, Dan Kubb, David Naughton, +Randal Schwartz, Simon Flack and all the others who've helped. + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 SEE ALSO + +L + +=cut + +1; diff --git a/DBIx-Class-Loader/lib/DBIx/Class/Loader/DB2.pm b/DBIx-Class-Loader/lib/DBIx/Class/Loader/DB2.pm new file mode 100644 index 0000000..0fcb112 --- /dev/null +++ b/DBIx-Class-Loader/lib/DBIx/Class/Loader/DB2.pm @@ -0,0 +1,99 @@ +package DBIx::Class::Loader::DB2; + +use strict; +use base 'DBIx::Class::Loader::Generic'; +use DBI; +use Carp; + +=head1 NAME + +DBIx::Class::Loader::DB2 - DBIx::Class::Loader DB2 Implementation. + +=head1 SYNOPSIS + + use DBIx::Class::Loader; + + # $loader is a DBIx::Class::Loader::DB2 + my $loader = DBIx::Class::Loader->new( + dsn => "dbi:DB2:dbname", + user => "myuser", + password => "", + namespace => "Data", + schema => "MYSCHEMA", + dropschema => 0, + ); + my $class = $loader->find_class('film'); # $class => Data::Film + my $obj = $class->retrieve(1); + +=head1 DESCRIPTION + +See L. + +=cut + +sub _db_classes { + return (); +} + +sub _tables { + my $self = shift; + my %args = @_; + my $schema = uc ($args{schema} || ''); + my $dbh = DBI->connect( @{ $self->{_datasource} } ) or croak($DBI::errstr); + + # this is split out to avoid version parsing errors... + my $is_dbd_db2_gte_114 = ( $DBD::DB2::VERSION >= 1.14 ); + my @tables = $is_dbd_db2_gte_114 ? + $dbh->tables( { TABLE_SCHEM => '%', TABLE_TYPE => 'TABLE,VIEW' } ) + : $dbh->tables; + $dbh->disconnect; + # People who use table or schema names that aren't identifiers deserve + # what they get. Still, FIXME? + s/\"//g for @tables; + @tables = grep {!/^SYSIBM\./ and !/^SYSCAT\./ and !/^SYSSTAT\./} @tables; + @tables = grep {/^$schema\./} @tables if($schema); + return @tables; +} + +sub _table_info { + my ( $self, $table ) = @_; +# $|=1; +# print "_table_info($table)\n"; + my ($schema, $tabname) = split /\./, $table, 2; + # print "Schema: $schema, Table: $tabname\n"; + + # FIXME: Horribly inefficient and just plain evil. (JMM) + my $dbh = DBI->connect( @{ $self->{_datasource} } ) or croak($DBI::errstr); + $dbh->{RaiseError} = 1; + + my $sth = $dbh->prepare(<<'SQL') or die; +SELECT c.COLNAME +FROM SYSCAT.COLUMNS as c +WHERE c.TABSCHEMA = ? and c.TABNAME = ? +SQL + + $sth->execute($schema, $tabname) or die; + my @cols = map { @$_ } @{$sth->fetchall_arrayref}; + + $sth = $dbh->prepare(<<'SQL') or die; +SELECT kcu.COLNAME +FROM SYSCAT.TABCONST as tc +JOIN SYSCAT.KEYCOLUSE as kcu ON tc.constname = kcu.constname +WHERE tc.TABSCHEMA = ? and tc.TABNAME = ? and tc.TYPE = 'P' +SQL + + $sth->execute($schema, $tabname) or die; + $dbh->disconnect; + + my @pri = map { @$_ } @{$sth->fetchall_arrayref}; + + return ( \@cols, \@pri ); +} + +=head1 SEE ALSO + +L + +=cut + +1; diff --git a/DBIx-Class-Loader/lib/DBIx/Class/Loader/Generic.pm b/DBIx-Class-Loader/lib/DBIx/Class/Loader/Generic.pm new file mode 100644 index 0000000..5a7621e --- /dev/null +++ b/DBIx-Class-Loader/lib/DBIx/Class/Loader/Generic.pm @@ -0,0 +1,317 @@ +package DBIx::Class::Loader::Generic; + +use strict; +use base 'DBIx::Class::Componentised'; +use Carp; +use Lingua::EN::Inflect; +use UNIVERSAL::require; +require DBIx::Class::DB; +require DBIx::Class::Core; + +=head1 NAME + +DBIx::Class::Loader::Generic - Generic DBIx::Class::Loader Implementation. + +=head1 SYNOPSIS + +See L + +=head1 DESCRIPTION + +=head2 OPTIONS + +Available constructor options are: + +=head3 additional_base_classes + +List of additional base classes your table classes will use. + +=head3 left_base_classes + +List of additional base classes, that need to be leftmost. + +=head3 additional_classes + +List of additional classes which your table classes will use. + +=head3 constraint + +Only load tables matching regex. + +=head3 exclude + +Exclude tables matching regex. + +=head3 debug + +Enable debug messages. + +=head3 dsn + +DBI Data Source Name. + +=head3 namespace + +Namespace under which your table classes will be initialized. + +=head3 password + +Password. + +=head3 relationships + +Try to automatically detect/setup has_a and has_many relationships. + +=head3 inflect + +An hashref, which contains exceptions to Lingua::EN::Inflect::PL(). +Useful for foreign language column names. + +=head3 user + +Username. + +=head2 METHODS + +=cut + +=head3 new + +Not intended to be called directly. This is used internally by the +C method in L. + +=cut + +sub new { + my ( $class, %args ) = @_; + if ( $args{debug} ) { + no strict 'refs'; + *{"$class\::debug"} = sub { 1 }; + } + my $additional = $args{additional_classes} || []; + $additional = [$additional] unless ref $additional eq 'ARRAY'; + my $additional_base = $args{additional_base_classes} || []; + $additional_base = [$additional_base] + unless ref $additional_base eq 'ARRAY'; + my $left_base = $args{left_base_classes} || []; + $left_base = [$left_base] unless ref $left_base eq 'ARRAY'; + my $self = bless { + _datasource => + [ $args{dsn}, $args{user}, $args{password}, $args{options} ], + _namespace => $args{namespace}, + _additional => $additional, + _additional_base => $additional_base, + _left_base => $left_base, + _constraint => $args{constraint} || '.*', + _exclude => $args{exclude}, + _relationships => $args{relationships}, + _inflect => $args{inflect}, + _schema => $args{schema}, + _dropschema => $args{dropschema}, + CLASSES => {}, + }, $class; + warn qq/\### START DBIx::Class::Loader dump ###\n/ if $self->debug; + $self->_load_classes; + $self->_relationships if $self->{_relationships}; + warn qq/\### END DBIx::Class::Loader dump ###\n/ if $self->debug; + $self; +} + +=head3 find_class + +Returns a tables class. + + my $class = $loader->find_class($table); + +=cut + +sub find_class { + my ( $self, $table ) = @_; + return $self->{CLASSES}->{$table}; +} + +=head3 classes + +Returns a sorted list of classes. + + my $@classes = $loader->classes; + +=cut + +sub classes { + my $self = shift; + return sort values %{ $self->{CLASSES} }; +} + +=head3 debug + +Overload to enable debug messages. + +=cut + +sub debug { 0 } + +=head3 tables + +Returns a sorted list of tables. + + my @tables = $loader->tables; + +=cut + +sub tables { + my $self = shift; + return sort keys %{ $self->{CLASSES} }; +} + +# Overload in your driver class +sub _db_classes { croak "ABSTRACT METHOD" } + +# Setup has_a and has_many relationships +sub _belongs_to_many { + my ( $self, $table, $column, $other, $other_column ) = @_; + my $table_class = $self->find_class($table); + my $other_class = $self->find_class($other); + + warn qq/\# Belongs_to relationship\n/ if $self->debug; + + if($other_column) { + warn qq/$table_class->belongs_to( '$column' => '$other_class',/ + . qq/ { "foreign.$other_column" => "self.$column" },/ + . qq/ { accessor => 'filter' });\n\n/ + if $self->debug; + $table_class->belongs_to( $column => $other_class, + { "foreign.$other_column" => "self.$column" }, + { accessor => 'filter' } + ); + } + else { + warn qq/$table_class->belongs_to( '$column' => '$other_class' );\n\n/ + if $self->debug; + $table_class->belongs_to( $column => $other_class ); + } + + my ($table_class_base) = $table_class =~ /.*::(.+)/; + my $plural = Lingua::EN::Inflect::PL( lc $table_class_base ); + $plural = $self->{_inflect}->{ lc $table_class_base } + if $self->{_inflect} + and exists $self->{_inflect}->{ lc $table_class_base }; + + warn qq/\# Has_many relationship\n/ if $self->debug; + + if($other_column) { + warn qq/$other_class->has_many( '$plural' => '$table_class',/ + . qq/ { "foreign.$column" => "self.$other_column" } );\n\n/ + if $self->debug; + $other_class->has_many( $plural => $table_class, + { "foreign.$column" => "self.$other_column" } + ); + } + else { + warn qq/$other_class->has_many( '$plural' => '$table_class',/ + . qq/'$other_column' );\n\n/ + if $self->debug; + $other_class->has_many( $plural => $table_class, $column ); + } +} + +# Load and setup classes +sub _load_classes { + my $self = shift; + my @schema = ('schema' => $self->{_schema}) if($self->{_schema}); + my @tables = $self->_tables(@schema); + my @db_classes = $self->_db_classes(); + my $additional = join '', map "use $_;\n", @{ $self->{_additional} }; + my $additional_base = join '', map "use base '$_';\n", + @{ $self->{_additional_base} }; + my $left_base = join '', map "use base '$_';\n", @{ $self->{_left_base} }; + my $constraint = $self->{_constraint}; + my $exclude = $self->{_exclude}; + + my $namespace = $self->{_namespace}; + my $dbclass = "$namespace\::_db"; + $self->inject_base( $dbclass, 'DBIx::Class::DB' ); + $dbclass->connection( @{ $self->{_datasource} } ); + + foreach my $table (@tables) { + next unless $table =~ /$constraint/; + next if ( defined $exclude && $table =~ /$exclude/ ); + my ($schema, $tbl) = split /\./, $table; + my $tablename = lc $table; + if($tbl) { + $tablename = $self->{_dropschema} ? $tbl : lc $table; + } + my $class = $self->_table2class($schema, $tbl); + $self->inject_base( $class, $dbclass, 'DBIx::Class::Core' ); + $_->require for @db_classes; + $self->inject_base( $class, $_ ) for @db_classes; + warn qq/\# Initializing table "$table" as "$class"\n/ if $self->debug; + $class->table(lc $tablename); + my ( $cols, $pks ) = $self->_table_info($table); + carp("$table has no primary key") unless @$pks; + $class->add_columns(@$cols); + $class->set_primary_key(@$pks) if @$pks; + $self->{CLASSES}->{lc $tablename} = $class; + my $code = "package $class;\n$additional_base$additional$left_base"; + warn qq/$code/ if $self->debug; + warn qq/$class->table('$tablename');\n/ if $self->debug; + my $columns = join "', '", @$cols; + warn qq/$class->add_columns('$columns')\n/ if $self->debug; + my $primaries = join "', '", @$pks; + warn qq/$class->set_primary_key('$primaries')\n/ if $self->debug && @$pks; + eval $code; + croak qq/Couldn't load additional classes "$@"/ if $@; + unshift @{"$class\::ISA"}, $_ foreach ( @{ $self->{_left_base} } ); + } +} + +# Find and setup relationships +sub _relationships { + my $self = shift; + foreach my $table ( $self->tables ) { + my $dbh = $self->find_class($table)->storage->dbh; + my $quoter = $dbh->get_info(29) || q{"}; + if ( my $sth = $dbh->foreign_key_info( '', '', '', '', '', $table ) ) { + for my $res ( @{ $sth->fetchall_arrayref( {} ) } ) { + my $column = $res->{FK_COLUMN_NAME}; + my $other = $res->{UK_TABLE_NAME}; + my $other_column = $res->{UK_COLUMN_NAME}; + $column =~ s/$quoter//g; + $other =~ s/$quoter//g; + $other_column =~ s/$quoter//g; + eval { $self->_belongs_to_many( $table, $column, $other, + $other_column ) }; + warn qq/\# belongs_to_many failed "$@"\n\n/ + if $@ && $self->debug; + } + } + } +} + +# Make a class from a table +sub _table2class { + my ( $self, $schema, $table ) = @_; + my $namespace = $self->{_namespace} || ""; + $namespace =~ s/(.*)::$/$1/; + if($table) { + $schema = ucfirst lc $schema; + $namespace .= "::$schema" if(!$self->{_dropschema}); + } else { + $table = $schema; + } + my $subclass = join '', map ucfirst, split /[\W_]+/, lc $table; + my $class = $namespace ? "$namespace\::" . $subclass : $subclass; +} + +# Overload in driver class +sub _tables { croak "ABSTRACT METHOD" } + +sub _table_info { croak "ABSTRACT METHOD" } + +=head1 SEE ALSO + +L + +=cut + +1; diff --git a/DBIx-Class-Loader/lib/DBIx/Class/Loader/Pg.pm b/DBIx-Class-Loader/lib/DBIx/Class/Loader/Pg.pm new file mode 100644 index 0000000..babd80e --- /dev/null +++ b/DBIx-Class-Loader/lib/DBIx/Class/Loader/Pg.pm @@ -0,0 +1,76 @@ +package DBIx::Class::Loader::Pg; + +use strict; +use base 'DBIx::Class::Loader::Generic'; +use DBI; +use Carp; + +our $SCHEMA = 'public'; + +=head1 NAME + +DBIx::Class::Loader::Pg - DBIx::Class::Loader Postgres Implementation. + +=head1 SYNOPSIS + + use DBIx::Class::Loader; + + # $loader is a DBIx::Class::Loader::Pg + my $loader = DBIx::Class::Loader->new( + dsn => "dbi:Pg:dbname=dbname", + user => "postgres", + password => "", + namespace => "Data", + ); + my $class = $loader->find_class('film'); # $class => Data::Film + my $obj = $class->retrieve(1); + +=head1 DESCRIPTION + +See L. + +=cut + +sub _db_classes { + return qw/DBIx::Class::PK::Auto::Pg/; +} + +sub _tables { + my $self = shift; + my $dbh = DBI->connect( @{ $self->{_datasource} } ) or croak($DBI::errstr); + + # This is split out to avoid version parsing errors... + my $is_dbd_pg_gte_131 = ( $DBD::Pg::VERSION >= 1.31 ); + my @tables = $is_dbd_pg_gte_131 ? + $dbh->tables( undef, $SCHEMA, "", "table", { noprefix => 1, pg_noprefix => 1 } ) + : $dbh->tables; + + $dbh->disconnect; + s/"//g for @tables; + return @tables; +} + +sub _table_info { + my ( $self, $table ) = @_; + my $dbh = DBI->connect( @{ $self->{_datasource} } ) or croak($DBI::errstr); + + my $sth = $dbh->column_info(undef, $SCHEMA, $table, undef); + my @cols = map { $_->[3] } @{ $sth->fetchall_arrayref }; + s/"//g for @cols; + + my @primary = $dbh->primary_key(undef, $SCHEMA, $table); + + $dbh->disconnect; + + s/"//g for @primary; + + return ( \@cols, \@primary ); +} + +=head1 SEE ALSO + +L + +=cut + +1; diff --git a/DBIx-Class-Loader/lib/DBIx/Class/Loader/SQLite.pm b/DBIx-Class-Loader/lib/DBIx/Class/Loader/SQLite.pm new file mode 100644 index 0000000..466253f --- /dev/null +++ b/DBIx-Class-Loader/lib/DBIx/Class/Loader/SQLite.pm @@ -0,0 +1,153 @@ +package DBIx::Class::Loader::SQLite; + +use strict; +use base 'DBIx::Class::Loader::Generic'; +use Text::Balanced qw( extract_bracketed ); +use DBI; +use Carp; + +=head1 NAME + +DBIx::Class::Loader::SQLite - DBIx::Class::Loader SQLite Implementation. + +=head1 SYNOPSIS + + use DBIx::Class::Loader; + + # $loader is a DBIx::Class::Loader::SQLite + my $loader = DBIx::Class::Loader->new( + dsn => "dbi:SQLite:dbname=/path/to/dbfile", + namespace => "Data", + ); + my $class = $loader->find_class('film'); # $class => Data::Film + my $obj = $class->retrieve(1); + +=head1 DESCRIPTION + +See L. + +=cut + +sub _db_classes { + return qw/DBIx::Class::PK::Auto::SQLite/; +} + +sub _relationships { + my $self = shift; + foreach my $table ( $self->tables ) { + + my $dbh = $self->find_class($table)->storage->dbh; + my $sth = $dbh->prepare(<<""); +SELECT sql FROM sqlite_master WHERE tbl_name = ? + + $sth->execute($table); + my ($sql) = $sth->fetchrow_array; + $sth->finish; + + # Cut "CREATE TABLE ( )" blabla... + $sql =~ /^[\w\s]+\((.*)\)$/si; + my $cols = $1; + + # strip single-line comments + $cols =~ s/\-\-.*\n/\n/g; + + # temporarily replace any commas inside parens, + # so we don't incorrectly split on them below + my $cols_no_bracketed_commas = $cols; + while ( my $extracted = + ( extract_bracketed( $cols, "()", "[^(]*" ) )[0] ) + { + my $replacement = $extracted; + $replacement =~ s/,/--comma--/g; + $replacement =~ s/^\(//; + $replacement =~ s/\)$//; + $cols_no_bracketed_commas =~ s/$extracted/$replacement/m; + } + + # Split column definitions + for my $col ( split /,/, $cols_no_bracketed_commas ) { + + # put the paren-bracketed commas back, to help + # find multi-col fks below + $col =~ s/\-\-comma\-\-/,/g; + + # CDBI doesn't have built-in support multi-col fks, so ignore them + next if $col =~ s/^\s*FOREIGN\s+KEY\s*//i && $col =~ /^\([^,)]+,/; + + # Strip punctuations around key and table names + $col =~ s/[()\[\]'"]/ /g; + $col =~ s/^\s+//gs; + + # Grab reference + if ( $col =~ /^(\w+).*REFERENCES\s+(\w+)\s*(\w+)?/i ) { + chomp $col; + warn qq/\# Found foreign key definition "$col"\n\n/ + if $self->debug; + eval { $self->_belongs_to_many( $table, $1, $2, $3 ) }; + warn qq/\# belongs_to_many failed "$@"\n\n/ + if $@ && $self->debug; + } + } + } +} + +sub _tables { + my $self = shift; + my $dbh = DBI->connect( @{ $self->{_datasource} } ) or croak($DBI::errstr); + my $sth = $dbh->prepare("SELECT * FROM sqlite_master"); + $sth->execute; + my @tables; + while ( my $row = $sth->fetchrow_hashref ) { + next unless lc( $row->{type} ) eq 'table'; + push @tables, $row->{tbl_name}; + } + $dbh->disconnect; + return @tables; +} + +sub _table_info { + my ( $self, $table ) = @_; + + # find all columns. + my $dbh = DBI->connect( @{ $self->{_datasource} } ) or croak($DBI::errstr); + my $sth = $dbh->prepare("PRAGMA table_info('$table')"); + $sth->execute(); + my @columns; + while ( my $row = $sth->fetchrow_hashref ) { + push @columns, $row->{name}; + } + $sth->finish; + + # find primary key. so complex ;-( + $sth = $dbh->prepare(<<'SQL'); +SELECT sql FROM sqlite_master WHERE tbl_name = ? +SQL + $sth->execute($table); + my ($sql) = $sth->fetchrow_array; + $sth->finish; + $dbh->disconnect; + my ($primary) = $sql =~ m/ + (?:\(|\,) # either a ( to start the definition or a , for next + \s* # maybe some whitespace + (\w+) # the col name + [^,]* # anything but the end or a ',' for next column + PRIMARY\sKEY/sxi; + my @pks; + + if ($primary) { + @pks = ($primary); + } + else { + my ($pks) = $sql =~ m/PRIMARY\s+KEY\s*\(\s*([^)]+)\s*\)/; + @pks = split( m/\s*\,\s*/, $pks ) if $pks; + } + return ( \@columns, \@pks ); +} + +=head1 SEE ALSO + +L + +=cut + +1; diff --git a/DBIx-Class-Loader/lib/DBIx/Class/Loader/Writing.pm b/DBIx-Class-Loader/lib/DBIx/Class/Loader/Writing.pm new file mode 100644 index 0000000..7d1a10f --- /dev/null +++ b/DBIx-Class-Loader/lib/DBIx/Class/Loader/Writing.pm @@ -0,0 +1,49 @@ +package DBIx::Class::Loader::Writing; + +# Empty. POD only. + +1; + +=head1 NAME + +DBIx::Class::Loader::Writing - Loader subclass writing guide + +=head1 SYNOPSIS + + package DBIx::Class::Loader::Foo; + + # THIS IS JUST A TEMPLATE TO GET YOU STARTED. + + use strict; + use base 'DBIx::Class::Loader::Generic'; + use DBI; + use Carp; + + sub _db_classes { + return qw/DBIx::Class::PK::Auto::Foo/; + # You may want to return more, or less, than this. + } + + sub _tables { + my $self = shift; + my $dbh = DBI->connect( @{ $self->{_datasource} } ) + or croak($DBI::errstr); + return $dbh->tables; # Your DBD may need something different + } + + sub _table_info { + my ( $self, $table ) = @_; + ... + return ( \@cols, \@primary ); + } + + sub _relationships { + my $self = shift; + ... + $self->_belongs_to_many($table, $f_key, $f_table, $f_column); + # For each relationship you want to set up ($f_column is + # optional, default is $f_table's primary key) + ... + } + +=cut diff --git a/DBIx-Class-Loader/lib/DBIx/Class/Loader/mysql.pm b/DBIx-Class-Loader/lib/DBIx/Class/Loader/mysql.pm new file mode 100644 index 0000000..23e90f8 --- /dev/null +++ b/DBIx-Class-Loader/lib/DBIx/Class/Loader/mysql.pm @@ -0,0 +1,111 @@ +package DBIx::Class::Loader::mysql; + +use strict; +use base 'DBIx::Class::Loader::Generic'; +use DBI; +use Carp; + +=head1 NAME + +DBIx::Class::Loader::mysql - DBIx::Class::Loader mysql Implementation. + +=head1 SYNOPSIS + + use DBIx::Class::Loader; + + # $loader is a DBIx::Class::Loader::mysql + my $loader = DBIx::Class::Loader->new( + dsn => "dbi:mysql:dbname", + user => "root", + password => "", + namespace => "Data", + ); + my $class = $loader->find_class('film'); # $class => Data::Film + my $obj = $class->retrieve(1); + +=head1 DESCRIPTION + +See L. + +=cut + +sub _db_classes { + return qw/DBIx::Class::PK::Auto::MySQL/; +} + +# Very experimental and untested! +sub _relationships { + my $self = shift; + my @tables = $self->tables; + my $dbh = $self->find_class( $tables[0] )->storage->dbh; + my $dsn = $self->{_datasource}[0]; + my %conn = + $dsn =~ m/\Adbi:\w+(?:\(.*?\))?:(.+)\z/i + && index( $1, '=' ) >= 0 + ? split( /[=;]/, $1 ) + : ( database => $1 ); + my $dbname = $conn{database} || $conn{dbname} || $conn{db}; + die("Can't figure out the table name automatically.") if !$dbname; + + foreach my $table (@tables) { + my $query = "SHOW CREATE TABLE ${dbname}.${table}"; + my $sth = $dbh->prepare($query) + or die("Cannot get table definition: $table"); + $sth->execute; + my $table_def = $sth->fetchrow_arrayref->[1] || ''; + + my (@cols) = ($table_def =~ /CONSTRAINT `.*` FOREIGN KEY \(`(.*)`\) REFERENCES `(.*)` \(`(.*)`\)/g); + + while (scalar @cols > 0) { + my $column = shift @cols; + my $remote_table = shift @cols; + my $remote_column = shift @cols; + + eval { $self->_belongs_to_many( $table, $column, $remote_table, $remote_column) }; + warn qq/\# belongs_to_many failed "$@"\n\n/ if $@ && $self->debug; + } + + $sth->finish; + } +} + +sub _tables { + my $self = shift; + my $dbh = DBI->connect( @{ $self->{_datasource} } ) or croak($DBI::errstr); + my @tables; + foreach my $table ( $dbh->tables ) { + my $quoter = $dbh->get_info(29); + $table =~ s/$quoter//g if ($quoter); + push @tables, $1 + if $table =~ /\A(\w+)\z/; + } + $dbh->disconnect; + return @tables; +} + +sub _table_info { + my ( $self, $table ) = @_; + my $dbh = DBI->connect( @{ $self->{_datasource} } ) or croak($DBI::errstr); + + # MySQL 4.x doesn't support quoted tables + my $query = "DESCRIBE $table"; + my $sth = $dbh->prepare($query) or die("Cannot get table status: $table"); + $sth->execute; + my ( @cols, @pri ); + while ( my $hash = $sth->fetchrow_hashref ) { + my ($col) = $hash->{Field} =~ /(\w+)/; + push @cols, $col; + push @pri, $col if $hash->{Key} eq "PRI"; + } + + $dbh->disconnect; + return ( \@cols, \@pri ); +} + +=head1 SEE ALSO + +L + +=cut + +1; diff --git a/DBIx-Class-Loader/t/01use.t b/DBIx-Class-Loader/t/01use.t new file mode 100644 index 0000000..7222d5d --- /dev/null +++ b/DBIx-Class-Loader/t/01use.t @@ -0,0 +1,12 @@ +use strict; +use Test::More tests => 3; + +BEGIN { + use_ok 'DBIx::Class::Loader'; + SKIP: { + use_ok 'DBIx::Class::Loader::mysql'; + } + SKIP: { + use_ok 'DBIx::Class::Loader::Pg'; + } +} diff --git a/DBIx-Class-Loader/t/02pod.t b/DBIx-Class-Loader/t/02pod.t new file mode 100644 index 0000000..1647794 --- /dev/null +++ b/DBIx-Class-Loader/t/02pod.t @@ -0,0 +1,7 @@ +use Test::More; + +eval "use Test::Pod 1.14"; +plan skip_all => 'Test::Pod 1.14 required' if $@; +plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; + +all_pod_files_ok(); diff --git a/DBIx-Class-Loader/t/03podcoverage.t b/DBIx-Class-Loader/t/03podcoverage.t new file mode 100644 index 0000000..d91be5e --- /dev/null +++ b/DBIx-Class-Loader/t/03podcoverage.t @@ -0,0 +1,7 @@ +use Test::More; + +eval "use Test::Pod::Coverage 1.04"; +plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@; +plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; + +all_pod_coverage_ok(); diff --git a/DBIx-Class-Loader/t/10sqlite_common.t b/DBIx-Class-Loader/t/10sqlite_common.t new file mode 100644 index 0000000..7208977 --- /dev/null +++ b/DBIx-Class-Loader/t/10sqlite_common.t @@ -0,0 +1,23 @@ +use strict; +use lib qw( ./t ); +use dbixcl_common_tests; + +eval { require DBD::SQLite }; +my $class = $@ ? 'SQLite2' : 'SQLite'; + +{ + my $tester = dbixcl_common_tests->new( + vendor => 'SQLite', + auto_inc_pk => 'INTEGER NOT NULL PRIMARY KEY', + dsn => "dbi:$class:dbname=./t/sqlite_test", + user => '', + password => '', + multi_fk_broken => 1, + ); + + $tester->run_tests(); +} + +END { + unlink './t/sqlite_test'; +} diff --git a/DBIx-Class-Loader/t/11mysql_common.t b/DBIx-Class-Loader/t/11mysql_common.t new file mode 100644 index 0000000..f20479a --- /dev/null +++ b/DBIx-Class-Loader/t/11mysql_common.t @@ -0,0 +1,28 @@ +use strict; +use lib qw( . ./t ); +use dbixcl_common_tests; + +my $database = $ENV{MYSQL_NAME} || ''; +my $user = $ENV{MYSQL_USER} || ''; +my $password = $ENV{MYSQL_PASS} || ''; +my $test_innodb = $ENV{MYSQL_TEST_INNODB} || 0; + +my $skip_rels_msg = 'You need to set the MYSQL_TEST_INNODB environment variable to test relationships'; + +my $tester = dbixcl_common_tests->new( + vendor => 'Mysql', + auto_inc_pk => 'INTEGER NOT NULL PRIMARY KEY AUTO_INCREMENT', + innodb => q{Engine='InnoDB'}, + dsn => "dbi:mysql:$database", + user => $user, + password => $password, + skip_rels => $test_innodb ? 0 : $skip_rels_msg, + multi_fk_broken => 1, +); + +if( !$database || !$user ) { + $tester->skip_tests('You need to set the MYSQL_NAME, MYSQL_USER and MYSQL_PASS environment variables'); +} +else { + $tester->run_tests(); +} diff --git a/DBIx-Class-Loader/t/12pg_common.t b/DBIx-Class-Loader/t/12pg_common.t new file mode 100644 index 0000000..56a4194 --- /dev/null +++ b/DBIx-Class-Loader/t/12pg_common.t @@ -0,0 +1,22 @@ +use strict; +use lib qw( . ./t ); +use dbixcl_common_tests; + +my $database = $ENV{PG_NAME} || ''; +my $user = $ENV{PG_USER} || ''; +my $password = $ENV{PG_PASS} || ''; + +my $tester = dbixcl_common_tests->new( + vendor => 'Pg', + auto_inc_pk => 'SERIAL NOT NULL PRIMARY KEY', + dsn => "dbi:Pg:dbname=$database", + user => $user, + password => $password, +); + +if( !$database || !$user ) { + $tester->skip_tests('You need to set the PG_NAME, PG_USER and PG_PASS environment variables'); +} +else { + $tester->run_tests(); +} diff --git a/DBIx-Class-Loader/t/13db2_common.t b/DBIx-Class-Loader/t/13db2_common.t new file mode 100644 index 0000000..de5318f --- /dev/null +++ b/DBIx-Class-Loader/t/13db2_common.t @@ -0,0 +1,22 @@ +use strict; +use lib qw( . ./t ); +use dbixcl_common_tests; + +my $database = $ENV{DB2_NAME} || ''; +my $user = $ENV{DB2_USER} || ''; +my $password = $ENV{DB2_PASS} || ''; + +my $tester = dbixcl_common_tests->new( + vendor => 'DB2', + auto_inc_pk => 'SERIAL NOT NULL PRIMARY KEY', + dsn => "dbi:DB2:$database", + user => $user, + password => $password, +); + +if( !$database || !$user ) { + $tester->skip_tests('You need to set the DB2_NAME, DB2_USER and DB2_PASS environment variables'); +} +else { + $tester->run_tests(); +} diff --git a/DBIx-Class-Loader/t/dbixcl_common_tests.pm b/DBIx-Class-Loader/t/dbixcl_common_tests.pm new file mode 100644 index 0000000..57c1256 --- /dev/null +++ b/DBIx-Class-Loader/t/dbixcl_common_tests.pm @@ -0,0 +1,372 @@ +package dbixcl_common_tests; + +use strict; + +use Test::More; +use DBIx::Class::Loader; +use DBI; + +sub new { + my $class = shift; + + my $self; + + if( ref($_[0]) eq 'HASH') { + my $args = shift; + $self = { (%$args) }; + } + else { + $self = { @_ }; + } + + # Only MySQL uses this + $self->{innodb} ||= ''; + + return bless $self => $class; +} + +sub skip_tests { + my ($self, $why) = @_; + + plan skip_all => $why; +} + +sub run_tests { + my $self = shift; + + plan tests => 26; + + $self->create(); + + my $namespace = 'DBIXCL_Test_' . $self->{vendor}; + + my $loader = DBIx::Class::Loader->new( + dsn => $self->{dsn}, + user => $self->{user}, + password => $self->{password}, + namespace => $namespace, + constraint => '^loader_test.*', + relationships => 1, + ); + + my $class1 = $loader->find_class("loader_test1"); + my $class2 = $loader->find_class("loader_test2"); + + is( $class1, "${namespace}::LoaderTest1" ); + is( $class2, "${namespace}::LoaderTest2" ); + + my $obj = $class1->find(1); + is( $obj->id, 1 ); + is( $obj->dat, "foo" ); + is( $class2->count, 4 ); + + my ($obj2) = $class2->find( dat => 'bbb' ); + is( $obj2->id, 2 ); + + SKIP: { + skip $self->{skip_rels}, 20 if $self->{skip_rels}; + + my $class3 = $loader->find_class("loader_test3"); + my $class4 = $loader->find_class("loader_test4"); + my $class5 = $loader->find_class("loader_test5"); + my $class6 = $loader->find_class("loader_test6"); + my $class7 = $loader->find_class("loader_test7"); + my $class8 = $loader->find_class("loader_test8"); + my $class9 = $loader->find_class("loader_test9"); + + is( $class3, "${namespace}::LoaderTest3" ); + is( $class4, "${namespace}::LoaderTest4" ); + is( $class5, "${namespace}::LoaderTest5" ); + is( $class6, "${namespace}::LoaderTest6" ); + is( $class7, "${namespace}::LoaderTest7" ); + is( $class8, "${namespace}::LoaderTest8" ); + is( $class9, "${namespace}::LoaderTest9" ); + + # basic rel test + my $obj4 = $class4->find(123); + is( ref($obj4->fkid), $class3); + + # fk def in comments should not be parsed + my $obj5 = $class5->find( id1 => 1, id2 => 1 ); + is( ref( $obj5->id2 ), '' ); + + # mulit-col fk def (works halfway for some, not others...) + my $obj6 = $class6->find(1); + isa_ok( $obj6->loader_test2, $class2 ); + SKIP: { + skip "Multi-column FKs are only half-working for this vendor", 1 + unless $self->{multi_fk_broken}; + is( ref( $obj6->id2 ), '' ); + } + + # fk that references a non-pk key (UNIQUE) + my $obj8 = $class8->find(1); + isa_ok( $obj8->loader_test7, $class7 ); + + # from Chisel's tests... + SKIP: { + if($self->{vendor} =~ /sqlite/i) { + skip 'SQLite cannot do the advanced tests', 8; + } + + my $class10 = $loader->find_class('loader_test10'); + my $class11 = $loader->find_class('loader_test11'); + + is( $class10, "${namespace}::LoaderTest10" ); + is( $class11, "${namespace}::LoaderTest11" ); + + my $obj10 = $class10->create({ subject => 'xyzzy' }); + + $obj10->update(); + ok( defined $obj10, '$obj10 is defined' ); + + my $obj11 = $class11->create({ loader_test10 => $obj10->id() }); + $obj11->update(); + ok( defined $obj11, '$obj11 is defined' ); + + eval { + my $obj10_2 = $obj11->loader_test10; + $obj10_2->loader_test11( $obj11->id11() ); + $obj10_2->update(); + }; + is($@, '', 'No errors after eval{}'); + + SKIP: { + skip 'Previous eval block failed', 3 + unless ($@ eq ''); + + my $results = $class10->search({ subject => 'xyzzy' }); + is( $results->count(), 1, + 'One $class10 returned from search' ); + + my $obj10_3 = $results->first(); + isa_ok( $obj10_3, $class10 ); + is( $obj10_3->loader_test11()->id(), $obj11->id(), + 'found same $class11 object we expected' ); + } + + for ( $class10, $class11 ) { + $_->storage->dbh->disconnect; + } + } + + for ( $class3, $class4, $class5, $class6, $class7, + $class8, $class9 ) { + $_->storage->dbh->disconnect; + } + } + + for ( $class1, $class2 ) { + $_->storage->dbh->disconnect; + } +} + +sub dbconnect { + my ($self, $complain) = @_; + + DBI->connect( + $self->{dsn}, $self->{user}, + $self->{password}, + { + RaiseError => $complain, + PrintError => $complain, + AutoCommit => 1, + } + ); +} + +sub create { + my $self = shift; + + my @statements = ( + qq{ + CREATE TABLE loader_test1 ( + id $self->{auto_inc_pk}, + dat VARCHAR(32) + ) $self->{innodb}; + }, + + q{ INSERT INTO loader_test1 (dat) VALUES('foo'); }, + q{ INSERT INTO loader_test1 (dat) VALUES('bar'); }, + q{ INSERT INTO loader_test1 (dat) VALUES('baz'); }, + + qq{ + CREATE TABLE loader_test2 ( + id $self->{auto_inc_pk}, + dat VARCHAR(32) + ) $self->{innodb}; + }, + + q{ INSERT INTO loader_test2 (dat) VALUES('aaa'); }, + q{ INSERT INTO loader_test2 (dat) VALUES('bbb'); }, + q{ INSERT INTO loader_test2 (dat) VALUES('ccc'); }, + q{ INSERT INTO loader_test2 (dat) VALUES('ddd'); }, + ); + + my @statements_reltests = ( + qq{ + CREATE TABLE loader_test3 ( + id INTEGER NOT NULL PRIMARY KEY, + dat VARCHAR(32) + ) $self->{innodb}; + }, + + q{ INSERT INTO loader_test3 (id,dat) VALUES(1,'aaa'); }, + q{ INSERT INTO loader_test3 (id,dat) VALUES(2,'bbb'); }, + q{ INSERT INTO loader_test3 (id,dat) VALUES(3,'ccc'); }, + q{ INSERT INTO loader_test3 (id,dat) VALUES(4,'ddd'); }, + + qq{ + CREATE TABLE loader_test4 ( + id INTEGER NOT NULL PRIMARY KEY, + fkid INTEGER NOT NULL, + dat VARCHAR(32), + FOREIGN KEY (fkid) REFERENCES loader_test3 (id) + ) $self->{innodb}; + }, + + q{ INSERT INTO loader_test4 (id,fkid,dat) VALUES(123,1,'aaa'); }, + q{ INSERT INTO loader_test4 (id,fkid,dat) VALUES(124,2,'bbb'); }, + q{ INSERT INTO loader_test4 (id,fkid,dat) VALUES(125,3,'ccc'); }, + q{ INSERT INTO loader_test4 (id,fkid,dat) VALUES(126,4,'ddd'); }, + + qq{ + CREATE TABLE loader_test5 ( + id1 INTEGER, + id2 INTEGER, -- , id2 INTEGER REFERENCES loader_test1, + dat TEXT, + PRIMARY KEY (id1,id2) + ) $self->{innodb}; + }, + + q{ INSERT INTO loader_test5 (id1,id2,dat) VALUES (1,1,'aaa'); }, + + qq{ + CREATE TABLE loader_test6 ( + id $self->{auto_inc_pk}, + id2 INTEGER, + loader_test2 INTEGER, + dat TEXT, + FOREIGN KEY (loader_test2) REFERENCES loader_test2 (id), + FOREIGN KEY (id, id2 ) REFERENCES loader_test5 (id1,id2) + ) $self->{innodb}; + }, + + (q{ INSERT INTO loader_test6 (id2,loader_test2,dat) } . + q{ VALUES (1,1,'aaa'); }), + + qq{ + CREATE TABLE loader_test7 ( + id INTEGER NOT NULL PRIMARY KEY, + id2 VARCHAR(8) NOT NULL UNIQUE, + dat TEXT + ) $self->{innodb}; + }, + + q{ INSERT INTO loader_test7 (id,id2,dat) VALUES (1,'aaa','bbb'); }, + + qq{ + CREATE TABLE loader_test8 ( + id INTEGER NOT NULL PRIMARY KEY, + loader_test7 VARCHAR(8) NOT NULL, + dat TEXT, + FOREIGN KEY (loader_test7) REFERENCES loader_test7 (id2) + ) $self->{innodb}; + }, + + (q{ INSERT INTO loader_test8 (id,loader_test7,dat) } . + q{ VALUES (1,'aaa','bbb'); }), + + qq{ + CREATE TABLE loader_test9 ( + loader_test9 TEXT NOT NULL + ) $self->{innodb}; + }, + ); + + my @statements_advanced = ( + qq{ + CREATE TABLE loader_test10 ( + id10 $self->{auto_inc_pk}, + subject VARCHAR(8), + loader_test11 INTEGER + ) $self->{innodb}; + }, + + qq{ + CREATE TABLE loader_test11 ( + id11 $self->{auto_inc_pk}, + message VARCHAR(8) DEFAULT 'foo', + loader_test10 INTEGER NOT NULL, + FOREIGN KEY (loader_test10) REFERENCES loader_test10 (id10) + ) $self->{innodb}; + }, + + (q{ ALTER TABLE loader_test10 ADD CONSTRAINT } . + q{ loader_test11_fk FOREIGN KEY (loader_test11) } . + q{ REFERENCES loader_test11 (id11); }), + ); + + $self->{created} = 1; + + my $dbh = $self->dbconnect(1); + $dbh->do($_) for (@statements); + unless($self->{skip_rels}) { + $dbh->do($_) for (@statements_reltests); + unless($self->{vendor} =~ /sqlite/i) { + $dbh->do($_) for (@statements_advanced); + } + } + $dbh->disconnect(); +} + +sub DESTROY { + my $self = shift; + + return unless $self->{created}; + + my @tables = qw/ + loader_test1 + loader_test2 + /; + + my @tables_reltests = qw/ + loader_test4 + loader_test3 + loader_test6 + loader_test5 + loader_test8 + loader_test7 + loader_test9 + /; + + my @tables_advanced = qw/ + loader_test11 + loader_test10 + /; + + my $drop_fk_mysql = + q{ALTER TABLE loader_test10 DROP FOREIGN KEY loader_test11_fk;}; + + my $drop_fk = + q{ALTER TABLE loader_test10 DROP CONSTRAINT loader_test11_fk;}; + + my $dbh = $self->dbconnect(0); + + unless($self->{skip_rels}) { + $dbh->do("DROP TABLE $_") for (@tables_reltests); + unless($self->{vendor} =~ /sqlite/i) { + if($self->{vendor} =~ /mysql/i) { + $dbh->do($drop_fk_mysql); + } + else { + $dbh->do($drop_fk); + } + $dbh->do("DROP TABLE $_") for (@tables_advanced); + } + } + $dbh->do("DROP TABLE $_") for (@tables); + $dbh->disconnect(); +} + +1;