lib/DBIx/Class/UUIDColumns.pm

   1 package DBIx::Class::UUIDColumns;
   2 use base qw/DBIx::Class/;
   3
   4 __PACKAGE__->mk_classdata( 'uuid_auto_columns' => [] );
   5 __PACKAGE__->mk_classdata( 'uuid_maker' );
   6 __PACKAGE__->uuid_class( __PACKAGE__->_find_uuid_module );
   7
   8 =head1 NAME
   9
  10 DBIx::Class::UUIDColumns - Implicit uuid columns
  11
  12 =head1 SYNOPSIS
  13
  14   package Artist;
  15   __PACKAGE__->load_components(qw/UUIDColumns Core DB/);
  16   __PACKAGE__->uuid_columns( 'artist_id' );
  17
  18 =head1 DESCRIPTION
  19
  20 This L<DBIx::Class> component resembles the behaviour of
  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
  27 =head2 uuid_columns
  28
  29 =cut
  30
  31 # be compatible with Class::DBI::UUID
  32 sub uuid_columns {
  33     my $self = shift;
  34     for (@_) {
  35         $self->throw_exception("column $_ doesn't exist") unless $self->has_column($_);
  36     }
  37     $self->uuid_auto_columns(\@_);
  38 }
  39
  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
  58 sub insert {
  59     my $self = shift;
  60     for my $column (@{$self->uuid_auto_columns}) {
  61         $self->store_column( $column, $self->get_uuid )
  62             unless defined $self->get_column( $column );
  63     }
  64     $self->next::method(@_);
  65 }
  66
  67 sub get_uuid {
  68     return shift->uuid_maker->as_string;
  69 }
  70
  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
  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;