[Bast-commits] r9099 - in DBIx-Class/0.08/trunk:
lib/DBIx/Class/Storage/DBI t
caelum at dev.catalyst.perl.org
caelum at dev.catalyst.perl.org
Wed Apr 7 00:13:38 GMT 2010
Author: caelum
Date: 2010-04-07 01:13:38 +0100 (Wed, 07 Apr 2010)
New Revision: 9099
Added:
DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI/UniqueIdentifier.pm
Modified:
DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI/MSSQL.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm
DBIx-Class/0.08/trunk/t/749sybase_asa.t
Log:
UUID support for SQL Anywhere
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI/MSSQL.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI/MSSQL.pm 2010-04-06 23:05:06 UTC (rev 9098)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI/MSSQL.pm 2010-04-07 00:13:38 UTC (rev 9099)
@@ -3,7 +3,7 @@
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();
@@ -66,43 +66,12 @@
}
}
-# 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;
@@ -111,13 +80,12 @@
$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;
}
@@ -363,7 +331,7 @@
=head1 AUTHOR
-See L<DBIx::Class/CONTRIBUTORS>.
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm 2010-04-06 23:05:06 UTC (rev 9098)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm 2010-04-07 00:13:38 UTC (rev 9099)
@@ -2,7 +2,7 @@
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 ();
@@ -35,6 +35,8 @@
sub last_insert_id { shift->_identity }
+sub _new_uuid { 'UUIDTOSTR(NEWID())' }
+
sub insert {
my $self = shift;
my ($source, $to_insert) = @_;
@@ -46,7 +48,9 @@
# 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;
}
@@ -58,11 +62,41 @@
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 ($alias2source, $rs_alias) = $self->_resolve_ident_sources($ident);
+
+ for my $select_idx (0..$#$select) {
+ my $selected = $select->[$select_idx];
+
+ next if ref $selected;
+
+ my ($alias, $col) = split /\./, $selected;
+ ($alias, $col) = ($rs_alias, $selected) if not defined $col;
+
+ my $data_type = eval {
+ $alias2source->{$alias}->column_info($col)->{data_type}
+ };
+
+ if ($data_type && $data_type =~ /^uniqueidentifier\z/i) {
+ $select->[$select_idx] = { UUIDTOSTR => $selected };
+ }
}
return $self->next::method(@_);
Added: DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI/UniqueIdentifier.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI/UniqueIdentifier.pm (rev 0)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/Storage/DBI/UniqueIdentifier.pm 2010-04-07 00:13:38 UTC (rev 9099)
@@ -0,0 +1,83 @@
+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;
Modified: DBIx-Class/0.08/trunk/t/749sybase_asa.t
===================================================================
--- DBIx-Class/0.08/trunk/t/749sybase_asa.t 2010-04-06 23:05:06 UTC (rev 9098)
+++ DBIx-Class/0.08/trunk/t/749sybase_asa.t 2010-04-07 00:13:38 UTC (rev 9099)
@@ -3,9 +3,12 @@
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/};
@@ -21,21 +24,21 @@
[ $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 $guard = Scope::Guard->new(\&cleanup);
+
my $dbh = $schema->storage->dbh;
- push @handles_to_clean, $dbh;
-
eval { $dbh->do("DROP TABLE artist") };
$dbh->do(<<EOF);
@@ -160,13 +163,62 @@
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/;
}
More information about the Bast-commits
mailing list