Class-DBI-Loader-0.34/0000755000076500007650000000000010600465104015407 5ustar daisukedaisuke00000000000000Class-DBI-Loader-0.34/Changes0000644000076500007650000001025710600464772016721 0ustar daisukedaisuke00000000000000Revision history for Perl extension Class::DBI::Loader 0.34 Thu Mar 22 20:30:00 2007 - Apply patch by Kim Scheibel to allow mysql table with catalog name separators 0.33 Thu May 25 00:00:00 2006 - Implement the 'require' parameter. Suggested by esh at exile.ru 0.32 Sun Mar 05 01:10:00 2006 - Explicitly disconnect inside _table() for SQLite.pm and Pg.pm - Apply patch from rt #17546, and work with foreign keys in mysql 5. 0.31 Thu Feb 23 18:10:00 2006 - Fix Class::DBI::Loader::mysql (rt #13689). Patch by Raphael Kraus - Add missing use lib in t/04mysql.t 0.30 Sat Feb 04 23:05:00 2006 - I had completely misunderstood the subtle semantics of the way the classes were being constructed, especially the class hierarchy created by additional_base and left_base. The old behavior has been restored. 0.29 Tue Jan 31 11:12:00 2006 - Document 'options' parameter - Explicitly require Class::DBI::Pg >= 0.07 when the target database is PostgreSQL 8.x 0.28 Sat Jan 28 08:45:00 2006 - Forgot to update MANIFEST, which lead to failing tests. 0.27 Fri Jan 27 11:43:00 2006 - Inline use base () calls when generating classes. - Use connection() over set_db(), if available. - Test for additional_base_classes and left_base_classes - Shut up t/03podcoverage.t failure. Reporeted by Kenichi Ishigaki 0.26 Thu Jan 26 11:26:00 2006 - Changes that went into 0.25 didn't fix the problems described in dbdpg-general mailing lists. http://gborg.postgresql.org/pipermail/dbdpg-general/2006-January/001954.html Toby Corkindale gave me the tests to properly test the problem, and I was able to verify it. 0.25 Thu Jan 26 02:14:00 2006 - Pg: disconnect from database after getting the list of tables - Maintainer changed to Daisuke Maki. 0.24 Tue XXX XX 00:00:00 2005 - Strip punctuations around key and table names for SQLite (Autrijus Tang) 0.23 Tue Jun 14 01:00:00 2005 - fixed mysql loader, escape with backticks (Andy Grundman) - debug output is now usable code!!! 0.22 Thu Jun 11 23:00:00 2005 - fixed pod - second try for a sane release 0.21 Thu Jun 09 23:00:00 2005 - added inflect support (Uwe Voelker) - added Class::DBI::Sweet support (Uwe Voelker) 0.20 Sun May 29 01:00:00 2005 - better errors 0.19 Sat Apr 16 23:00:00 2005 - improved SQLite support (multi column keys, comments...) (David Naughton) 0.18 Fri Apr 08 18:00:00 2005 - added pod tests for kwalitee - fixed that annoying mysql quoter bug (Andy Grundman) 0.17 Sat Feb 12 01:00:00 2005 - exclude support (David Naughton) 0.16 Sun Feb 20 17:00:00 2005 - added $dbh->disconnect to mysql loader (Dan Kubb) 0.15 Sat Feb 19 20:00:00 2005 - fixed DBD::Pg 1.39_02 compatibility (chocolateboy) 0.14 Fri Feb 04 18:00:00 2005 - bugfixes 0.13 Fri Feb 04 02:00:00 2005 - misc mysql fixes (Dan Kubb) 0.12 Thu Jan 27 07:00:00 2004 - automatic relationships for SQLite - automatic relationships for MySQL (Adam Anderson) 0.11 Mon Dec 20 20:00:00 2004 - support for SQLite2 (Marcus Ramberg) 0.10 Wed Dec 15 01:00:00 2004 - support for automatic has_a and has_many relationships, big thanks to Randal Schwartz for his article about this! - better documentation - cleanup 0.07 Thu Dec 14 22:00:00 2004 - better documentation 0.06 Thu Dec 14 21:00:00 2004 - cleanup, driver classes now just define _tables() and _db_class() (Simon Flack) - constraint support, only load tables matching regex - aditional_classes support (Simon Flack) - additional_base_classes support - new tests 0.05 Sat Nov 13 19:30:00 2004 - more cleanup 0.04 Sat Nov 13 19:00:00 2004 - cleanup 0.03 Sun Jul 11 00:00:00 2004 - fixed Pg $dbh->tables. 0.02 Tue Feb 24 00:00:00 2004 - fixed mysql quoted table names problem. 0.01 Mon Aug 26 00:00:00 2004 - original version. Class-DBI-Loader-0.34/lib/0000755000076500007650000000000010600465104016155 5ustar daisukedaisuke00000000000000Class-DBI-Loader-0.34/lib/Class/0000755000076500007650000000000010600465104017222 5ustar daisukedaisuke00000000000000Class-DBI-Loader-0.34/lib/Class/DBI/0000755000076500007650000000000010600465104017620 5ustar daisukedaisuke00000000000000Class-DBI-Loader-0.34/lib/Class/DBI/Loader/0000755000076500007650000000000010600465104021026 5ustar daisukedaisuke00000000000000Class-DBI-Loader-0.34/lib/Class/DBI/Loader/Generic.pm0000644000076500007650000001436010435405554022755 0ustar daisukedaisuke00000000000000package Class::DBI::Loader::Generic; use strict; use vars qw($VERSION); use Carp; use Lingua::EN::Inflect; $VERSION = '0.30'; =head1 NAME Class::DBI::Loader::Generic - Generic Class::DBI::Loader Implementation. =head1 SYNOPSIS See L =head1 DESCRIPTION =head1 METHODS =head2 new %args See the documentation for Cnew()> =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}, _require => $args{require}, _require_warn => $args{require_warn}, CLASSES => {}, }, $class; warn qq/\### START Class::DBI::Loader dump ###\n/ if $self->debug; $self->_load_classes; $self->_relationships if $self->{_relationships}; warn qq/\### END Class::DBI::Loader dump ###\n/ if $self->debug; # disconnect to avoid confusion. foreach my $table ($self->tables) { $self->find_class($table)->db_Main->disconnect; } $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_class { croak "ABSTRACT METHOD" } # Setup has_a and has_many relationships sub _has_a_many { my ( $self, $table, $column, $other ) = @_; my $table_class = $self->find_class($table); my $other_class = $self->find_class($other); warn qq/\# Has_a relationship\n/ if $self->debug; warn qq/$table_class->has_a( '$column' => '$other_class' );\n\n/ if $self->debug; $table_class->has_a( $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; warn qq/$other_class->has_many( '$plural' => '$table_class' );\n\n/ if $self->debug; $other_class->has_many( $plural => $table_class ); } # Load and setup classes sub _load_classes { my $self = shift; my @tables = $self->_tables(); my $db_class = $self->_db_class(); 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 $use_connection = $Class::DBI::VERSION >= 0.96; foreach my $table (@tables) { next unless $table =~ /$constraint/; next if ( defined $exclude && $table =~ /$exclude/ ); my $class = $self->_table2class($table); warn qq/\# Initializing table "$table" as "$class"\n/ if $self->debug; { no strict 'refs'; @{"$class\::ISA"} = $db_class; } if ($use_connection) { $class->connection(@{$self->{_datasource}}); } else { $class->set_db( Main => @{ $self->{_datasource} } ); } $class->set_up_table($table); $self->{CLASSES}->{$table} = $class; my $code = "package $class;$additional_base$additional$left_base"; warn qq/$code/ if $self->debug; warn qq/$class->table('$table');\n\n/ if $self->debug; eval $code; croak qq/Couldn't load additional classes "$@"/ if $@; { no strict 'refs'; unshift @{"$class\::ISA"}, $_ foreach ( @{ $self->{_left_base} } ); } if ($self->{_require}) { eval "require $class"; if ($self->{_require_warn} && $@ && $@ !~ /Can't locate/) { warn; } } } } # Find and setup relationships sub _relationships { my $self = shift; foreach my $table ( $self->tables ) { my $dbh = $self->find_class($table)->db_Main; 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}; eval { $self->_has_a_many( $table, $column, $other ) }; warn qq/\# has_a_many failed "$@"\n\n/ if $@ && $self->debug; } } } } # Make a class from a table sub _table2class { my ( $self, $table ) = @_; my $namespace = $self->{_namespace} || ""; $namespace =~ s/(.*)::$/$1/; my $subclass = join '', map ucfirst, split /[\W_]+/, $table; my $class = $namespace ? "$namespace\::" . $subclass : $subclass; } # Overload in driver class sub _tables { croak "ABSTRACT METHOD" } =head1 SEE ALSO L, L, L, L =cut 1; Class-DBI-Loader-0.34/lib/Class/DBI/Loader/mysql.pm0000644000076500000000000000652410600464124022176 0ustar daisukewheel00000000000000package Class::DBI::Loader::mysql; use strict; use base 'Class::DBI::Loader::Generic'; use vars '$VERSION'; use DBI; use Carp; use Class::DBI; require Class::DBI::mysql; require Class::DBI::Loader::Generic; $VERSION = '0.30'; =head1 NAME Class::DBI::Loader::mysql - Class::DBI::Loader mysql Implementation. =head1 SYNOPSIS use Class::DBI::Loader; # $loader is a Class::DBI::Loader::mysql my $loader = Class::DBI::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, L. =cut sub _db_class { return 'Class::DBI::mysql' } # Very experimental and untested! sub _relationships { my $self = shift; my @tables = $self->tables; my $dbh = $self->find_class( $tables[0] )->db_Main; my $dsn = $self->{_datasource}[0]; my %conn = $dsn =~ m/^dbi:\w+:([\w=]+)/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; my $quoter = $dbh->get_info(29); my $is_mysql5 = $dbh->get_info(18) =~ /^5./; foreach my $table (@tables) { if ( $is_mysql5 ) { my $query = qq( SELECT column_name, referenced_table_name FROM information_schema.key_column_usage WHERE referenced_table_name IS NOT NULL AND table_schema = ? AND table_name = ? ); my $sth = $dbh->prepare($query) or die("Cannot get table information: $table"); $sth->execute($dbname, $table); while ( my $data = $sth->fetchrow_hashref ) { eval { $self->_has_a_many( $table, $data->{column_name}, $data->{referenced_table_name} ) }; warn qq/\# has_a_many failed "$@"\n\n/ if $@ && $self->debug; } $sth->finish; } else { my $query = "SHOW TABLE STATUS FROM $dbname LIKE '$table'"; my $sth = $dbh->prepare($query) or die("Cannot get table status: $table"); $sth->execute; my $comment = $sth->fetchrow_hashref->{comment}; $comment =~ s/$quoter//g if ($quoter); while ( $comment =~ m!\(`?(\w+)`?\)\sREFER\s`?\w+/(\w+)`?\(`?\w+`?\)!g ) { eval { $self->_has_a_many( $table, $1, $2 ) }; warn qq/\# has_a_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 ) { if(my $catalog_sep = quotemeta($dbh->get_info(41))) { $table = (split($catalog_sep, $table))[-1] if $table =~ m/$catalog_sep/; } my $quoter = $dbh->get_info(29); $table =~ s/$quoter//g if ($quoter); push @tables, $1 if $table =~ /\A(\w+)\z/; } $dbh->disconnect; return @tables; } =head1 SEE ALSO L, L =cut 1; Class-DBI-Loader-0.34/lib/Class/DBI/Loader/Pg.pm0000644000076500007650000000321110402333616021731 0ustar daisukedaisuke00000000000000package Class::DBI::Loader::Pg; use strict; use base 'Class::DBI::Loader::Generic'; use vars '$VERSION'; use DBI; use Carp; require Class::DBI::Pg; require Class::DBI::Loader::Generic; $VERSION = '0.30'; =head1 NAME Class::DBI::Loader::Pg - Class::DBI::Loader Postgres Implementation. =head1 SYNOPSIS use Class::DBI::Loader; # $loader is a Class::DBI::Loader::Pg my $loader = Class::DBI::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, L. =cut sub _db_class { return 'Class::DBI::Pg' } sub _tables { my $self = shift; my $dbh = DBI->connect( @{ $self->{_datasource} } ) or croak($DBI::errstr); # we do this check here because we don't really want to include this as # a pre-requisite in the Makefile.PL for all those non-Pg users my $sth = $dbh->prepare("SELECT version()"); $sth->execute(); my($vstr) = $sth->fetchrow_array(); $sth->finish; my($pg_version) = $vstr =~ /^PostgreSQL ([\d\.]{3})/; if ($pg_version >= 8 && $Class::DBI::Pg::VERSION < 0.07) { die "Class::DBI::Pg $Class::DBI::Pg::VERSION does not support PostgreSQL > 8.x"; } my @tables = ( $DBD::Pg::VERSION >= 1.31 ) ? $dbh->tables( undef, "public", "", "table", { noprefix => 1, pg_noprefix => 1 } ) : $dbh->tables; $dbh->disconnect; return @tables; } =head1 SEE ALSO L, L =cut 1; Class-DBI-Loader-0.34/lib/Class/DBI/Loader/SQLite.pm0000644000076500007650000000653710402333600022533 0ustar daisukedaisuke00000000000000package Class::DBI::Loader::SQLite; use strict; use base 'Class::DBI::Loader::Generic'; use vars '$VERSION'; use Text::Balanced qw( extract_bracketed ); use DBI; use Carp; require Class::DBI::SQLite; require Class::DBI::Loader::Generic; $VERSION = '0.30'; =head1 NAME Class::DBI::Loader::SQLite - Class::DBI::Loader SQLite Implementation. =head1 SYNOPSIS use Class::DBI::Loader; # $loader is a Class::DBI::Loader::SQLite my $loader = Class::DBI::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 Multi-column primary keys are supported. It's also fine to define multi-column foreign keys, but they will be ignored because L does not support them. See L, L. =cut sub _db_class { return 'Class::DBI::SQLite' } sub _relationships { my $self = shift; foreach my $table ( $self->tables ) { my $dbh = $self->find_class($table)->db_Main; 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+)/i ) { chomp $col; warn qq/\# Found foreign key definition "$col"\n\n/ if $self->debug; eval { $self->_has_a_many( $table, $1, $2 ) }; warn qq/\# has_a_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}; } $sth->finish; $dbh->disconnect; return @tables; } =head1 SEE ALSO L, L =cut 1; Class-DBI-Loader-0.34/lib/Class/DBI/Loader.pm0000644000076500007650000001004610600464461021372 0ustar daisukedaisuke00000000000000package Class::DBI::Loader; use strict; use vars '$VERSION'; $VERSION = '0.34'; =head1 NAME Class::DBI::Loader - Dynamic definition of Class::DBI sub classes. =head1 SYNOPSIS use Class::DBI::Loader; my $loader = Class::DBI::Loader->new( dsn => "dbi:mysql:dbname", user => "root", password => "", options => { RaiseError => 1, AutoCommit => 0 }, namespace => "Data", additional_classes => qw/Class::DBI::AbstractSearch/, # or arrayref additional_base_classes => qw/My::Stuff/, # or arrayref left_base_classes => qw/Class::DBI::Sweet/, # or arrayref constraint => '^foo.*', relationships => 1, options => { AutoCommit => 1 }, inflect => { child => 'children' }, require => 1 ); my $class = $loader->find_class('film'); # $class => Data::Film my $obj = $class->retrieve(1); use with mod_perl in your startup.pl # load all tables use Class::DBI::Loader; my $loader = Class::DBI::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 Class::DBI::Loader automate the definition of Class::DBI sub-classes. scan table schemas and setup columns, primary key. class names are defined by table names and namespace option. +-----------+-----------+-----------+ | table | namespace | class | +-----------+-----------+-----------+ | foo | Data | Data::Foo | | foo_bar | | FooBar | +-----------+-----------+-----------+ Class::DBI::Loader supports MySQL, Postgres and SQLite. See L. =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 = "Class::DBI::Loader::" . $driver; eval qq/use $impl/; die qq/Couldn't require loader class "$impl", "$@"/ if $@; return $impl->new(%args); } =head1 METHODS =head2 new %args =over 4 =item additional_base_classes List of additional base classes your table classes will use. =item left_base_classes List of additional base classes, that need to be leftmost, for example L (former L). =item additional_classes List of additional classes which your table classes will use. =item constraint Only load tables matching regex. =item exclude Exclude tables matching regex. =item debug Enable debug messages. =item dsn DBI Data Source Name. =item namespace Namespace under which your table classes will be initialized. =item password Password. =item options Optional hashref to specify DBI connect options =item relationships Try to automatically detect/setup has_a and has_many relationships. =item inflect An hashref, which contains exceptions to Lingua::EN::Inflect::PL(). Useful for foreign language column names. =item user Username. =item require Attempt to require the dynamically defined module, so that extensions defined in files. By default errors from imported modules are suppressed. When you want to debug, use require_warn. =item require_warn Warn of import errors when requiring modules. =back =head1 AUTHOR Daisuke Maki C =head1 AUTHOR EMERITUS Sebastian Riedel, C IKEBE Tomohiro, C =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, L, L, L, L, L, L, L =cut 1; Class-DBI-Loader-0.34/Makefile.PL0000644000076500007650000000053210366530134017366 0ustar daisukedaisuke00000000000000use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Class::DBI::Loader', 'VERSION_FROM' => 'lib/Class/DBI/Loader.pm', 'PREREQ_PM' => { Test::More => 0.32, Class::DBI => 0.89, DBI => 1.30, Lingua::EN::Inflect => 0, Text::Balanced => 0 }, ); Class-DBI-Loader-0.34/MANIFEST0000644000076500007650000000056510435406043016551 0ustar daisukedaisuke00000000000000Changes lib/Class/DBI/Loader.pm lib/Class/DBI/Loader/Generic.pm lib/Class/DBI/Loader/mysql.pm lib/Class/DBI/Loader/Pg.pm lib/Class/DBI/Loader/SQLite.pm Makefile.PL MANIFEST META.yml Module meta-data (added by MakeMaker) README t/01use.t t/02pod.t t/03podcoverage.t t/04mysql.t t/05pg.t t/06sqlite.t t/lib/LoaderBase.pm t/lib/LoaderLeft.pm t/lib/SQLiteTest/LoaderTest1.pm Class-DBI-Loader-0.34/META.yml0000644000076500007650000000077710600465104016673 0ustar daisukedaisuke00000000000000--- #YAML:1.0 name: Class-DBI-Loader version: 0.34 abstract: ~ license: ~ generated_by: ExtUtils::MakeMaker version 6.31 distribution_type: module requires: Class::DBI: 0.89 DBI: 1.3 Lingua::EN::Inflect: 0 Test::More: 0.32 Text::Balanced: 0 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.2.html version: 1.2 Class-DBI-Loader-0.34/README0000644000076500007650000000413010366530134016272 0ustar daisukedaisuke00000000000000NAME Class::DBI::Loader - Dynamic definition of Class::DBI sub classes. SYNOPSIS use Class::DBI::Loader; my $loader = Class::DBI::Loader->new( dsn => "dbi:mysql:dbname", user => "root", password => "", namespace => "Data", additional_classes => qw/Class::DBI::AbstractSearch/, additional_base_classes => qw/My::Stuff/, constraint => '^foo.*', relationships => 1 ); my $class = $loader->find_class('film'); # $class => Data::Film my $obj = $class->retrieve(1); use with mod_perl in your startup.pl # load all tables use Class::DBI::Loader; my $loader = Class::DBI::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); DESCRIPTION Class::DBI::Loader automate the definition of Class::DBI sub-classes. scan table schemas and setup columns, primary key. class names are defined by table names and namespace option. +-----------+-----------+-----------+ | table | namespace | class | +-----------+-----------+-----------+ | foo | Data | Data::Foo | | foo_bar | | FooBar | +-----------+-----------+-----------+ Class::DBI::Loader supports MySQL, Postgres and SQLite. See Class::DBI::Loader::Generic. AUTHOR Sebastian Riedel, "sri@oook.de" AUTHOR EMERITUS IKEBE Tomohiro, "ikebe@edge.co.jp" THANK YOU Randal Schwartz, Simon Flack and all the others who've helped. LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. SEE ALSO Class::DBI, Class::DBI::mysql, Class::DBI::Pg, Class::DBI::SQLite, Class::DBI::Loader::Generic, Class::DBI::Loader::mysql, Class::DBI::Loader::Pg, Class::DBI::Loader::SQLite Class-DBI-Loader-0.34/t/0000755000076500007650000000000010600465104015652 5ustar daisukedaisuke00000000000000Class-DBI-Loader-0.34/t/01use.t0000644000076500007650000000060610366530133017002 0ustar daisukedaisuke00000000000000use strict; use Test::More tests => 3; BEGIN { use_ok 'Class::DBI::Loader'; SKIP: { eval { require Class::DBI::mysql; }; skip "Class::DBI::mysql not found", 1 if $@; use_ok 'Class::DBI::Loader::mysql'; } SKIP: { eval { require Class::DBI::Pg; }; skip "Class::DBI::Pg not found", 1 if $@; use_ok 'Class::DBI::Loader::Pg'; } } Class-DBI-Loader-0.34/t/02pod.t0000644000076500007650000000027610366530133016774 0ustar daisukedaisuke00000000000000use 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(); Class-DBI-Loader-0.34/t/03podcoverage.t0000644000076500007650000000032510366530133020504 0ustar daisukedaisuke00000000000000use 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(); Class-DBI-Loader-0.34/t/04mysql.t0000644000076500007650000000434210377275135017371 0ustar daisukedaisuke00000000000000use strict; use Test::More tests => 9; use lib("t/lib"); use Class::DBI::Loader; my $dbh; my $database = $ENV{MYSQL_NAME}; my $user = $ENV{MYSQL_USER}; my $password = $ENV{MYSQL_PASS}; SKIP: { eval { require Class::DBI::mysql; }; skip "Class::DBI::mysql is not installed", 9 if $@; skip 'You need to set the MYSQL_NAME, MYSQL_USER and MYSQL_PASS environment variables', 9 unless ( $database && $user ); my $dsn = "dbi:mysql:$database"; $dbh = DBI->connect( $dsn, $user, $password, { RaiseError => 1, PrintError => 1 } ); $dbh->do(<<'SQL'); CREATE TABLE loader_test1 ( id INTEGER NOT NULL PRIMARY KEY AUTO_INCREMENT, dat VARCHAR(32) ) SQL my $sth = $dbh->prepare(<<"SQL"); INSERT INTO loader_test1 (dat) VALUES(?) SQL for my $dat (qw(foo bar baz)) { $sth->execute($dat); $sth->finish; } $dbh->do(<<'SQL'); CREATE TABLE loader_test2 ( id INTEGER NOT NULL PRIMARY KEY AUTO_INCREMENT, dat VARCHAR(32) ) SQL $sth = $dbh->prepare(<<"SQL"); INSERT INTO loader_test2 (dat) VALUES(?) SQL for my $dat (qw(aaa bbb ccc ddd)) { $sth->execute($dat); $sth->finish; } $sth->finish; my $loader = Class::DBI::Loader->new( dsn => $dsn, user => $user, password => $password, constraint => '^loader_test.+', additional_base_classes => [ qw(LoaderBase) ], left_base_classes => [ qw(LoaderLeft) ] ); is( $loader->find_class("loader_test1"), "LoaderTest1" ); is( $loader->find_class("loader_test2"), "LoaderTest2" ); my $class1 = $loader->find_class("loader_test1"); { no strict 'refs'; is(${"${class1}::ISA"}[0], 'LoaderLeft'); } my $obj = $class1->retrieve(1); is( $obj->id, 1 ); is( $obj->dat, "foo" ); isa_ok($obj, 'LoaderBase'); isa_ok($obj, 'LoaderLeft'); my $class2 = $loader->find_class("loader_test2"); is( $class2->retrieve_all, 4 ); my ($obj2) = $class2->search( dat => 'bbb' ); is( $obj2->id, 2 ); } END { if ($dbh) { $dbh->do("DROP TABLE loader_test1"); $dbh->do("DROP TABLE loader_test2"); $dbh->disconnect; } } Class-DBI-Loader-0.34/t/05pg.t0000644000076500007650000000446110366530133016623 0ustar daisukedaisuke00000000000000use strict; use Test::More tests => 9; use lib("t/lib"); use Class::DBI::Loader; use DBI; my $dbh; my $database = $ENV{PG_NAME}; my $user = $ENV{PG_USER}; my $password = $ENV{PG_PASS}; SKIP: { eval { require Class::DBI::Pg; }; skip "Class::DBI::Pg is not installed", 9 if $@; skip 'You need to set the PG_NAME, PG_USER and PG_PASS environment variables', 9 unless ( $database && $user ); my $dsn = "dbi:Pg:dbname=$database"; $dbh = DBI->connect( $dsn, $user, $password, { RaiseError => 1, PrintError => 1, AutoCommit => 1 } ); $dbh->do(<<'SQL'); CREATE TABLE loader_test1 ( id SERIAL NOT NULL PRIMARY KEY , dat TEXT ) SQL my $sth = $dbh->prepare(<<"SQL"); INSERT INTO loader_test1 (dat) VALUES(?) SQL for my $dat (qw(foo bar baz)) { $sth->execute($dat); $sth->finish; } $dbh->do(<<'SQL'); CREATE TABLE loader_test2 ( id SERIAL NOT NULL PRIMARY KEY, dat TEXT ) SQL $sth = $dbh->prepare(<<"SQL"); INSERT INTO loader_test2 (dat) VALUES(?) SQL for my $dat (qw(aaa bbb ccc ddd)) { $sth->execute($dat); $sth->finish; } my $loader = Class::DBI::Loader->new( dsn => $dsn, user => $user, password => $password, namespace => 'PgTest', constraint => '^loader_test.*', additional_base_classes => [ qw(LoaderBase) ], left_base_classes => [ qw(LoaderLeft) ] ); is( $loader->find_class("loader_test1"), "PgTest::LoaderTest1" ); is( $loader->find_class("loader_test2"), "PgTest::LoaderTest2" ); my $class1 = $loader->find_class("loader_test1"); { no strict 'refs'; is(${"${class1}::ISA"}[0], 'LoaderLeft'); } my $obj = $class1->retrieve(1); is( $obj->id, 1 ); is( $obj->dat, "foo" ); isa_ok($obj, 'LoaderBase'); isa_ok($obj, 'LoaderLeft'); my $class2 = $loader->find_class("loader_test2"); is( $class2->retrieve_all, 4 ); my ($obj2) = $class2->search( dat => 'bbb' ); is( $obj2->id, 2 ); $class1->db_Main->disconnect; $class2->db_Main->disconnect; } END { if ($dbh) { $dbh->do("DROP TABLE loader_test1"); $dbh->do("DROP TABLE loader_test2"); $dbh->disconnect; } } Class-DBI-Loader-0.34/t/06sqlite.t0000644000076500007650000000653210435405454017524 0ustar daisukedaisuke00000000000000use strict; use lib("t/lib"); use Test::More; BEGIN { my @required_modules = ('Class::DBI::SQLite 0.09','Text::Balanced'); my $use_statements = 'use ' . (join '; use ', @required_modules) . ';'; my $skip_message = "all: failed to load one or more of these required modules:\n" . (join "\n", @required_modules); eval $use_statements; plan skip_all => $skip_message if $@; plan tests => 15; } use Class::DBI::Loader; use DBI; eval { require DBD::SQLite }; my $class = $@ ? 'SQLite2' : 'SQLite'; my $dbh; my $database = './t/sqlite_test'; my $dsn = "dbi:$class:dbname=$database"; $dbh = DBI->connect( $dsn, "", "", { RaiseError => 1, PrintError => 1, AutoCommit => 1 } ); $dbh->do(<<'SQL'); CREATE TABLE loader_test1 ( id INTEGER NOT NULL PRIMARY KEY , dat TEXT ) SQL my $sth = $dbh->prepare(<<"SQL"); INSERT INTO loader_test1 (dat) VALUES(?) SQL for my $dat (qw(foo bar baz)) { $sth->execute($dat); $sth->finish; } $dbh->do(<<'SQL'); CREATE TABLE loader_test2 ( id INTEGER NOT NULL PRIMARY KEY, dat TEXT ) SQL $sth = $dbh->prepare(<<"SQL"); INSERT INTO loader_test2 (dat) VALUES(?) SQL for my $dat (qw(aaa bbb ccc ddd)) { $sth->execute($dat); $sth->finish; } $dbh->do(<<'SQL'); CREATE TABLE loader_test3 ( id1 INTEGER, id2 INTEGER, --, id2 INTEGER REFERENCES loader_test1, dat TEXT, PRIMARY KEY (id1,id2) ) SQL $dbh->do("INSERT INTO loader_test3 (id1,id2,dat) VALUES (1,1,'aaa')"); $dbh->do(<<'SQL'); CREATE TABLE loader_test4 ( id INTEGER NOT NULL PRIMARY KEY, id2 INTEGER, loader_test2 INTEGER REFERENCES loader_test2, dat TEXT, FOREIGN KEY (id, id2 ) REFERENCES loader_test3 (id1,id2) ) SQL $dbh->do("INSERT INTO loader_test4 (id2,loader_test2,dat) VALUES (1,1,'aaa')"); my $loader = Class::DBI::Loader->new ( dsn => $dsn, namespace => 'SQLiteTest', constraint => '^loader_test.*', relationships => 1, additional_base_classes => 'LoaderBase', left_base_classes => 'LoaderLeft', require => 1, require_warn => 1 ); is( $loader->find_class("loader_test1"), "SQLiteTest::LoaderTest1" ); is( $loader->find_class("loader_test2"), "SQLiteTest::LoaderTest2" ); is( $loader->find_class("loader_test3"), "SQLiteTest::LoaderTest3" ); is( $loader->find_class("loader_test4"), "SQLiteTest::LoaderTest4" ); my $class1 = $loader->find_class("loader_test1"); { no strict 'refs'; is(${"${class1}::ISA"}[0], 'LoaderLeft'); } my $obj = $class1->retrieve(1); is( $obj->id, 1 ); is( $obj->dat, "foo" ); isa_ok($obj, 'LoaderBase'); isa_ok($obj, 'LoaderLeft'); my $class2 = $loader->find_class("loader_test2"); is( $class2->retrieve_all, 4 ); my ($obj2) = $class2->search( dat => 'bbb' ); is( $obj2->id, 2 ); my $class3 = $loader->find_class("loader_test3"); my $obj3 = $class3->retrieve( id1 => 1, id2 => 1 ); is( ref($obj3->id2), '' ); # fk def in comments should not be parsed my $class4 = $loader->find_class("loader_test4"); my $obj4 = $class4->retrieve(1); is( $obj4->loader_test2->isa('SQLiteTest::LoaderTest2'), 1 ); is( ref($obj4->id2), '' ); # mulit-col fk def should not be parsed # check for extension found in SQLiteTest::LoaderTest1 is($obj->dat_double, "foofoo"); for ($class1, $class2, $class3, $class4) { $_->db_Main->disconnect; } END { unlink './t/sqlite_test'; } Class-DBI-Loader-0.34/t/lib/0000755000076500007650000000000010600465104016420 5ustar daisukedaisuke00000000000000Class-DBI-Loader-0.34/t/lib/LoaderBase.pm0000644000076500007650000000025110366530133020761 0ustar daisukedaisuke00000000000000# $Id: LoaderBase.pm 3157 2006-01-27 02:41:40Z daisuke $ # # Copyright (c) 2006 Daisuke Maki # All rights reserved. package LoaderBase; use strict; 1;Class-DBI-Loader-0.34/t/lib/LoaderLeft.pm0000644000076500007650000000025110366530133021001 0ustar daisukedaisuke00000000000000# $Id: LoaderLeft.pm 3157 2006-01-27 02:41:40Z daisuke $ # # Copyright (c) 2006 Daisuke Maki # All rights reserved. package LoaderLeft; use strict; 1;Class-DBI-Loader-0.34/t/lib/SQLiteTest/0000755000076500007650000000000010600465104020421 5ustar daisukedaisuke00000000000000Class-DBI-Loader-0.34/t/lib/SQLiteTest/LoaderTest1.pm0000644000076500007650000000012410435405573023115 0ustar daisukedaisuke00000000000000package SQLiteTest::LoaderTest1; use strict; sub dat_double { shift->dat x 2 } 1;