From: Rafael Kitover <rkitover@cpan.org>
Date: Sat, 24 Apr 2010 21:48:51 +0000 (-0400)
Subject: added preserve_case option
X-Git-Tag: 0.07000~54
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bc1cb85e84e6a30c75763edd478378a68009c722;p=dbsrgits%2FDBIx-Class-Schema-Loader.git

added preserve_case option
---

diff --git a/Changes b/Changes
index 6db1296..b21aada 100644
--- a/Changes
+++ b/Changes
@@ -1,7 +1,10 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
-        - support CamelCase table names and column names (in case-sensitive
-          mode)
+        - added 'preserve_case' option with support for SQLite, mysql, MSSQL and
+          Firebird/InterBase; 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
           possible (except for Sybase ASE) to ease cross-deployment
         - use column_info instead of select to get Oracle column list (RT#42281)
diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm
index 83947a8..23c4ba5 100644
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -79,6 +79,7 @@ __PACKAGE__->mk_group_accessors('simple', qw/
                                 generate_pod
                                 pod_comment_mode
                                 pod_comment_spillover_length
+                                preserve_case
 /);
 
 =head1 NAME
@@ -450,6 +451,18 @@ columns with the DATE/DATETIME/TIMESTAMP data_types.
 File in Perl format, which should return a HASH reference, from which to read
 loader options.
 
+=head1 preserve_case
+
+Usually column names are lowercased, to make them easier to work with in
+L<DBIx::Class>. This option lets you turn this behavior off, if the driver
+supports it.
+
+Drivers for case sensitive databases like Sybase ASE or MSSQL with a
+case-sensitive collation will turn this option on unconditionally.
+
+Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
+setting this option.
+
 =head1 METHODS
 
 None of these methods are intended for direct invocation by regular
@@ -1474,7 +1487,7 @@ sub _setup_src_meta {
 
     my $cols = $self->_table_columns($table);
     my $col_info = $self->__columns_info_for($table);
-    if ($self->_is_case_sensitive) {
+    if ($self->preserve_case) {
         for my $col (keys %$col_info) {
             $col_info->{$col}{accessor} = lc $col
                 if $col ne lc($col);
@@ -1755,8 +1768,6 @@ sub _quote_table_name {
     return $qt . $table . $qt;
 }
 
-sub _is_case_sensitive { 0 }
-
 sub _custom_column_info {
     my ( $self, $table_name, $column_name, $column_info ) = @_;
 
@@ -1778,6 +1789,18 @@ sub _datetime_column_info {
     return $result;
 }
 
+sub _lc {
+    my ($self, $name) = @_;
+
+    return $self->preserve_case ? $name : lc($name);
+}
+
+sub _uc {
+    my ($self, $name) = @_;
+
+    return $self->preserve_case ? $name : uc($name);
+}
+
 # remove the dump dir from @INC on destruction
 sub DESTROY {
     my $self = shift;
diff --git a/lib/DBIx/Class/Schema/Loader/DBI.pm b/lib/DBIx/Class/Schema/Loader/DBI.pm
index 9864b33..bc949f3 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI.pm
@@ -190,7 +190,7 @@ sub _table_columns {
 
     my $sth = $self->_sth_for($table, undef, \'1 = 0');
     $sth->execute;
-    my $retval = $self->_is_case_sensitive ? \@{$sth->{NAME}} : \@{$sth->{NAME_lc}};
+    my $retval = $self->preserve_case ? \@{$sth->{NAME}} : \@{$sth->{NAME_lc}};
     $sth->finish;
 
     $retval;
@@ -326,7 +326,7 @@ sub _columns_info_for {
     my %result;
     my $sth = $self->_sth_for($table, undef, \'1 = 0');
     $sth->execute;
-    my @columns = @{ $self->_is_case_sensitive ? $sth->{NAME} : $sth->{NAME_lc} };
+    my @columns = @{ $self->preserve_case ? $sth->{NAME} : $sth->{NAME_lc} };
     for my $i ( 0 .. $#columns ){
         my $column_info = {};
         $column_info->{data_type} = lc $sth->{TYPE}->[$i];
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm b/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm
index fddab7b..886a45b 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm
@@ -37,6 +37,10 @@ sub _setup {
 
     my $dbh = $self->schema->storage->dbh;
     $self->{db_schema} ||= $dbh->selectrow_array('VALUES(CURRENT_USER)', {});
+
+    if (not defined $self->preserve_case) {
+        $self->preserve_case(0);
+    }
 }
 
 sub _table_uniq_info {
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm
index 8976058..6cfb7ec 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm
@@ -8,10 +8,6 @@ use base qw/DBIx::Class::Schema::Loader::DBI/;
 use Carp::Clan qw/^DBIx::Class/;
 use List::Util 'first';
 
-__PACKAGE__->mk_group_ro_accessors('simple', qw/
-    unquoted_ddl
-/);
-
 our $VERSION = '0.07000';
 
 =head1 NAME
@@ -21,54 +17,55 @@ Firebird Implementation.
 
 =head1 DESCRIPTION
 
-See L<DBIx::Class::Schema::Loader::Base> for available options.
+See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
+
+=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.
 
-See the L</unquoted_ddl> option in this driver if you would like to have
-lowercase column names.
-
-=head1 DRIVER OPTIONS
-
-=head2 unquoted_ddl
+See the L<preserve_case|DBIx::Class::Schema::Loader::Base/preserve_case> option
+to false if you would like to have lowercase column names.
 
-Set this loader option if your DDL uses unquoted identifiers and you will not
-use quoting (the L<quote_char|DBIx::Class::Storage::DBI/quote_char> option in
+Setting this option is a good idea if your DDL uses unquoted identifiers and
+you will not use quoting (the
+L<quote_char|DBIx::Class::Storage::DBI/quote_char> option in
 L<connect_info|DBIx::Class::Storage::DBI/connect_info>.)
 
+Be careful to also not use any SQL reserved words in your DDL.
+
 This will generate lowercase column names (as opposed to the actual uppercase
 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.
 
-=cut
-
-sub _is_case_sensitive {
-    my $self = shift;
+B<NOTE:> This option used to be called C<unquoted_ddl> but has been removed in
+favor of the more generic option.
 
-    return $self->unquoted_ddl ? 0 : 1;
-}
+=cut
 
 sub _setup {
     my $self = shift;
 
-    $self->next::method;
+    $self->next::method(@_);
 
     $self->schema->storage->sql_maker->name_sep('.');
 
-    if (not defined $self->unquoted_ddl) {
+    if (not defined $self->preserve_case) {
         warn <<'EOF';
 
-WARNING: Assuming mixed-case Firebird DDL, see the unquoted_ddl option in
+WARNING: Assuming mixed-case 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);
     }
 
-    if (not $self->unquoted_ddl) {
+    if ($self->preserve_case) {
         $self->schema->storage->sql_maker->quote_char('"');
     }
     else {
@@ -76,18 +73,6 @@ EOF
     }
 }
 
-sub _lc {
-    my ($self, $name) = @_;
-
-    return $self->unquoted_ddl ? lc($name) : $name;
-}
-
-sub _uc {
-    my ($self, $name) = @_;
-
-    return $self->unquoted_ddl ? uc($name) : $name;
-}
-
 sub _table_pk_info {
     my ($self, $table) = @_;
 
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm b/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm
index 62158ad..7d65c44 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm
@@ -6,10 +6,6 @@ use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common';
 use Carp::Clan qw/^DBIx::Class/;
 use Class::C3;
 
-__PACKAGE__->mk_group_accessors('simple', qw/
-    case_sensitive_collation
-/);
-
 our $VERSION = '0.07000';
 
 =head1 NAME
@@ -39,24 +35,23 @@ case-sensitive databases.
 
 To manually control case-sensitive mode, put:
 
-    case_sensitive_collation => 1|0
+    preserve_case => 1|0
 
 in your Loader options.
 
-=cut
+See L<preserve_case|DBIx::Class::Schema::Loader::Base/preserve_case>.
 
-sub _is_case_sensitive {
-    my $self = shift;
+B<NOTE:> this option used to be called C<case_sensitive_collation>, but has
+been renamed to a more generic option.
 
-    return $self->case_sensitive_collation ? 1 : 0;
-}
+=cut
 
 sub _setup {
     my $self = shift;
 
-    $self->next::method;
+    $self->next::method(@_);
 
-    return if defined $self->case_sensitive_collation;
+    return if defined $self->preserve_case;
 
     my $dbh = $self->schema->storage->dbh;
 
@@ -75,22 +70,18 @@ sub _setup {
         warn <<'EOF';
 
 WARNING: MSSQL Collation detection failed. Defaulting to case-insensitive mode.
-Override the 'case_sensitive_collation' attribute in your Loader options if
-needed.
+Override the 'preserve_case' attribute in your Loader options if needed.
+
+See 'preserve_case' in
+perldoc DBIx::Class::Schema::Loader::Base
 EOF
-        $self->case_sensitive_collation(0);
+        $self->preserve_case(0);
         return;
     }
 
     my $case_sensitive = $collation_name =~ /_(?:CS|BIN2?)(?:_|\z)/;
 
-    $self->case_sensitive_collation($case_sensitive ? 1 : 0);
-}
-
-sub _lc {
-    my ($self, $name) = @_;
-
-    return $self->case_sensitive_collation ? $name : lc($name);
+    $self->preserve_case($case_sensitive ? 1 : 0);
 }
 
 sub _tables_list {
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm b/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm
index d93cfe3..ded20b7 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm
@@ -36,6 +36,10 @@ sub _setup {
     if (lc($self->db_schema) ne lc($current_schema)) {
         $dbh->do('ALTER SESSION SET current_schema=' . $self->db_schema);
     }
+
+    if (not defined $self->preserve_case) {
+        $self->preserve_case(0);
+    }
 }
 
 sub _table_as_sql {
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm b/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm
index 6264a97..d8a8b9e 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm
@@ -35,9 +35,13 @@ sub _setup {
     my $self = shift;
 
     $self->next::method(@_);
+
     $self->{db_schema} ||= 'public';
-}
 
+    if (not defined $self->preserve_case) {
+        $self->preserve_case(0);
+    }
+}
 
 sub _table_uniq_info {
     my ($self, $table) = @_;
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm b/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm
index f6b6479..63cacda 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm
@@ -25,8 +25,14 @@ See L<DBIx::Class::Schema::Loader::Base>.
 sub _setup {
     my $self = shift;
 
+    $self->next::method(@_);
+
     $self->{db_schema} ||=
         ($self->schema->storage->dbh->selectrow_array('select user'))[0];
+
+    if (not defined $self->preserve_case) {
+        $self->preserve_case(0);
+    }
 }
 
 sub _tables_list {
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
index e08cb56..9ebeede 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
@@ -16,32 +16,32 @@ our $VERSION = '0.07000';
 
 DBIx::Class::Schema::Loader::DBI::SQLite - DBIx::Class::Schema::Loader::DBI SQLite 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>.
+See L<DBIx::Class::Schema::Loader> and 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.
+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 _setup {
+    my $self = shift;
+
+    $self->next::method(@_);
+
+    if (not defined $self->preserve_case) {
+        $self->preserve_case(0);
+    }
+}
+
 sub rescan {
     my ($self, $schema) = @_;
 
@@ -91,14 +91,14 @@ sub _table_fk_info {
         my $rel = $rels[ $fk->{id} ] ||= {
             local_columns => [],
             remote_columns => undef,
-            remote_table => lc $fk->{table}
+            remote_table => $fk->{table}
         };
 
-        push @{ $rel->{local_columns} }, lc $fk->{from};
-        push @{ $rel->{remote_columns} }, lc $fk->{to} if defined $fk->{to};
+        push @{ $rel->{local_columns} }, $self->_lc($fk->{from});
+        push @{ $rel->{remote_columns} }, $self->_lc($fk->{to}) if defined $fk->{to};
         warn "This is supposed to be the same rel but remote_table changed from ",
             $rel->{remote_table}, " to ", $fk->{table}
-            if $rel->{remote_table} ne lc $fk->{table};
+            if $rel->{remote_table} ne $fk->{table};
     }
     $sth->finish;
     return \@rels;
@@ -122,7 +122,7 @@ sub _table_uniq_info {
         $get_idx_sth->execute;
         my @cols;
         while (my $idx_row = $get_idx_sth->fetchrow_hashref) {
-            push @cols, lc $idx_row->{name};
+            push @cols, $self->_lc($idx_row->{name});
         }
         $get_idx_sth->finish;
         push @uniqs, [ $name => \@cols ];
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm b/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm
index 1a479d8..f11f4c1 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm
@@ -19,7 +19,15 @@ See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
 
 =cut
 
-sub _is_case_sensitive { 1 }
+sub _setup {
+    my $self = shift;
+
+    $self->next::method(@_);
+
+    if (not defined $self->preserve_case) {
+        $self->preserve_case(1);
+    }
+}
 
 sub _rebless {
     my $self = shift;
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/mysql.pm b/lib/DBIx/Class/Schema/Loader/DBI/mysql.pm
index 9e78f09..2e22729 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/mysql.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/mysql.pm
@@ -27,6 +27,16 @@ See L<DBIx::Class::Schema::Loader::Base>.
 
 =cut
 
+sub _setup {
+    my $self = shift;
+
+    $self->next::method(@_);
+
+    if (not defined $self->preserve_case) {
+        $self->preserve_case(0);
+    }
+}
+
 sub _tables_list { 
     my ($self, $opts) = @_;
 
@@ -55,10 +65,10 @@ sub _table_fk_info {
         my $f_table = shift @reldata;
         my $f_cols = shift @reldata;
 
-        my @cols   = map { s/(?: \Q$self->{_quoter}\E | $qt )//x; lc $_ }
+        my @cols   = map { s/(?: \Q$self->{_quoter}\E | $qt )//x; $self->_lc($_) }
             split(/$qt?\s*$qt?,$qt?\s*$qt?/, $cols);
 
-        my @f_cols = map { s/(?: \Q$self->{_quoter}\E | $qt )//x; lc $_ }
+        my @f_cols = map { s/(?: \Q$self->{_quoter}\E | $qt )//x; $self->_lc($_) }
             split(/$qt?\s*$qt?,$qt?\s*$qt?/, $f_cols);
 
         push(@rels, {
@@ -84,7 +94,7 @@ sub _mysql_table_get_keys {
         while(my $row = $sth->fetchrow_hashref) {
             next if $row->{Non_unique};
             push(@{$keydata{$row->{Key_name}}},
-                [ $row->{Seq_in_index}, lc $row->{Column_name} ]
+                [ $row->{Seq_in_index}, $self->_lc($row->{Column_name}) ]
             );
         }
         foreach my $keyname (keys %keydata) {
diff --git a/t/10sqlite_common.t b/t/10sqlite_common.t
index 19982e7..71f9ade 100644
--- a/t/10sqlite_common.t
+++ b/t/10sqlite_common.t
@@ -23,6 +23,10 @@ my $tester = dbixcsl_common_tests->new(
         'smallint'    => { data_type => 'smallint' },
         'int'         => { data_type => 'int' },
         'integer'     => { data_type => 'integer' },
+
+        # test that type name is lowercased
+        'INTEGER'     => { data_type => 'integer' },
+
         'bigint'      => { data_type => 'bigint' },
         'float'       => { data_type => 'float' },
         'double precision' =>
diff --git a/t/16mssql_common.t b/t/16mssql_common.t
index 1f3823a..31c373a 100644
--- a/t/16mssql_common.t
+++ b/t/16mssql_common.t
@@ -191,7 +191,7 @@ my $tester = dbixcsl_common_tests->new(
             ok ((my $rsrc = $schema->resultset($monikers->{mssql_loader_test5})->result_source),
                 'got result_source');
 
-            if ($schema->_loader->_is_case_sensitive) {
+            if ($schema->_loader->preserve_case) {
                 is_deeply [ $rsrc->columns ], [qw/Id FooCol BarCol/],
                     'column name case is preserved with case-sensitive collation';
 
diff --git a/t/18firebird_common.t b/t/18firebird_common.t
index d154cbd..94342cf 100644
--- a/t/18firebird_common.t
+++ b/t/18firebird_common.t
@@ -41,7 +41,7 @@ my $tester = dbixcsl_common_tests->new(
         );
     },
     null        => '',
-    loader_options => { unquoted_ddl => 1 },
+    loader_options => { preserve_case => 0 },
     connect_info => [ ($dbd_interbase_dsn ? {
             dsn         => $dbd_interbase_dsn,
             user        => $dbd_interbase_user,
@@ -141,15 +141,15 @@ q{
 
             my $guard = Scope::Guard->new(\&cleanup_extra);
 
-            delete $schema->_loader->{unquoted_ddl};
+            delete $schema->_loader->{preserve_case};
 
             my $warning;
             {
                 local $SIG{__WARN__} = sub { $warning = shift };
                 $schema->_loader->_setup;
             }
-            like $warning, qr/unquoted_ddl option/,
-                'warning mentions unquoted_ddl option';
+            like $warning, qr/'preserve_case' option/,
+                'warning mentions preserve_case option';
 
             {
                 local $SIG{__WARN__} = sub {};
diff --git a/t/lib/dbixcsl_common_tests.pm b/t/lib/dbixcsl_common_tests.pm
index 283805d..6557e07 100644
--- a/t/lib/dbixcsl_common_tests.pm
+++ b/t/lib/dbixcsl_common_tests.pm
@@ -1653,7 +1653,7 @@ sub setup_data_type_tests {
     my %seen_col_names;
 
     while (my ($col_def, $expected_info) = each %$types) {
-        (my $type_alias = lc($col_def)) =~ s/\( ([^)]+) \)//xg;
+        (my $type_alias = $col_def) =~ s/\( ([^)]+) \)//xg;
 
         my $size = $1;
         $size = '' unless defined $size;
@@ -1680,7 +1680,10 @@ sub setup_data_type_tests {
             $col_name .= "_sz_$size_name";
         }
 
-        $col_name .= "_$seen_col_names{$col_name}" if $seen_col_names{$col_name}++;
+        # XXX would be better to check _loader->preserve_case
+        $col_name = lc $col_name;
+
+        $col_name .= '_' . $seen_col_names{$col_name} if $seen_col_names{$col_name}++;
 
         $ddl .= "    $col_name $col_def,\n";