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