UUID-Tiny-1.04/000755 000766 000120 00000000000 12205426227 014257 5ustar00caugustinadmin000000 000000 UUID-Tiny-1.04/Changes000644 000766 000024 00000004431 12205425665 015577 0ustar00caugustinstaff000000 000000 Revision history for UUID-Tiny 1.04 2013-08-22, caugustin.de Fixed typos from bug report #87187. Rejected bug report #83073 (UUID::Tiny correctly sets the variant). Thread-tests still not running (Mac OS X 10.8.x and other machines). Thread-tests removed, bug report #57188 deferred. POD changed to better reflect the new standard interface. Fixed a bug in Makefile.PL reported by Matt Koscica. 1.03_01 2010-05-04, caugustin.de Thread-patches from Michael C. Schwern applied. Test not running on Mac OS X 10.6.3 ... 1.03 2010-01-31, caugustin.de Once again clk_seq uniqueness and fixing some small bugs with _get_clk_seq() (due to failed CPAN Tester's ID 6750882). Changed COPYRIGHT due to rt.cpan.org Bug #53642. License should now be shown in CPAN. 1.0202 2010-01-12, caugustin.de Fixed a small bug (calling _init_globals without need). Introduced a test on clk_seq uniqueness (due to failed CPAN Tester's ID 6357718). We'll see ... 1.0201 2010-01-12, caugustin.de Bug #50519 fixed: Test number 03 fails on Windows (just skipping this test on MSWin32). 1.02 2009-08-21, caugustin.de Cosmetic changes to documentation. Changed comments on Perl versions. Changed POD example code (there were some "-" in the names). "my" instead of "our" seed (no need to be a public global var). Introducing UUID_TIME etc. as alternatives to UUID_V1 etc. New standard interface added ("use UUID::Tiny ':std';"). Tries to load alternative SHA-1 modules, UUID_SHA1_AVAIL added. Refactoring by Jesse Vincent. Testing the legacy interface. New _init_globals() to make UUID::Tiny "fork-safe". Test cases to prove "fork-safety" of v1 and v4 UUIDs. Locking for thread-safety of MD5_CALCULATOR and SHA1_CALCULATOR. 1.01 2009-07-12, caugustin.de Synopsis corrected after CPAN upload of version 1.00. Explicit use of Digest::MD5 and Digest::SHA1 after related failures on CPAN Testers (let's see if it will help ...). Modified clk_seq algorithm (simplified, independent of node_id). 1.00 2009-06-21, caugustin.de First, feature-complete and tested version. UUID-Tiny-1.04/lib/000755 000766 000120 00000000000 12205426227 015025 5ustar00caugustinadmin000000 000000 UUID-Tiny-1.04/Makefile.PL000644 000766 000024 00000001455 12204436530 016251 0ustar00caugustinstaff000000 000000 use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'UUID::Tiny', AUTHOR => 'Christian Augustin ', VERSION_FROM => 'lib/UUID/Tiny.pm', ABSTRACT_FROM => 'lib/UUID/Tiny.pm', ($ExtUtils::MakeMaker::VERSION >= 6.3002 ? ('LICENSE'=> 'perl') : ()), PL_FILES => {}, PREREQ_PM => { 'Carp' => 0, 'Digest::MD5' => 0, 'MIME::Base64' => 0, 'Time::HiRes' => 0, 'POSIX' => 0, 'Test::More' => 0, 'IO::File' => 0, ($] < 5.010000 ? ( 'Digest::SHA1' => 0) :()), # only require Digest::SHA1 on 5.8 }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'UUID-Tiny-*' }, ); UUID-Tiny-1.04/MANIFEST000644 000766 000120 00000000422 12205426227 015406 0ustar00caugustinadmin000000 000000 Changes lib/UUID/Tiny.pm Makefile.PL MANIFEST This list of files README t/00-load.t t/01-UUID-std.t t/02-UUID-legacy.t t/03-UUID-fork.t t/boilerplate.t t/data/test.jpg t/pod-coverage.t t/pod.t META.yml Module meta-data (added by MakeMaker) UUID-Tiny-1.04/META.yml000644 000766 000120 00000001267 12205426227 015536 0ustar00caugustinadmin000000 000000 --- #YAML:1.0 name: UUID-Tiny version: 1.04 abstract: Pure Perl UUID Support With Functional Interface author: - Christian Augustin license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: Carp: 0 Digest::MD5: 0 IO::File: 0 MIME::Base64: 0 POSIX: 0 Test::More: 0 Time::HiRes: 0 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.56 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 UUID-Tiny-1.04/README000644 000766 000024 00000003232 12205425614 015154 0ustar00caugustinstaff000000 000000 UUID-Tiny Version 1.04 This is a Pure Perl module for the creation of UUIDs: - version 1 time based (with random multicast MAC address) - version 3 MD5 based - version 4 random number based - version 5 SHA-1 based The module uses a functional interface and creates binary (network byte order) or string representations. Version 3 and 5 UUIDs can be created from file content instead of "names" (strings). Be aware that, because of being a Pure Perl implementation, there are performance limits and the randomness of multicast MAC addresses and the version 4 numbers are not perfect. If you can afford module compilation and installation, you should look at Data::UUID instead! INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install DEPENDENCIES Should run from Perl 5.8 up and uses this modules (mostly Perl 5.8 core): Carp Digest::MD5 Digest::SHA1 (or Digest::SHA or Digest::SHA::PurePerl) MIME::Base64 Time::HiRes POSIX SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc UUID::Tiny You can also look for information at: RT, CPAN's request tracker http://rt.cpan.org/NoAuth/Bugs.html?Dist=UUID-Tiny AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/UUID-Tiny CPAN Ratings http://cpanratings.perl.org/d/UUID-Tiny Search CPAN http://search.cpan.org/dist/UUID-Tiny/ COPYRIGHT AND LICENCE Copyright (C) 2009, 2010, 2013 Christian Augustin This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. UUID-Tiny-1.04/t/000755 000766 000120 00000000000 12205426227 014522 5ustar00caugustinadmin000000 000000 UUID-Tiny-1.04/t/00-load.t000644 000766 000024 00000000214 11217200775 016056 0ustar00caugustinstaff000000 000000 #!perl -T use Test::More tests => 1; BEGIN { use_ok( 'UUID::Tiny' ); } diag( "Testing UUID::Tiny $UUID::Tiny::VERSION, Perl $], $^X" ); UUID-Tiny-1.04/t/01-UUID-std.t000644 000766 000024 00000016165 12204420716 016506 0ustar00caugustinstaff000000 000000 #!perl -T use strict; use warnings; use Test::More 'no_plan'; use Carp; use IO::File; use MIME::Base64; use UUID::Tiny qw(:std); # # Pre-defined UUIDs ... ok( equal_uuids(UUID_NIL, '00000000-0000-0000-0000-000000000000'), 'NIL' ); ok( equal_uuids(UUID_NS_DNS, '6ba7b810-9dad-11d1-80b4-00c04fd430c8'), 'DNS' ); ok( equal_uuids(UUID_NS_URL, '6ba7b811-9dad-11d1-80b4-00c04fd430c8'), 'URL' ); ok( equal_uuids(UUID_NS_OID, '6ba7b812-9dad-11d1-80b4-00c04fd430c8'), 'OID' ); ok( equal_uuids(UUID_NS_X500, '6ba7b814-9dad-11d1-80b4-00c04fd430c8'), 'X500' ); # # is_uuid_string() ... # ok( is_uuid_string(uuid_to_string(UUID_NIL)), 'is_uuid_string($UUID_NIL)' ); ok( is_uuid_string(uuid_to_string(UUID_NS_URL)), 'is_uuid_string() with URL UUID' ); ok( !is_uuid_string('6ba7b810-9dad-11d1-80b4-00c04fd430'), 'is_uuid_string() with truncated UUID-string' ); # # uuid_to_string() and string_to_uuid() ... # is( uuid_to_string(UUID_NIL), '00000000-0000-0000-0000-000000000000', 'uuid_to_string(UUID_NIL)', ); is( uuid_to_string(UUID_NS_DNS), '6ba7b810-9dad-11d1-80b4-00c04fd430c8', 'uuid_to_string(UUID_NS_DNS)', ); is( uuid_to_string(uuid_to_string(UUID_NS_URL)), uuid_to_string(UUID_NS_URL), 'uuid_to_string with UUID string returns UUID string' ); is( string_to_uuid(UUID_NS_OID), UUID_NS_OID, 'string_to_uuid of UUID return UUID' ); my $hex_uuid = uuid_to_string(UUID_NS_URL); $hex_uuid =~ tr/-//; is( string_to_uuid($hex_uuid), UUID_NS_URL, 'string_to_uuid of hex string' ); my $base64_uuid = encode_base64(UUID_NS_URL); is( string_to_uuid($base64_uuid), UUID_NS_URL, 'string_to_uuid of Base64 string' ); is( string_to_uuid( 'urn:uuid:' . uuid_to_string(UUID_NS_DNS) ), UUID_NS_DNS, 'string_to_uuid with URN string representation' ); is( string_to_uuid( 'uuid:' . uuid_to_string(UUID_NS_DNS) ), UUID_NS_DNS, 'string_to_uuid with shortened URN string representation' ); is( string_to_uuid( 'URN:UUID:' . uc(uuid_to_string(UUID_NS_DNS)) ), UUID_NS_DNS, 'string_to_uuid with all-uppercase URN string representation' ); eval{ string_to_uuid( 'This is nonsense!' ) }; like( $@, qr/is no UUID string/, 'string_to_uuid with invalid string' ); # # Create v3 (MD5) UUIDs ... # is( create_uuid_as_string( UUID_MD5, UUID_NS_DNS, 'python.org' ), '6fa459ea-ee8a-3ca4-894e-db77e160355e', 'v3 UUID with DNS und python.org' ); is( create_uuid_as_string( UUID_V3, UUID_NS_DNS, 'www.doughellmann.com' ), 'bcd02e22-68f0-3046-a512-327cca9def8f', 'v3 UUID test with www.doughellmann.com and DNS Namespace UUID' ); my $test_data = do { local $/; open my $fh, '<', 't/data/test.jpg' or croak "Open failed!"; <$fh>; }; my $fh; open $fh, '<', 't/data/test.jpg' or croak "Open failed!"; is( create_uuid_as_string( UUID_MD5, $fh ), create_uuid_as_string( UUID_V3, $test_data ), 'V3 UUID from GLOB' ); undef $fh; $fh = new IO::File 't/data/test.jpg' or croak 'IO::File failed.'; is( create_uuid_as_string( UUID_MD5, $fh ), create_uuid_as_string( UUID_V3, $test_data ), 'V3 UUID from IO::File' ); undef $fh; # # Create v5 UUIDs ... # if (!UUID_SHA1_AVAIL) { diag('No SHA1 available, skipping UUID_SHA1 tests ...'); } else { is( create_uuid_as_string( UUID_SHA1, UUID_NS_DNS, 'python.org' ), '886313e1-3b8a-5372-9b90-0c9aee199e5d', 'v5 UUID with DNS und python.org' ); is( create_uuid_as_string( UUID_V5, UUID_NS_DNS, 'www.doughellmann.com' ), 'e3329b12-30b7-57c4-8117-c2cd34a87ce9', 'v5 UUID test with www.doughellmann.com and DNS Namespace UUID' ); open $fh, '<', 't/data/test.jpg' or croak "Open failed!"; is( create_uuid_as_string( UUID_SHA1, $fh ), create_uuid_as_string( UUID_V5, $test_data ), 'V5 UUID from GLOB' ); undef $fh; $fh = new IO::File 't/data/test.jpg' or croak 'IO::File failed.'; is( create_uuid_as_string( UUID_SHA1, $fh ), create_uuid_as_string( UUID_V5, $test_data ), 'V5 UUID from IO::File' ); undef $fh; is( create_uuid(UUID_SHA1, 'Ein Test-String.'), create_uuid(UUID_V5, UUID_NIL, 'Ein Test-String.'), 'create_uuid without NS UUID' ); } # # is_v1_uuid() and is_v5_uuid() ... # ok( version_of_uuid(UUID_NS_URL) == 1, 'is_v1_uuid with UUID' ); ok( version_of_uuid(string_to_uuid(UUID_NS_URL)) == 1, 'is_v1_uuid with UUID string' ); ok( version_of_uuid( string_to_uuid('e3329b12-30b7-57c4-8117-c2cd34a87ce9')) == 5, 'is_v5_uuid with UUID' ); ok( version_of_uuid('e3329b12-30b7-57c4-8117-c2cd34a87ce9') == 5, 'is_v5_uuid with UUID string' ); # # Generate v1mc UUIDs ... # my $now = time(); my $v1_uuid = create_uuid(); #diag uuid_to_string($v1_uuid); ok( version_of_uuid($v1_uuid) == 1, 'create_uuid creates v1 UUID' ); # Check time_of_uuid() ... my $uuid_time = int(time_of_uuid($v1_uuid)); ok( ($uuid_time == $now) || ($uuid_time == $now + 1), 'check time of UUID' ); is( time_of_uuid(UUID_NIL), undef, 'time_of_uuid($UUID_NIL) is undef' ); is( time_of_uuid($v1_uuid), time_of_uuid(uuid_to_string($v1_uuid)), 'time_of_uuid with UUID and UUID string' ); # Check clk_seq_of_uuid() ... ok( defined clk_seq_of_uuid($v1_uuid), 'clk_seq_of_uuid works as expected' ); ok( !defined clk_seq_of_uuid(UUID_NIL), 'clk_seq_of_uuid of UUID NIL undef'); is( clk_seq_of_uuid($v1_uuid), clk_seq_of_uuid(uuid_to_string($v1_uuid)), 'clk_seq_of_uuid with UUID and UUID string' ); # Check equal_uuids() ... ok( equal_uuids($v1_uuid, uuid_to_string($v1_uuid)), 'equal_uuids()' ); ok( !equal_uuids(uuid_to_string($v1_uuid), UUID_NS_URL), '!equal_uuids()' ); # Check if time advances as expected ... sleep 1; ok( $now < time_of_uuid(create_uuid()), 'check if time advances ...'); # Check for uniqueness of consecutive UUIDs ... my %uuid; my $prev_uuid; for (my $i = 0; $i < 10000; $i++) { my $act_uuid = create_uuid(); if (!exists $uuid{$act_uuid}) { $uuid{$act_uuid} = 1; if (defined $prev_uuid) { ok( ( (time_of_uuid($prev_uuid) < time_of_uuid($act_uuid)) && (clk_seq_of_uuid($prev_uuid) == clk_seq_of_uuid($act_uuid)) ) || ( (time_of_uuid($prev_uuid) >= time_of_uuid($act_uuid)) && (clk_seq_of_uuid($prev_uuid) != clk_seq_of_uuid($act_uuid)) ), 'time advances or clk_seq is different' ); } $prev_uuid = $act_uuid; } else { fail('Consecutive v1 UUIDs are not unique!'); } } # # Generate v4 UUIDs ... # my $v4_uuid = create_uuid(UUID_RANDOM); #diag uuid_to_string($v4_uuid); ok( version_of_uuid($v4_uuid) == 4, 'create_uuid creates v4 UUID' ); # Check for uniqueness of random UUIDs ... my $not_unique = 0; for (my $i = 0; $i < 100000; $i++) { my $act_uuid = create_uuid(UUID_V4); if (!exists $uuid{$act_uuid}) { $uuid{$act_uuid} = 1; } else { $not_unique = 1; last; } } ok( !$not_unique, '100.000 V4 UUIDs are unique!' ); UUID-Tiny-1.04/t/02-UUID-legacy.t000644 000766 000024 00000002047 11243014571 017153 0ustar00caugustinstaff000000 000000 #!perl -T use strict; use warnings; use Test::More 'no_plan'; use Carp; use IO::File; use MIME::Base64; use UUID::Tiny; # As of 1.02, tests only the existance of the old "legacy" interface ... my @legacy = qw( UUID_NIL UUID_NS_DNS UUID_NS_URL UUID_NS_OID UUID_NS_X500 UUID_V1 UUID_V3 UUID_V4 UUID_V5 UUID_SHA1_AVAIL create_UUID create_UUID_as_string is_UUID_string UUID_to_string string_to_UUID version_of_UUID time_of_UUID clk_seq_of_UUID equal_UUIDs ); my @not_legacy = qw( UUID_TIME UUID_MD5 UUID_RANDOM UUID_SHA1 create_uuid create_uuid_as_string is_uuid_string uuid_to_string string_to_uuid version_of_uuid time_of_uuid clk_seq_of_uuid equal_uuids ); no warnings; foreach my $legacy_symbol (@legacy) { ok( exists $main::{$legacy_symbol}, "$legacy_symbol available" ); } foreach my $not_legacy_symbol (@not_legacy) { ok( !exists $main::{$not_legacy_symbol}, "$not_legacy_symbol unavailable" ); } my $test = create_UUID(UUID_V1); $test = create_UUID(UUID_V4); UUID-Tiny-1.04/t/03-UUID-fork.t000644 000766 000024 00000003723 11331073674 016662 0ustar00caugustinstaff000000 000000 #!perl -T use strict; use warnings; use Test::More; use Carp; use UUID::Tiny qw(:std); if ($^O eq 'MSWin32') { plan skip_all => 'Pipe-open not supported on MSWin32'; } else { plan tests => 6 } my %uuid; my $first_time_uuid = create_uuid_as_string(UUID_TIME); my $first_rand_uuid = create_uuid_as_string(UUID_RANDOM); use IO::Handle; if (my $pid = open my $child, "-|") { my $child_data; # Check uniqueness of time based UUIDs ... chomp($child_data = <$child>); my $time_uuid = create_uuid_as_string(UUID_TIME); ok( !equal_uuids($first_time_uuid, $time_uuid), 'First time based UUID differs from parent one.' ); ok( !equal_uuids($child_data, $time_uuid), 'Time based UUIDs of parent and child differ.' ); # Check integrity of parent clock sequence ... ok( ( time_of_uuid($first_time_uuid) < time_of_uuid($time_uuid) && clk_seq_of_uuid($first_time_uuid) == clk_seq_of_uuid($time_uuid) ) || ( clk_seq_of_uuid($first_time_uuid) != clk_seq_of_uuid($time_uuid) ), 'Integrity of parent clock sequence OK.' ); # Check uniqueness of clock sequence ... isnt( clk_seq_of_uuid($child_data), clk_seq_of_uuid($time_uuid), 'Clock sequence of child differs.' ); # Check uniqueness of random UUIDs ... chomp($child_data = <$child>); my $random_uuid = create_uuid_as_string(UUID_RANDOM); isnt( $first_rand_uuid, $random_uuid, 'Parent random UUIDs differ.' ); isnt( $child_data, $random_uuid, 'Child and parent random UUIDs differ.' ); close $child; } else { croak "Error on fork(): $!" unless defined $pid; STDOUT->autoflush(1); # Generate time based UUID for comparison ... print STDOUT create_uuid_as_string(UUID_TIME), "\n"; # Generate random UUID for comparison ... print STDOUT create_uuid_as_string(UUID_RANDOM), "\n"; exit; } UUID-Tiny-1.04/t/boilerplate.t000644 000766 000024 00000002324 11217505007 017224 0ustar00caugustinstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 3; sub not_in_file_ok { my ($filename, %regex) = @_; open( my $fh, '<', $filename ) or die "couldn't open $filename for reading: $!"; my %violated; while (my $line = <$fh>) { while (my ($desc, $regex) = each %regex) { if ($line =~ $regex) { push @{$violated{$desc}||=[]}, $.; } } } if (%violated) { fail("$filename contains boilerplate text"); diag "$_ appears on lines @{$violated{$_}}" for keys %violated; } else { pass("$filename contains no boilerplate text"); } } sub module_boilerplate_ok { my ($module) = @_; not_in_file_ok($module => 'the great new $MODULENAME' => qr/ - The great new /, 'boilerplate description' => qr/Quick summary of what the module/, 'stub function definition' => qr/function[12]/, ); } not_in_file_ok(README => "The README is used..." => qr/The README is used/, "'version information here'" => qr/to provide version information/, ); not_in_file_ok(Changes => "placeholder date/time" => qr(Date/time) ); module_boilerplate_ok('lib/UUID/Tiny.pm'); UUID-Tiny-1.04/t/data/000755 000766 000120 00000000000 12205426227 015433 5ustar00caugustinadmin000000 000000 UUID-Tiny-1.04/t/pod-coverage.t000644 000766 000024 00000001047 11217200775 017302 0ustar00caugustinstaff000000 000000 use strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, # but older versions don't recognize some common documentation styles my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; all_pod_coverage_ok(); UUID-Tiny-1.04/t/pod.t000644 000766 000024 00000000350 11217200775 015505 0ustar00caugustinstaff000000 000000 #!perl -T use strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok(); UUID-Tiny-1.04/t/data/test.jpg000644 000766 000024 00000001250 11242363702 017126 0ustar00caugustinstaff000000 000000 JFIFHHC  !"$"$ /!AQ1a"23BRbq#?NmsZWV cH2@>lGio 뫮M1Ji@-x6TqcQ!#b-9Em/x4H# HywvĻBs) i^K[V>oZ qHUYֽX H[Cv_!;R3rC)ο^y\vnCNN8\H *9IY2Ym-:ߤ3K0뺖QOUUID-Tiny-1.04/lib/UUID/000755 000766 000120 00000000000 12205426227 015573 5ustar00caugustinadmin000000 000000 UUID-Tiny-1.04/lib/UUID/Tiny.pm000644 000766 000024 00000060134 12204440543 017072 0ustar00caugustinstaff000000 000000 package UUID::Tiny; use 5.008; use warnings; use strict; use Carp; use Digest::MD5; use MIME::Base64; use Time::HiRes; use POSIX; my $SHA1_CALCULATOR = undef; { # Check for availability of SHA-1 ... local $@; # don't leak an error condition eval { require Digest::SHA; $SHA1_CALCULATOR = Digest::SHA->new(1) } || eval { require Digest::SHA1; $SHA1_CALCULATOR = Digest::SHA1->new() } || eval { require Digest::SHA::PurePerl; $SHA1_CALCULATOR = Digest::SHA::PurePerl->new(1) }; }; my $MD5_CALCULATOR = Digest::MD5->new(); # ToDo: # - Check and report for undefined UUIDs with all UUID manipulating functions! # - Better error propagation for better debugging. =head1 NAME UUID::Tiny - Pure Perl UUID Support With Functional Interface =head1 VERSION Version 1.04 =cut our $VERSION = '1.04'; =head1 SYNOPSIS Create version 1, 3, 4 and 5 UUIDs: use UUID::Tiny ':std'; my $v1_mc_UUID = create_uuid(); my $v1_mc_UUID_2 = create_uuid(UUID_V1); my $v1_mc_UUID_3 = create_uuid(UUID_TIME); my $v3_md5_UUID = create_uuid(UUID_V3, $str); my $v3_md5_UUID_2 = create_uuid(UUID_MD5, UUID_NS_DNS, 'caugustin.de'); my $v4_rand_UUID = create_uuid(UUID_V4); my $v4_rand_UUID_2 = create_uuid(UUID_RANDOM); my $v5_sha1_UUID = create_uuid(UUID_V5, $str); my $v5_with_NS_UUID = create_uuid(UUID_SHA1, UUID_NS_DNS, 'caugustin.de'); my $v1_mc_UUID_string = create_uuid_as_string(UUID_V1); my $v3_md5_UUID_string = uuid_to_string($v3_md5_UUID); if ( version_of_uuid($v1_mc_UUID) == 1 ) { ... }; if ( version_of_uuid($v5_sha1_UUID) == 5 ) { ... }; if ( is_uuid_string($v1_mc_UUID_string) ) { ... }; if ( equal_uuids($uuid1, $uuid2) ) { ... }; my $uuid_time = time_of_uuid($v1_mc_UUID); my $uuid_clk_seq = clk_seq_of_uuid($v1_mc_UUID); =cut =head1 DESCRIPTION UUID::Tiny is a lightweight, low dependency Pure Perl module for UUID creation and testing. This module provides the creation of version 1 time based UUIDs (using random multicast MAC addresses), version 3 MD5 based UUIDs, version 4 random UUIDs, and version 5 SHA-1 based UUIDs. ATTENTION! UUID::Tiny uses Perl's C to create the basic random numbers, so the created v4 UUIDs are B cryptographically strong! No fancy OO interface, no plethora of different UUID representation formats and transformations - just string and binary. Conversion, test and time functions equally accept UUIDs and UUID strings, so don't bother to convert UUIDs for them! Continuing with 1.0x versions all constants and public functions are exported by default, but this will change in the future (see below). UUID::Tiny deliberately uses a minimal functional interface for UUID creation (and conversion/testing), because in this case OO looks like overkill to me and makes the creation and use of UUIDs unnecessarily complicated. If you need raw performance for UUID creation, or the real MAC address in version 1 UUIDs, or an OO interface, and if you can afford module compilation and installation on the target system, then better look at other CPAN UUID modules like L. This module is "fork safe", especially for random UUIDs (it works around Perl's rand() problem when forking processes). This module is currently B "thread safe". Even though I've incorporated some changes proposed by Michael G. Schwern (thanks!), Digest::MD5 and Digest::SHA seem so have trouble with threads. There is a test file for threads, but it is de-activated. So use at your own risk! =cut =head1 DEPENDENCIES This module should run from Perl 5.8 up and uses mostly standard (5.8 core) modules for its job. No compilation or installation required. These are the modules UUID::Tiny depends on: Carp Digest::MD5 Perl 5.8 core Digest::SHA Perl 5.10 core (or Digest::SHA1, or Digest::SHA::PurePerl) MIME::Base64 Perl 5.8 core Time::HiRes Perl 5.8 core POSIX Perl 5.8 core If you are using this module on a Perl prior to 5.10 and you don't have Digest::SHA1 installed, you can use Digest::SHA::PurePerl instead. =cut =head1 ATTENTION! NEW STANDARD INTERFACE After some debate I'm convinced that it is more Perlish (and far easier to write) to use all-lowercase function names - without exceptions. And that it is more polite to export symbols only on demand. While the 1.0x versions will continue to export the old, "legacy" interface on default, the future standard interface is available using the C<:std> tag on import from version 1.02 on: use UUID::Tiny ':std'; my $md5_uuid = create_uuid(UUID_MD5, $str); In preparation for future version of UUID::Tiny you have to use the C<:legacy> tag if you want to stay with the version 1.0 interface: use UUID::Tiny ':legacy'; my $md5_uuid = create_UUID(UUID_V3, $str); =cut use Exporter; our @ISA = qw(Exporter); our @EXPORT; our @EXPORT_OK; our %EXPORT_TAGS = ( std => [qw( UUID_NIL UUID_NS_DNS UUID_NS_URL UUID_NS_OID UUID_NS_X500 UUID_V1 UUID_TIME UUID_V3 UUID_MD5 UUID_V4 UUID_RANDOM UUID_V5 UUID_SHA1 UUID_SHA1_AVAIL create_uuid create_uuid_as_string is_uuid_string uuid_to_string string_to_uuid version_of_uuid time_of_uuid clk_seq_of_uuid equal_uuids )], legacy => [qw( UUID_NIL UUID_NS_DNS UUID_NS_URL UUID_NS_OID UUID_NS_X500 UUID_V1 UUID_V3 UUID_V4 UUID_V5 UUID_SHA1_AVAIL create_UUID create_UUID_as_string is_UUID_string UUID_to_string string_to_UUID version_of_UUID time_of_UUID clk_seq_of_UUID equal_UUIDs )], ); Exporter::export_tags('legacy'); Exporter::export_ok_tags('std'); =head1 CONSTANTS =cut =over 4 =item B This module provides the NIL UUID (shown with its string representation): UUID_NIL: '00000000-0000-0000-0000-000000000000' =cut use constant UUID_NIL => "\x00" x 16; =item B This module provides the common pre-defined namespace UUIDs (shown with their string representation): UUID_NS_DNS: '6ba7b810-9dad-11d1-80b4-00c04fd430c8' UUID_NS_URL: '6ba7b811-9dad-11d1-80b4-00c04fd430c8' UUID_NS_OID: '6ba7b812-9dad-11d1-80b4-00c04fd430c8' UUID_NS_X500: '6ba7b814-9dad-11d1-80b4-00c04fd430c8' =cut use constant UUID_NS_DNS => "\x6b\xa7\xb8\x10\x9d\xad\x11\xd1\x80\xb4\x00\xc0\x4f\xd4\x30\xc8"; use constant UUID_NS_URL => "\x6b\xa7\xb8\x11\x9d\xad\x11\xd1\x80\xb4\x00\xc0\x4f\xd4\x30\xc8"; use constant UUID_NS_OID => "\x6b\xa7\xb8\x12\x9d\xad\x11\xd1\x80\xb4\x00\xc0\x4f\xd4\x30\xc8"; use constant UUID_NS_X500 => "\x6b\xa7\xb8\x14\x9d\xad\x11\xd1\x80\xb4\x00\xc0\x4f\xd4\x30\xc8"; =item B This module provides the UUID version numbers as constants: UUID_V1 UUID_V3 UUID_V4 UUID_V5 With C you get additional, "speaking" constants: UUID_TIME UUID_MD5 UUID_RANDOM UUID_SHA1 =cut use constant UUID_V1 => 1; use constant UUID_TIME => 1; use constant UUID_V3 => 3; use constant UUID_MD5 => 3; use constant UUID_V4 => 4; use constant UUID_RANDOM => 4; use constant UUID_V5 => 5; use constant UUID_SHA1 => 5; =item B my $uuid = create_UUID( UUID_SHA1_AVAIL? UUID_V5 : UUID_V3, $str ); This function returns 1 if a module to create SHA-1 digests could be loaded, 0 otherwise. UUID::Tiny (since version 1.02) tries to load Digest::SHA, Digest::SHA1 or Digest::SHA::PurePerl, but does not die if none of them is found. Instead C and C die when trying to create an SHA-1 based UUID without an appropriate module available. =cut sub UUID_SHA1_AVAIL { return defined $SHA1_CALCULATOR ? 1 : 0; } =back =cut =head1 FUNCTIONS All public functions are exported by default (they should not collide with other functions). C creates standard binary UUIDs in network byte order (MSB first), C creates the standard string representation of UUIDs. All query and test functions (except C) accept both representations. =over 4 =cut =item B, B (:std) my $v1_mc_UUID = create_UUID(); my $v1_mc_UUID = create_UUID(UUID_V1); my $v3_md5_UUID = create_UUID(UUID_V3, $ns_uuid, $name_or_filehandle); my $v3_md5_UUID = create_UUID(UUID_V3, $name_or_filehandle); my $v4_rand_UUID = create_UUID(UUID_V4); my $v5_sha1_UUID = create_UUID(UUID_V5, $ns_uuid, $name_or_filehandle); my $v5_sha1_UUID = create_UUID(UUID_V5, $name_or_filehandle); Creates a binary UUID in network byte order (MSB first). For v3 and v5 UUIDs a C (normally a string), C ("classic" file handle) or C object (i.e. C) can be used; files have to be opened for reading. I found no hint if and how UUIDs should be created from file content. It seems to be undefined, but it is useful - so I would suggest to use UUID_NIL as the namespace UUID, because no "real name" is used; UUID_NIL is used by default if a namespace UUID is missing (only 2 arguments are used). =cut sub create_uuid { use bytes; my ($v, $arg2, $arg3) = (shift || UUID_V1, shift, shift); my $uuid = UUID_NIL; my $ns_uuid = string_to_uuid(defined $arg3 ? $arg2 : UUID_NIL); my $name = defined $arg3 ? $arg3 : $arg2; if ($v == UUID_V1) { $uuid = _create_v1_uuid(); } elsif ($v == UUID_V3 ) { $uuid = _create_v3_uuid($ns_uuid, $name); } elsif ($v == UUID_V4) { $uuid = _create_v4_uuid(); } elsif ($v == UUID_V5) { $uuid = _create_v5_uuid($ns_uuid, $name); } else { croak __PACKAGE__ . "::create_uuid(): Invalid UUID version '$v'!"; } # Set variant 2 in UUID ... substr $uuid, 8, 1, chr(ord(substr $uuid, 8, 1) & 0x3f | 0x80); return $uuid; } *create_UUID = \&create_uuid; sub _create_v1_uuid { my $uuid = ''; # Create time and clock sequence ... my $timestamp = Time::HiRes::time(); my $clk_seq = _get_clk_seq($timestamp); # hi = time mod (1000000 / 0x100000000) my $hi = floor( $timestamp / 65536.0 / 512 * 78125 ); $timestamp -= $hi * 512.0 * 65536 / 78125; my $low = floor( $timestamp * 10000000.0 + 0.5 ); # MAGIC offset: 01B2-1DD2-13814000 if ( $low < 0xec7ec000 ) { $low += 0x13814000; } else { $low -= 0xec7ec000; $hi++; } if ( $hi < 0x0e4de22e ) { $hi += 0x01b21dd2; } else { $hi -= 0x0e4de22e; # wrap around } # Set time in UUID ... substr $uuid, 0, 4, pack( 'N', $low ); # set time low substr $uuid, 4, 2, pack( 'n', $hi & 0xffff ); # set time mid substr $uuid, 6, 2, pack( 'n', ( $hi >> 16 ) & 0x0fff ); # set time high # Set clock sequence in UUID ... substr $uuid, 8, 2, pack( 'n', $clk_seq ); # Set random node in UUID ... substr $uuid, 10, 6, _random_node_id(); return _set_uuid_version($uuid, 0x10); } sub _create_v3_uuid { my $ns_uuid = shift; my $name = shift; my $uuid = ''; # Create digest in UUID ... $MD5_CALCULATOR->reset(); $MD5_CALCULATOR->add($ns_uuid); if ( ref($name) =~ m/^(?:GLOB|IO::)/ ) { $MD5_CALCULATOR->addfile($name); } elsif ( ref $name ) { croak __PACKAGE__ . '::create_uuid(): Name for v3 UUID' . ' has to be SCALAR, GLOB or IO object, not ' . ref($name) .'!' ; } elsif ( defined $name ) { $MD5_CALCULATOR->add($name); } else { croak __PACKAGE__ . '::create_uuid(): Name for v3 UUID is not defined!'; } # Use only first 16 Bytes ... $uuid = substr( $MD5_CALCULATOR->digest(), 0, 16 ); return _set_uuid_version( $uuid, 0x30 ); } sub _create_v4_uuid { # Create random value in UUID ... my $uuid = ''; for ( 1 .. 4 ) { $uuid .= pack 'I', _rand_32bit(); } return _set_uuid_version($uuid, 0x40); } sub _create_v5_uuid { my $ns_uuid = shift; my $name = shift; my $uuid = ''; if (!$SHA1_CALCULATOR) { croak __PACKAGE__ . '::create_uuid(): No SHA-1 implementation available! ' . 'Please install Digest::SHA1, Digest::SHA or ' . 'Digest::SHA::PurePerl to use SHA-1 based UUIDs.' ; } $SHA1_CALCULATOR->reset(); $SHA1_CALCULATOR->add($ns_uuid); if ( ref($name) =~ m/^(?:GLOB|IO::)/ ) { $SHA1_CALCULATOR->addfile($name); } elsif ( ref $name ) { croak __PACKAGE__ . '::create_uuid(): Name for v5 UUID' . ' has to be SCALAR, GLOB or IO object, not ' . ref($name) .'!' ; } elsif ( defined $name ) { $SHA1_CALCULATOR->add($name); } else { croak __PACKAGE__ . '::create_uuid(): Name for v5 UUID is not defined!'; } # Use only first 16 Bytes ... $uuid = substr( $SHA1_CALCULATOR->digest(), 0, 16 ); return _set_uuid_version($uuid, 0x50); } sub _set_uuid_version { my $uuid = shift; my $version = shift; substr $uuid, 6, 1, chr( ord( substr( $uuid, 6, 1 ) ) & 0x0f | $version ); return $uuid; } =item B, B (:std) Similar to C, but creates a UUID string. =cut sub create_uuid_as_string { return uuid_to_string(create_uuid(@_)); } *create_UUID_as_string = \&create_uuid_as_string; =item B, B (:std) my $bool = is_UUID_string($str); =cut our $IS_UUID_STRING = qr/^[0-9a-f]{8}(?:-[0-9a-f]{4}){3}-[0-9a-f]{12}$/is; our $IS_UUID_HEX = qr/^[0-9a-f]{32}$/is; our $IS_UUID_Base64 = qr/^[+\/0-9A-Za-z]{22}(?:==)?$/s; sub is_uuid_string { my $uuid = shift; return $uuid =~ m/$IS_UUID_STRING/; } *is_UUID_string = \&is_uuid_string; =item B, B (:std) my $uuid_str = UUID_to_string($uuid); This function returns C<$uuid> unchanged if it is a UUID string already. =cut sub uuid_to_string { my $uuid = shift; use bytes; return $uuid if $uuid =~ m/$IS_UUID_STRING/; croak __PACKAGE__ . "::uuid_to_string(): Invalid UUID!" unless length $uuid == 16; return join '-', map { unpack 'H*', $_ } map { substr $uuid, 0, $_, '' } ( 4, 2, 2, 2, 6 ); } *UUID_to_string = \&uuid_to_string; =item B, B (:std) my $uuid = string_to_UUID($uuid_str); This function returns C<$uuid_str> unchanged if it is a UUID already. In addition to the standard UUID string representation and its URN forms (starting with C or C), this function accepts 32 digit hex strings, variants with different positions of C<-> and Base64 encoded UUIDs. Throws an exception if string can't be interpreted as a UUID. If you want to make sure to have a "pure" standard UUID representation, check with C! =cut sub string_to_uuid { my $uuid = shift; use bytes; return $uuid if length $uuid == 16; return decode_base64($uuid) if ($uuid =~ m/$IS_UUID_Base64/); my $str = $uuid; $uuid =~ s/^(?:urn:)?(?:uuid:)?//io; $uuid =~ tr/-//d; return pack 'H*', $uuid if $uuid =~ m/$IS_UUID_HEX/; croak __PACKAGE__ . "::string_to_uuid(): '$str' is no UUID string!"; } *string_to_UUID = \&string_to_uuid; =item B, B (:std) my $version = version_of_UUID($uuid); This function accepts binary and string UUIDs. =cut sub version_of_uuid { my $uuid = shift; use bytes; $uuid = string_to_uuid($uuid); return (ord(substr($uuid, 6, 1)) & 0xf0) >> 4; } *version_of_UUID = \&version_of_uuid; =item B, B (:std) my $uuid_time = time_of_UUID($uuid); This function accepts UUIDs and UUID strings. Returns the time as a floating point value, so use C to get a C compatible value. Returns C if the UUID is not version 1. =cut sub time_of_uuid { my $uuid = shift; use bytes; $uuid = string_to_uuid($uuid); return unless version_of_uuid($uuid) == 1; my $low = unpack 'N', substr($uuid, 0, 4); my $mid = unpack 'n', substr($uuid, 4, 2); my $high = unpack('n', substr($uuid, 6, 2)) & 0x0fff; my $hi = $mid | $high << 16; # MAGIC offset: 01B2-1DD2-13814000 if ($low >= 0x13814000) { $low -= 0x13814000; } else { $low += 0xec7ec000; $hi --; } if ($hi >= 0x01b21dd2) { $hi -= 0x01b21dd2; } else { $hi += 0x0e4de22e; # wrap around } $low /= 10000000.0; $hi /= 78125.0 / 512 / 65536; # / 1000000 * 0x10000000 return $hi + $low; } *time_of_UUID = \&time_of_uuid; =item B, B (:std) my $uuid_clk_seq = clk_seq_of_UUID($uuid); This function accepts UUIDs and UUID strings. Returns the clock sequence for a version 1 UUID. Returns C if UUID is not version 1. =cut sub clk_seq_of_uuid { use bytes; my $uuid = shift; $uuid = string_to_uuid($uuid); return unless version_of_uuid($uuid) == 1; my $r = unpack 'n', substr($uuid, 8, 2); my $v = $r >> 13; my $w = ($v >= 6) ? 3 # 11x : ($v >= 4) ? 2 # 10- : 1 # 0-- ; $w = 16 - $w; return $r & ((1 << $w) - 1); } *clk_seq_of_UUID = \&clk_seq_of_uuid; =item B, B (:std) my $bool = equal_UUIDs($uuid1, $uuid2); Returns true if the provided UUIDs are equal. Accepts UUIDs and UUID strings (can be mixed). =cut sub equal_uuids { my ($u1, $u2) = @_; return unless defined $u1 && defined $u2; return string_to_uuid($u1) eq string_to_uuid($u2); } *equal_UUIDs = \&equal_uuids; # # Private functions ... # my $Last_Pid; my $Clk_Seq :shared; # There is a problem with $Clk_Seq and rand() on forking a process using # UUID::Tiny, because the forked process would use the same basic $Clk_Seq and # the same seed (!) for rand(). $Clk_Seq is UUID::Tiny's problem, but with # rand() it is Perl's bad behavior. So _init_globals() has to be called every # time before using $Clk_Seq or rand() ... sub _init_globals { lock $Clk_Seq; if (!defined $Last_Pid || $Last_Pid != $$) { $Last_Pid = $$; # $Clk_Seq = _generate_clk_seq(); # There's a slight chance to get the same value as $Clk_Seq ... for (my $i = 0; $i <= 5; $i++) { my $new_clk_seq = _generate_clk_seq(); if (!defined($Clk_Seq) || $new_clk_seq != $Clk_Seq) { $Clk_Seq = $new_clk_seq; last; } if ($i == 5) { croak __PACKAGE__ . "::_init_globals(): Can't get unique clk_seq!"; } } srand(); } return; } my $Last_Timestamp :shared; sub _get_clk_seq { my $ts = shift; _init_globals(); lock $Last_Timestamp; lock $Clk_Seq; #if (!defined $Last_Timestamp || $ts <= $Last_Timestamp) { if (defined $Last_Timestamp && $ts <= $Last_Timestamp) { #$Clk_Seq = ($Clk_Seq + 1) % 65536; # The old variant used modulo, but this looks unnecessary, # because we should only use the significant part of the # number, and that also lets the counter circle around: $Clk_Seq = ($Clk_Seq + 1) & 0x3fff; } $Last_Timestamp = $ts; #return $Clk_Seq & 0x03ff; # no longer needed - and it was wrong too! return $Clk_Seq; } sub _generate_clk_seq { my $self = shift; # _init_globals(); my @data; push @data, '' . $$; push @data, ':' . Time::HiRes::time(); # 16 bit digest # We should return only the significant part of the number! return (unpack 'n', _digest_as_octets(2, @data)) & 0x3fff; } sub _random_node_id { my $self = shift; my $r1 = _rand_32bit(); my $r2 = _rand_32bit(); my $hi = ($r1 >> 8) ^ ($r2 & 0xff); my $lo = ($r2 >> 8) ^ ($r1 & 0xff); $hi |= 0x80; my $id = substr pack('V', $hi), 0, 3; $id .= substr pack('V', $lo), 0, 3; return $id; } sub _rand_32bit { _init_globals(); my $v1 = int(rand(65536)) % 65536; my $v2 = int(rand(65536)) % 65536; return ($v1 << 16) | $v2; } sub _fold_into_octets { use bytes; my ($num_octets, $s) = @_; my $x = "\x0" x $num_octets; while (length $s > 0) { my $n = ''; while (length $x > 0) { my $c = ord(substr $x, -1, 1, '') ^ ord(substr $s, -1, 1, ''); $n = chr($c) . $n; last if length $s <= 0; } $n = $x . $n; $x = $n; } return $x; } sub _digest_as_octets { my $num_octets = shift; $MD5_CALCULATOR->reset(); $MD5_CALCULATOR->add($_) for @_; return _fold_into_octets($num_octets, $MD5_CALCULATOR->digest); } =back =cut =head1 DISCUSSION =over =item B The random multi-cast MAC address gives privacy, and getting the real MAC address with Perl is really dirty (and slow); =item B Using SHA-1 reduces the probability of collisions and provides a better "randomness" of the resulting UUID compared to MD5. Version 5 is recommended in RFC 4122 if backward compatibility is not an issue. Using MD5 (version 3) has a better performance. This could be important with creating UUIDs from file content rather than names. =back =head1 UUID DEFINITION See RFC 4122 (L) for technical details on UUIDs. Wikipedia gives a more palatable description at L. =head1 AUTHOR Christian Augustin, C<< >> =head1 CONTRIBUTORS Some of this code is based on UUID::Generator by ITO Nobuaki Ebanb@cpan.orgE. But that module is announced to be marked as "deprecated" in the future and it is much too complicated for my liking. So I decided to reduce it to the necessary parts and to re-implement those parts with a functional interface ... Jesse Vincent, C<< >>, improved version 1.02 with his tips and a heavy refactoring. Michael G. Schwern provided a patch for better thread support (as far as UUID::Tiny can be improved itself) that is incorporated in version 1.04. =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc UUID::Tiny You can also look for information at: =over 4 =item * RT: CPAN's request tracker L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =back =head1 ACKNOWLEDGEMENTS Kudos to ITO Nobuaki Ebanb@cpan.orgE for his UUID::Generator::PurePerl module! My work is based on his code, and without it I would've been lost with all those incomprehensible RFC texts and C codes ... Thanks to Jesse Vincent (C<< >>) for his feedback, tips and refactoring! =head1 COPYRIGHT & LICENSE Copyright 2009, 2010, 2013 Christian Augustin, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. ITO Nobuaki has very graciously given me permission to take over copyright for the portions of code that are copied from or resemble his work (see rt.cpan.org #53642 L). =cut 1; # End of UUID::Tiny