From: Jonathan Rockway <jon@jrock.us>
Date: Mon, 21 Apr 2008 21:19:38 +0000 (-0500)
Subject: mostly working
X-Git-Tag: 0.01~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Types-UUID.git;a=commitdiff_plain;h=316d7a7eb65f9f8f65934435eb26f9ce4fbcabef

mostly working
---

diff --git a/Makefile.PL b/Makefile.PL
index 14643ee..6c7c542 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -3,6 +3,8 @@ use inc::Module::Install;
 name 'MooseX-Types-UUID';
 all_from 'lib/MooseX/Types/UUID.pm';
 
+requires 'MooseX::Types';
+build_requires 'Test::Exception';
 build_requires 'Test::More';
 build_requires 'ok';
 
diff --git a/lib/MooseX/Types/UUID.pm b/lib/MooseX/Types/UUID.pm
index 7edc0a9..dcbdfd2 100644
--- a/lib/MooseX/Types/UUID.pm
+++ b/lib/MooseX/Types/UUID.pm
@@ -2,10 +2,56 @@ package MooseX::Types::UUID;
 use strict;
 use warnings;
 
-=head1 NAME
+use MooseX::Types -declare => ['UUID'];
+use MooseX::Types::Moose qw(Str);
+
+sub _validate_uuid {
+    my ($str) = @_;
+    return $str =~ /^[A-F0-9]{8}-[A-F0-9]{4}-[A-F0-9]{4}-[A-F0-9]{4}-[A-F0-9]{12}$/;
+}
 
-MooseX::Types::UUID - 
+subtype UUID,
+  as Str, where { _validate_uuid($_) };
 
-=cut
+coerce UUID
+  # i've never seen lowercase UUIDs, but someone's bound to try it
+  from Str, via { uc };
 
 1;
+
+__END__
+
+=head1 NAME
+
+MooseX::Types::UUID - UUID type for Moose classes
+
+=head1 SYNOPSIS
+
+  package Class;
+  use Moose;
+  use MooseX::Types::UUID qw(UUID);
+  
+  has 'uuid' => ( is => 'ro', isa => UUID );
+
+  package main;
+  Class->new( uuid => '77C71F92-0EC7-11DD-B986-DF138EE79F6F' );
+
+=head1 DESCRIPTION
+
+This module lets you constrain attributes to only contain UUIDs (in
+their usual human-readable form).  No coercion is attempted.
+
+=head1 EXPORT
+
+None by default, you'll usually want to request C<UUID> explicitly.
+
+=head1 AUTHOR
+
+Jonathan Rockway C<< <jrockway@cpan.org> >>
+
+Infinity Interactive (L<http://www.iinteractive.com/>)
+
+=head1 COPYRIGHT
+
+This program is Free software, you may redistribute it under the same
+terms as Perl itself.
diff --git a/t/01-basic.t b/t/01-basic.t
new file mode 100644
index 0000000..7d8461a
--- /dev/null
+++ b/t/01-basic.t
@@ -0,0 +1,19 @@
+use strict;
+use warnings;
+use Test::Exception;
+use Test::More tests => 2;
+
+{ package Class;
+  use Moose;
+  use MooseX::Types::UUID qw(UUID);
+  
+  has 'uuid' => ( is => 'ro', isa => UUID );
+}
+
+lives_ok {
+    Class->new( uuid => '77C71F92-0EC7-11DD-B986-DF138EE79F6F' );
+} 'valid UUID works';
+
+throws_ok {
+    Class->new( uuid => 'there is no way you could possibly think this is a UUID' );
+} qr/does not pass the type constraint/;