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 | |
40d8d018 |
8 | __PACKAGE__->mk_group_accessors(inherited => 'new_guid'); |
9 | |
548d1627 |
10 | =head1 NAME |
11 | |
12 | DBIx::Class::Storage::DBI::UniqueIdentifier - Storage component for RDBMSes |
40d8d018 |
13 | supporting GUID types |
548d1627 |
14 | |
15 | =head1 DESCRIPTION |
16 | |
40d8d018 |
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 |
548d1627 |
39 | |
40d8d018 |
40 | In which case the coderef should return a string GUID, using L<Data::GUID>, or |
41 | whatever GUID generation method you prefer. |
548d1627 |
42 | |
40d8d018 |
43 | =back |
548d1627 |
44 | |
40d8d018 |
45 | For example: |
46 | |
47 | $schema->storage->new_guid(sub { Data::GUID->new->as_string }); |
548d1627 |
48 | |
49 | =cut |
50 | |
40d8d018 |
51 | my $GUID_TYPE = qr/^(?:uniqueidentifier(?:str)?|guid)\z/i; |
52 | |
53 | sub _is_guid_type { |
54 | my ($self, $data_type) = @_; |
55 | |
56 | return $data_type =~ $GUID_TYPE; |
57 | } |
548d1627 |
58 | |
59 | sub insert { |
60 | my $self = shift; |
61 | my ($source, $to_insert) = @_; |
62 | |
52416317 |
63 | my $col_info = $source->columns_info; |
548d1627 |
64 | |
65 | my %guid_cols; |
66 | my @pk_cols = $source->primary_columns; |
67 | my %pk_cols; |
68 | @pk_cols{@pk_cols} = (); |
69 | |
70 | my @pk_guids = grep { |
52416317 |
71 | $col_info->{$_}{data_type} |
548d1627 |
72 | && |
40d8d018 |
73 | $col_info->{$_}{data_type} =~ $GUID_TYPE |
548d1627 |
74 | } @pk_cols; |
75 | |
76 | my @auto_guids = grep { |
52416317 |
77 | $col_info->{$_}{data_type} |
548d1627 |
78 | && |
40d8d018 |
79 | $col_info->{$_}{data_type} =~ $GUID_TYPE |
548d1627 |
80 | && |
52416317 |
81 | $col_info->{$_}{auto_nextval} |
548d1627 |
82 | } grep { not exists $pk_cols{$_} } $source->columns; |
83 | |
84 | my @get_guids_for = |
85 | grep { not exists $to_insert->{$_} } (@pk_guids, @auto_guids); |
86 | |
87 | my $updated_cols = {}; |
88 | |
89 | for my $guid_col (@get_guids_for) { |
40d8d018 |
90 | my $new_guid; |
91 | |
92 | my $guid_method = $self->new_guid; |
93 | |
94 | if (not defined $guid_method) { |
95 | $self->throw_exception( |
96 | 'You must set new_guid on your storage. See perldoc ' |
97 | .'DBIx::Class::Storage::DBI::UniqueIdentifier' |
98 | ); |
99 | } |
100 | |
101 | if (ref $guid_method eq 'CODE') { |
102 | $new_guid = $guid_method->(); |
103 | } |
104 | else { |
105 | ($new_guid) = $self->_get_dbh->selectrow_array("SELECT $guid_method"); |
106 | } |
107 | |
548d1627 |
108 | $updated_cols->{$guid_col} = $to_insert->{$guid_col} = $new_guid; |
109 | } |
110 | |
111 | $updated_cols = { %$updated_cols, %{ $self->next::method(@_) } }; |
112 | |
113 | return $updated_cols; |
114 | } |
115 | |
116 | =head1 AUTHOR |
117 | |
118 | See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>. |
119 | |
120 | =head1 LICENSE |
121 | |
122 | You may distribute this code under the same terms as Perl itself. |
123 | |
124 | =cut |
125 | |
126 | 1; |