From: Rafael Kitover Date: Mon, 17 May 2010 21:33:47 +0000 (-0400) Subject: finish preserve_case support X-Git-Tag: 0.07000~8 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b511f36e7550cfe8aac546be689c8bd320a83975;p=dbsrgits%2FDBIx-Class-Schema-Loader.git finish preserve_case support --- diff --git a/Changes b/Changes index 474cc95..0f959b2 100644 --- a/Changes +++ b/Changes @@ -1,15 +1,15 @@ Revision history for Perl extension DBIx::Class::Schema::Loader + - rescan now reloads all tables - minor type info improvements for all DBs - fix erroneous default_value for MySQL NOT NULL columns (RT#57225) - remove is_deferrable => 1 from default for belongs_to rels - better type info for Oracle - preliminary Informix support - unregister dropped sources on rescan - - added 'preserve_case' option with support for SQLite, mysql, MSSQL, - SQLAnywhere and Firebird/InterBase; removed the MSSQL - 'case_sensitive_collation' and the Firebird/InterBase 'unquoted_ddl' - options in favor of it. + - added 'preserve_case' option with support for all DBs where it makes + sense; removed the MSSQL 'case_sensitive_collation' and the + Firebird/InterBase 'unquoted_ddl' options in favor of it. - support CamelCase table names and column names (in case-preserving mode) at the v7 naming level - rewrite datetime default functions as \'CURRENT_TIMESTAMP' where diff --git a/TODO b/TODO index 73abcd0..81dabd3 100644 --- a/TODO +++ b/TODO @@ -4,7 +4,6 @@ - introspect views and make proper ResultSource::View classes with defining SQL - encode loader options in Schema.pm - introspect on_update/on_delete/is_deferrable - - preserve_case mode for remaining backends - Low Priority - support multiple/all schemas, instead of just one - support pk/uk/fk info on views, possibly (materialized views?) @@ -30,8 +29,6 @@ - add hashref form of generate_pod to control which POD is generated - add hashref form of components to control which components are added to which classes - - add common tests for preserve_case option where it must be exclusive - (Oracle, Firebird) - check rel accessors for method conflicts - add an option to add extra code to Result classes - redo in-memory schema as an @INC coderef rather than temp files @@ -64,13 +61,11 @@ - table/column comments - introspect on_update/on_delete/is_deferrable - introspect view SQL - - preserve_case mode - domains - Oracle - table/column comments - introspect on_update/on_delete/is_deferrable - introspect view SQL - - preserve_case mode - domains - Sybase ASE - table/column comments @@ -98,7 +93,6 @@ - domains - Informix - data_type tests - - preserve_case mode - table/column comments - introspect on_update/on_delete/is_deferrable - introspect view SQL diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm index 85374ec..1c49a0d 100644 --- a/lib/DBIx/Class/Schema/Loader/Base.pm +++ b/lib/DBIx/Class/Schema/Loader/Base.pm @@ -852,8 +852,8 @@ sub _load_external { } if ($old_real_inc_path) { - open(my $fh, '<', $old_real_inc_path) - or croak "Failed to open '$old_real_inc_path' for reading: $!"; + my $code = slurp $old_real_inc_path; + $self->_ext_stmt($class, <<"EOF"); # These lines were loaded from '$old_real_inc_path', @@ -862,7 +862,6 @@ sub _load_external { # upgrade. See skip_load_external to disable this feature. EOF - my $code = slurp $old_real_inc_path; $code = $self->_rewrite_old_classnames($code); if ($self->dynamic) { @@ -910,14 +909,11 @@ sub load { Arguments: schema -Rescan the database for newly added tables. Does -not process drops or changes. Returns a list of -the newly added table monikers. +Rescan the database for 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. +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. =cut @@ -944,9 +940,12 @@ sub rescan { } } - my $loaded = $self->_load_tables(@created); + delete $self->{_dump_storage}; + delete $self->{_relations_started}; + + my $loaded = $self->_load_tables(@current); - return map { $self->monikers->{$_} } @$loaded; + return map { $self->monikers->{$_} } @created; } sub _relbuilder { diff --git a/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm b/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm index 2d36a15..b996dab 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm @@ -41,6 +41,10 @@ sub _setup { if (not defined $self->preserve_case) { $self->preserve_case(0); } + elsif ($self->preserve_case) { + $self->schema->storage->sql_maker->quote_char('"'); + $self->schema->storage->sql_maker->name_sep('.'); + } } sub _table_uniq_info { @@ -58,12 +62,12 @@ sub _table_uniq_info { WHERE tc.TABSCHEMA = ? and tc.TABNAME = ? and tc.TYPE = 'U'} ) or die $DBI::errstr; - $sth->execute($self->db_schema, uc $table) or die $DBI::errstr; + $sth->execute($self->db_schema, $self->_uc($table)) or die $DBI::errstr; my %keydata; while(my $row = $sth->fetchrow_arrayref) { my ($col, $constname, $seq) = @$row; - push(@{$keydata{$constname}}, [ $seq, lc $col ]); + push(@{$keydata{$constname}}, [ $seq, $self->_lc($col) ]); } foreach my $keyname (keys %keydata) { my @ordered_cols = map { $_->[1] } sort { $a->[0] <=> $b->[0] } @@ -81,7 +85,7 @@ sub _tables_list { my ($self, $opts) = @_; my $dbh = $self->schema->storage->dbh; - my @tables = map { lc } $dbh->tables( + my @tables = map $self->_lc($_), $dbh->tables( $self->db_schema ? { TABLE_SCHEM => $self->db_schema } : undef ); s/\Q$self->{_quoter}\E//g for @tables; @@ -92,16 +96,16 @@ sub _tables_list { sub _table_pk_info { my ($self, $table) = @_; - return $self->next::method(uc $table); + return $self->next::method($self->_uc($table)); } sub _table_fk_info { my ($self, $table) = @_; - my $rels = $self->next::method(uc $table); + my $rels = $self->next::method($self->_uc($table)); foreach my $rel (@$rels) { - $rel->{remote_table} = lc $rel->{remote_table}; + $rel->{remote_table} = $self->_lc($rel->{remote_table}); } return $rels; @@ -111,7 +115,7 @@ sub _columns_info_for { my $self = shift; my ($table) = @_; - my $result = $self->next::method(uc $table); + my $result = $self->next::method($self->_uc($table)); my $dbh = $self->schema->storage->dbh; @@ -125,7 +129,7 @@ sub _columns_info_for { AND identity = 'Y' AND generated != '' }, {}, 1); - $sth->execute($self->db_schema, uc $table, uc $col); + $sth->execute($self->db_schema, $self->_uc($table), $self->_uc($col)); if ($sth->fetchrow_array) { $info->{is_auto_increment} = 1; } diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Informix.pm b/lib/DBIx/Class/Schema/Loader/DBI/Informix.pm index 2a918ce..e4f8f2e 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/Informix.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/Informix.pm @@ -29,6 +29,10 @@ sub _setup { if (not defined $self->preserve_case) { $self->preserve_case(0); } + elsif ($self->preserve_case) { + $self->schema->storage->sql_maker->quote_char('"'); + $self->schema->storage->sql_maker->name_sep('.'); + } } sub _tables_list { diff --git a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm index f6d2d42..c5cfb2a 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm @@ -21,16 +21,16 @@ See L and L. =head1 COLUMN NAME CASE ISSUES -By default column names from unquoted DDL will be generated in uppercase, as -that is the only way they will work with quoting on. +By default column names from unquoted DDL will be generated in lowercase, for +consistency with other backends. -See the L option -to false if you would like to have lowercase column names. +Set the L option +to true if you would like to have column names in the internal case, which is +uppercase for DDL that uses unquoted identifiers. -Setting this option is a good idea if your DDL uses unquoted identifiers and -you will not use quoting (the -L option in -L.) +Do not use quoting (the L +option in L when in the +default C<< preserve_case => 0 >> mode. Be careful to also not use any SQL reserved words in your DDL. @@ -40,9 +40,6 @@ names) in your Result classes that will only work with quoting off. Mixed-case table and column names will be ignored when this option is on and will not work with quoting turned off. -B This option used to be called C but has been removed in -favor of the more generic option. - =cut sub _setup { @@ -53,14 +50,14 @@ sub _setup { if (not defined $self->preserve_case) { warn <<'EOF'; -WARNING: Assuming mixed-case Firebird DDL, see +WARNING: Assuming unquoted Firebird DDL, see perldoc DBIx::Class::Schema::Loader::DBI::InterBase and the 'preserve_case' option in perldoc DBIx::Class::Schema::Loader::Base for more information. EOF - $self->preserve_case(1); + $self->preserve_case(0); } if ($self->preserve_case) { diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm b/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm index b03b91b..a3fb1eb 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm @@ -81,7 +81,7 @@ sub _table_columns { my $sth = $dbh->column_info(undef, $self->db_schema, $self->_uc($table), '%'); - return [ map lc($_->{COLUMN_NAME}), @{ $sth->fetchall_arrayref({ COLUMN_NAME => 1 }) || [] } ]; + return [ map $self->_lc($_->{COLUMN_NAME}), @{ $sth->fetchall_arrayref({ COLUMN_NAME => 1 }) || [] } ]; } sub _table_uniq_info { diff --git a/t/13db2_common.t b/t/13db2_common.t index 6d41caa..f5f1475 100644 --- a/t/13db2_common.t +++ b/t/13db2_common.t @@ -13,6 +13,8 @@ my $tester = dbixcsl_common_tests->new( user => $user, password => $password, null => '', + preserve_case_mode_is_exclusive => 1, + quote_char => '"', data_types => { 'timestamp DEFAULT CURRENT TIMESTAMP' => { data_type => 'timestamp', default_value => \'current_timestamp', original => { default_value => \'current timestamp' } }, diff --git a/t/14ora_common.t b/t/14ora_common.t index 60c5645..1cab6fa 100644 --- a/t/14ora_common.t +++ b/t/14ora_common.t @@ -29,7 +29,8 @@ my $tester = dbixcsl_common_tests->new( my ($table, $col) = @_; return qq{ DROP SEQUENCE ${table}_${col}_seq }; }, - quote_char => '"', + preserve_case_mode_is_exclusive => 1, + quote_char => '"', dsn => $dsn, user => $user, password => $password, diff --git a/t/18firebird_common.t b/t/18firebird_common.t index a4b3ead..342d885 100644 --- a/t/18firebird_common.t +++ b/t/18firebird_common.t @@ -41,7 +41,9 @@ my $tester = dbixcsl_common_tests->new( ); }, null => '', - loader_options => { preserve_case => 0 }, + preserve_case_mode_is_exclusive => 1, + quote_char => '"', + warnings => [ qr/'preserve_case' option/ ], connect_info => [ ($dbd_interbase_dsn ? { dsn => $dbd_interbase_dsn, user => $dbd_interbase_user, @@ -109,7 +111,7 @@ my $tester = dbixcsl_common_tests->new( => { data_type => 'blob sub_type text' }, }, extra => { - count => 7, + count => 6, run => sub { $schema = shift; @@ -141,15 +143,8 @@ q{ my $guard = Scope::Guard->new(\&cleanup_extra); - delete $schema->_loader->{preserve_case}; - - my $warning; - { - local $SIG{__WARN__} = sub { $warning = shift }; - $schema->_loader->_setup; - } - like $warning, qr/'preserve_case' option/, - 'warning mentions preserve_case option'; + local $schema->_loader->{preserve_case} = 1; + $schema->_loader->_setup; { local $SIG{__WARN__} = sub {}; diff --git a/t/19informix_common.t b/t/19informix_common.t index 2df6a97..f3deeed 100644 --- a/t/19informix_common.t +++ b/t/19informix_common.t @@ -2,6 +2,9 @@ use strict; use lib qw(t/lib); use dbixcsl_common_tests; +# to support " quoted identifiers +BEGIN { $ENV{DELIMIDENT} = 'y' } + # This test doesn't run over a shared memory connection, because of the single connection limit. my $dsn = $ENV{DBICTEST_INFORMIX_DSN} || ''; @@ -17,6 +20,8 @@ my $tester = dbixcsl_common_tests->new( dsn => $dsn, user => $user, password => $password, + loader_options => { preserve_case => 1 }, + quote_char => '"', ); if( !$dsn ) { diff --git a/t/lib/dbixcsl_common_tests.pm b/t/lib/dbixcsl_common_tests.pm index eb86ceb..62a4f68 100644 --- a/t/lib/dbixcsl_common_tests.pm +++ b/t/lib/dbixcsl_common_tests.pm @@ -88,7 +88,7 @@ sub run_tests { my $extra_count = $self->{extra}{count} || 0; - plan tests => @connect_info * (178 + $extra_count + ($self->{data_type_tests}{test_count} || 0)); + plan tests => @connect_info * (179 + $extra_count + ($self->{data_type_tests}{test_count} || 0)); foreach my $info_idx (0..$#connect_info) { my $info = $connect_info[$info_idx]; @@ -177,7 +177,7 @@ sub setup_schema { my %loader_opts = ( constraint => - qr/^(?:\S+\.)?(?:(?:$self->{vendor}|extra)_)?loader_test[0-9]+(?!.*_)/i, + qr/^(?:\S+\.)?(?:(?:$self->{vendor}|extra)_?)?loader_?test[0-9]+(?!.*_)/i, relationships => 1, additional_classes => 'TestAdditional', additional_base_classes => 'TestAdditionalBase', @@ -246,6 +246,8 @@ sub setup_schema { $warn_count++ for grep /\b(?!loader_test9)\w+ has no primary key/i, @loader_warnings; + $warn_count++ for grep { my $w = $_; grep $w =~ $_, @{ $self->{warnings} || [] } } @loader_warnings; + if ($standard_sources) { if($self->{skip_rels}) { SKIP: { @@ -885,7 +887,7 @@ sub test_schema { my $find_cb = sub { return if -d; - return if $_ eq 'LoaderTest30.pm'; + return if /^(?:LoaderTest30|LoaderTest1|LoaderTest2X)\.pm\z/; open my $fh, '<', $_ or die "Could not open $_ for reading: $!"; binmode $fh; @@ -894,6 +896,9 @@ sub test_schema { find $find_cb, $DUMP_DIR; +# system "rm -f /tmp/before_rescan/* /tmp/after_rescan/*"; +# system "cp t/_common_dump/DBIXCSL_Test/Schema/*.pm /tmp/before_rescan"; + my $before_digest = $digest->digest; $conn->storage->disconnect; # needed for Firebird and Informix @@ -920,6 +925,8 @@ sub test_schema { }; is_deeply(\@new, [ qw/LoaderTest30/ ], "Rescan"); +# system "cp t/_common_dump/DBIXCSL_Test/Schema/*.pm /tmp/after_rescan"; + $digest = Digest::MD5->new; find $find_cb, $DUMP_DIR; my $after_digest = $digest->digest; @@ -959,6 +966,8 @@ sub test_schema { # run extra tests $self->{extra}{run}->($conn, $monikers, $classes) if $self->{extra}{run}; + $self->test_preserve_case($conn); + $self->drop_tables unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}; $conn->storage->disconnect; @@ -1000,6 +1009,58 @@ sub test_data_types { } } +sub test_preserve_case { + my ($self, $conn) = @_; + + my ($oqt, $cqt) = $self->get_oqt_cqt(always => 1); # open quote, close quote + + my $dbh = $conn->storage->dbh; + + { + # Silence annoying but harmless postgres "NOTICE: CREATE TABLE..." + local $SIG{__WARN__} = sub { + my $msg = shift; + warn $msg unless $msg =~ m{^NOTICE:\s+CREATE TABLE}; + }; + + $dbh->do($_) for ( +qq| + CREATE TABLE ${oqt}LoaderTest40${cqt} ( + ${oqt}Id${cqt} INTEGER NOT NULL PRIMARY KEY, + ${oqt}Foo3Bar${cqt} VARCHAR(100) NOT NULL + ) $self->{innodb} +|, +qq| + CREATE TABLE ${oqt}LoaderTest41${cqt} ( + ${oqt}Id${cqt} INTEGER NOT NULL PRIMARY KEY, + ${oqt}LoaderTest40Id${cqt} INTEGER, + FOREIGN KEY (${oqt}LoaderTest40Id${cqt}) REFERENCES ${oqt}LoaderTest40${cqt} (${oqt}Id${cqt}) + ) $self->{innodb} +|, +qq| INSERT INTO ${oqt}LoaderTest40${cqt} VALUES (1, 'foo') |, +qq| INSERT INTO ${oqt}LoaderTest41${cqt} VALUES (1, 1) |, + ); + } + $conn->storage->disconnect; + + local $conn->_loader->{preserve_case} = 1; + $conn->_loader->_setup; + + { + local $SIG{__WARN__} = sub {}; + $conn->rescan; + } + + if (not $self->{skip_rels}) { + is $conn->resultset('LoaderTest41')->find(1)->loader_test40->foo3_bar, 'foo', + 'rel and accessor for mixed-case column name in mixed case table'; + } + else { + is $conn->resultset('LoaderTest40')->find(1)->foo3_bar, 'foo', + 'accessor for mixed-case column name in mixed case table'; + } +} + sub monikers_and_classes { my ($self, $schema_class) = @_; my ($monikers, $classes); @@ -1060,6 +1121,26 @@ sub dbconnect { return $dbh; } +sub get_oqt_cqt { + my $self = shift; + my %opts = @_; + + if ((not $opts{always}) && $self->{preserve_case_mode_is_exclusive}) { + return ('', ''); + } + + # XXX should get quote_char from the storage of an initialized loader. + my ($oqt, $cqt); # open quote, close quote + if (ref $self->{quote_char}) { + ($oqt, $cqt) = @{ $self->{quote_char} }; + } + else { + $oqt = $cqt = $self->{quote_char} || ''; + } + + return ($oqt, $cqt); +} + sub create { my $self = shift; @@ -1132,14 +1213,7 @@ sub create { ); # some DBs require mixed case identifiers to be quoted - # XXX should get quote_char from the storage of an initialized loader. - my ($oqt, $cqt); # open quote, close quote - if (ref $self->{quote_char}) { - ($oqt, $cqt) = @{ $self->{quote_char} }; - } - else { - $oqt = $cqt = $self->{quote_char} || ''; - } + my ($oqt, $cqt) = $self->get_oqt_cqt; @statements_reltests = ( qq{ @@ -1517,7 +1591,7 @@ sub create { $dbh->do($_) foreach (@statements); - $dbh->do($_) foreach (@{ $self->{data_type_tests}{ddl} || {} }); + $dbh->do($_) foreach (@{ $self->{data_type_tests}{ddl} || [] }); unless($self->{skip_rels}) { # hack for now, since DB2 doesn't like inline comments, and we need @@ -1607,6 +1681,8 @@ sub drop_tables { my @tables_rescan = qw/ loader_test30 /; + my @tables_preserve_case_tests = qw/ LoaderTest41 LoaderTest40 /; + my $drop_fk_mysql = q{ALTER TABLE loader_test10 DROP FOREIGN KEY loader_test11_fk}; @@ -1622,6 +1698,7 @@ sub drop_tables { unless($self->{skip_rels}) { $dbh->do("DROP TABLE $_") for (@tables_reltests); + $dbh->do("DROP TABLE $_") for (@tables_reltests); if($self->{vendor} =~ /mysql/i) { $dbh->do($drop_fk_mysql); } @@ -1645,6 +1722,10 @@ sub drop_tables { $dbh->do("DROP TABLE $data_type_table"); } + my ($oqt, $cqt) = $self->get_oqt_cqt(always => 1); + + $dbh->do("DROP TABLE ${oqt}${_}${cqt}") for @tables_preserve_case_tests; + $dbh->disconnect; # fixup for Firebird