lib/DBIx/Class/Storage/DBI/UniqueIdentifier.pm

   1 package DBIx::Class::Storage::DBI::UniqueIdentifier;
   2
   3 use strict;
   4 use warnings;
   5 use base 'DBIx::Class::Storage::DBI';
   6 use mro 'c3';
   7
   8 =head1 NAME
   9
  10 DBIx::Class::Storage::DBI::UniqueIdentifier - Storage component for RDBMSes
  11 supporting the 'uniqueidentifier' type
  12
  13 =head1 DESCRIPTION
  14
  15 This is a storage component for databases that support the C<uniqueidentifier>
  16 type and the C<NEWID()> function for generating UUIDs.
  17
  18 UUIDs are generated automatically for PK columns with the C<uniqueidentifier>
  19 L<data_type|DBIx::Class::ResultSource/data_type>, as well as non-PK with this
  20 L<data_type|DBIx::Class::ResultSource/data_type> and
  21 L<auto_nextval|DBIx::Class::ResultSource/auto_nextval>.
  22
  23 Currently used by L<DBIx::Class::Storage::DBI::MSSQL> and
  24 L<DBIx::Class::Storage::DBI::SQLAnywhere>.
  25
  26 The composing class can define a C<_new_uuid> method to override the function
  27 used to generate a new UUID.
  28
  29 =cut
  30
  31 sub _new_uuid { 'NEWID()' }
  32
  33 sub insert {
  34   my $self = shift;
  35   my ($source, $to_insert) = @_;
  36
  37   my $supplied_col_info = $self->_resolve_column_info($source, [keys %$to_insert] );
  38
  39   my %guid_cols;
  40   my @pk_cols = $source->primary_columns;
  41   my %pk_cols;
  42   @pk_cols{@pk_cols} = ();
  43
  44   my @pk_guids = grep {
  45     $source->column_info($_)->{data_type}
  46     &&
  47     $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i
  48   } @pk_cols;
  49
  50   my @auto_guids = grep {
  51     $source->column_info($_)->{data_type}
  52     &&
  53     $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i
  54     &&
  55     $source->column_info($_)->{auto_nextval}
  56   } grep { not exists $pk_cols{$_} } $source->columns;
  57
  58   my @get_guids_for =
  59     grep { not exists $to_insert->{$_} } (@pk_guids, @auto_guids);
  60
  61   my $updated_cols = {};
  62
  63   for my $guid_col (@get_guids_for) {
  64     my ($new_guid) = $self->_get_dbh->selectrow_array('SELECT '.$self->_new_uuid);
  65     $updated_cols->{$guid_col} = $to_insert->{$guid_col} = $new_guid;
  66   }
  67
  68   $updated_cols = { %$updated_cols, %{ $self->next::method(@_) } };
  69
  70   return $updated_cols;
  71 }
  72
  73 =head1 AUTHOR
  74
  75 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
  76
  77 =head1 LICENSE
  78
  79 You may distribute this code under the same terms as Perl itself.
  80
  81 =cut
  82
  83 1;