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 __PACKAGE__->mk_group_accessors(inherited => 'new_guid');
   9
  10 =head1 NAME
  11
  12 DBIx::Class::Storage::DBI::UniqueIdentifier - Storage component for RDBMSes
  13 supporting GUID types
  14
  15 =head1 DESCRIPTION
  16
  17 This is a storage component for databases that support GUID types such as
  18 C<uniqueidentifier>, C<uniqueidentifierstr> or C<guid>.
  19
  20 GUIDs are generated automatically for PK columns with a supported
  21 L<data_type|DBIx::Class::ResultSource/data_type>, as well as non-PK with
  22 L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> set.
  23
  24 =head1 METHODS
  25
  26 =head2 new_guid
  27
  28 The composing class must set C<new_guid> to the method used to generate a new
  29 GUID. It can also set it to C<undef>, in which case the user is required to set
  30 it, or a runtime error will be thrown. It can be:
  31
  32 =over 4
  33
  34 =item string
  35
  36 In which case it is used as the name of database function to create a new GUID,
  37
  38 =item coderef
  39
  40 In which case the coderef should return a string GUID, using L<Data::GUID>, or
  41 whatever GUID generation method you prefer.
  42
  43 =back
  44
  45 For example:
  46
  47   $schema->storage->new_guid(sub { Data::GUID->new->as_string });
  48
  49 =cut
  50
  51 my $GUID_TYPE = qr/^(?:uniqueidentifier(?:str)?|guid)\z/i;
  52
  53 sub _is_guid_type {
  54   my ($self, $data_type) = @_;
  55
  56   return $data_type =~ $GUID_TYPE;
  57 }
  58
  59 sub insert {
  60   my $self = shift;
  61   my ($source, $to_insert) = @_;
  62
  63   my $col_info = $source->columns_info;
  64
  65   my %guid_cols;
  66   my @pk_cols = $source->primary_columns;
  67   my %pk_cols;
  68   @pk_cols{@pk_cols} = ();
  69
  70   my @pk_guids = grep {
  71     $col_info->{$_}{data_type}
  72     &&
  73     $col_info->{$_}{data_type} =~ $GUID_TYPE
  74   } @pk_cols;
  75
  76   my @auto_guids = grep {
  77     $col_info->{$_}{data_type}
  78     &&
  79     $col_info->{$_}{data_type} =~ $GUID_TYPE
  80     &&
  81     $col_info->{$_}{auto_nextval}
  82   } grep { not exists $pk_cols{$_} } $source->columns;
  83
  84   my @get_guids_for =
  85     grep { not exists $to_insert->{$_} } (@pk_guids, @auto_guids);
  86
  87   my $updated_cols = {};
  88
  89   for my $guid_col (@get_guids_for) {
  90     my $new_guid;
  91
  92     my $guid_method = $self->new_guid;
  93
  94     if (not defined $guid_method) {
  95       $self->throw_exception(
  96         'You must set new_guid on your storage. See perldoc '
  97        .'DBIx::Class::Storage::DBI::UniqueIdentifier'
  98       );
  99     }
 100
 101     if (ref $guid_method eq 'CODE') {
 102       $new_guid = $guid_method->();
 103     }
 104     else {
 105       ($new_guid) = $self->_get_dbh->selectrow_array("SELECT $guid_method");
 106     }
 107
 108     $updated_cols->{$guid_col} = $to_insert->{$guid_col} = $new_guid;
 109   }
 110
 111   $updated_cols = { %$updated_cols, %{ $self->next::method(@_) } };
 112
 113   return $updated_cols;
 114 }
 115
 116 =head1 AUTHOR
 117
 118 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
 119
 120 =head1 LICENSE
 121
 122 You may distribute this code under the same terms as Perl itself.
 123
 124 =cut
 125
 126 1;