File Coverage

blib/lib/UUID/Tiny.pm
Criterion Covered Total %
statement 242 257 94.1
branch 47 66 71.2
condition 10 14 71.4
subroutine 52 52 100.0
pod 10 10 100.0
total 361 399 90.4


line stmt bran cond sub pod time code
1             package UUID::Tiny;
2              
3 5     5   189418 use 5.008;
  5         24  
  5         198  
4 5     5   28 use warnings;
  5         14  
  5         215  
5 5     5   27 use strict;
  5         14  
  5         445  
6 5     5   29 use Carp;
  5         9  
  5         363  
7 5     5   36 use Digest::MD5;
  5         8  
  5         176  
8 5     5   2810 use MIME::Base64;
  5         2837  
  5         278  
9 5     5   4829 use Time::HiRes;
  5         10244  
  5         29  
10 5     5   5579 use POSIX;
  5         37444  
  5         36  
11              
12             my $SHA1_CALCULATOR = undef;
13              
14             {
15             # Check for availability of SHA-1 ...
16             local $@; # don't leak an error condition
17             eval { require Digest::SHA; $SHA1_CALCULATOR = Digest::SHA->new(1) } ||
18             eval { require Digest::SHA1; $SHA1_CALCULATOR = Digest::SHA1->new() } ||
19             eval {
20             require Digest::SHA::PurePerl;
21             $SHA1_CALCULATOR = Digest::SHA::PurePerl->new(1)
22             };
23             };
24              
25             my $MD5_CALCULATOR = Digest::MD5->new();
26              
27              
28             # ToDo:
29             # - Check and report for undefined UUIDs with all UUID manipulating functions!
30             # - Better error propagation for better debugging.
31              
32              
33              
34             =head1 NAME
35              
36             UUID::Tiny - Pure Perl UUID Support With Functional Interface
37              
38             =head1 VERSION
39              
40             Version 1.04
41              
42             =cut
43              
44             our $VERSION = '1.04';
45              
46              
47             =head1 SYNOPSIS
48              
49             Create version 1, 3, 4 and 5 UUIDs:
50              
51             use UUID::Tiny ':std';
52              
53             my $v1_mc_UUID = create_uuid();
54             my $v1_mc_UUID_2 = create_uuid(UUID_V1);
55             my $v1_mc_UUID_3 = create_uuid(UUID_TIME);
56             my $v3_md5_UUID = create_uuid(UUID_V3, $str);
57             my $v3_md5_UUID_2 = create_uuid(UUID_MD5, UUID_NS_DNS, 'caugustin.de');
58             my $v4_rand_UUID = create_uuid(UUID_V4);
59             my $v4_rand_UUID_2 = create_uuid(UUID_RANDOM);
60             my $v5_sha1_UUID = create_uuid(UUID_V5, $str);
61             my $v5_with_NS_UUID = create_uuid(UUID_SHA1, UUID_NS_DNS, 'caugustin.de');
62              
63             my $v1_mc_UUID_string = create_uuid_as_string(UUID_V1);
64             my $v3_md5_UUID_string = uuid_to_string($v3_md5_UUID);
65              
66             if ( version_of_uuid($v1_mc_UUID) == 1 ) { ... };
67             if ( version_of_uuid($v5_sha1_UUID) == 5 ) { ... };
68             if ( is_uuid_string($v1_mc_UUID_string) ) { ... };
69             if ( equal_uuids($uuid1, $uuid2) ) { ... };
70              
71             my $uuid_time = time_of_uuid($v1_mc_UUID);
72             my $uuid_clk_seq = clk_seq_of_uuid($v1_mc_UUID);
73              
74             =cut
75              
76              
77             =head1 DESCRIPTION
78              
79             UUID::Tiny is a lightweight, low dependency Pure Perl module for UUID
80             creation and testing. This module provides the creation of version 1 time
81             based UUIDs (using random multicast MAC addresses), version 3 MD5 based UUIDs,
82             version 4 random UUIDs, and version 5 SHA-1 based UUIDs.
83              
84             ATTENTION! UUID::Tiny uses Perl's C to create the basic random
85             numbers, so the created v4 UUIDs are B cryptographically strong!
86              
87             No fancy OO interface, no plethora of different UUID representation formats
88             and transformations - just string and binary. Conversion, test and time
89             functions equally accept UUIDs and UUID strings, so don't bother to convert
90             UUIDs for them!
91              
92             Continuing with 1.0x versions all constants and public functions are exported
93             by default, but this will change in the future (see below).
94              
95             UUID::Tiny deliberately uses a minimal functional interface for UUID creation
96             (and conversion/testing), because in this case OO looks like overkill to me
97             and makes the creation and use of UUIDs unnecessarily complicated.
98              
99             If you need raw performance for UUID creation, or the real MAC address in
100             version 1 UUIDs, or an OO interface, and if you can afford module compilation
101             and installation on the target system, then better look at other CPAN UUID
102             modules like L.
103              
104             This module is "fork safe", especially for random UUIDs (it works around
105             Perl's rand() problem when forking processes).
106              
107             This module is currently B "thread safe". Even though I've incorporated
108             some changes proposed by Michael G. Schwern (thanks!), Digest::MD5 and
109             Digest::SHA seem so have trouble with threads. There is a test file for
110             threads, but it is de-activated. So use at your own risk!
111              
112             =cut
113              
114              
115             =head1 DEPENDENCIES
116              
117             This module should run from Perl 5.8 up and uses mostly standard (5.8 core)
118             modules for its job. No compilation or installation required. These are the
119             modules UUID::Tiny depends on:
120              
121             Carp
122             Digest::MD5 Perl 5.8 core
123             Digest::SHA Perl 5.10 core (or Digest::SHA1, or Digest::SHA::PurePerl)
124             MIME::Base64 Perl 5.8 core
125             Time::HiRes Perl 5.8 core
126             POSIX Perl 5.8 core
127              
128             If you are using this module on a Perl prior to 5.10 and you don't have
129             Digest::SHA1 installed, you can use Digest::SHA::PurePerl instead.
130              
131             =cut
132              
133              
134             =head1 ATTENTION! NEW STANDARD INTERFACE
135              
136             After some debate I'm convinced that it is more Perlish (and far easier to
137             write) to use all-lowercase function names - without exceptions. And that it
138             is more polite to export symbols only on demand.
139              
140             While the 1.0x versions will continue to export the old, "legacy" interface on
141             default, the future standard interface is available using the C<:std> tag on
142             import from version 1.02 on:
143              
144             use UUID::Tiny ':std';
145             my $md5_uuid = create_uuid(UUID_MD5, $str);
146              
147             In preparation for future version of UUID::Tiny you have to use the
148             C<:legacy> tag if you want to stay with the version 1.0 interface:
149              
150             use UUID::Tiny ':legacy';
151             my $md5_uuid = create_UUID(UUID_V3, $str);
152              
153             =cut
154              
155 5     5   19327 use Exporter;
  5         14  
  5         936  
156             our @ISA = qw(Exporter);
157             our @EXPORT;
158             our @EXPORT_OK;
159             our %EXPORT_TAGS = (
160             std => [qw(
161             UUID_NIL
162             UUID_NS_DNS UUID_NS_URL UUID_NS_OID UUID_NS_X500
163             UUID_V1 UUID_TIME
164             UUID_V3 UUID_MD5
165             UUID_V4 UUID_RANDOM
166             UUID_V5 UUID_SHA1
167             UUID_SHA1_AVAIL
168             create_uuid create_uuid_as_string
169             is_uuid_string
170             uuid_to_string string_to_uuid
171             version_of_uuid time_of_uuid clk_seq_of_uuid
172             equal_uuids
173             )],
174             legacy => [qw(
175             UUID_NIL
176             UUID_NS_DNS UUID_NS_URL UUID_NS_OID UUID_NS_X500
177             UUID_V1
178             UUID_V3
179             UUID_V4
180             UUID_V5
181             UUID_SHA1_AVAIL
182             create_UUID create_UUID_as_string
183             is_UUID_string
184             UUID_to_string string_to_UUID
185             version_of_UUID time_of_UUID clk_seq_of_UUID
186             equal_UUIDs
187             )],
188             );
189              
190             Exporter::export_tags('legacy');
191             Exporter::export_ok_tags('std');
192              
193              
194             =head1 CONSTANTS
195              
196             =cut
197              
198             =over 4
199              
200             =item B
201              
202             This module provides the NIL UUID (shown with its string representation):
203              
204             UUID_NIL: '00000000-0000-0000-0000-000000000000'
205              
206             =cut
207              
208 5     5   73 use constant UUID_NIL => "\x00" x 16;
  5         12  
  5         422  
209              
210              
211             =item B
212              
213             This module provides the common pre-defined namespace UUIDs (shown with their
214             string representation):
215              
216             UUID_NS_DNS: '6ba7b810-9dad-11d1-80b4-00c04fd430c8'
217             UUID_NS_URL: '6ba7b811-9dad-11d1-80b4-00c04fd430c8'
218             UUID_NS_OID: '6ba7b812-9dad-11d1-80b4-00c04fd430c8'
219             UUID_NS_X500: '6ba7b814-9dad-11d1-80b4-00c04fd430c8'
220              
221             =cut
222              
223 5         267 use constant UUID_NS_DNS =>
224 5     5   28 "\x6b\xa7\xb8\x10\x9d\xad\x11\xd1\x80\xb4\x00\xc0\x4f\xd4\x30\xc8";
  5         10  
225 5         255 use constant UUID_NS_URL =>
226 5     5   43 "\x6b\xa7\xb8\x11\x9d\xad\x11\xd1\x80\xb4\x00\xc0\x4f\xd4\x30\xc8";
  5         9  
227 5         252 use constant UUID_NS_OID =>
228 5     5   27 "\x6b\xa7\xb8\x12\x9d\xad\x11\xd1\x80\xb4\x00\xc0\x4f\xd4\x30\xc8";
  5         8  
229 5         259 use constant UUID_NS_X500 =>
230 5     5   37 "\x6b\xa7\xb8\x14\x9d\xad\x11\xd1\x80\xb4\x00\xc0\x4f\xd4\x30\xc8";
  5         8  
231              
232              
233             =item B
234              
235             This module provides the UUID version numbers as constants:
236              
237             UUID_V1
238             UUID_V3
239             UUID_V4
240             UUID_V5
241              
242             With C you get additional, "speaking" constants:
243              
244             UUID_TIME
245             UUID_MD5
246             UUID_RANDOM
247             UUID_SHA1
248              
249             =cut
250              
251 5     5   26 use constant UUID_V1 => 1; use constant UUID_TIME => 1;
  5     5   7  
  5         216  
  5         24  
  5         9  
  5         215  
252 5     5   29 use constant UUID_V3 => 3; use constant UUID_MD5 => 3;
  5     5   6  
  5         220  
  5         26  
  5         11  
  5         246  
253 5     5   45 use constant UUID_V4 => 4; use constant UUID_RANDOM => 4;
  5     5   8  
  5         236  
  5         26  
  5         10  
  5         204  
254 5     5   935 use constant UUID_V5 => 5; use constant UUID_SHA1 => 5;
  5     5   17  
  5         199  
  5         25  
  5         9  
  5         578  
255              
256              
257             =item B
258              
259             my $uuid = create_UUID( UUID_SHA1_AVAIL? UUID_V5 : UUID_V3, $str );
260              
261             This function returns 1 if a module to create SHA-1 digests could be loaded, 0
262             otherwise.
263              
264             UUID::Tiny (since version 1.02) tries to load Digest::SHA, Digest::SHA1 or
265             Digest::SHA::PurePerl, but does not die if none of them is found. Instead
266             C and C die when trying to create an
267             SHA-1 based UUID without an appropriate module available.
268              
269             =cut
270              
271             sub UUID_SHA1_AVAIL {
272 1 50   1 1 6 return defined $SHA1_CALCULATOR ? 1 : 0;
273             }
274              
275             =back
276              
277             =cut
278              
279             =head1 FUNCTIONS
280              
281             All public functions are exported by default (they should not collide with
282             other functions).
283              
284             C creates standard binary UUIDs in network byte order
285             (MSB first), C creates the standard string
286             representation of UUIDs.
287              
288             All query and test functions (except C) accept both
289             representations.
290              
291             =over 4
292              
293             =cut
294              
295             =item B, B (:std)
296              
297             my $v1_mc_UUID = create_UUID();
298             my $v1_mc_UUID = create_UUID(UUID_V1);
299             my $v3_md5_UUID = create_UUID(UUID_V3, $ns_uuid, $name_or_filehandle);
300             my $v3_md5_UUID = create_UUID(UUID_V3, $name_or_filehandle);
301             my $v4_rand_UUID = create_UUID(UUID_V4);
302             my $v5_sha1_UUID = create_UUID(UUID_V5, $ns_uuid, $name_or_filehandle);
303             my $v5_sha1_UUID = create_UUID(UUID_V5, $name_or_filehandle);
304              
305             Creates a binary UUID in network byte order (MSB first). For v3 and v5 UUIDs a
306             C (normally a string), C ("classic" file handle) or C object
307             (i.e. C) can be used; files have to be opened for reading.
308              
309             I found no hint if and how UUIDs should be created from file content. It seems
310             to be undefined, but it is useful - so I would suggest to use UUID_NIL as the
311             namespace UUID, because no "real name" is used; UUID_NIL is used by default if
312             a namespace UUID is missing (only 2 arguments are used).
313              
314             =cut
315              
316             sub create_uuid {
317 5     5   5463 use bytes;
  5         52  
  5         26  
318 110027   100 110027 1 6220828 my ($v, $arg2, $arg3) = (shift || UUID_V1, shift, shift);
319 110027         145676 my $uuid = UUID_NIL;
320 110027 100       249171 my $ns_uuid = string_to_uuid(defined $arg3 ? $arg2 : UUID_NIL);
321 110027 100       264535 my $name = defined $arg3 ? $arg3 : $arg2;
322              
323 110027 100       359309 if ($v == UUID_V1) {
    100          
    100          
    50          
324 10007         21752 $uuid = _create_v1_uuid();
325             }
326             elsif ($v == UUID_V3 ) {
327 6         16 $uuid = _create_v3_uuid($ns_uuid, $name);
328             }
329             elsif ($v == UUID_V4) {
330 100006         184102 $uuid = _create_v4_uuid();
331             }
332             elsif ($v == UUID_V5) {
333 8         17 $uuid = _create_v5_uuid($ns_uuid, $name);
334             }
335             else {
336 0         0 croak __PACKAGE__ . "::create_uuid(): Invalid UUID version '$v'!";
337             }
338              
339             # Set variant 2 in UUID ...
340 110027         229029 substr $uuid, 8, 1, chr(ord(substr $uuid, 8, 1) & 0x3f | 0x80);
341              
342 110027         352493 return $uuid;
343             }
344              
345             *create_UUID = \&create_uuid;
346              
347              
348             sub _create_v1_uuid {
349 10007     10007   14005 my $uuid = '';
350              
351             # Create time and clock sequence ...
352 10007         28129 my $timestamp = Time::HiRes::time();
353 10007         23387 my $clk_seq = _get_clk_seq($timestamp);
354              
355             # hi = time mod (1000000 / 0x100000000)
356 10007         50760 my $hi = floor( $timestamp / 65536.0 / 512 * 78125 );
357 10007         22083 $timestamp -= $hi * 512.0 * 65536 / 78125;
358 10007         27520 my $low = floor( $timestamp * 10000000.0 + 0.5 );
359              
360             # MAGIC offset: 01B2-1DD2-13814000
361 10007 50       23152 if ( $low < 0xec7ec000 ) {
362 10007         16366 $low += 0x13814000;
363             }
364             else {
365 0         0 $low -= 0xec7ec000;
366 0         0 $hi++;
367             }
368              
369 10007 50       20397 if ( $hi < 0x0e4de22e ) {
370 10007         26760 $hi += 0x01b21dd2;
371             }
372             else {
373 0         0 $hi -= 0x0e4de22e; # wrap around
374             }
375              
376             # Set time in UUID ...
377 10007         34722 substr $uuid, 0, 4, pack( 'N', $low ); # set time low
378 10007         20920 substr $uuid, 4, 2, pack( 'n', $hi & 0xffff ); # set time mid
379 10007         21548 substr $uuid, 6, 2, pack( 'n', ( $hi >> 16 ) & 0x0fff ); # set time high
380              
381             # Set clock sequence in UUID ...
382 10007         15857 substr $uuid, 8, 2, pack( 'n', $clk_seq );
383              
384             # Set random node in UUID ...
385 10007         21182 substr $uuid, 10, 6, _random_node_id();
386              
387 10007         27076 return _set_uuid_version($uuid, 0x10);
388             }
389              
390             sub _create_v3_uuid {
391 6     6   10 my $ns_uuid = shift;
392 6         9 my $name = shift;
393 6         8 my $uuid = '';
394              
395             # Create digest in UUID ...
396 6         27 $MD5_CALCULATOR->reset();
397 6         16 $MD5_CALCULATOR->add($ns_uuid);
398              
399 6 100       29 if ( ref($name) =~ m/^(?:GLOB|IO::)/ ) {
    50          
    50          
400 2         36 $MD5_CALCULATOR->addfile($name);
401             }
402             elsif ( ref $name ) {
403 0         0 croak __PACKAGE__
404             . '::create_uuid(): Name for v3 UUID'
405             . ' has to be SCALAR, GLOB or IO object, not '
406             . ref($name) .'!'
407             ;
408             }
409             elsif ( defined $name ) {
410 4         18 $MD5_CALCULATOR->add($name);
411             }
412             else {
413 0         0 croak __PACKAGE__
414             . '::create_uuid(): Name for v3 UUID is not defined!';
415             }
416              
417             # Use only first 16 Bytes ...
418 6         31 $uuid = substr( $MD5_CALCULATOR->digest(), 0, 16 );
419              
420 6         17 return _set_uuid_version( $uuid, 0x30 );
421             }
422              
423             sub _create_v4_uuid {
424             # Create random value in UUID ...
425 100006     100006   130376 my $uuid = '';
426 100006         172561 for ( 1 .. 4 ) {
427 400024         701016 $uuid .= pack 'I', _rand_32bit();
428             }
429              
430 100006         227984 return _set_uuid_version($uuid, 0x40);
431             }
432              
433             sub _create_v5_uuid {
434 8     8   12 my $ns_uuid = shift;
435 8         11 my $name = shift;
436 8         15 my $uuid = '';
437              
438 8 50       34 if (!$SHA1_CALCULATOR) {
439 0         0 croak __PACKAGE__
440             . '::create_uuid(): No SHA-1 implementation available! '
441             . 'Please install Digest::SHA1, Digest::SHA or '
442             . 'Digest::SHA::PurePerl to use SHA-1 based UUIDs.'
443             ;
444             }
445              
446 8         28 $SHA1_CALCULATOR->reset();
447 8         101 $SHA1_CALCULATOR->add($ns_uuid);
448              
449 8 100       37 if ( ref($name) =~ m/^(?:GLOB|IO::)/ ) {
    50          
    50          
450 2         9 $SHA1_CALCULATOR->addfile($name);
451             } elsif ( ref $name ) {
452 0         0 croak __PACKAGE__
453             . '::create_uuid(): Name for v5 UUID'
454             . ' has to be SCALAR, GLOB or IO object, not '
455             . ref($name) .'!'
456             ;
457             } elsif ( defined $name ) {
458 6         28 $SHA1_CALCULATOR->add($name);
459             } else {
460 0         0 croak __PACKAGE__
461             . '::create_uuid(): Name for v5 UUID is not defined!';
462             }
463              
464             # Use only first 16 Bytes ...
465 8         143 $uuid = substr( $SHA1_CALCULATOR->digest(), 0, 16 );
466              
467 8         20 return _set_uuid_version($uuid, 0x50);
468             }
469              
470             sub _set_uuid_version {
471 110027     110027   164392 my $uuid = shift;
472 110027         144571 my $version = shift;
473 110027         298297 substr $uuid, 6, 1, chr( ord( substr( $uuid, 6, 1 ) ) & 0x0f | $version );
474              
475 110027         297794 return $uuid;
476             }
477              
478              
479             =item B, B (:std)
480              
481             Similar to C, but creates a UUID string.
482              
483             =cut
484              
485             sub create_uuid_as_string {
486 20     20 1 6447 return uuid_to_string(create_uuid(@_));
487             }
488              
489             *create_UUID_as_string = \&create_uuid_as_string;
490              
491              
492             =item B, B (:std)
493              
494             my $bool = is_UUID_string($str);
495              
496             =cut
497              
498             our $IS_UUID_STRING = qr/^[0-9a-f]{8}(?:-[0-9a-f]{4}){3}-[0-9a-f]{12}$/is;
499             our $IS_UUID_HEX = qr/^[0-9a-f]{32}$/is;
500             our $IS_UUID_Base64 = qr/^[+\/0-9A-Za-z]{22}(?:==)?$/s;
501              
502             sub is_uuid_string {
503 3     3 1 5 my $uuid = shift;
504 3         30 return $uuid =~ m/$IS_UUID_STRING/;
505             }
506              
507             *is_UUID_string = \&is_uuid_string;
508              
509              
510             =item B, B (:std)
511              
512             my $uuid_str = UUID_to_string($uuid);
513              
514             This function returns C<$uuid> unchanged if it is a UUID string already.
515              
516             =cut
517              
518             sub uuid_to_string {
519 35     35 1 62 my $uuid = shift;
520 5     5   6664 use bytes;
  5         10  
  5         28  
521 35 100       250 return $uuid
522             if $uuid =~ m/$IS_UUID_STRING/;
523 34 50       85 croak __PACKAGE__ . "::uuid_to_string(): Invalid UUID!"
524             unless length $uuid == 16;
525 170         627 return join '-',
526 170         464 map { unpack 'H*', $_ }
527 34         70 map { substr $uuid, 0, $_, '' }
528             ( 4, 2, 2, 2, 6 );
529             }
530              
531             *UUID_to_string = \&uuid_to_string;
532              
533              
534             =item B, B (:std)
535              
536             my $uuid = string_to_UUID($uuid_str);
537              
538             This function returns C<$uuid_str> unchanged if it is a UUID already.
539              
540             In addition to the standard UUID string representation and its URN forms
541             (starting with C or C), this function accepts 32 digit hex
542             strings, variants with different positions of C<-> and Base64 encoded UUIDs.
543              
544             Throws an exception if string can't be interpreted as a UUID.
545              
546             If you want to make sure to have a "pure" standard UUID representation, check
547             with C!
548              
549             =cut
550              
551             sub string_to_uuid {
552 190082     190082 1 251115 my $uuid = shift;
553              
554 5     5   787 use bytes;
  5         8  
  5         30  
555 190082 100       650253 return $uuid if length $uuid == 16;
556 27 100       257 return decode_base64($uuid) if ($uuid =~ m/$IS_UUID_Base64/);
557 26         49 my $str = $uuid;
558 26         116 $uuid =~ s/^(?:urn:)?(?:uuid:)?//io;
559 26         62 $uuid =~ tr/-//d;
560 26 100       322 return pack 'H*', $uuid if $uuid =~ m/$IS_UUID_HEX/;
561 1         227 croak __PACKAGE__ . "::string_to_uuid(): '$str' is no UUID string!";
562             }
563              
564             *string_to_UUID = \&string_to_uuid;
565              
566              
567             =item B, B (:std)
568              
569             my $version = version_of_UUID($uuid);
570              
571             This function accepts binary and string UUIDs.
572              
573             =cut
574              
575             sub version_of_uuid {
576 40017     40017 1 57276 my $uuid = shift;
577 5     5   1034 use bytes;
  5         10  
  5         19  
578 40017         74055 $uuid = string_to_uuid($uuid);
579 40017         145168 return (ord(substr($uuid, 6, 1)) & 0xf0) >> 4;
580             }
581              
582             *version_of_UUID = \&version_of_uuid;
583              
584              
585             =item B, B (:std)
586              
587             my $uuid_time = time_of_UUID($uuid);
588              
589             This function accepts UUIDs and UUID strings. Returns the time as a floating
590             point value, so use C to get a C compatible value.
591              
592             Returns C if the UUID is not version 1.
593              
594             =cut
595              
596             sub time_of_uuid {
597 20005     20005 1 110356 my $uuid = shift;
598 5     5   580 use bytes;
  5         10  
  5         22  
599 20005         39313 $uuid = string_to_uuid($uuid);
600 20005 100       37441 return unless version_of_uuid($uuid) == 1;
601            
602 20004         51636 my $low = unpack 'N', substr($uuid, 0, 4);
603 20004         34900 my $mid = unpack 'n', substr($uuid, 4, 2);
604 20004         49142 my $high = unpack('n', substr($uuid, 6, 2)) & 0x0fff;
605              
606 20004         40215 my $hi = $mid | $high << 16;
607              
608             # MAGIC offset: 01B2-1DD2-13814000
609 20004 50       39394 if ($low >= 0x13814000) {
610 20004         26314 $low -= 0x13814000;
611             }
612             else {
613 0         0 $low += 0xec7ec000;
614 0         0 $hi --;
615             }
616              
617 20004 50       37203 if ($hi >= 0x01b21dd2) {
618 20004         25925 $hi -= 0x01b21dd2;
619             }
620             else {
621 0         0 $hi += 0x0e4de22e; # wrap around
622             }
623              
624 20004         25484 $low /= 10000000.0;
625 20004         24554 $hi /= 78125.0 / 512 / 65536; # / 1000000 * 0x10000000
626              
627 20004         66949 return $hi + $low;
628             }
629              
630             *time_of_UUID = \&time_of_uuid;
631              
632              
633             =item B, B (:std)
634              
635             my $uuid_clk_seq = clk_seq_of_UUID($uuid);
636              
637             This function accepts UUIDs and UUID strings. Returns the clock sequence for a
638             version 1 UUID. Returns C if UUID is not version 1.
639              
640             =cut
641              
642             sub clk_seq_of_uuid {
643 5     5   1031 use bytes;
  5         9  
  5         18  
644 20006     20006 1 52756 my $uuid = shift;
645 20006         39914 $uuid = string_to_uuid($uuid);
646 20006 100       36316 return unless version_of_uuid($uuid) == 1;
647              
648 20005         42025 my $r = unpack 'n', substr($uuid, 8, 2);
649 20005         31041 my $v = $r >> 13;
650 20005 50       51664 my $w = ($v >= 6) ? 3 # 11x
    50          
651             : ($v >= 4) ? 2 # 10-
652             : 1 # 0--
653             ;
654 20005         23911 $w = 16 - $w;
655              
656 20005         59135 return $r & ((1 << $w) - 1);
657             }
658              
659             *clk_seq_of_UUID = \&clk_seq_of_uuid;
660              
661              
662             =item B, B (:std)
663              
664             my $bool = equal_UUIDs($uuid1, $uuid2);
665              
666             Returns true if the provided UUIDs are equal. Accepts UUIDs and UUID strings
667             (can be mixed).
668              
669             =cut
670              
671             sub equal_uuids {
672 9     9 1 77 my ($u1, $u2) = @_;
673 9 50 33     89 return unless defined $u1 && defined $u2;
674 9         40 return string_to_uuid($u1) eq string_to_uuid($u2);
675             }
676              
677             *equal_UUIDs = \&equal_uuids;
678              
679              
680             #
681             # Private functions ...
682             #
683             my $Last_Pid;
684 5     5   6252 my $Clk_Seq :shared;
  5         7706  
  5         2561  
685              
686             # There is a problem with $Clk_Seq and rand() on forking a process using
687             # UUID::Tiny, because the forked process would use the same basic $Clk_Seq and
688             # the same seed (!) for rand(). $Clk_Seq is UUID::Tiny's problem, but with
689             # rand() it is Perl's bad behavior. So _init_globals() has to be called every
690             # time before using $Clk_Seq or rand() ...
691              
692             sub _init_globals {
693 430045     430045   472902 lock $Clk_Seq;
694              
695 430045 100 100     2120189 if (!defined $Last_Pid || $Last_Pid != $$) {
696 5         17 $Last_Pid = $$;
697             # $Clk_Seq = _generate_clk_seq();
698             # There's a slight chance to get the same value as $Clk_Seq ...
699 5         27 for (my $i = 0; $i <= 5; $i++) {
700 5         26 my $new_clk_seq = _generate_clk_seq();
701 5 50 66     74 if (!defined($Clk_Seq) || $new_clk_seq != $Clk_Seq) {
702 5         9 $Clk_Seq = $new_clk_seq;
703 5         11 last;
704             }
705 0 0       0 if ($i == 5) {
706 0         0 croak __PACKAGE__
707             . "::_init_globals(): Can't get unique clk_seq!";
708             }
709             }
710 5         255 srand();
711             }
712              
713 430045         639956 return;
714             }
715              
716             my $Last_Timestamp :shared;
717              
718             sub _get_clk_seq {
719 10007     10007   15609 my $ts = shift;
720 10007         17891 _init_globals();
721              
722 10007         11456 lock $Last_Timestamp;
723 10007         13723 lock $Clk_Seq;
724              
725             #if (!defined $Last_Timestamp || $ts <= $Last_Timestamp) {
726 10007 50 66     53600 if (defined $Last_Timestamp && $ts <= $Last_Timestamp) {
727             #$Clk_Seq = ($Clk_Seq + 1) % 65536;
728             # The old variant used modulo, but this looks unnecessary,
729             # because we should only use the significant part of the
730             # number, and that also lets the counter circle around:
731 0         0 $Clk_Seq = ($Clk_Seq + 1) & 0x3fff;
732             }
733 10007         13497 $Last_Timestamp = $ts;
734              
735             #return $Clk_Seq & 0x03ff; # no longer needed - and it was wrong too!
736 10007         33369 return $Clk_Seq;
737             }
738              
739             sub _generate_clk_seq {
740 5     5   10 my $self = shift;
741             # _init_globals();
742              
743 5         9 my @data;
744 5         29 push @data, '' . $$;
745 5         127 push @data, ':' . Time::HiRes::time();
746              
747             # 16 bit digest
748             # We should return only the significant part of the number!
749 5         44 return (unpack 'n', _digest_as_octets(2, @data)) & 0x3fff;
750             }
751              
752             sub _random_node_id {
753 10007     10007   13927 my $self = shift;
754              
755 10007         18568 my $r1 = _rand_32bit();
756 10007         23534 my $r2 = _rand_32bit();
757              
758 10007         18236 my $hi = ($r1 >> 8) ^ ($r2 & 0xff);
759 10007         13554 my $lo = ($r2 >> 8) ^ ($r1 & 0xff);
760              
761 10007         20959 $hi |= 0x80;
762              
763 10007         24370 my $id = substr pack('V', $hi), 0, 3;
764 10007         19056 $id .= substr pack('V', $lo), 0, 3;
765              
766 10007         36174 return $id;
767             }
768              
769             sub _rand_32bit {
770 420038     420038   665303 _init_globals();
771 420038         673151 my $v1 = int(rand(65536)) % 65536;
772 420038         567533 my $v2 = int(rand(65536)) % 65536;
773 420038         1321493 return ($v1 << 16) | $v2;
774             }
775              
776             sub _fold_into_octets {
777 5     5   44 use bytes;
  5         23  
  5         490  
778 5     5   14 my ($num_octets, $s) = @_;
779              
780 5         22 my $x = "\x0" x $num_octets;
781              
782 5         21 while (length $s > 0) {
783 40         51 my $n = '';
784 40         93 while (length $x > 0) {
785 80         155 my $c = ord(substr $x, -1, 1, '') ^ ord(substr $s, -1, 1, '');
786 80         123 $n = chr($c) . $n;
787 80 100       268 last if length $s <= 0;
788             }
789 40         63 $n = $x . $n;
790              
791 40         108 $x = $n;
792             }
793              
794 5         98 return $x;
795             }
796              
797             sub _digest_as_octets {
798 5     5   10 my $num_octets = shift;
799              
800 5         58 $MD5_CALCULATOR->reset();
801 5         55 $MD5_CALCULATOR->add($_) for @_;
802              
803 5         49 return _fold_into_octets($num_octets, $MD5_CALCULATOR->digest);
804             }
805              
806              
807             =back
808              
809             =cut
810              
811              
812             =head1 DISCUSSION
813              
814             =over
815              
816             =item B
817              
818             The random multi-cast MAC address gives privacy, and getting the real MAC
819             address with Perl is really dirty (and slow);
820              
821             =item B
822              
823             Using SHA-1 reduces the probability of collisions and provides a better
824             "randomness" of the resulting UUID compared to MD5. Version 5 is recommended
825             in RFC 4122 if backward compatibility is not an issue.
826              
827             Using MD5 (version 3) has a better performance. This could be important with
828             creating UUIDs from file content rather than names.
829              
830             =back
831              
832              
833             =head1 UUID DEFINITION
834              
835             See RFC 4122 (L) for technical details on
836             UUIDs. Wikipedia gives a more palatable description at
837             L.
838              
839              
840             =head1 AUTHOR
841              
842             Christian Augustin, C<< >>
843              
844              
845             =head1 CONTRIBUTORS
846              
847             Some of this code is based on UUID::Generator by ITO Nobuaki
848             Ebanb@cpan.orgE. But that module is announced to be marked as
849             "deprecated" in the future and it is much too complicated for my liking.
850              
851             So I decided to reduce it to the necessary parts and to re-implement those
852             parts with a functional interface ...
853              
854             Jesse Vincent, C<< >>, improved version 1.02 with
855             his tips and a heavy refactoring.
856              
857             Michael G. Schwern provided a patch for better thread support (as far as
858             UUID::Tiny can be improved itself) that is incorporated in version 1.04.
859              
860              
861              
862             =head1 BUGS
863              
864             Please report any bugs or feature requests to C,
865             or through the web interface at
866             L.
867             I will be notified, and then you'll automatically be notified of progress on
868             your bug as I make changes.
869              
870              
871             =head1 SUPPORT
872              
873             You can find documentation for this module with the perldoc command.
874              
875             perldoc UUID::Tiny
876              
877             You can also look for information at:
878              
879             =over 4
880              
881             =item * RT: CPAN's request tracker
882              
883             L
884              
885             =item * AnnoCPAN: Annotated CPAN documentation
886              
887             L
888              
889             =item * CPAN Ratings
890              
891             L
892              
893             =item * Search CPAN
894              
895             L
896              
897             =back
898              
899              
900             =head1 ACKNOWLEDGEMENTS
901              
902             Kudos to ITO Nobuaki Ebanb@cpan.orgE for his UUID::Generator::PurePerl
903             module! My work is based on his code, and without it I would've been lost with
904             all those incomprehensible RFC texts and C codes ...
905              
906             Thanks to Jesse Vincent (C<< >>) for his feedback, tips and refactoring!
907              
908              
909             =head1 COPYRIGHT & LICENSE
910              
911             Copyright 2009, 2010, 2013 Christian Augustin, all rights reserved.
912              
913             This program is free software; you can redistribute it and/or modify it
914             under the same terms as Perl itself.
915              
916             ITO Nobuaki has very graciously given me permission to take over copyright for
917             the portions of code that are copied from or resemble his work (see
918             rt.cpan.org #53642 L).
919              
920             =cut
921              
922             1; # End of UUID::Tiny