I was wrong about 2d12a809 - the crash is real
[dbsrgits/DBIx-Class.git] / 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;