Commit | Line | Data |
548d1627 |
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 | =head1 NAME |
9 | |
10 | DBIx::Class::Storage::DBI::UniqueIdentifier - Storage component for RDBMSes |
11 | supporting the 'uniqueidentifier' type |
12 | |
13 | =head1 DESCRIPTION |
14 | |
15 | This is a storage component for databases that support the C<uniqueidentifier> |
16 | type and the C<NEWID()> function for generating UUIDs. |
17 | |
18 | UUIDs are generated automatically for PK columns with the C<uniqueidentifier> |
19 | L<data_type|DBIx::Class::ResultSource/data_type>, as well as non-PK with this |
20 | L<data_type|DBIx::Class::ResultSource/data_type> and |
21 | L<auto_nextval|DBIx::Class::ResultSource/auto_nextval>. |
22 | |
23 | Currently used by L<DBIx::Class::Storage::DBI::MSSQL> and |
24 | L<DBIx::Class::Storage::DBI::SQLAnywhere>. |
25 | |
26 | The composing class can define a C<_new_uuid> method to override the function |
27 | used to generate a new UUID. |
28 | |
29 | =cut |
30 | |
31 | sub _new_uuid { 'NEWID()' } |
32 | |
33 | sub insert { |
34 | my $self = shift; |
35 | my ($source, $to_insert) = @_; |
36 | |
37 | my $supplied_col_info = $self->_resolve_column_info($source, [keys %$to_insert] ); |
38 | |
39 | my %guid_cols; |
40 | my @pk_cols = $source->primary_columns; |
41 | my %pk_cols; |
42 | @pk_cols{@pk_cols} = (); |
43 | |
44 | my @pk_guids = grep { |
45 | $source->column_info($_)->{data_type} |
46 | && |
47 | $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i |
48 | } @pk_cols; |
49 | |
50 | my @auto_guids = grep { |
51 | $source->column_info($_)->{data_type} |
52 | && |
53 | $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i |
54 | && |
55 | $source->column_info($_)->{auto_nextval} |
56 | } grep { not exists $pk_cols{$_} } $source->columns; |
57 | |
58 | my @get_guids_for = |
59 | grep { not exists $to_insert->{$_} } (@pk_guids, @auto_guids); |
60 | |
61 | my $updated_cols = {}; |
62 | |
63 | for my $guid_col (@get_guids_for) { |
64 | my ($new_guid) = $self->_get_dbh->selectrow_array('SELECT '.$self->_new_uuid); |
65 | $updated_cols->{$guid_col} = $to_insert->{$guid_col} = $new_guid; |
66 | } |
67 | |
68 | $updated_cols = { %$updated_cols, %{ $self->next::method(@_) } }; |
69 | |
70 | return $updated_cols; |
71 | } |
72 | |
73 | =head1 AUTHOR |
74 | |
75 | See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>. |
76 | |
77 | =head1 LICENSE |
78 | |
79 | You may distribute this code under the same terms as Perl itself. |
80 | |
81 | =cut |
82 | |
83 | 1; |