Revision history for DBIx::Class
+0.08121 2010-04-11 18:43:00 (UTC)
- Support for Firebird RDBMS with DBD::InterBase and ODBC
- Add core support for INSERT RETURNING (for storages that
supports this syntax, currently PostgreSQL and Firebird)
+ - Fix spurious warnings on multiple UTF8Columns component loads
+ - DBIx::Class::UTF8Columns entered deprecated state
- DBIx::Class::InflateColumn::File entered deprecated state
- DBIx::Class::Optional::Dependencies left experimental state
- Add req_group_list to Opt::Deps (RT#55211)
- Add support for mysql-specific STRAIGHT_JOIN (RT#55579)
- Cascading delete/update are now wrapped in a transaction
for atomicity
+ - Fix accidental autovivification of ENV vars
+ - Fix update_all and delete_all to be wrapped in a transaction
- Fix multiple deficiencies when using MultiCreate with
data-encoder components (e.g. ::EncodedColumn)
- Fix regression where SQL files with comments were not
attribute
- Fix ambiguity in default directory handling of create_ddl_dir
(RT#54063)
- - Fix update_all and delete_all to be wrapped in a transaction
- Support add_columns('+colname' => { ... }) to augment column
definitions.
- - Fix spurious warnings on multiple UTF8Columns component loads
- - Unicode support documentation in Cookbook and UTF8Columns
0.08120 2010-02-24 08:58:00 (UTC)
- Make sure possibly overwritten deployment_statements methods in
'MRO::Compat' => '0.09',
'Module::Find' => '0.06',
'Path::Class' => '0.18',
- 'SQL::Abstract' => '1.63',
+ 'SQL::Abstract' => '1.64',
'SQL::Abstract::Limit' => '0.13',
'Sub::Name' => '0.04',
'Data::Dumper::Concise' => '1.000',
# 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
-$VERSION = '0.08120_1';
+$VERSION = '0.08121_01';
$VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
use Carp::Clan qw/^DBIx::Class|^Class::C3::Componentised/;
use mro 'c3';
+my $warned;
+
# this warns of subtle bugs introduced by UTF8Columns hacky handling of store_column
+# if and only if it is placed before something overriding store_column
sub inject_base {
my $class = shift;
- my $target = shift;
+ my ($target, @complist) = @_;
- my @present_components = (@{mro::get_linear_isa ($target)||[]});
- shift @present_components; # don't need to interrogate myself
+ # we already did load the component
+ my $keep_checking = ! (
+ $target->isa ('DBIx::Class::UTF8Columns')
+ ||
+ $target->isa ('DBIx::Class::ForceUTF8')
+ );
- no strict 'refs';
- for my $comp (reverse @_) {
+ my @target_isa;
- # if we are trying add a UTF8Columns component *for the first time*
- if ($comp->isa ('DBIx::Class::UTF8Columns') && ! $target->isa ('DBIx::Class::UTF8Columns') ) {
- require B;
- my @broken;
+ while ($keep_checking && @complist) {
+
+ @target_isa = do { no strict 'refs'; @{"$target\::ISA"} }
+ unless @target_isa;
- for (@present_components) {
- last if $_ eq 'DBIx::Class::Row'; # don't care about anything further down the chain
+ my $comp = pop @complist;
- my $cref = $_->can ('store_column')
- or next;
+ # warn here on use of either component, as we have no access to ForceUTF8,
+ # the author does not respond, and the Catalyst wiki used to recommend it
+ for (qw/DBIx::Class::UTF8Columns DBIx::Class::ForceUTF8/) {
+ if ($comp->isa ($_) ) {
+ $keep_checking = 0; # no use to check from this point on
+ carp "Use of $_ is strongly discouraged. See documentationm of DBIx::Class::UTF8Columns for more info\n"
+ unless ($warned->{UTF8Columns}++ || $ENV{DBIC_UTF8COLUMNS_OK});
+ last;
+ }
+ }
+
+ # something unset $keep_checking - we got a unicode mangler
+ if (! $keep_checking) {
+
+ my $base_store_column = do { require DBIx::Class::Row; DBIx::Class::Row->can ('store_column') };
+
+ my @broken;
+ for my $existing_comp (@target_isa) {
+ my $sc = $existing_comp->can ('store_column')
+ or next;
- push @broken, $_ if B::svref_2object($cref)->STASH->NAME eq $_;
+ if ($sc ne $base_store_column) {
+ require B;
+ my $definer = B::svref_2object($sc)->STASH->NAME;
+ push @broken, ($definer eq $existing_comp)
+ ? $existing_comp
+ : "$existing_comp (via $definer)"
+ ;
+ }
}
- carp "Incorrect loading order of $comp by ${target} will affect other components overriding store_column ("
+ carp "Incorrect loading order of $comp by $target will affect other components overriding 'store_column' ("
. join (', ', @broken)
.'). Refer to the documentation of DBIx::Class::UTF8Columns for more info'
- if @broken;
+ if @broken;
}
- unshift @present_components, $comp;
+ unshift @target_isa, $comp;
}
- $class->next::method($target, @_);
+ $class->next::method(@_);
}
1;
The solution is to use the smallest practical value for LongReadLen.
+=head2 create_ddl_dir does not produce DDL for MySQL views
+
+L<SQL::Translator> does not create DDL for MySQL views if it doesn't know you
+are using mysql version 5.000001 or higher. To explicity set this version, add
+C<mysql_version> to the C<producer_args> in the C<%sqlt> options.
+
+ $schema->create_ddl_dir(['MySQL'], '1.0', './sql/', undef, { producer_args => { mysql_version => 5.000058 } })
+
=cut
my $updated_cols = $source->storage->insert(
$source,
{ $self->get_columns },
- (keys %auto_pri) && $source->storage->can_insert_returning
+ (keys %auto_pri) && $source->storage->_supports_insert_returning
? { returning => [ sort { $auto_pri{$a} <=> $auto_pri{$b} } keys %auto_pri ] }
: ()
,
Begins a transaction (does nothing if AutoCommit is off). Equivalent to
calling $schema->storage->txn_begin. See
-L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
+L<DBIx::Class::Storage/"txn_begin"> for more information.
=cut
=head2 txn_commit
Commits the current transaction. Equivalent to calling
-$schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
+$schema->storage->txn_commit. See L<DBIx::Class::Storage/"txn_commit">
for more information.
=cut
Rolls back the current transaction. Equivalent to calling
$schema->storage->txn_rollback. See
-L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
+L<DBIx::Class::Storage/"txn_rollback"> for more information.
=cut
Creates a new savepoint (does nothing outside a transaction).
Equivalent to calling $schema->storage->svp_begin. See
-L<DBIx::Class::Storage::DBI/"svp_begin"> for more information.
+L<DBIx::Class::Storage/"svp_begin"> for more information.
=cut
Releases a savepoint (does nothing outside a transaction).
Equivalent to calling $schema->storage->svp_release. See
-L<DBIx::Class::Storage::DBI/"svp_release"> for more information.
+L<DBIx::Class::Storage/"svp_release"> for more information.
=cut
Rollback to a savepoint (does nothing outside a transaction).
Equivalent to calling $schema->storage->svp_rollback. See
-L<DBIx::Class::Storage::DBI/"svp_rollback"> for more information.
+L<DBIx::Class::Storage/"svp_rollback"> for more information.
=cut
__PACKAGE__->mk_group_accessors('simple' =>
qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid
_conn_tid transaction_depth _dbh_autocommit _driver_determined savepoints
- __server_info/
+ _server_info_hash/
);
# the values for these accessors are picked out (and deleted) from
__PACKAGE__->mk_group_accessors('inherited' => qw/
sql_maker_class
- can_insert_returning
+ _supports_insert_returning
/);
__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks');
my @info = @{$self->_dbi_connect_info || []};
$self->_dbh(undef); # in case ->connected failed we might get sent here
+ $self->_server_info_hash (undef);
$self->_dbh($self->_connect(@info));
$self->_conn_pid($$);
$self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
$self->_run_connection_actions unless $self->{_in_determine_driver};
-
- $self->_populate_server_info;
}
sub _run_connection_actions {
$self->_do_connection_actions(connect_call_ => $_) for @actions;
}
-sub _populate_server_info {
+sub _server_info {
my $self = shift;
- my %info;
- my $dbms_ver = eval {
- local $@;
- $self->_get_dbh->get_info(18)
- };
+ unless ($self->_server_info_hash) {
- if (defined $dbms_ver) {
- $info{dbms_ver} = $dbms_ver;
+ my %info;
- ($dbms_ver) = $dbms_ver =~ /^(\S+)/;
+ my $server_version = $self->_get_server_version;
- my @verparts = split /\./, $dbms_ver;
- $info{dbms_ver_normalized} = sprintf "%d.%03d%03d", @verparts;
- }
+ if (defined $server_version) {
+ $info{dbms_version} = $server_version;
- $self->__server_info(\%info);
+ my ($numeric_version) = $server_version =~ /^([\d\.]+)/;
+ my @verparts = split (/\./, $numeric_version);
+ if (
+ @verparts
+ &&
+ $verparts[0] <= 999
+ ) {
+ # consider only up to 3 version parts, iff not more than 3 digits
+ my @use_parts;
+ while (@verparts && @use_parts < 3) {
+ my $p = shift @verparts;
+ last if $p > 999;
+ push @use_parts, $p;
+ }
+ push @use_parts, 0 while @use_parts < 3;
- return \%info;
-}
+ $info{normalized_dbms_version} = sprintf "%d.%03d%03d", @use_parts;
+ }
+ }
-sub _server_info {
- my $self = shift;
+ $self->_server_info_hash(\%info);
+ }
- $self->_get_dbh;
+ return $self->_server_info_hash
+}
- return $self->__server_info(@_);
+sub _get_server_version {
+ eval { shift->_get_dbh->get_info(18) };
}
sub _determine_driver {
=cut
-sub can_insert_returning { 1 }
+sub _supports_insert_returning { 1 }
sub _sequence_fetch {
my ($self, $nextval, $sequence) = @_;
}
}
-sub _populate_server_info {
+sub _get_server_version {
my $self = shift;
return $self->next::method(@_) if ref $self ne __PACKAGE__;
use strict;
use warnings;
-use base qw/DBIx::Class::Storage::DBI/;
+use base qw/DBIx::Class::Storage::DBI::UniqueIdentifier/;
use mro 'c3';
use List::Util();
}
}
-# support MSSQL GUID column types
-
sub insert {
my $self = shift;
my ($source, $to_insert) = @_;
my $supplied_col_info = $self->_resolve_column_info($source, [keys %$to_insert] );
- my %guid_cols;
- my @pk_cols = $source->primary_columns;
- my %pk_cols;
- @pk_cols{@pk_cols} = ();
-
- my @pk_guids = grep {
- $source->column_info($_)->{data_type}
- &&
- $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i
- } @pk_cols;
-
- my @auto_guids = grep {
- $source->column_info($_)->{data_type}
- &&
- $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i
- &&
- $source->column_info($_)->{auto_nextval}
- } grep { not exists $pk_cols{$_} } $source->columns;
-
- my @get_guids_for =
- grep { not exists $to_insert->{$_} } (@pk_guids, @auto_guids);
-
- my $updated_cols = {};
-
- for my $guid_col (@get_guids_for) {
- my ($new_guid) = $self->_get_dbh->selectrow_array('SELECT NEWID()');
- $updated_cols->{$guid_col} = $to_insert->{$guid_col} = $new_guid;
- }
-
my $is_identity_insert = (List::Util::first { $_->{is_auto_increment} } (values %$supplied_col_info) )
? 1
: 0;
$self->_set_identity_insert ($source->name);
}
- $updated_cols = { %$updated_cols, %{ $self->next::method(@_) } };
+ my $updated_cols = $self->next::method(@_);
if ($is_identity_insert) {
$self->_unset_identity_insert ($source->name);
}
-
return $updated_cols;
}
unless ($self->_sql_maker) {
unless ($self->{_sql_maker_opts}{limit_dialect}) {
- my ($version) = $self->_server_info->{dbms_ver} =~ /^(\d+)/;
- $version ||= 0;
+ my $version = $self->_server_info->{normalized_dbms_version} || 0;
$self->{_sql_maker_opts} = {
limit_dialect => ($version >= 9 ? 'RowNumberOver' : 'Top'),
=head1 AUTHOR
-See L<DBIx::Class/CONTRIBUTORS>.
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
warn __PACKAGE__.": DBD::Pg 2.9.2 or greater is strongly recommended\n"
if ($DBD::Pg::VERSION < 2.009002); # pg uses (used?) version::qv()
-sub can_insert_returning {
+sub _supports_insert_returning {
my $self = shift;
return 1
- if $self->_server_info->{dbms_ver_normalized} >= 8.002;
+ if $self->_server_info->{normalized_dbms_version} >= 8.002;
return 0;
}
backup
is_datatype_numeric
- can_insert_returning
+ _supports_insert_returning
_count_select
_subq_count_select
_subq_update_delete
_dbh_sth
_dbh_execute
_prefetch_insert_auto_nextvals
+ _server_info_hash
/],
);
+
has _master_connect_info_opts =>
(is => 'rw', isa => HashRef, default => sub { {} });
return min map $_->_ping, $self->all_storages;
}
+sub _server_info {
+ my $self = shift;
+
+ if (not $self->_server_info_hash) {
+ no warnings 'numeric'; # in case dbms_version doesn't normalize
+
+ my @infos =
+ map $_->[1],
+ sort { $a->[0] <=> $b->[0] }
+ map [ (defined $_->{normalized_dbms_version} ? $_->{normalized_dbms_version}
+ : $_->{dbms_version}), $_ ],
+ map $_->_server_info, $self->all_storages;
+
+ my $min_version_info = $infos[0];
+
+ $self->_server_info_hash($min_version_info); # on master
+ }
+
+ return $self->_server_info_hash;
+}
+
+sub _get_server_version {
+ my $self = shift;
+
+ return $self->_server_info->{dbms_version};
+}
+
=head1 GOTCHAS
Due to the fact that replicants can lag behind a master, you must take care to
use strict;
use warnings;
-use base qw/DBIx::Class::Storage::DBI/;
+use base qw/DBIx::Class::Storage::DBI::UniqueIdentifier/;
use mro 'c3';
use List::Util ();
sub last_insert_id { shift->_identity }
+sub _new_uuid { 'UUIDTOSTR(NEWID())' }
+
sub insert {
my $self = shift;
my ($source, $to_insert) = @_;
# user might have an identity PK without is_auto_increment
if (not $identity_col) {
foreach my $pk_col ($source->primary_columns) {
- if (not exists $to_insert->{$pk_col}) {
+ if (not exists $to_insert->{$pk_col} &&
+ $source->column_info($pk_col)->{data_type} !~ /^uniqueidentifier/i)
+ {
$identity_col = $pk_col;
last;
}
my $table_name = $source->from;
$table_name = $$table_name if ref $table_name;
- my ($identity) = $dbh->selectrow_array("SELECT GET_IDENTITY('$table_name')");
+ my ($identity) = eval {
+ local $@; $dbh->selectrow_array("SELECT GET_IDENTITY('$table_name')")
+ };
- $to_insert->{$identity_col} = $identity;
+ if (defined $identity) {
+ $to_insert->{$identity_col} = $identity;
+ $self->_identity($identity);
+ }
+ }
- $self->_identity($identity);
+ return $self->next::method(@_);
+}
+
+# convert UUIDs to strings in selects
+sub _select_args {
+ my $self = shift;
+ my ($ident, $select) = @_;
+
+ my $col_info = $self->_resolve_column_info($ident);
+
+ for my $select_idx (0..$#$select) {
+ my $selected = $select->[$select_idx];
+
+ next if ref $selected;
+
+ my $data_type = $col_info->{$selected}{data_type};
+
+ if ($data_type && $data_type =~ /^uniqueidentifier\z/i) {
+ $select->[$select_idx] = { UUIDTOSTR => $selected };
+ }
}
return $self->next::method(@_);
$sqltargs ||= {};
- my $sqlite_version = eval { $self->_server_info->{dbms_ver} };
- $sqlite_version ||= '';
+ # it'd be cool to use the normalized perl-style version but this needs sqlt hacking as well
+ if (my $sqlite_version = $self->_server_info->{dbms_version}) {
+ # numify, SQLT does a numeric comparison
+ $sqlite_version =~ s/^(\d+) \. (\d+) (?: \. (\d+))? .*/${1}.${2}/x;
- # numify, SQLT does a numeric comparison
- $sqlite_version =~ s/^(\d+) \. (\d+) (?: \. (\d+))? .*/${1}.${2}/x;
-
- $sqltargs->{producer_args}{sqlite_version} = $sqlite_version if $sqlite_version;
+ $sqltargs->{producer_args}{sqlite_version} = $sqlite_version if $sqlite_version;
+ }
$self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
}
$dbh->do('ROLLBACK');
}
-sub _populate_server_info {
+sub _get_server_version {
my $self = shift;
- my $info = $self->next::method(@_);
-
my $product_version = $self->_get_dbh->selectrow_hashref('xp_msver ProductVersion');
- if ((my $version = $data->{Character_Value}) =~ /^(\d+)\./) {
- $info->{dbms_ver} = $version;
- } else {
- $self->throw_exception(q{
-MSSQL Version Retrieval Failed, Your ProductVersion's Character_Value is missing
-or malformed!
- });
+ if ((my $version = $product_version->{Character_Value}) =~ /^(\d+)\./) {
+ return $version;
+ }
+ else {
+ $self->throw_exception(
+ "MSSQL Version Retrieval Failed, Your ProductVersion's Character_Value is missing or malformed!"
+ );
}
-
- return $info;
}
1;
--- /dev/null
+package DBIx::Class::Storage::DBI::UniqueIdentifier;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Storage::DBI';
+use mro 'c3';
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::UniqueIdentifier - Storage component for RDBMSes
+supporting the 'uniqueidentifier' type
+
+=head1 DESCRIPTION
+
+This is a storage component for databases that support the C<uniqueidentifier>
+type and the C<NEWID()> function for generating UUIDs.
+
+UUIDs are generated automatically for PK columns with the C<uniqueidentifier>
+L<data_type|DBIx::Class::ResultSource/data_type>, as well as non-PK with this
+L<data_type|DBIx::Class::ResultSource/data_type> and
+L<auto_nextval|DBIx::Class::ResultSource/auto_nextval>.
+
+Currently used by L<DBIx::Class::Storage::DBI::MSSQL> and
+L<DBIx::Class::Storage::DBI::SQLAnywhere>.
+
+The composing class can define a C<_new_uuid> method to override the function
+used to generate a new UUID.
+
+=cut
+
+sub _new_uuid { 'NEWID()' }
+
+sub insert {
+ my $self = shift;
+ my ($source, $to_insert) = @_;
+
+ my $supplied_col_info = $self->_resolve_column_info($source, [keys %$to_insert] );
+
+ my %guid_cols;
+ my @pk_cols = $source->primary_columns;
+ my %pk_cols;
+ @pk_cols{@pk_cols} = ();
+
+ my @pk_guids = grep {
+ $source->column_info($_)->{data_type}
+ &&
+ $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i
+ } @pk_cols;
+
+ my @auto_guids = grep {
+ $source->column_info($_)->{data_type}
+ &&
+ $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i
+ &&
+ $source->column_info($_)->{auto_nextval}
+ } grep { not exists $pk_cols{$_} } $source->columns;
+
+ my @get_guids_for =
+ grep { not exists $to_insert->{$_} } (@pk_guids, @auto_guids);
+
+ my $updated_cols = {};
+
+ for my $guid_col (@get_guids_for) {
+ my ($new_guid) = $self->_get_dbh->selectrow_array('SELECT '.$self->_new_uuid);
+ $updated_cols->{$guid_col} = $to_insert->{$guid_col} = $new_guid;
+ }
+
+ $updated_cols = { %$updated_cols, %{ $self->next::method(@_) } };
+
+ return $updated_cols;
+}
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+1;
=head1 NAME
-DBIx::Class::UTF8Columns - Force UTF8 (Unicode) flag on columns
-
- Please ensure you understand the purpose of this module before use.
- Read the warnings below to prevent data corruption through misuse.
+DBIx::Class::UTF8Columns - Force UTF8 (Unicode) flag on columns (DEPRECATED)
=head1 SYNOPSIS
that column data is correctly serialised as a byte stream when
stored and de-serialised to unicode strings on retrieval.
+ THE USE OF THIS MODULE (AND ITS COUSIN DBIx::Class::ForceUTF8) IS VERY
+ STRONGLY DISCOURAGED, PLEASE READ THE WARNINGS BELOW FOR AN EXPLANATION.
+
+If you want to continue using this module and do not want to recieve
+further warnings set the environmane variable C<DBIC_UTF8COLUMNS_OK>
+to a true value.
+
+=head2 Warning - Module does not function properly on create/insert
+
+Recently (April 2010) a bug was found deep in the core of L<DBIx::Class>
+which affects any component attempting to perform encoding/decoding by
+overloading L<store_column|DBIx::Class::Row/store_column> and
+L<get_columns|DBIx::Class::Row/get_columns>. As a result of this problem
+L<create|DBIx::Class::ResultSet/create> sends the original column values
+to the database, while L<update|DBIx::Class::ResultSet/update> sends the
+encoded values. L<DBIx::Class::UTF8Columns> and L<DBIx::Class::ForceUTF8>
+are both affected by ths bug.
+
+It is unclear how this bug went undetected for so long (it was
+introduced in March 2006), No attempts to fix it will be made while the
+implications of changing such a fundamental behavior of DBIx::Class are
+being evaluated. However in this day and age you should not be using
+this module anyway as Unicode is properly supported by all major
+database engines, as explained below.
+
+If you have specific questions about the integrity of your data in light
+of this development - please
+L<join us on IRC or the mailing list|DBIx::Class/GETTING HELP/SUPPORT>
+to further discuss your concerns with the team.
+
=head2 Warning - Native Database Unicode Support
If your database natively supports Unicode (as does SQLite with the
data in a subtle and unexpected manner.
It is far better to do Unicode support within the database if
-possible rather convert data into and out of the database on every
-round trip.
+possible rather than converting data to and from raw bytes on every
+database round trip.
=head2 Warning - Component Overloading
our @test_classes; #< array that will be pushed into by test classes defined in this file
DBICTest::Schema->load_classes( map {s/.+:://;$_} @test_classes ) if @test_classes;
-my $schema;
-
-require DBIx::Class::Storage::DBI::Pg;
+my $test_server_supports_insert_returning = do {
+ my $s = DBICTest::Schema->connect($dsn, $user, $pass);
+ $s->storage->_determine_driver;
+ $s->storage->_supports_insert_returning;
+};
-my $can_insert_returning =
- DBIx::Class::Storage::DBI::Pg->can('can_insert_returning');
+my $schema;
-for my $use_insert_returning (0..1) {
+for my $use_insert_returning ($test_server_supports_insert_returning
+ ? (0,1)
+ : (0)
+) {
no warnings qw/redefine once/;
- local *DBIx::Class::Storage::DBI::Pg::can_insert_returning = sub {
+ local *DBIx::Class::Storage::DBI::Pg::_supports_insert_returning = sub {
$use_insert_returning
};
$schema = DBICTest::Schema->connect($dsn, $user, $pass);
$schema->storage->ensure_connected;
- if ($use_insert_returning && (not $can_insert_returning->($schema->storage)))
- {
- diag "Your version of PostgreSQL does not support INSERT ... RETURNING.";
- diag "*** SKIPPING FURTHER TESTS";
- last;
- }
-
drop_test_schema($schema);
create_test_schema($schema);
######## test non-serial auto-pk
- if ($schema->storage->can_insert_returning) {
+ if ($schema->storage->_supports_insert_returning) {
$schema->source('TimestampPrimaryKey')->name('dbic_t_schema.timestamp_primary_key_test');
my $row = $schema->resultset('TimestampPrimaryKey')->create({});
ok $row->id;
use Test::More;
use Test::Exception;
+use Scope::Guard ();
use lib qw(t/lib);
use DBICTest;
+DBICTest::Schema->load_classes('ArtistGUID');
+
# tests stolen from 748informix.t
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_ASA_${_}" } qw/DSN USER PASS/};
[ $dsn2, $user2, $pass2 ],
);
-my @handles_to_clean;
+my $schema;
foreach my $info (@info) {
my ($dsn, $user, $pass) = @$info;
next unless $dsn;
- my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
auto_savepoint => 1
});
- my $dbh = $schema->storage->dbh;
+ my $guard = Scope::Guard->new(\&cleanup);
- push @handles_to_clean, $dbh;
+ my $dbh = $schema->storage->dbh;
eval { $dbh->do("DROP TABLE artist") };
ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" );
}
}
+
+ my @uuid_types = qw/uniqueidentifier uniqueidentifierstr/;
+
+# test uniqueidentifiers
+ for my $uuid_type (@uuid_types) {
+ local $schema->source('ArtistGUID')->column_info('artistid')->{data_type}
+ = $uuid_type;
+
+ local $schema->source('ArtistGUID')->column_info('a_guid')->{data_type}
+ = $uuid_type;
+
+ $schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ eval { $dbh->do("DROP TABLE artist") };
+ $dbh->do(<<"SQL");
+CREATE TABLE artist (
+ artistid $uuid_type NOT NULL,
+ name VARCHAR(100),
+ rank INT NOT NULL DEFAULT '13',
+ charfield CHAR(10) NULL,
+ a_guid $uuid_type,
+ primary key(artistid)
+)
+SQL
+ });
+
+ my $row;
+ lives_ok {
+ $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' })
+ } 'created a row with a GUID';
+
+ ok(
+ eval { $row->artistid },
+ 'row has GUID PK col populated',
+ );
+ diag $@ if $@;
+
+ ok(
+ eval { $row->a_guid },
+ 'row has a GUID col with auto_nextval populated',
+ );
+ diag $@ if $@;
+
+ my $row_from_db = $schema->resultset('ArtistGUID')
+ ->search({ name => 'mtfnpy' })->first;
+
+ is $row_from_db->artistid, $row->artistid,
+ 'PK GUID round trip';
+
+ is $row_from_db->a_guid, $row->a_guid,
+ 'NON-PK GUID round trip';
+ }
}
done_testing;
-# clean up our mess
-END {
- foreach my $dbh (@handles_to_clean) {
- eval { $dbh->do("DROP TABLE $_") } for qw/artist bindtype_test/;
- }
+sub cleanup {
+ eval { $schema->storage->dbh->do("DROP TABLE $_") } for qw/artist bindtype_test/;
}
{
package A::SubComp;
use base 'A::Comp';
+
1;
}
-warnings_like (
- sub {
- package A::Test;
- use base 'DBIx::Class::Core';
- __PACKAGE__->load_components(qw(UTF8Columns +A::SubComp +A::Comp));
- 1;
- },
- [qr/Incorrect loading order of DBIx::Class::UTF8Columns.+affect other components overriding store_column \(A::Comp\)/],
- 'incorrect order warning issued',
-);
-
warnings_are (
sub {
- package A::Test2;
+ local $ENV{DBIC_UTF8COLUMNS_OK} = 1;
+ package A::Test1;
use base 'DBIx::Class::Core';
__PACKAGE__->load_components(qw(Core +A::Comp Ordered UTF8Columns));
- __PACKAGE__->load_components(qw(Ordered +A::Comp Row UTF8Columns Core));
+ __PACKAGE__->load_components(qw(Ordered +A::SubComp Row UTF8Columns Core));
+ sub store_column { shift->next::method (@_) };
1;
},
[],
'no spurious warnings issued',
);
-my $test2_mro;
+my $test1_mro;
my $idx = 0;
-for (@{mro::get_linear_isa ('A::Test2')} ) {
- $test2_mro->{$_} = $idx++;
+for (@{mro::get_linear_isa ('A::Test1')} ) {
+ $test1_mro->{$_} = $idx++;
}
-cmp_ok ($test2_mro->{'A::Comp'}, '<', $test2_mro->{'DBIx::Class::UTF8Columns'}, 'mro of Test2 correct (A::Comp before UTF8Col)' );
-cmp_ok ($test2_mro->{'DBIx::Class::UTF8Columns'}, '<', $test2_mro->{'DBIx::Class::Core'}, 'mro of Test2 correct (UTF8Col before Core)' );
-cmp_ok ($test2_mro->{'DBIx::Class::Core'}, '<', $test2_mro->{'DBIx::Class::Row'}, 'mro of Test2 correct (Core before Row)' );
+cmp_ok ($test1_mro->{'A::SubComp'}, '<', $test1_mro->{'A::Comp'}, 'mro of Test1 correct (A::SubComp before A::Comp)' );
+cmp_ok ($test1_mro->{'A::Comp'}, '<', $test1_mro->{'DBIx::Class::UTF8Columns'}, 'mro of Test1 correct (A::Comp before UTF8Col)' );
+cmp_ok ($test1_mro->{'DBIx::Class::UTF8Columns'}, '<', $test1_mro->{'DBIx::Class::Core'}, 'mro of Test1 correct (UTF8Col before Core)' );
+cmp_ok ($test1_mro->{'DBIx::Class::Core'}, '<', $test1_mro->{'DBIx::Class::Row'}, 'mro of Test1 correct (Core before Row)' );
+
+warnings_like (
+ sub {
+ package A::Test2;
+ use base 'DBIx::Class::Core';
+ __PACKAGE__->load_components(qw(UTF8Columns +A::Comp));
+ sub store_column { shift->next::method (@_) };
+ 1;
+ },
+ [qr/Incorrect loading order of DBIx::Class::UTF8Columns.+affect other components overriding 'store_column' \(A::Comp\)/],
+ 'incorrect order warning issued (violator defines)',
+);
+
+warnings_like (
+ sub {
+ package A::Test3;
+ use base 'DBIx::Class::Core';
+ __PACKAGE__->load_components(qw(UTF8Columns +A::SubComp));
+ sub store_column { shift->next::method (@_) };
+ 1;
+ },
+ [qr/Incorrect loading order of DBIx::Class::UTF8Columns.+affect other components overriding 'store_column' \(A::SubComp \(via A::Comp\)\)/],
+ 'incorrect order warning issued (violator inherits)',
+);
my $schema = DBICTest->init_schema();
DBICTest::Schema::CD->load_components('UTF8Columns');
DBICTest::Schema::CD->utf8_columns('title');
Class::C3->reinitialize();
-my $cd = $schema->resultset('CD')->create( { artist => 1, title => "weird\x{466}stuff", year => '2048' } );
+{
+ package DBICTest::UTF8::Debugger;
-ok( utf8::is_utf8( $cd->title ), 'got title with utf8 flag' );
-ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'store title without utf8' );
+ use base 'DBIx::Class::Storage::Statistics';
-ok(! utf8::is_utf8( $cd->year ), 'got year without utf8 flag' );
-ok(! utf8::is_utf8( $cd->{_column_data}{year} ), 'store year without utf8' );
+ __PACKAGE__->mk_group_accessors(simple => 'call_stack');
-$cd->title('nonunicode');
-ok(! utf8::is_utf8( $cd->title ), 'got title without utf8 flag' );
-ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'store utf8-less chars' );
+ sub query_start {
+ my $self = shift;
+ my $sql = shift;
+
+ my @bind = map { substr $_, 1, -1 } (@_); # undo the effect of _fix_bind_params
+
+ $self->call_stack ( [ @{$self->call_stack || [] }, [$sql, @bind] ] );
+ $self->next::method ($sql, @_);
+ }
+}
+
+# as per http://search.cpan.org/dist/Test-Simple/lib/Test/More.pm#utf8
+binmode (Test::More->builder->$_, ':utf8') for qw/output failure_output todo_output/;
+
+my $bytestream_title = my $utf8_title = "weird \x{466} stuff";
+utf8::encode($bytestream_title);
+cmp_ok ($bytestream_title, 'ne', $utf8_title, 'unicode/raw differ (sanity check)');
+my $storage = $schema->storage;
+$storage->debugobj (DBICTest::UTF8::Debugger->new);
+$storage->debugobj->silence (1);
+$storage->debug (1);
-my $v_utf8 = "\x{219}";
+my $cd = $schema->resultset('CD')->create( { artist => 1, title => $utf8_title, year => '2048' } );
-$cd->update ({ title => $v_utf8 });
-$cd->title($v_utf8);
+# bind values are always alphabetically ordered by column, thus [2]
+TODO: {
+ local $TODO = "This has been broken since rev 1191, Mar 2006";
+ is ($storage->debugobj->call_stack->[-1][2], $bytestream_title, 'INSERT: raw bytes sent to the database');
+}
+
+# this should be using the cursor directly, no inflation/processing of any sort
+my ($raw_db_title) = $schema->resultset('CD')
+ ->search ($cd->ident_condition)
+ ->get_column('title')
+ ->_resultset
+ ->cursor
+ ->next;
+
+is ($raw_db_title, $bytestream_title, 'INSERT: raw bytes retrieved from database');
+
+for my $reloaded (0, 1) {
+ my $test = $reloaded ? 'reloaded' : 'stored';
+ $cd->discard_changes if $reloaded;
+
+ ok( utf8::is_utf8( $cd->title ), "got $test title with utf8 flag" );
+ ok(! utf8::is_utf8( $cd->{_column_data}{title} ), "in-object $test title without utf8" );
+
+ ok(! utf8::is_utf8( $cd->year ), "got $test year without utf8 flag" );
+ ok(! utf8::is_utf8( $cd->{_column_data}{year} ), "in-object $test year without utf8" );
+}
+
+$cd->title('nonunicode');
+ok(! utf8::is_utf8( $cd->title ), 'update title without utf8 flag' );
+ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'store utf8-less title' );
+
+$cd->update;
+$cd->discard_changes;
+ok(! utf8::is_utf8( $cd->title ), 'reloaded title without utf8 flag' );
+ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'reloaded utf8-less title' );
+
+$bytestream_title = $utf8_title = "something \x{219} else";
+utf8::encode($bytestream_title);
+
+$cd->update ({ title => $utf8_title });
+is ($storage->debugobj->call_stack->[-1][1], $bytestream_title, 'UPDATE: raw bytes sent to the database');
+($raw_db_title) = $schema->resultset('CD')
+ ->search ($cd->ident_condition)
+ ->get_column('title')
+ ->_resultset
+ ->cursor
+ ->next;
+is ($raw_db_title, $bytestream_title, 'UPDATE: raw bytes retrieved from database');
+
+$cd->discard_changes;
+$cd->title($utf8_title);
ok( !$cd->is_column_changed('title'), 'column is not dirty after setting the same unicode value' );
-$cd->update ({ title => $v_utf8 });
+$cd->update ({ title => $utf8_title });
$cd->title('something_else');
ok( $cd->is_column_changed('title'), 'column is dirty after setting to something completely different');
TODO: {
local $TODO = 'There is currently no way to propagate aliases to inflate_result()';
- $cd = $schema->resultset('CD')->find ({ title => $v_utf8 }, { select => 'title', as => 'name' });
+ $cd = $schema->resultset('CD')->find ({ title => $utf8_title }, { select => 'title', as => 'name' });
ok (utf8::is_utf8( $cd->get_column ('name') ), 'utf8 flag propagates via as');
}
projects / dbsrgits/DBIx-Class.git / commitdiff