File Coverage

blib/lib/Data/GUID.pm
Criterion Covered Total %
statement 102 102 100.0
branch 20 20 100.0
condition 2 2 100.0
subroutine 32 32 100.0
pod 4 4 100.0
total 160 160 100.0


line stmt bran cond sub pod time code
1 4     4   299691 use strict;
  4         31  
  4         106  
2 4     4   18 use warnings;
  4         7  
  4         169  
3             package Data::GUID;
4             # ABSTRACT: globally unique identifiers
5             $Data::GUID::VERSION = '0.051';
6 4     4   22 use Carp ();
  4         7  
  4         90  
7 4     4   1585 use Data::UUID 1.148;
  4         2211  
  4         236  
8 4     4   1629 use Sub::Install 0.03;
  4         6668  
  4         21  
9              
10             #pod =head1 SYNOPSIS
11             #pod
12             #pod use Data::GUID;
13             #pod
14             #pod my $guid = Data::GUID->new;
15             #pod
16             #pod my $string = $guid->as_string; # or "$guid"
17             #pod
18             #pod my $other_guid = Data::GUID->from_string($string);
19             #pod
20             #pod if (($guid <=> $other_guid) == 0) {
21             #pod print "They're the same!\n";
22             #pod }
23             #pod
24             #pod =head1 DESCRIPTION
25             #pod
26             #pod Data::GUID provides a simple interface for generating and using globally unique
27             #pod identifiers.
28             #pod
29             #pod =head1 GETTING A NEW GUID
30             #pod
31             #pod =head2 new
32             #pod
33             #pod my $guid = Data::GUID->new;
34             #pod
35             #pod This method returns a new globally unique identifier.
36             #pod
37             #pod =cut
38              
39             my $_uuid_gen_obj;
40             my $_uuid_gen_pid;
41             my $_uuid_gen = sub {
42             return $_uuid_gen_obj if $_uuid_gen_obj
43             && $_uuid_gen_pid == $$;
44              
45             $_uuid_gen_pid = $$;
46             $_uuid_gen_obj = Data::UUID->new;
47             };
48              
49             sub new {
50 18     18 1 613 my ($class) = @_;
51              
52 18         39 return $class->from_data_uuid($_uuid_gen->()->create);
53             }
54              
55             #pod =head1 GUIDS FROM EXISTING VALUES
56             #pod
57             #pod These method returns a new Data::GUID object for the given GUID value. In all
58             #pod cases, these methods throw an exception if given invalid input.
59             #pod
60             #pod =head2 from_string
61             #pod
62             #pod my $guid = Data::GUID->from_string("B0470602-A64B-11DA-8632-93EBF1C0E05A");
63             #pod
64             #pod =head2 from_hex
65             #pod
66             #pod # note that a hex guid is a guid string without hyphens and with a leading 0x
67             #pod my $guid = Data::GUID->from_hex("0xB0470602A64B11DA863293EBF1C0E05A");
68             #pod
69             #pod =head2 from_base64
70             #pod
71             #pod my $guid = Data::GUID->from_base64("sEcGAqZLEdqGMpPr8cDgWg==");
72             #pod
73             #pod =head2 from_data_uuid
74             #pod
75             #pod This method returns a new Data::GUID object if given a Data::UUID value.
76             #pod Because Data::UUID values are not blessed and because Data::UUID provides no
77             #pod validation method, this method will only throw an exception if the given data
78             #pod is of the wrong size.
79             #pod
80             #pod =cut
81              
82             sub from_data_uuid {
83 41     41 1 1891 my ($class, $value) = @_;
84              
85 4 100   4   2717 my $length = do { use bytes; defined $value ? length $value : 0; };
  4         51  
  4         18  
  41         49  
  41         82  
86 41 100       530 Carp::croak "given value is not a valid Data::UUID value" if $length != 16;
87 35         111 bless \$value => $class;
88             }
89              
90             #pod =head1 IDENTIFYING GUIDS
91             #pod
92             #pod =head2 string_guid_regex
93             #pod
94             #pod =head2 hex_guid_regex
95             #pod
96             #pod =head2 base64_guid_regex
97             #pod
98             #pod These methods return regex objects that match regex strings of the appropriate
99             #pod type.
100             #pod
101             #pod =cut
102              
103             my ($hex, $base64, %type);
104              
105             BEGIN { # because %type must be populated for method/exporter generation
106 4     4   21 $hex = qr/[0-9A-F]/i;
107 4         10 $base64 = qr{[A-Z0-9+/=]}i;
108              
109 4         330 %type = ( # uuid_method validation_regex
110             string => [ 'string', qr/\A$hex{8}-?(?:$hex{4}-?){3}$hex{12}\z/, ],
111             hex => [ 'hexstring', qr/\A0x$hex{32}\z/, ],
112             base64 => [ 'b64string', qr/\A$base64{24}\z/, ],
113             );
114              
115 4         24 for my $key (keys %type) {
116 4     4   621 no strict 'refs';
  4         8  
  4         250  
117 12         22 my $subname = "$key\_guid_regex";
118 7     7   1270 *$subname = sub { $type{ $key }[1] }
119 12         1278 }
120             }
121              
122             # provided for test scripts
123 12     12   2026 sub __type_regex { shift; $type{$_[0]}[1] }
  12         44  
124              
125             sub _install_from_method {
126 12     12   32 my ($type, $alien_method, $regex) = @_;
127 12         33 my $alien_from_method = "from_$alien_method";
128              
129             my $our_from_code = sub {
130 73     73   2709 my ($class, $string) = @_;
131 73   100     164 $string ||= q{}; # to avoid (undef =~) warning
132 73 100       4281 Carp::croak qq{"$string" is not a valid $type GUID} if $string !~ $regex;
133 16         34 $class->from_data_uuid( $_uuid_gen->()->$alien_from_method($string) );
134 12         39 };
135              
136 12         63 Sub::Install::install_sub({ code => $our_from_code, as => "from_$type" });
137             }
138              
139             sub _install_as_method {
140 12     12   19 my ($type, $alien_method) = @_;
141              
142 12         22 my $alien_to_method = "to_$alien_method";
143              
144             my $our_to_method = sub {
145 49     49   1897 my ($self) = @_;
146 49         71 $_uuid_gen->()->$alien_to_method( $self->as_binary );
147 12         31 };
148              
149 12         37 Sub::Install::install_sub({ code => $our_to_method, as => "as_$type" });
150             }
151              
152             BEGIN { # possibly unnecessary -- rjbs, 2006-03-11
153 4     4   20 do {
154 4         20 while (my ($type, $profile) = each %type) {
155 12         350 _install_from_method($type, @$profile);
156 12         569 _install_as_method ($type, @$profile);
157             }
158             };
159             }
160              
161             sub _from_multitype {
162 8     8   22 my ($class, $what, $types) = @_;
163             sub {
164 30     30   5199 my ($class, $value) = @_;
165 30 100       38 return $value if eval { $value->isa('Data::GUID') };
  30         189  
166              
167 28 100       77 my $value_string = defined $value ? qq{"$value"} : 'undef';
168              
169             # The only good ref is a blessed ref, and only into our denomination!
170 28 100       51 if (my $ref = ref $value) {
171 4         394 Carp::croak "a $ref reference is not a valid GUID $what"
172             }
173              
174 24         41 for my $type (@$types) {
175 63         94 my $from = "from_$type";
176 63         68 my $guid = eval { $class->$from($value); };
  63         136  
177 63 100       197 return $guid if $guid;
178             }
179              
180 12         621 Carp::croak "$value_string is not a valid GUID $what";
181             }
182 8         62 }
183              
184             #pod =head2 from_any_string
185             #pod
186             #pod my $string = get_string_from_ether;
187             #pod
188             #pod my $guid = Data::GUID->from_any_string($string);
189             #pod
190             #pod This method returns a Data::GUID object for the given string, trying all known
191             #pod string interpretations. An exception is thrown if the value is not a valid
192             #pod GUID string.
193             #pod
194             #pod =cut
195              
196             BEGIN { # possibly unnecessary -- rjbs, 2006-03-11
197 4     4   1063 Sub::Install::install_sub({
198             code => __PACKAGE__->_from_multitype('string', [ keys %type ]),
199             as => 'from_any_string',
200             });
201             }
202              
203             #pod =head2 best_guess
204             #pod
205             #pod my $value = get_value_from_ether;
206             #pod
207             #pod my $guid = Data::GUID->best_guess($value);
208             #pod
209             #pod This method returns a Data::GUID object for the given value, trying everything
210             #pod it can. It works like C>, but will also accept Data::UUID
211             #pod values. (In effect, this means that any sixteen byte value is acceptable.)
212             #pod
213             #pod =cut
214              
215             BEGIN { # possibly unnecessary -- rjbs, 2006-03-11
216 4     4   459 Sub::Install::install_sub({
217             code => __PACKAGE__->_from_multitype('value', [(keys %type), 'data_uuid']),
218             as => 'best_guess',
219             });
220             }
221              
222             #pod =head1 GUIDS INTO STRINGS
223             #pod
224             #pod These methods return various string representations of a GUID.
225             #pod
226             #pod =head2 as_string
227             #pod
228             #pod This method returns a "traditional" GUID/UUID string representation. This is
229             #pod five hexadecimal strings, delimited by hyphens. For example:
230             #pod
231             #pod B0470602-A64B-11DA-8632-93EBF1C0E05A
232             #pod
233             #pod This method is also used to stringify Data::GUID objects.
234             #pod
235             #pod =head2 as_hex
236             #pod
237             #pod This method returns a plain hexadecimal representation of the GUID, with a
238             #pod leading C<0x>. For example:
239             #pod
240             #pod 0xB0470602A64B11DA863293EBF1C0E05A
241             #pod
242             #pod =head2 as_base64
243             #pod
244             #pod This method returns a base-64 string representation of the GUID. For example:
245             #pod
246             #pod sEcGAqZLEdqGMpPr8cDgWg==
247             #pod
248             #pod =cut
249              
250             #pod =head1 OTHER METHODS
251             #pod
252             #pod =head2 compare_to_guid
253             #pod
254             #pod This method compares a GUID to another GUID and returns -1, 0, or 1, as do
255             #pod other comparison routines.
256             #pod
257             #pod =cut
258              
259             sub compare_to_guid {
260 8     8 1 16 my ($self, $other) = @_;
261              
262             my $other_binary
263 8 100       13 = eval { $other->isa('Data::GUID') } ? $other->as_binary : $other;
  8         40  
264              
265 8         15 $_uuid_gen->()->compare($self->as_binary, $other_binary);
266             }
267              
268             #pod =head2 as_binary
269             #pod
270             #pod This method returns the packed binary representation of the GUID. At present
271             #pod this method relies on Data::GUID's underlying use of Data::UUID. It is not
272             #pod guaranteed to continue to work the same way, or at all. I.
273             #pod
274             #pod =cut
275              
276             sub as_binary {
277 63     63 1 85 my ($self) = @_;
278 63         455 $$self;
279             }
280              
281             use overload
282             q{""} => 'as_string',
283 6 100   6   818 '<=>' => sub { ($_[2] ? -1 : 1) * $_[0]->compare_to_guid($_[1]) },
284 4     4   5153 fallback => 1;
  4         3515  
  4         29  
285              
286             #pod =head1 IMPORTING
287             #pod
288             #pod Data::GUID does not export any subroutines by default, but it provides a few
289             #pod routines which will be imported on request. These routines may be called as
290             #pod class methods, or may be imported to be called as subroutines. Calling them by
291             #pod fully qualified name is incorrect.
292             #pod
293             #pod use Data::GUID qw(guid);
294             #pod
295             #pod my $guid = guid; # OK
296             #pod my $guid = Data::GUID->guid; # OK
297             #pod my $guid = Data::GUID::guid; # NOT OK
298             #pod
299             #pod =cut
300              
301             #pod =head2 guid
302             #pod
303             #pod This routine returns a new Data::GUID object.
304             #pod
305             #pod =head2 guid_string
306             #pod
307             #pod This returns the string representation of a new GUID.
308             #pod
309             #pod =head2 guid_hex
310             #pod
311             #pod This returns the hex representation of a new GUID.
312             #pod
313             #pod =head2 guid_base64
314             #pod
315             #pod This returns the base64 representation of a new GUID.
316             #pod
317             #pod =head2 guid_from_anything
318             #pod
319             #pod This returns the result of calling the C> method.
320             #pod
321             #pod =cut
322              
323             BEGIN {
324 4     4   725 Sub::Install::install_sub({ code => 'new', as => 'guid' });
325              
326 4         281 for my $type (keys %type) {
327 12         366 my $method = "guid_$type";
328 12         20 my $as = "as_$type";
329              
330             Sub::Install::install_sub({
331             as => $method,
332             code => sub {
333 15     15   2851 my ($class) = @_;
334 15         30 $class->new->$as;
335             },
336 12         66 });
337             }
338             }
339              
340             sub _curry_class {
341 14     14   21 my ($class, $subname, $eval) = @_;
342 8     8   3650 return $eval ? sub { eval { $class->$subname(@_) } }
  8         47  
343 14 100   6   64 : sub { $class->$subname(@_) };
  6         43  
344             }
345              
346             my %exports;
347             BEGIN {
348             %exports
349 16         23 = map { my $method = $_; $_ => sub { _curry_class($_[0], $method) } }
  16         377  
  12         1957  
350 4     4   842 ((map { "guid_$_" } keys %type), 'guid');
  12         41  
351             }
352              
353             use Sub::Exporter 0.90 -setup => {
354             exports => {
355             %exports, # defined just above
356 2         36 guid_from_anything => sub { _curry_class($_[0], 'from_any_string', 1) },
357             }
358 4     4   2309 };
  4         42208  
  4         48  
359              
360             #pod =head1 TODO
361             #pod
362             #pod =for :list
363             #pod * add namespace support
364             #pod * remove dependency on wretched Data::UUID
365             #pod * make it work on 5.005
366             #pod
367             #pod =cut
368              
369             1;
370              
371             __END__