r30561@brandon-blacks-computer (orig r3197): blblack | 2007-04-16 21:29:51 -0500
fix for ^sqlite_ tables from chromatic
'File::Spec' => 0,
'Scalar::Util' => 0,
'Data::Dump' => 1.06,
- 'UNIVERSAL::require' => 0.10,
- 'Lingua::EN::Inflect' => 1.89,
+ 'UNIVERSAL::require' => 0.11,
'Lingua::EN::Inflect::Number' => 1.1,
'Text::Balanced' => 0,
- 'Class::Accessor' => 0.22,
- 'Class::Data::Accessor' => 0.02,
- 'Class::C3' => 0.11,
+ 'Digest::MD5' => 2.36,
+ 'Class::Accessor::Fast' => 0.30,
+ 'Class::Data::Accessor' => 0.03,
+ 'Class::C3' => 0.14,
'Carp::Clan' => 0,
- 'DBIx::Class' => 0.06003,
+ 'DBIx::Class' => 0.07005,
},
recommends => {
'Class::Inspector' => 0,
- 'DBI' => 1.50,
- 'DBD::SQLite' => 1.12,
- 'DBD::mysql' => 3.0003,
- 'DBD::Pg' => 1.49,
- 'DBD::DB2' => 0.78,
+ 'DBI' => 1.53,
+ 'DBD::SQLite' => 1.13,
+ 'DBD::mysql' => 4.004,
+ 'DBD::Pg' => 1.49, # Soon to be 1.50
+ 'DBD::DB2' => 1.0,
+ 'DBD::Oracle' => 0.19,
},
build_requires => {
'Test::More' => 0.32,
- 'DBI' => 1.50,
- 'DBD::SQLite' => 1.12,
+ 'DBI' => 1.53,
+ 'DBD::SQLite' => 1.13,
'File::Path' => 0,
},
create_makefile_pl => 'passthrough',
- skip ^sqlite_ tables in SQLite (thanks chromatic)
+0.03999_01 Sat Apr 14 19:57:40 GMT 2007
+ - Added *experimental* Oracle support from work done
+ by Tsunoda Kazuya some months ago. Not well tested.
+ - Added "rescan" schema (and loader) method, which picks
+ up newly created tables at runtime
+ - Made dump_to_dir / dump_overwrite much more intelligent
+ (they now preserve customizations by default)
+ - Added support for DBI's new standard "statistics_info"
+ method to gather unique key info (only supported by
+ DBD::Pg trunk afaik)
+ - columns_info_for imported from DBIx::Class
+ - relationships are now on by default, use skip_relationships
+ to disable them
+ - Removed previously deprecated methods/options
+ - Added $VERSION to all packages in this dist
+
0.03011 Sat Apr 14 19:03:07 UTC 2007
- fix case-sensitivity in UNIQUE parsing for SQLite
support pk/uk/fk info on views, possibly. May or may not be a sane thing to try to do.
-dump_to_dir needs an overwrite flag, and needs to not overwrite by default
-
Fix up ResultSet Manager / Methods / etc stuff. May require some work in the
main DBIx::Class first.
# Always remember to do all digits for the version even if they're 0
# i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports
# brain damage and presumably various other packaging systems too
-our $VERSION = '0.03011';
+our $VERSION = '0.03999_01';
-__PACKAGE__->mk_classaccessor('dump_to_dir');
-__PACKAGE__->mk_classaccessor('loader');
-__PACKAGE__->mk_classaccessor('_loader_args');
+__PACKAGE__->mk_classaccessor('_loader_args' => {});
+__PACKAGE__->mk_classaccessors(qw/dump_to_dir _loader_invoked _loader/);
=head1 NAME
use base qw/DBIx::Class::Schema::Loader/;
__PACKAGE__->loader_options(
- relationships => 1,
constraint => '^foo.*',
# debug => 1,
);
That being said, transitioning your code from a Schema generated by this
module to one that doesn't use this module should be straightforward and
-painless (as long as you're not using any methods that are now deprecated
-in this document), so don't shy away from it just for fears of the
-transition down the road.
+painless, so don't shy away from it just for fears of the transition down
+the road.
=head1 METHODS
only useful in fairly complex scenarios, see the
L<DBIx::Class::Schema::Loader::Base> documentation.
-This method is *required* at this time, for backwards compatibility
-reasons. If you do not wish to change any options, just call it
-with an empty argument list during schema class initialization.
-
-Setting these options explicitly via this method B<after> calling
-C<connection> is deprecated and will stop working in version 0.04000.
-For now the code merely warns about this condition.
-
-The preferred way of doing things is to either call C<loader_options>
-before any connection is made, or embed the C<loader_options> in
-the connection information itself as shown below.
+One must call C<loader_options> before any connection is made,
+or embed the C<loader_options> in the connection information itself
+as shown below. Setting C<loader_options> after the connection has
+already been made is useless.
=cut
my $self = shift;
my %args = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
-
- my $class = ref $self || $self;
- $args{schema} = $self;
- $args{schema_class} = $class;
- weaken($args{schema}) if ref $self;
-
$self->_loader_args(\%args);
- if($self->storage && !$class->loader) {
- warn "Do not set loader_options after specifying the connection info,"
- . " this will be unsupported in 0.04000";
- $self->_invoke_loader;
- }
$self;
}
my $self = shift;
my $class = ref $self || $self;
- $self->_loader_args->{dump_directory} ||= $self->dump_to_dir;
+ my $args = $self->_loader_args;
+
+ # set up the schema/schema_class arguments
+ $args->{schema} = $self;
+ $args->{schema_class} = $class;
+ weaken($args->{schema}) if ref $self;
+ $args->{dump_directory} ||= $self->dump_to_dir;
# XXX this only works for relative storage_type, like ::DBI ...
my $impl = "DBIx::Class::Schema::Loader" . $self->storage_type;
croak qq/Could not load storage_type loader "$impl": / .
qq/"$UNIVERSAL::require::ERROR"/;
- # XXX in the future when we get rid of ->loader, the next two
- # lines can be replaced by "$impl->new(%{$self->_loader_args})->load;"
- $class->loader($impl->new(%{$self->_loader_args}));
- $class->loader->load;
+ $self->_loader($impl->new(%$args));
+ $self->_loader->load;
+ $self->_loader_invoked(1);
$self;
}
$self = $self->next::method(@_);
my $class = ref $self || $self;
- if($self->_loader_args && !$class->loader) {
+ if(!$class->_loader_invoked) {
$self->_invoke_loader
}
use DBIx::Class::Schema::Loader qw/ make_schema_at /;
make_schema_at(
'New::Schema::Name',
- { relationships => 1, debug => 1 },
+ { debug => 1 },
[ 'dbi:Pg:dbname="foo"','postgres' ],
);
# Complex: dump loaded schema to disk, all from the commandline:
- perl -MDBIx::Class::Schema::Loader=make_schema_at,dump_to_dir:./lib -e 'make_schema_at("New::Schema::Name", { relationships => 1 }, [ "dbi:Pg:dbname=foo","postgres" ])'
+ perl -MDBIx::Class::Schema::Loader=make_schema_at,dump_to_dir:./lib -e 'make_schema_at("New::Schema::Name", { debug => 1 }, [ "dbi:Pg:dbname=foo","postgres" ])'
# Same, but inside a script, and using a different way to specify the
# dump directory:
use DBIx::Class::Schema::Loader qw/ make_schema_at /;
make_schema_at(
'New::Schema::Name',
- { relationships => 1, debug => 1, dump_directory => './lib' },
+ { debug => 1, dump_directory => './lib' },
[ 'dbi:Pg:dbname="foo"','postgres' ],
);
$target->connection(@$connect_info);
}
+=head2 rescan
+
+Re-scans the database for newly added tables since the initial
+load, and adds them to the schema at runtime, including relationships,
+etc. Does not process drops or changes.
+
+Returns a list of the new monikers added.
+
+=cut
+
+sub rescan { my $self = shift; $self->_loader->rescan($self) }
+
=head1 EXAMPLE
Using the example in L<DBIx::Class::Manual::ExampleSchema> as a basis
use base qw/DBIx::Class::Schema::Loader/;
__PACKAGE__->loader_options(
- relationships => 1,
debug => 1,
);
__PACKAGE__->connection('dbi:SQLite:example.db');
and remove the Main directory tree (optional). Every thing else
should work the same
-=head1 DEPRECATED METHODS
-
-You don't need to read anything in this section unless you're upgrading
-code that was written against pre-0.03 versions of this module. This
-version is intended to be backwards-compatible with pre-0.03 code, but
-will issue warnings about your usage of deprecated features/methods.
-
-B<All of these deprecated methods will dissappear in version 0.04000>,
-and converting code that uses these methods should be trivial.
-
-=head2 load_from_connection
-
-This deprecated method is now roughly an alias for L</loader_options>.
-
-For now, using this method will invoke the legacy behavior for
-backwards compatibility, and merely emit a warning about upgrading
-your code.
-
-It also reverts the default inflection scheme to
-use L<Lingua::EN::Inflect> just like pre-0.03 versions of this
-module did.
-
-You can force these legacy inflections with the
-option L<DBIx::Class::Schema::Loader::Base/legacy_default_inflections>,
-even after switch over to the preferred L</loader_options> way of doing
-things. That option will not go away until at least 0.05.
-
-See the source of this method for more details.
-
-=cut
-
-sub load_from_connection {
- my ($self, %args) = @_;
-
- my $cmds_ver = $Catalyst::Model::DBIC::Schema::VERSION;
- if($cmds_ver) {
- if($cmds_ver < 0.14) {
- warn 'You should upgrade your installation of'
- . ' Catalyst::Model::DBIC::Schema to 0.14 or higher, then:';
- }
- warn 'You should regenerate your Model files, which may eliminate'
- . ' the following deprecation warning:';
- }
- warn 'load_from_connection deprecated, and will dissappear in 0.04000, '
- . 'please [re-]read the [new] DBIx::Class::Schema::Loader '
- . 'documentation';
-
- # Support the old connect_info / dsn / etc args...
- $args{connect_info} = [
- delete $args{dsn},
- delete $args{user},
- delete $args{password},
- delete $args{options},
- ] if $args{dsn};
-
- $self->connection(@{delete $args{connect_info}})
- if $args{connect_info};
-
- $self->loader_options('legacy_default_inflections' => 1, %args);
-}
-
-=head2 loader
-
-This is an accessor in the generated Schema class for accessing
-the L<DBIx::Class::Schema::Loader::Base> -based loader object
-that was used during construction. See the
-L<DBIx::Class::Schema::Loader::Base> docs for more information
-on the available loader methods there.
-
-This accessor is deprecated. Do not use it. Anything you can
-get from C<loader>, you can get via the normal L<DBIx::Class::Schema>
-methods, and your code will be more robust and forward-thinking
-for doing so.
-
-If you're already using C<loader> in your code, make an effort
-to get rid of it. If you think you've found a situation where it
-is necessary, let me know and we'll see what we can do to remedy
-that situation.
-
-In some future version, this accessor *will* disappear. It was
-apparently quite a design/API mistake to ever have exposed it to
-user-land in the first place, all things considered.
-
=head1 KNOWN ISSUES
=head2 Multiple Database Schemas
use Data::Dump qw/ dump /;
use POSIX qw//;
use File::Spec qw//;
+use Cwd qw//;
+use Digest::MD5 qw//;
require DBIx::Class;
+our $VERSION = '0.03999_01';
+
__PACKAGE__->mk_ro_accessors(qw/
schema
schema_class
left_base_classes
components
resultset_components
- relationships
+ skip_relationships
moniker_map
inflect_singular
inflect_plural
dump_directory
dump_overwrite
- legacy_default_inflections
-
db_schema
_tables
classes
These constructor options are the base options for
L<DBIx::Class::Schema::Loader/loader_opts>. Available constructor options are:
-=head2 relationships
+=head2 skip_relationships
-Try to automatically detect/setup has_a and has_many relationships.
+Skip setting up relationships. The default is to attempt the loading
+of relationships.
=head2 debug
C<ResultSetManager> will be automatically added to the above
C<components> list if this option is set.
-=head2 legacy_default_inflections
-
-Setting this option changes the default fallback for L</inflect_plural> to
-utilize L<Lingua::EN::Inflect/PL>, and L</inflect_singular> to a no-op.
-Those choices produce substandard results, but might be necessary to support
-your existing code if you started developing on a version prior to 0.03 and
-don't wish to go around updating all your relationship names to the new
-defaults.
-
-This option will continue to be supported until at least version 0.05xxx,
-but may dissappear sometime thereafter. It is recommended that you update
-your code to use the newer-style inflections when you have the time.
-
=head2 dump_directory
This option is designed to be a tool to help you transition from this
The created schema class will have the same classname as the one on
which you are setting this option (and the ResultSource classes will be
-based on this name as well). Therefore it is wise to note that if you
-point the C<dump_directory> option of a schema class at the live libdir
-where that class is currently located, it will overwrite itself with a
-manual version of itself. This might be a really good or bad thing
-depending on your situation and perspective.
+based on this name as well).
Normally you wouldn't hard-code this setting in your schema class, as it
is meant for one-time manual usage.
=head2 dump_overwrite
-If set to a true value, the dumping code will overwrite existing files.
-The default is false, which means the dumping code will skip the already
-existing files.
-
-=head1 DEPRECATED CONSTRUCTOR OPTIONS
-
-B<These will be removed in version 0.04000 !!!>
-
-=head2 inflect_map
+Default false. If true, Loader will unconditionally delete any existing
+files before creating the new ones from scratch when dumping a schema to disk.
-Equivalent to L</inflect_plural>.
+The default behavior is instead to only replace the top portion of the
+file, up to and including the final stanza which contains
+C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
+leaving any customizations you placed after that as they were.
-=head2 inflect
-
-Equivalent to L</inflect_plural>.
-
-=head2 connect_info, dsn, user, password, options
-
-You connect these schemas the same way you would any L<DBIx::Class::Schema>,
-which is by calling either C<connect> or C<connection> on a schema class
-or object. These options are only supported via the deprecated
-C<load_from_connection> interface, which is also being removed in 0.04000.
+When C<dump_overwrite> is not set, if the output file already exists,
+but the aforementioned final stanza is not found, or the checksum
+contained there does not match the generated contents, Loader will
+croak and not touch the file.
=head1 METHODS
bless $self => $class;
- $self->{db_schema} ||= '';
$self->_ensure_arrayref(qw/additional_classes
additional_base_classes
left_base_classes
$self->{monikers} = {};
$self->{classes} = {};
- # Support deprecated arguments
- for(qw/inflect_map inflect/) {
- warn "Argument $_ is deprecated in favor of 'inflect_plural'"
- . ", and will be removed in 0.04000"
- if $self->{$_};
- }
- $self->{inflect_plural} ||= $self->{inflect_map} || $self->{inflect};
-
$self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
$self->{schema} ||= $self->{schema_class};
+ $self->{relbuilder} = DBIx::Class::Schema::Loader::RelBuilder->new(
+ $self->schema_class, $self->inflect_plural, $self->inflect_singular
+ ) if !$self->{skip_relationships};
+
$self;
}
-sub _load_external {
- my $self = shift;
+sub _find_file_in_inc {
+ my ($self, $file) = @_;
- my $abs_dump_dir;
+ foreach my $prefix (@INC) {
+ my $fullpath = $prefix . '/' . $file;
+ return $fullpath if -f $fullpath;
+ }
- $abs_dump_dir = File::Spec->rel2abs($self->dump_directory)
- if $self->dump_directory;
+ return;
+}
- foreach my $table_class (values %{$self->classes}) {
- $table_class->require;
- if($@ && $@ !~ /^Can't locate /) {
- croak "Failed to load external class definition"
- . " for '$table_class': $@";
- }
- next if $@; # "Can't locate" error
-
- # If we make it to here, we loaded an external definition
- warn qq/# Loaded external class definition for '$table_class'\n/
- if $self->debug;
-
- if($abs_dump_dir) {
- my $class_path = $table_class;
- $class_path =~ s{::}{/}g;
- $class_path .= '.pm';
- my $filename = File::Spec->rel2abs($INC{$class_path});
- croak 'Failed to locate actual external module file for '
- . "'$table_class'"
- if !$filename;
- next if($filename =~ /^$abs_dump_dir/);
- open(my $fh, '<', $filename)
- or croak "Failed to open $filename for reading: $!";
- $self->_raw_stmt($table_class,
- q|# These lines loaded from user-supplied external file: |
- );
- while(<$fh>) {
- chomp;
- $self->_raw_stmt($table_class, $_);
- }
- $self->_raw_stmt($table_class,
- q|# End of lines loaded from user-supplied external file |
- );
- close($fh)
- or croak "Failed to close $filename: $!";
- }
+sub _load_external {
+ my ($self, $class) = @_;
+
+ my $class_path = $class;
+ $class_path =~ s{::}{/}g;
+ $class_path .= '.pm';
+
+ my $inc_path = $self->_find_file_in_inc($class_path);
+
+ return if !$inc_path;
+
+ my $real_dump_path = $self->dump_directory
+ ? Cwd::abs_path(
+ File::Spec->catfile($self->dump_directory, $class_path)
+ )
+ : '';
+ my $real_inc_path = Cwd::abs_path($inc_path);
+ return if $real_inc_path eq $real_dump_path;
+
+ $class->require;
+ croak "Failed to load external class definition"
+ . " for '$class': $@"
+ if $@;
+
+ # If we make it to here, we loaded an external definition
+ warn qq/# Loaded external class definition for '$class'\n/
+ if $self->debug;
+
+ # The rest is only relevant when dumping
+ return if !$self->dump_directory;
+
+ croak 'Failed to locate actual external module file for '
+ . "'$class'"
+ if !$real_inc_path;
+ open(my $fh, '<', $real_inc_path)
+ or croak "Failed to open '$real_inc_path' for reading: $!";
+ $self->_ext_stmt($class,
+ qq|# These lines were loaded from '$real_inc_path' found in \@INC.|
+ .q|# They are now part of the custom portion of this file|
+ .q|# for you to hand-edit. If you do not either delete|
+ .q|# this section or remove that file from @INC, this section|
+ .q|# will be repeated redundantly when you re-create this|
+ .q|# file again via Loader!|
+ );
+ while(<$fh>) {
+ chomp;
+ $self->_ext_stmt($class, $_);
}
+ $self->_ext_stmt($class,
+ q|# End of lines loaded from '$real_inc_path' |
+ );
+ close($fh)
+ or croak "Failed to close $real_inc_path: $!";
}
=head2 load
sub load {
my $self = shift;
- $self->_load_classes;
- $self->_load_relationships if $self->relationships;
- $self->_load_external;
+ $self->_load_tables($self->_tables_list);
+}
+
+=head2 rescan
+
+Arguments: schema
+
+Rescan the database for newly added tables. Does
+not process drops or changes. Returns a list of
+the newly added table monikers.
+
+The schema argument should be the schema class
+or object to be affected. It should probably
+be derived from the original schema_class used
+during L</load>.
+
+=cut
+
+sub rescan {
+ my ($self, $schema) = @_;
+
+ $self->{schema} = $schema;
+
+ my @created;
+ my @current = $self->_tables_list;
+ foreach my $table ($self->_tables_list) {
+ if(!exists $self->{_tables}->{$table}) {
+ push(@created, $table);
+ }
+ }
+
+ $self->_load_tables(@created);
+
+ return map { $self->monikers->{$_} } @created;
+}
+
+sub _load_tables {
+ my ($self, @tables) = @_;
+
+ # First, use _tables_list with constraint and exclude
+ # to get a list of tables to operate on
+
+ my $constraint = $self->constraint;
+ my $exclude = $self->exclude;
+
+ @tables = grep { /$constraint/ } @tables if $constraint;
+ @tables = grep { ! /$exclude/ } @tables if $exclude;
+
+ # Save the new tables to the tables list
+ foreach (@tables) {
+ $self->{_tables}->{$_} = 1;
+ }
+
+ # Set up classes/monikers
+ {
+ no warnings 'redefine';
+ local *Class::C3::reinitialize = sub { };
+ use warnings;
+
+ $self->_make_src_class($_) for @tables;
+ }
+
+ Class::C3::reinitialize;
+
+ $self->_setup_src_meta($_) for @tables;
+
+ if(!$self->skip_relationships) {
+ $self->_load_relationships($_) for @tables;
+ }
+
+ $self->_load_external($_)
+ for map { $self->classes->{$_} } @tables;
+
$self->_dump_to_dir if $self->dump_directory;
# Drop temporary cache
# which is a filename
my $dir = $self->dump_directory;
- foreach (@name_parts) {
- $dir = File::Spec->catdir($dir,$_);
- if(! -d $dir) {
+ while (1) {
+ if(!-d $dir) {
mkdir($dir) or croak "mkdir('$dir') failed: $!";
}
+ last if !@name_parts;
+ $dir = File::Spec->catdir($dir, shift @name_parts);
}
}
warn "Dumping manual schema for $schema_class to directory $target_dir ...\n";
- if(! -d $target_dir) {
- mkdir($target_dir) or croak "mkdir('$target_dir') failed: $!";
- }
+ my $schema_text =
+ qq|package $schema_class;\n\n|
+ . qq|use strict;\nuse warnings;\n\n|
+ . qq|use base 'DBIx::Class::Schema';\n\n|
+ . qq|__PACKAGE__->load_classes;\n|;
- my $verstr = $DBIx::Class::Schema::Loader::VERSION;
- my $datestr = POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime);
- my $tagline = qq|# Created by DBIx::Class::Schema::Loader v$verstr @ $datestr|;
+ $self->_write_classfile($schema_class, $schema_text);
- $self->_ensure_dump_subdirs($schema_class);
+ foreach my $src_class (sort keys %{$self->{_dump_storage}}) {
+ my $src_text =
+ qq|package $src_class;\n\n|
+ . qq|use strict;\nuse warnings;\n\n|
+ . qq|use base 'DBIx::Class';\n\n|;
- my $schema_fn = $self->_get_dump_filename($schema_class);
- if (-f $schema_fn && !$self->dump_overwrite) {
- warn "$schema_fn exists, will not overwrite\n";
- }
- else {
- open(my $schema_fh, '>', $schema_fn)
- or croak "Cannot open $schema_fn for writing: $!";
- print $schema_fh qq|package $schema_class;\n\n$tagline\n\n|;
- print $schema_fh qq|use strict;\nuse warnings;\n\n|;
- print $schema_fh qq|use base 'DBIx::Class::Schema';\n\n|;
- print $schema_fh qq|__PACKAGE__->load_classes;\n|;
- print $schema_fh qq|\n1;\n\n|;
- close($schema_fh)
- or croak "Cannot close $schema_fn: $!";
+ $self->_write_classfile($src_class, $src_text);
}
- foreach my $src_class (sort keys %{$self->{_dump_storage}}) {
- $self->_ensure_dump_subdirs($src_class);
- my $src_fn = $self->_get_dump_filename($src_class);
- if (-f $src_fn && !$self->dump_overwrite) {
- warn "$src_fn exists, will not overwrite\n";
- next;
- }
- open(my $src_fh, '>', $src_fn)
- or croak "Cannot open $src_fn for writing: $!";
- print $src_fh qq|package $src_class;\n\n$tagline\n\n|;
- print $src_fh qq|use strict;\nuse warnings;\n\n|;
- print $src_fh qq|use base 'DBIx::Class';\n\n|;
- print $src_fh qq|$_\n|
- for @{$self->{_dump_storage}->{$src_class}};
- print $src_fh qq|\n1;\n\n|;
- close($src_fh)
- or croak "Cannot close $src_fn: $!";
+ warn "Schema dump completed.\n";
+}
+
+sub _write_classfile {
+ my ($self, $class, $text) = @_;
+
+ my $filename = $self->_get_dump_filename($class);
+ $self->_ensure_dump_subdirs($class);
+
+ if (-f $filename && $self->dump_overwrite) {
+ warn "Deleting existing file '$filename' due to "
+ . "'dump_overwrite' setting\n";
+ unlink($filename);
+ }
+
+ my $custom_content = $self->_get_custom_content($class, $filename);
+
+ $custom_content ||= qq|\n# You can replace this text with custom|
+ . qq| content, and it will be preserved on regeneration|
+ . qq|\n1;\n|;
+
+ $text .= qq|$_\n|
+ for @{$self->{_dump_storage}->{$class} || []};
+
+ $text .= qq|\n\n# Created by DBIx::Class::Schema::Loader|
+ . qq| v| . $DBIx::Class::Schema::Loader::VERSION
+ . q| @ | . POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
+ . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
+
+ open(my $fh, '>', $filename)
+ or croak "Cannot open '$filename' for writing: $!";
+
+ # Write the top half and its MD5 sum
+ print $fh $text . Digest::MD5::md5_base64($text) . "\n\n";
+
+ # Write out anything loaded via external partial class file in @INC
+ print $fh qq|$_\n|
+ for @{$self->{_ext_storage}->{$class} || []};
+
+ print $fh $custom_content;
+
+ close($fh)
+ or croak "Cannot close '$filename': $!";
+}
+
+sub _get_custom_content {
+ my ($self, $class, $filename) = @_;
+
+ return if ! -f $filename;
+ open(my $fh, '<', $filename)
+ or croak "Cannot open '$filename' for reading: $!";
+
+ my $mark_re =
+ qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
+
+ my $found = 0;
+ my $buffer = '';
+ while(<$fh>) {
+ if(!$found && /$mark_re/) {
+ $found = 1;
+ $buffer .= $1;
+ croak "Checksum mismatch in '$filename'"
+ if Digest::MD5::md5_base64($buffer) ne $2;
+
+ $buffer = '';
+ }
+ else {
+ $buffer .= $_;
+ }
}
- warn "Schema dump completed.\n";
+ croak "Cannot not overwrite '$filename' without 'dump_overwrite',"
+ . " it does not appear to have been generated by Loader"
+ if !$found;
+
+ return $buffer;
}
sub _use {
}
}
-# Load and setup classes
-sub _load_classes {
- my $self = shift;
+# Create class with applicable bases, setup monikers, etc
+sub _make_src_class {
+ my ($self, $table) = @_;
my $schema = $self->schema;
my $schema_class = $self->schema_class;
- my $constraint = $self->constraint;
- my $exclude = $self->exclude;
- my @tables = sort $self->_tables_list;
- warn "No tables found in database, nothing to load" if !@tables;
+ my $table_moniker = $self->_table2moniker($table);
+ my $table_class = $schema_class . q{::} . $table_moniker;
- if(@tables) {
- @tables = grep { /$constraint/ } @tables if $constraint;
- @tables = grep { ! /$exclude/ } @tables if $exclude;
+ my $table_normalized = lc $table;
+ $self->classes->{$table} = $table_class;
+ $self->classes->{$table_normalized} = $table_class;
+ $self->monikers->{$table} = $table_moniker;
+ $self->monikers->{$table_normalized} = $table_moniker;
- warn "All tables excluded by constraint/exclude, nothing to load"
- if !@tables;
- }
+ { no strict 'refs'; @{"${table_class}::ISA"} = qw/DBIx::Class/ }
- $self->{_tables} = \@tables;
+ $self->_use ($table_class, @{$self->additional_classes});
+ $self->_inject($table_class, @{$self->additional_base_classes});
- foreach my $table (@tables) {
- my $table_moniker = $self->_table2moniker($table);
- my $table_class = $schema_class . q{::} . $table_moniker;
+ $self->_dbic_stmt($table_class, 'load_components', @{$self->components}, 'Core');
- my $table_normalized = lc $table;
- $self->classes->{$table} = $table_class;
- $self->classes->{$table_normalized} = $table_class;
- $self->monikers->{$table} = $table_moniker;
- $self->monikers->{$table_normalized} = $table_moniker;
+ $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
+ if @{$self->resultset_components};
+ $self->_inject($table_class, @{$self->left_base_classes});
+}
- no warnings 'redefine';
- local *Class::C3::reinitialize = sub { };
- use warnings;
+# Set up metadata (cols, pks, etc) and register the class with the schema
+sub _setup_src_meta {
+ my ($self, $table) = @_;
- { no strict 'refs'; @{"${table_class}::ISA"} = qw/DBIx::Class/ }
+ my $schema = $self->schema;
+ my $schema_class = $self->schema_class;
- $self->_use ($table_class, @{$self->additional_classes});
- $self->_inject($table_class, @{$self->additional_base_classes});
+ my $table_class = $self->classes->{$table};
+ my $table_moniker = $self->monikers->{$table};
- $self->_dbic_stmt($table_class, 'load_components', @{$self->components}, qw/PK::Auto Core/);
+ $self->_dbic_stmt($table_class,'table',$table);
- $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
- if @{$self->resultset_components};
- $self->_inject($table_class, @{$self->left_base_classes});
+ my $cols = $self->_table_columns($table);
+ my $col_info;
+ eval { $col_info = $self->_columns_info_for($table) };
+ if($@) {
+ $self->_dbic_stmt($table_class,'add_columns',@$cols);
+ }
+ else {
+ my %col_info_lc = map { lc($_), $col_info->{$_} } keys %$col_info;
+ $self->_dbic_stmt(
+ $table_class,
+ 'add_columns',
+ map { $_, ($col_info_lc{$_}||{}) } @$cols
+ );
}
- Class::C3::reinitialize;
-
- foreach my $table (@tables) {
- my $table_class = $self->classes->{$table};
- my $table_moniker = $self->monikers->{$table};
-
- $self->_dbic_stmt($table_class,'table',$table);
-
- my $cols = $self->_table_columns($table);
- my $col_info;
- eval { $col_info = $schema->storage->columns_info_for($table) };
- if($@) {
- $self->_dbic_stmt($table_class,'add_columns',@$cols);
- }
- else {
- my %col_info_lc = map { lc($_), $col_info->{$_} } keys %$col_info;
- $self->_dbic_stmt(
- $table_class,
- 'add_columns',
- map { $_, ($col_info_lc{$_}||{}) } @$cols
- );
- }
-
- my $pks = $self->_table_pk_info($table) || [];
- @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
- : carp("$table has no primary key");
+ my $pks = $self->_table_pk_info($table) || [];
+ @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
+ : carp("$table has no primary key");
- my $uniqs = $self->_table_uniq_info($table) || [];
- $self->_dbic_stmt($table_class,'add_unique_constraint',@$_) for (@$uniqs);
+ my $uniqs = $self->_table_uniq_info($table) || [];
+ $self->_dbic_stmt($table_class,'add_unique_constraint',@$_) for (@$uniqs);
- $schema_class->register_class($table_moniker, $table_class);
- $schema->register_class($table_moniker, $table_class) if $schema ne $schema_class;
- }
+ $schema_class->register_class($table_moniker, $table_class);
+ $schema->register_class($table_moniker, $table_class) if $schema ne $schema_class;
}
=head2 tables
sub tables {
my $self = shift;
- return @{$self->_tables};
+ return keys %{$self->_tables};
}
# Make a moniker from a table
}
sub _load_relationships {
- my $self = shift;
+ my ($self, $table) = @_;
- # Construct the fk_info RelBuilder wants to see, by
- # translating table names to monikers in the _fk_info output
- my %fk_info;
- foreach my $table ($self->tables) {
- my $tbl_fk_info = $self->_table_fk_info($table);
- foreach my $fkdef (@$tbl_fk_info) {
- $fkdef->{remote_source} =
- $self->monikers->{delete $fkdef->{remote_table}};
- }
- my $moniker = $self->monikers->{$table};
- $fk_info{$moniker} = $tbl_fk_info;
+ my $tbl_fk_info = $self->_table_fk_info($table);
+ foreach my $fkdef (@$tbl_fk_info) {
+ $fkdef->{remote_source} =
+ $self->monikers->{delete $fkdef->{remote_table}};
}
- my $relbuilder = DBIx::Class::Schema::Loader::RelBuilder->new(
- $self->schema_class, \%fk_info, $self->inflect_plural,
- $self->inflect_singular
- );
+ my $local_moniker = $self->monikers->{$table};
+ my $rel_stmts = $self->{relbuilder}->generate_code($local_moniker, $tbl_fk_info);
- my $rel_stmts = $relbuilder->generate_code;
foreach my $src_class (sort keys %$rel_stmts) {
my $src_stmts = $rel_stmts->{$src_class};
foreach my $stmt (@$src_stmts) {
push(@{$self->{_dump_storage}->{$class}}, $stmt) if $self->dump_directory;
}
+# Like above, but separately for the externally loaded stuff
+sub _ext_stmt {
+ my ($self, $class, $stmt) = @_;
+ push(@{$self->{_ext_storage}->{$class}}, $stmt) if $self->dump_directory;
+}
+
=head2 monikers
Returns a hashref of loaded table to moniker mappings. There will
use strict;
use warnings;
-use base qw/DBIx::Class::Schema::Loader::Base Class::Accessor::Fast/;
+use base qw/DBIx::Class::Schema::Loader::Base/;
use Class::C3;
use Carp::Clan qw/^DBIx::Class/;
use UNIVERSAL::require;
+our $VERSION = '0.03999_01';
+
=head1 NAME
DBIx::Class::Schema::Loader::DBI - DBIx::Class::Schema::Loader DBI Implementation.
return @tables;
}
+=head2 load
+
+We override L<DBIx::Class::Schema::Loader::Base/load> here to hook in our localized settings for C<$dbh> error handling.
+
+=cut
+
+sub load {
+ my $self = shift;
+
+ local $self->schema->storage->dbh->{RaiseError} = 1;
+ local $self->schema->storage->dbh->{PrintError} = 0;
+ $self->next::method(@_);
+}
+
# Returns an arrayref of column names
sub _table_columns {
my ($self, $table) = @_;
my $sth = $dbh->prepare($self->schema->storage->sql_maker->select($table, undef, \'1 = 0'));
$sth->execute;
- return \@{$sth->{NAME_lc}};
+ my $retval = \@{$sth->{NAME_lc}};
+ $sth->finish;
+
+ $retval;
}
# Returns arrayref of pk col names
sub _table_pk_info {
- my ( $self, $table ) = @_;
+ my ($self, $table) = @_;
my $dbh = $self->schema->storage->dbh;
return \@primary;
}
-# Override this for uniq info
+# Override this for vendor-specific uniq info
sub _table_uniq_info {
- warn "No UNIQUE constraint information can be gathered for this vendor";
- return [];
+ my ($self, $table) = @_;
+
+ my $dbh = $self->schema->storage->dbh;
+ if(!$dbh->can('statistics_info')) {
+ warn "No UNIQUE constraint information can be gathered for this vendor";
+ return [];
+ }
+
+ my %indices;
+ my $sth = $dbh->statistics_info(undef, $self->db_schema, $table, 1, 1);
+ while(my $row = $sth->fetchrow_hashref) {
+ # skip table-level stats, conditional indexes, and any index missing
+ # critical fields
+ next if $row->{TYPE} eq 'table'
+ || defined $row->{FILTER_CONDITION}
+ || !$row->{INDEX_NAME}
+ || !defined $row->{ORDINAL_POSITION}
+ || !$row->{COLUMN_NAME};
+
+ $indices{$row->{INDEX_NAME}}->{$row->{ORDINAL_POSITION}} = $row->{COLUMN_NAME};
+ }
+ $sth->finish;
+
+ my @retval;
+ foreach my $index_name (keys %indices) {
+ my $index = $indices{$index_name};
+ push(@retval, [ $index_name => [
+ map { $index->{$_} }
+ sort keys %$index
+ ]]);
+ }
+
+ return \@retval;
}
# Find relationships
$rels{$relid}->{tbl} = $uk_tbl;
$rels{$relid}->{cols}->{$uk_col} = $fk_col;
}
+ $sth->finish;
my @rels;
foreach my $relid (keys %rels) {
return \@rels;
}
+# ported in from DBIx::Class::Storage::DBI:
+sub _columns_info_for {
+ my ($self, $table) = @_;
+
+ my $dbh = $self->schema->storage->dbh;
+
+ if ($dbh->can('column_info')) {
+ my %result;
+ eval {
+ my $sth = $dbh->column_info( undef, $self->db_schema, $table, '%' );
+ $sth->execute();
+ while ( my $info = $sth->fetchrow_hashref() ){
+ my %column_info;
+ $column_info{data_type} = $info->{TYPE_NAME};
+ $column_info{size} = $info->{COLUMN_SIZE};
+ $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
+ $column_info{default_value} = $info->{COLUMN_DEF};
+ my $col_name = $info->{COLUMN_NAME};
+ $col_name =~ s/^\"(.*)\"$/$1/;
+
+ $result{$col_name} = \%column_info;
+ }
+ $sth->finish;
+ };
+ return \%result if !$@ && scalar keys %result;
+ }
+
+ if($self->db_schema) {
+ $table = $self->db_schema . $self->{_namesep} . $table;
+ }
+ my %result;
+ my $sth = $dbh->prepare($self->schema->storage->sql_maker->select($table, undef, \'1 = 0'));
+ $sth->execute;
+ my @columns = @{$sth->{NAME_lc}};
+ for my $i ( 0 .. $#columns ){
+ my %column_info;
+ $column_info{data_type} = $sth->{TYPE}->[$i];
+ $column_info{size} = $sth->{PRECISION}->[$i];
+ $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
+
+ if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
+ $column_info{data_type} = $1;
+ $column_info{size} = $2;
+ }
+
+ $result{$columns[$i]} = \%column_info;
+ }
+ $sth->finish;
+
+ foreach my $col (keys %result) {
+ my $colinfo = $result{$col};
+ my $type_num = $colinfo->{data_type};
+ my $type_name;
+ if(defined $type_num && $dbh->can('type_info')) {
+ my $type_info = $dbh->type_info($type_num);
+ $type_name = $type_info->{TYPE_NAME} if $type_info;
+ $colinfo->{data_type} = $type_name if $type_name;
+ }
+ }
+
+ return \%result;
+}
+
=head1 SEE ALSO
L<DBIx::Class::Schema::Loader>
use Carp::Clan qw/^DBIx::Class/;
use Class::C3;
+our $VERSION = '0.03999_01';
+
=head1 NAME
DBIx::Class::Schema::Loader::DBI::DB2 - DBIx::Class::Schema::Loader::DBI DB2 Implementation.
package My::Schema;
use base qw/DBIx::Class::Schema::Loader/;
- __PACKAGE__->loader_options(
- relationships => 1,
- db_schema => "MYSCHEMA",
- );
+ __PACKAGE__->loader_options( db_schema => "MYSCHEMA" );
1;
--- /dev/null
+package DBIx::Class::Schema::Loader::DBI::Oracle;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Schema::Loader::DBI';
+use Carp::Clan qw/^DBIx::Class/;
+use Class::C3;
+
+our $VERSION = '0.03999_01';
+
+=head1 NAME
+
+DBIx::Class::Schema::Loader::DBI::Oracle - DBIx::Class::Schema::Loader::DBI
+Oracle Implementation.
+
+=head1 SYNOPSIS
+
+ package My::Schema;
+ use base qw/DBIx::Class::Schema::Loader/;
+
+ __PACKAGE__->loader_options( debug => 1 );
+
+ 1;
+
+=head1 DESCRIPTION
+
+See L<DBIx::Class::Schema::Loader::Base>.
+
+This module is considered experimental and not well tested yet.
+
+=cut
+
+sub _table_columns {
+ my ($self, $table) = @_;
+
+ my $dbh = $self->schema->storage->dbh;
+
+ my $sth = $dbh->prepare($self->schema->storage->sql_maker->select($table, undef, \'1 = 0'));
+ $sth->execute;
+ return \@{$sth->{NAME_lc}};
+}
+
+sub _tables_list {
+ my $self = shift;
+
+ my $dbh = $self->schema->storage->dbh;
+
+ my @tables;
+ for my $table ( $dbh->tables(undef, $self->db_schema, '%', 'TABLE,VIEW') ) { #catalog, schema, table, type
+ my $quoter = $dbh->get_info(29);
+ $table =~ s/$quoter//g;
+
+ # remove "user." (schema) prefixes
+ $table =~ s/\w+\.//;
+
+ next if $table eq 'PLAN_TABLE';
+ $table = lc $table;
+ push @tables, $1
+ if $table =~ /\A(\w+)\z/;
+ }
+ return @tables;
+}
+
+sub _table_uniq_info {
+ my ($self, $table) = @_;
+
+ my @uniqs;
+ my $dbh = $self->schema->storage->dbh;
+
+ my $sth = $dbh->prepare_cached(
+ qq{SELECT constraint_name, ucc.column_name FROM user_constraints JOIN user_cons_columns ucc USING (constraint_name) WHERE ucc.table_name=? AND constraint_type='U'}
+ ,{}, 1);
+
+ $sth->execute(uc $table);
+ my %constr_names;
+ while(my $constr = $sth->fetchrow_arrayref) {
+ my $constr_name = $constr->[0];
+ my $constr_def = $constr->[1];
+ $constr_name =~ s/\Q$self->{_quoter}\E//;
+ $constr_def =~ s/\Q$self->{_quoter}\E//;
+ push @{$constr_names{$constr_name}}, lc $constr_def;
+ }
+ map {
+ push(@uniqs, [ lc $_ => $constr_names{$_} ]);
+ } keys %constr_names;
+
+ return \@uniqs;
+}
+
+sub _table_pk_info {
+ my ( $self, $table ) = @_;
+ return $self->SUPER::_table_pk_info(uc $table);
+}
+
+sub _table_fk_info {
+ my ($self, $table) = @_;
+
+ my $dbh = $self->schema->storage->dbh;
+ my $sth = $dbh->foreign_key_info( '', '', '', '',
+ $self->db_schema, uc $table );
+ return [] if !$sth;
+
+ my %rels;
+
+ my $i = 1; # for unnamed rels, which hopefully have only 1 column ...
+ while(my $raw_rel = $sth->fetchrow_arrayref) {
+ my $uk_tbl = lc $raw_rel->[2];
+ my $uk_col = lc $raw_rel->[3];
+ my $fk_col = lc $raw_rel->[7];
+ my $relid = ($raw_rel->[11] || ( "__dcsld__" . $i++ ));
+ $uk_tbl =~ s/\Q$self->{_quoter}\E//g;
+ $uk_col =~ s/\Q$self->{_quoter}\E//g;
+ $fk_col =~ s/\Q$self->{_quoter}\E//g;
+ $relid =~ s/\Q$self->{_quoter}\E//g;
+ $rels{$relid}->{tbl} = $uk_tbl;
+ $rels{$relid}->{cols}->{$uk_col} = $fk_col;
+ }
+
+ my @rels;
+ foreach my $relid (keys %rels) {
+ push(@rels, {
+ remote_columns => [ keys %{$rels{$relid}->{cols}} ],
+ local_columns => [ values %{$rels{$relid}->{cols}} ],
+ remote_table => $rels{$relid}->{tbl},
+ });
+ }
+
+ return \@rels;
+}
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
+L<DBIx::Class::Schema::Loader::DBI>
+
+=head1 AUTHOR
+
+TSUNODA Kazuya C<drk@drk7.jp>
+
+=cut
+
+1;
use Carp::Clan qw/^DBIx::Class/;
use Class::C3;
+our $VERSION = '0.03999_01';
+
=head1 NAME
DBIx::Class::Schema::Loader::DBI::Pg - DBIx::Class::Schema::Loader::DBI
package My::Schema;
use base qw/DBIx::Class::Schema::Loader/;
- __PACKAGE__->loader_options(
- relationships => 1,
- );
+ __PACKAGE__->loader_options( debug => 1 );
1;
sub _table_uniq_info {
my ($self, $table) = @_;
+ # Use the default support if available
+ return $self->next::method($table)
+ if $DBD::Pg::VERSION >= 1.50;
+
my @uniqs;
my $dbh = $self->schema->storage->dbh;
use Text::Balanced qw( extract_bracketed );
use Class::C3;
+our $VERSION = '0.03999_01';
+
=head1 NAME
DBIx::Class::Schema::Loader::DBI::SQLite - DBIx::Class::Schema::Loader::DBI SQLite Implementation.
package My::Schema;
use base qw/DBIx::Class::Schema::Loader/;
- __PACKAGE__->loader_optoins( relationships => 1 );
+ __PACKAGE__->loader_options( debug => 1 );
1;
See L<DBIx::Class::Schema::Loader::Base>.
+=head1 METHODS
+
+=head2 rescan
+
+SQLite will fail all further commands on a connection if the
+underlying schema has been modified. Therefore, any runtime
+changes requiring C<rescan> also require us to re-connect
+to the database. The C<rescan> method here handles that
+reconnection for you, but beware that this must occur for
+any other open sqlite connections as well.
+
=cut
+sub rescan {
+ my ($self, $schema) = @_;
+
+ $schema->storage->disconnect if $schema->storage;
+ $self->next::method($schema);
+}
+
# XXX this really needs a re-factor
sub _sqlite_parse_table {
my ($self, $table) = @_;
next if $row->{tbl_name} =~ /^sqlite_/;
push @tables, $row->{tbl_name};
}
+ $sth->finish;
return @tables;
}
package DBIx::Class::Schema::Loader::DBI::Writing;
use strict;
+our $VERSION = '0.03999_01';
+
# Empty. POD only.
1;
use Carp::Clan qw/^DBIx::Class/;
use Class::C3;
+our $VERSION = '0.03999_01';
+
=head1 NAME
DBIx::Class::Schema::Loader::DBI::mysql - DBIx::Class::Schema::Loader::DBI mysql Implementation.
package My::Schema;
use base qw/DBIx::Class::Schema::Loader/;
- __PACKAGE__->load_from_connection(
- relationships => 1,
- );
+ __PACKAGE__->loader_options( debug => 1 );
1;
use strict;
use warnings;
use Carp::Clan qw/^DBIx::Class/;
-use Lingua::EN::Inflect ();
use Lingua::EN::Inflect::Number ();
+our $VERSION = '0.03999_01';
+
=head1 NAME
DBIx::Class::Schema::Loader::RelBuilder - Builds relationships for DBIx::Class::Schema::Loader
=head2 new
-Arguments: schema_class (scalar), fk_info (hashref), inflect_plural, inflect_singular
+Arguments: schema_class (scalar), inflect_plural, inflect_singular
C<$schema_class> should be a schema class name, where the source
classes have already been set up and registered. Column info, primary
key, and unique constraints will be drawn from this schema for all
of the existing source monikers.
-The fk_info hashref's contents should take the form:
-
- {
- TableMoniker => [
- {
- local_columns => [ 'col2', 'col3' ],
- remote_columns => [ 'col5', 'col7' ],
- remote_moniker => 'AnotherTableMoniker',
- },
- # ...
- ],
- AnotherTableMoniker => [
- # ...
- ],
- # ...
- }
-
Options inflect_plural and inflect_singular are optional, and are better documented
in L<DBIx::Class::Schema::Loader::Base>.
=head2 generate_code
-This method will return the generated relationships as a hashref per table moniker,
-containing an arrayref of code strings which can be "eval"-ed in the context of
-the source class, like:
+Arguments: local_moniker (scalar), fk_info (arrayref)
+
+This generates the code for the relationships of a given table.
+
+C<local_moniker> is the moniker name of the table which had the REFERENCES
+statements. The fk_info arrayref's contents should take the form:
+
+ [
+ {
+ local_columns => [ 'col2', 'col3' ],
+ remote_columns => [ 'col5', 'col7' ],
+ remote_moniker => 'AnotherTableMoniker',
+ },
+ {
+ local_columns => [ 'col1', 'col4' ],
+ remote_columns => [ 'col1', 'col2' ],
+ remote_moniker => 'YetAnotherTableMoniker',
+ },
+ # ...
+ ],
+
+This method will return the generated relationships as a hashref keyed on the
+class names. The values are arrayrefs of hashes containing method name and
+arguments, like so:
{
'Some::Source::Class' => [
- "belongs_to( col1 => 'AnotherTableMoniker' )",
- "has_many( anothers => 'AnotherTableMoniker', 'col15' )",
+ { method => 'belongs_to', arguments => [ 'col1', 'Another::Source::Class' ],
+ { method => 'has_many', arguments => [ 'anothers', 'Yet::Another::Source::Class', 'col15' ],
],
'Another::Source::Class' => [
# ...
# ...
}
-You might want to use this in building an on-disk source class file, by
-adding each string to the appropriate source class file,
-prefixed by C<__PACKAGE__-E<gt>>.
-
=cut
sub new {
- my ( $class, $schema, $fk_info, $inflect_pl, $inflect_singular ) = @_;
+ my ( $class, $schema, $inflect_pl, $inflect_singular ) = @_;
my $self = {
schema => $schema,
- fk_info => $fk_info,
inflect_plural => $inflect_pl,
inflect_singular => $inflect_singular,
};
return $inflected if $inflected;
}
- return $self->{legacy_default_inflections}
- ? Lingua::EN::Inflect::PL($relname)
- : Lingua::EN::Inflect::Number::to_PL($relname);
+ return Lingua::EN::Inflect::Number::to_PL($relname);
}
# Singularize a relationship name
return $inflected if $inflected;
}
- return $self->{legacy_default_inflections}
- ? $relname
- : Lingua::EN::Inflect::Number::to_S($relname);
+ return Lingua::EN::Inflect::Number::to_S($relname);
}
sub generate_code {
- my $self = shift;
+ my ($self, $local_moniker, $rels) = @_;
my $all_code = {};
- foreach my $local_moniker (keys %{$self->{fk_info}}) {
- my $local_table = $self->{schema}->source($local_moniker)->from;
- my $local_class = $self->{schema}->class($local_moniker);
- my $rels = $self->{fk_info}->{$local_moniker};
+ my $local_table = $self->{schema}->source($local_moniker)->from;
+ my $local_class = $self->{schema}->class($local_moniker);
- my %counters;
- foreach my $rel (@$rels) {
- next if !$rel->{remote_source};
- $counters{$rel->{remote_source}}++;
+ my %counters;
+ foreach my $rel (@$rels) {
+ next if !$rel->{remote_source};
+ $counters{$rel->{remote_source}}++;
+ }
+
+ foreach my $rel (@$rels) {
+ next if !$rel->{remote_source};
+ my $local_cols = $rel->{local_columns};
+ my $remote_cols = $rel->{remote_columns};
+ my $remote_moniker = $rel->{remote_source};
+ my $remote_obj = $self->{schema}->source($remote_moniker);
+ my $remote_class = $self->{schema}->class($remote_moniker);
+ my $remote_table = $remote_obj->from;
+ $remote_cols ||= [ $remote_obj->primary_columns ];
+
+ if($#$local_cols != $#$remote_cols) {
+ croak "Column count mismatch: $local_moniker (@$local_cols) "
+ . "$remote_moniker (@$remote_cols)";
}
- foreach my $rel (@$rels) {
- next if !$rel->{remote_source};
- my $local_cols = $rel->{local_columns};
- my $remote_cols = $rel->{remote_columns};
- my $remote_moniker = $rel->{remote_source};
- my $remote_obj = $self->{schema}->source($remote_moniker);
- my $remote_class = $self->{schema}->class($remote_moniker);
- my $remote_table = $remote_obj->from;
- $remote_cols ||= [ $remote_obj->primary_columns ];
-
- if($#$local_cols != $#$remote_cols) {
- croak "Column count mismatch: $local_moniker (@$local_cols) "
- . "$remote_moniker (@$remote_cols)";
- }
+ my %cond;
+ foreach my $i (0 .. $#$local_cols) {
+ $cond{$remote_cols->[$i]} = $local_cols->[$i];
+ }
- my %cond;
- foreach my $i (0 .. $#$local_cols) {
- $cond{$remote_cols->[$i]} = $local_cols->[$i];
- }
+ # If more than one rel between this pair of tables, use the
+ # local col name(s) as the relname in the foreign source, instead
+ # of the local table name.
+ my $local_relname;
+ if($counters{$remote_moniker} > 1) {
+ $local_relname = $self->_inflect_plural(
+ lc($local_table) . q{_} . join(q{_}, @$local_cols)
+ );
+ } else {
+ $local_relname = $self->_inflect_plural(lc $local_table);
+ }
- # If more than one rel between this pair of tables, use the
- # local col name(s) as the relname in the foreign source, instead
- # of the local table name.
- my $local_relname;
- if($counters{$remote_moniker} > 1) {
- $local_relname = $self->_inflect_plural(
- lc($local_table) . q{_} . join(q{_}, @$local_cols)
- );
- } else {
- $local_relname = $self->_inflect_plural(lc $local_table);
- }
+ # for single-column case, set the relname to the column name,
+ # to make filter accessors work
+ my $remote_relname;
+ if(scalar keys %cond == 1) {
+ my ($col) = keys %cond;
+ $remote_relname = $self->_inflect_singular($cond{$col});
+ }
+ else {
+ $remote_relname = $self->_inflect_singular(lc $remote_table);
+ }
- # for single-column case, set the relname to the column name,
- # to make filter accessors work
- my $remote_relname;
- if(scalar keys %cond == 1) {
- my ($col) = keys %cond;
- $remote_relname = $self->_inflect_singular($cond{$col});
- }
- else {
- $remote_relname = $self->_inflect_singular(lc $remote_table);
- }
+ my %rev_cond = reverse %cond;
- my %rev_cond = reverse %cond;
+ for (keys %rev_cond) {
+ $rev_cond{"foreign.$_"} = "self.".$rev_cond{$_};
+ delete $rev_cond{$_};
+ }
- for (keys %rev_cond) {
- $rev_cond{"foreign.$_"} = "self.".$rev_cond{$_};
- delete $rev_cond{$_};
+ push(@{$all_code->{$local_class}},
+ { method => 'belongs_to',
+ args => [ $remote_relname,
+ $remote_class,
+ \%cond,
+ ],
}
-
- push(@{$all_code->{$local_class}},
- { method => 'belongs_to',
- args => [ $remote_relname,
- $remote_class,
- \%cond,
- ],
- }
- );
-
- push(@{$all_code->{$remote_class}},
- { method => 'has_many',
- args => [ $local_relname,
- $local_class,
- \%rev_cond,
- ],
- }
- );
- }
+ );
+
+ push(@{$all_code->{$remote_class}},
+ { method => 'has_many',
+ args => [ $local_relname,
+ $local_class,
+ \%rev_cond,
+ ],
+ }
+ );
}
return $all_code;
use strict;
-use Test::More tests => 9;
+use Test::More tests => 10;
BEGIN {
use_ok 'DBIx::Class::Schema::Loader';
use_ok 'DBIx::Class::Schema::Loader::DBI::mysql';
use_ok 'DBIx::Class::Schema::Loader::DBI::Pg';
use_ok 'DBIx::Class::Schema::Loader::DBI::DB2';
+ use_ok 'DBIx::Class::Schema::Loader::DBI::Oracle';
use_ok 'DBIx::Class::Schema::Loader::DBI::Writing';
}
--- /dev/null
+use strict;
+use lib qw(t/lib);
+use dbixcsl_common_tests;
+
+my $dsn = $ENV{DBICTEST_ORA_DSN} || '';
+my $user = $ENV{DBICTEST_ORA_USER} || '';
+my $password = $ENV{DBICTEST_ORA_PASS} || '';
+
+my $tester = dbixcsl_common_tests->new(
+ vendor => 'Oracle',
+ auto_inc_pk => 'SERIAL NOT NULL PRIMARY KEY',
+ dsn => $dsn,
+ user => $user,
+ password => $password,
+);
+
+if( !$dsn || !$user ) {
+ $tester->skip_tests('You need to set the DBICTEST_ORA_DSN, _USER, and _PASS environment variables');
+}
+else {
+ $tester->run_tests();
+}
use lib qw(t/lib);
use make_dbictest_db;
-$SIG{__WARN__} = sub { }; # Suppress warnings, as we test a lot of deprecated stuff here
-
# Takes a $schema as input, runs 4 basic tests
sub test_schema {
my ($testname, $schema) = @_;
}
my @invocations = (
- 'deprecated_one' => sub {
- package DBICTest::Schema::1;
- use base qw/ DBIx::Class::Schema::Loader /;
- __PACKAGE__->connection($make_dbictest_db::dsn);
- __PACKAGE__->load_from_connection( relationships => 1 );
- __PACKAGE__;
- },
- 'deprecated_two' => sub {
- package DBICTest::Schema::2;
- use base qw/ DBIx::Class::Schema::Loader /;
- __PACKAGE__->load_from_connection(
- relationships => 1,
- connect_info => [ $make_dbictest_db::dsn ],
- );
- __PACKAGE__;
- },
- 'deprecated_three' => sub {
- package DBICTest::Schema::3;
- use base qw/ DBIx::Class::Schema::Loader /;
- __PACKAGE__->load_from_connection(
- relationships => 1,
- dsn => $make_dbictest_db::dsn,
- );
- __PACKAGE__;
- },
- 'deprecated_four' => sub {
- package DBICTest::Schema::4;
- use base qw/ DBIx::Class::Schema::Loader /;
- __PACKAGE__->connection($make_dbictest_db::dsn);
- __PACKAGE__->loader_options( relationships => 1 );
- __PACKAGE__;
- },
'hardcode' => sub {
package DBICTest::Schema::5;
use base qw/ DBIx::Class::Schema::Loader /;
- __PACKAGE__->loader_options( relationships => 1 );
__PACKAGE__->connection($make_dbictest_db::dsn);
__PACKAGE__;
},
'normal' => sub {
package DBICTest::Schema::6;
use base qw/ DBIx::Class::Schema::Loader /;
- __PACKAGE__->loader_options( relationships => 1 );
+ __PACKAGE__->loader_options();
__PACKAGE__->connect($make_dbictest_db::dsn);
},
'make_schema_at' => sub {
use DBIx::Class::Schema::Loader qw/ make_schema_at /;
make_schema_at(
'DBICTest::Schema::7',
- { relationships => 1 },
+ { dump_overwrite => 1 },
[ $make_dbictest_db::dsn ],
);
DBICTest::Schema::7->clone;
use base qw/ DBIx::Class::Schema::Loader /;
__PACKAGE__->connect(
$make_dbictest_db::dsn,
- { loader_options => { relationships => 1 } }
+ { loader_options => { dump_overwrite => 1 } }
);
},
'embedded_options_in_attrs' => sub {
$make_dbictest_db::dsn,
undef,
undef,
- { AutoCommit => 1, loader_options => { relationships => 1 } }
+ { AutoCommit => 1, loader_options => { dump_overwrite => 1 } }
);
},
'embedded_options_make_schema_at' => sub {
{ },
[
$make_dbictest_db::dsn,
- { loader_options => { relationships => 1 } },
+ { loader_options => { dump_overwrite => 1 } },
],
);
"DBICTest::Schema::10";
'almost_embedded' => sub {
package DBICTest::Schema::11;
use base qw/ DBIx::Class::Schema::Loader /;
- __PACKAGE__->loader_options( relationships => 1 );
+ __PACKAGE__->loader_options( dump_overwrite => 1 );
__PACKAGE__->connect(
$make_dbictest_db::dsn,
undef, undef, { AutoCommit => 1 }
use DBIx::Class::Schema::Loader;
DBIx::Class::Schema::Loader::make_schema_at(
'DBICTest::Schema::12',
- { relationships => 1 },
+ { dump_overwrite => 1 },
[ $make_dbictest_db::dsn ],
);
DBICTest::Schema::12->clone;
package DBICTest::Schema;
use base qw/ DBIx::Class::Schema::Loader /;
- __PACKAGE__->loader_options( relationships => 1 );
+ __PACKAGE__->loader_options( dump_overwrite => 1 );
__PACKAGE__->storage_type( '::xyzzy' );
}
package DBICTest::Schema::1;
use base qw/ DBIx::Class::Schema::Loader /;
__PACKAGE__->loader_options(
- relationships => 1,
dump_directory => $dump_path,
);
}
package DBICTest::Schema::2;
use base qw/ DBIx::Class::Schema::Loader /;
__PACKAGE__->loader_options(
- relationships => 1,
dump_directory => $dump_path,
dump_overwrite => 1,
);
}
-plan tests => 8;
+plan tests => 5;
rmtree($dump_path, 1, 1);
eval { DBICTest::Schema::1->connect($make_dbictest_db::dsn) };
ok(!$@, 'no death with dump_directory set') or diag "Dump failed: $@";
-DBICTest::Schema::1->loader(undef);
+DBICTest::Schema::1->_loader_invoked(undef);
SKIP: {
skip "ActiveState perl produces additional warnings", 5
}
my @warnings_regexes = (
qr|Dumping manual schema|,
- (qr|DBICTest/Schema/1.*?.pm exists, will not overwrite|) x 3,
qr|Schema dump completed|,
);
ok(!$@, 'no death with dump_directory set (overwrite1)')
or diag "Dump failed: $@";
-DBICTest::Schema::2->loader(undef);
+DBICTest::Schema::2->_loader_invoked(undef);
eval { DBICTest::Schema::2->connect($make_dbictest_db::dsn) };
ok(!$@, 'no death with dump_directory set (overwrite2)')
or diag "Dump failed: $@";
--- /dev/null
+use strict;
+use Test::More;
+use lib qw(t/lib);
+use File::Path;
+use make_dbictest_db;
+require DBIx::Class::Schema::Loader;
+
+plan tests => 40;
+
+plan skip_all => "ActiveState perl produces additional warnings, and this test uses unix paths"
+ if ($^O eq 'MSWin32');
+
+my $DUMP_PATH = './t/_dump';
+
+sub do_dump_test {
+ my %tdata = @_;
+
+ my $schema_class = $tdata{classname};
+
+ no strict 'refs';
+ @{$schema_class . '::ISA'} = ('DBIx::Class::Schema::Loader');
+ $schema_class->loader_options(dump_directory => $DUMP_PATH, %{$tdata{options}});
+
+ my @warns;
+ eval {
+ local $SIG{__WARN__} = sub { push(@warns, @_) };
+ $schema_class->connect($make_dbictest_db::dsn);
+ };
+ my $err = $@;
+ $schema_class->storage->disconnect if !$err && $schema_class->storage;
+ undef *{$schema_class};
+
+ is($err, $tdata{error});
+
+ my $check_warns = $tdata{warnings};
+ is(@warns, @$check_warns);
+ for(my $i = 0; $i <= $#$check_warns; $i++) {
+ like($warns[$i], $check_warns->[$i]);
+ }
+
+ my $file_regexes = $tdata{regexes};
+ my $file_neg_regexes = $tdata{neg_regexes} || {};
+ my $schema_regexes = delete $file_regexes->{schema};
+
+ my $schema_path = $DUMP_PATH . '/' . $schema_class;
+ $schema_path =~ s{::}{/}g;
+ dump_file_like($schema_path . '.pm', @$schema_regexes);
+ foreach my $src (keys %$file_regexes) {
+ my $src_file = $schema_path . '/' . $src . '.pm';
+ dump_file_like($src_file, @{$file_regexes->{$src}});
+ }
+ foreach my $src (keys %$file_neg_regexes) {
+ my $src_file = $schema_path . '/' . $src . '.pm';
+ dump_file_not_like($src_file, @{$file_neg_regexes->{$src}});
+ }
+}
+
+sub dump_file_like {
+ my $path = shift;
+ open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!";
+ my $contents = do { local $/; <$dumpfh>; };
+ close($dumpfh);
+ like($contents, $_) for @_;
+}
+
+sub dump_file_not_like {
+ my $path = shift;
+ open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!";
+ my $contents = do { local $/; <$dumpfh>; };
+ close($dumpfh);
+ unlike($contents, $_) for @_;
+}
+
+sub append_to_class {
+ my ($class, $string) = @_;
+ $class =~ s{::}{/}g;
+ $class = $DUMP_PATH . '/' . $class . '.pm';
+ open(my $appendfh, '>>', $class) or die "Failed to open '$class' for append: $!";
+ print $appendfh $string;
+ close($appendfh);
+}
+
+rmtree($DUMP_PATH, 1, 1);
+
+do_dump_test(
+ classname => 'DBICTest::DumpMore::1',
+ options => { },
+ error => '',
+ warnings => [
+ qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
+ qr/Schema dump completed/,
+ ],
+ regexes => {
+ schema => [
+ qr/package DBICTest::DumpMore::1;/,
+ qr/->load_classes/,
+ ],
+ Foo => [
+ qr/package DBICTest::DumpMore::1::Foo;/,
+ qr/->set_primary_key/,
+ qr/1;\n$/,
+ ],
+ Bar => [
+ qr/package DBICTest::DumpMore::1::Bar;/,
+ qr/->set_primary_key/,
+ qr/1;\n$/,
+ ],
+ },
+);
+
+append_to_class('DBICTest::DumpMore::1::Foo',q{# XXX This is my custom content XXX});
+
+do_dump_test(
+ classname => 'DBICTest::DumpMore::1',
+ options => { },
+ error => '',
+ warnings => [
+ qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
+ qr/Schema dump completed/,
+ ],
+ regexes => {
+ schema => [
+ qr/package DBICTest::DumpMore::1;/,
+ qr/->load_classes/,
+ ],
+ Foo => [
+ qr/package DBICTest::DumpMore::1::Foo;/,
+ qr/->set_primary_key/,
+ qr/1;\n# XXX This is my custom content XXX/,
+ ],
+ Bar => [
+ qr/package DBICTest::DumpMore::1::Bar;/,
+ qr/->set_primary_key/,
+ qr/1;\n$/,
+ ],
+ },
+);
+
+do_dump_test(
+ classname => 'DBICTest::DumpMore::1',
+ options => { dump_overwrite => 1 },
+ error => '',
+ warnings => [
+ qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
+ qr/Deleting existing file /,
+ qr/Deleting existing file /,
+ qr/Deleting existing file /,
+ qr/Schema dump completed/,
+ ],
+ regexes => {
+ schema => [
+ qr/package DBICTest::DumpMore::1;/,
+ qr/->load_classes/,
+ ],
+ Foo => [
+ qr/package DBICTest::DumpMore::1::Foo;/,
+ qr/->set_primary_key/,
+ qr/1;\n$/,
+ ],
+ Bar => [
+ qr/package DBICTest::DumpMore::1::Bar;/,
+ qr/->set_primary_key/,
+ qr/1;\n$/,
+ ],
+ },
+ neg_regexes => {
+ Foo => [
+ qr/# XXX This is my custom content XXX/,
+ ],
+ },
+);
+
+END { rmtree($DUMP_PATH, 1, 1); }
sub run_tests {
my $self = shift;
- plan tests => 76;
+ plan tests => 80;
$self->create();
}
my $conn = $schema_class->clone;
- my $monikers = $schema_class->loader->monikers;
- my $classes = $schema_class->loader->classes;
+ my $monikers = {};
+ my $classes = {};
+ foreach my $source_name ($schema_class->sources) {
+ my $table_name = $schema_class->source($source_name)->from;
+ $monikers->{$table_name} = $source_name;
+ $classes->{$table_name} = $schema_class . q{::} . $source_name;
+ }
my $moniker1 = $monikers->{loader_test1};
my $class1 = $classes->{loader_test1};
isa_ok( $obj15->loader_test14, $class14 );
}
}
+
+ # rescan test
+ SKIP: {
+ skip $self->{skip_rels}, 4 if $self->{skip_rels};
+
+ my @statements_rescan = (
+ qq{
+ CREATE TABLE loader_test25 (
+ id INTEGER NOT NULL PRIMARY KEY,
+ loader_test2 INTEGER NOT NULL,
+ FOREIGN KEY (loader_test2) REFERENCES loader_test2 (id)
+ ) $self->{innodb}
+ },
+ q{ INSERT INTO loader_test25 (id,loader_test2) VALUES(123, 1) },
+ q{ INSERT INTO loader_test25 (id,loader_test2) VALUES(321, 2) },
+ );
+
+ my $dbh = $self->dbconnect(1);
+ $dbh->do($_) for @statements_rescan;
+ $dbh->disconnect;
+
+ my @new = $conn->rescan;
+ is(scalar(@new), 1);
+ is($new[0], 'LoaderTest25');
+
+ my $rsobj25 = $conn->resultset('LoaderTest25');
+ isa_ok($rsobj25, 'DBIx::Class::ResultSet');
+ my $obj25 = $rsobj25->find(123);
+ isa_ok( $obj25->loader_test2, $class2);
+ }
}
sub dbconnect {
},
q{ INSERT INTO loader_test15 (id,loader_test14) VALUES (1,123) },
- );
+ );
$self->drop_tables;
loader_test14
/;
+ my @tables_rescan = qw/ loader_test25 /;
+
my $drop_fk_mysql =
q{ALTER TABLE loader_test10 DROP FOREIGN KEY loader_test11_fk;};
unless($self->{no_implicit_rels}) {
$dbh->do("DROP TABLE $_") for (@tables_implicit_rels);
}
+ $dbh->do("DROP TABLE $_") for (@tables_rescan);
}
$dbh->do("DROP TABLE $_") for (@tables);
$dbh->disconnect;
projects / dbsrgits/DBIx-Class-Schema-Loader.git / commitdiff