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. It is passed the C<$self>
  42 L<DBIx::Class::Storage> reference as a parameter.
  43
  44 =back
  45
  46 For example:
  47
  48   $schema->storage->new_guid(sub { Data::GUID->new->as_string });
  49
  50 =cut
  51
  52 my $GUID_TYPE = qr/^(?:uniqueidentifier(?:str)?|guid)\z/i;
  53
  54 sub _is_guid_type {
  55   my ($self, $data_type) = @_;
  56
  57   return $data_type =~ $GUID_TYPE;
  58 }
  59
  60 sub _prefetch_autovalues  {
  61   my $self = shift;
  62   my ($source, $col_info, $to_insert) = @_;
  63
  64   my %guid_cols;
  65   my @pk_cols = $source->primary_columns;
  66   my %pk_col_idx;
  67   @pk_col_idx{@pk_cols} = ();
  68
  69   my @pk_guids = grep {
  70     $col_info->{$_}{data_type}
  71     &&
  72     $col_info->{$_}{data_type} =~ $GUID_TYPE
  73   } @pk_cols;
  74
  75   my @auto_guids = grep {
  76     $col_info->{$_}{data_type}
  77     &&
  78     $col_info->{$_}{data_type} =~ $GUID_TYPE
  79     &&
  80     $col_info->{$_}{auto_nextval}
  81   } grep { not exists $pk_col_idx{$_} } $source->columns;
  82
  83   my @get_guids_for =
  84     grep { not exists $to_insert->{$_} } (@pk_guids, @auto_guids);
  85
  86   for my $guid_col (@get_guids_for) {
  87     my $new_guid;
  88
  89     my $guid_method = $self->new_guid;
  90
  91     if (not defined $guid_method) {
  92       $self->throw_exception(
  93         'You must set new_guid on your storage. See perldoc '
  94        .'DBIx::Class::Storage::DBI::UniqueIdentifier'
  95       );
  96     }
  97
  98     if (ref $guid_method eq 'CODE') {
  99       $to_insert->{$guid_col} = $guid_method->($self);
 100     }
 101     else {
 102       ($to_insert->{$guid_col}) = $self->_get_dbh->selectrow_array("SELECT $guid_method");
 103     }
 104   }
 105
 106   return $self->next::method(@_);
 107 }
 108
 109 =head1 AUTHOR
 110
 111 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
 112
 113 =head1 LICENSE
 114
 115 You may distribute this code under the same terms as Perl itself.
 116
 117 =cut
 118
 119 1;