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, $to_insert) = @_;
  63
  64   my $col_info = $source->columns_info;
  65
  66   my %guid_cols;
  67   my @pk_cols = $source->primary_columns;
  68   my %pk_col_idx;
  69   @pk_col_idx{@pk_cols} = ();
  70
  71   my @pk_guids = grep {
  72     $col_info->{$_}{data_type}
  73     &&
  74     $col_info->{$_}{data_type} =~ $GUID_TYPE
  75   } @pk_cols;
  76
  77   my @auto_guids = grep {
  78     $col_info->{$_}{data_type}
  79     &&
  80     $col_info->{$_}{data_type} =~ $GUID_TYPE
  81     &&
  82     $col_info->{$_}{auto_nextval}
  83   } grep { not exists $pk_col_idx{$_} } $source->columns;
  84
  85   my @get_guids_for =
  86     grep { not exists $to_insert->{$_} } (@pk_guids, @auto_guids);
  87
  88   for my $guid_col (@get_guids_for) {
  89     my $new_guid;
  90
  91     my $guid_method = $self->new_guid;
  92
  93     if (not defined $guid_method) {
  94       $self->throw_exception(
  95         'You must set new_guid on your storage. See perldoc '
  96        .'DBIx::Class::Storage::DBI::UniqueIdentifier'
  97       );
  98     }
  99
 100     if (ref $guid_method eq 'CODE') {
 101       $to_insert->{$guid_col} = $guid_method->($self);
 102     }
 103     else {
 104       ($to_insert->{$guid_col}) = $self->_get_dbh->selectrow_array("SELECT $guid_method");
 105     }
 106   }
 107
 108   return $self->next::method(@_);
 109 }
 110
 111 =head1 AUTHOR
 112
 113 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
 114
 115 =head1 LICENSE
 116
 117 You may distribute this code under the same terms as Perl itself.
 118
 119 =cut
 120
 121 1;