Commit | Line | Data |
7da9cd47 |
1 | package DBIx::Class::UUIDColumns; |
1edd1722 |
2 | use base qw/DBIx::Class/; |
7da9cd47 |
3 | |
7da9cd47 |
4 | __PACKAGE__->mk_classdata( 'uuid_auto_columns' => [] ); |
947acfd9 |
5 | __PACKAGE__->mk_classdata( 'uuid_maker' ); |
6 | __PACKAGE__->uuid_class( __PACKAGE__->_find_uuid_module ); |
7da9cd47 |
7 | |
8 | =head1 NAME |
9 | |
10 | DBIx::Class::UUIDColumns - Implicit uuid columns |
11 | |
12 | =head1 SYNOPSIS |
13 | |
947acfd9 |
14 | package Artist; |
7da9cd47 |
15 | __PACKAGE__->load_components(qw/UUIDColumns Core DB/); |
e821dce9 |
16 | __PACKAGE__->uuid_columns( 'artist_id' ); |
7da9cd47 |
17 | |
18 | =head1 DESCRIPTION |
19 | |
e821dce9 |
20 | This L<DBIx::Class> component resembles the behaviour of |
7da9cd47 |
21 | L<Class::DBI::UUID>, to make some columns implicitly created as uuid. |
22 | |
23 | Note that the component needs to be loaded before Core. |
24 | |
25 | =head1 METHODS |
26 | |
8091aa91 |
27 | =head2 uuid_columns |
7da9cd47 |
28 | |
29 | =cut |
30 | |
31 | # be compatible with Class::DBI::UUID |
32 | sub uuid_columns { |
33 | my $self = shift; |
34 | for (@_) { |
701da8c4 |
35 | $self->throw_exception("column $_ doesn't exist") unless $self->has_column($_); |
7da9cd47 |
36 | } |
37 | $self->uuid_auto_columns(\@_); |
38 | } |
39 | |
947acfd9 |
40 | sub uuid_class { |
41 | my ($self, $class) = @_; |
42 | |
43 | if ($class) { |
44 | $class = "DBIx::Class::UUIDMaker$class" if $class =~ /^::/; |
45 | |
46 | if (!eval "require $class") { |
47 | $self->throw_exception("$class could not be loaded: $@"); |
48 | } elsif (!$class->isa('DBIx::Class::UUIDMaker')) { |
49 | $self->throw_exception("$class is not a UUIDMaker subclass"); |
50 | } else { |
51 | $self->uuid_maker($class->new); |
52 | }; |
53 | }; |
54 | |
55 | return ref $self->uuid_maker; |
56 | }; |
57 | |
7da9cd47 |
58 | sub insert { |
3b7992e1 |
59 | my $self = shift; |
7da9cd47 |
60 | for my $column (@{$self->uuid_auto_columns}) { |
103647d5 |
61 | $self->store_column( $column, $self->get_uuid ) |
62 | unless defined $self->get_column( $column ); |
7da9cd47 |
63 | } |
3b7992e1 |
64 | $self->next::method(@_); |
7da9cd47 |
65 | } |
66 | |
67 | sub get_uuid { |
947acfd9 |
68 | return shift->uuid_maker->as_string; |
7da9cd47 |
69 | } |
70 | |
947acfd9 |
71 | sub _find_uuid_module { |
72 | if ($^O ne 'openbsd' && eval{require APR::UUID}) { |
73 | # APR::UUID on openbsd causes some as yet unfound nastyness for XS |
74 | return '::APR::UUID'; |
75 | } elsif (eval{require UUID}) { |
76 | return '::UUID'; |
77 | } elsif (eval{require Data::UUID}) { |
78 | return '::Data::UUID'; |
79 | } elsif (eval{ |
80 | # squelch the 'too late for INIT' warning in Win32::API::Type |
81 | local $^W = 0; |
82 | require Win32::Guidgen; |
83 | }) { |
84 | return '::Win32::Guidgen'; |
85 | } elsif (eval{require Win32API::GUID}) { |
86 | return '::Win32API::GUID'; |
87 | } else { |
88 | shift->throw_exception('no suitable uuid module could be found') |
89 | }; |
90 | }; |
91 | |
7da9cd47 |
92 | =head1 AUTHORS |
93 | |
94 | Chia-liang Kao <clkao@clkao.org> |
95 | |
96 | =head1 LICENSE |
97 | |
98 | You may distribute this code under the same terms as Perl itself. |
99 | |
100 | =cut |
101 | |
102 | 1; |