—

              
package Test2::Util::UUID;
use strict;
use warnings;
our $VERSION = '0.002010';
use Carp qw/croak/;
my %EXPORT = (
    looks_like_uuid => 1,
    gen_uuid => 1,
    GEN_UUID_BACKEND => 1,
    uuid2bin => 1,
    bin2uuid => 1,
);
sub import {
    my $class  = shift;
    my $caller = caller;
    my %gen_params;
    my %import;
    while (my $arg = shift @_) {
        if ($EXPORT{$arg}) {
            $import{$arg}++;
            next;
        }
        if ($arg eq 'warn' || $arg eq 'backends') {
            $gen_params{$arg} = shift @_;
            next;
        }
        croak "Invalid argument '$arg'";
    }
    my $subs = $class->get_gen_uuid(%gen_params);
    for my $name (keys %import) {
        my $sub = $subs->{$name} || $class->can($name) or croak "'$name' is not available for import";
        no strict 'refs';
        *{"$caller\::$name"} = $sub;
    }
    return;
}
my %GEN_UUID_CACHE;
sub clear_cache { %GEN_UUID_CACHE = () }
sub get_gen_uuid {
    my $class  = shift;
    my %params = @_;
    my $warn     = $params{warn}     // ($ENV{TEST2_UUID_NO_WARN} ? 0                                           : 1);
    my $backends = $params{backends} // ($ENV{TEST2_UUID_BACKEND} ? [split /\s*,\s*/, $ENV{TEST2_UUID_BACKEND}] : ['UUID', 'Data::UUID::MT', 'UUID::Tiny', 'Data::UUID']);
    for my $backend (@$backends) {
        return $GEN_UUID_CACHE{$backend} if $GEN_UUID_CACHE{$backend};
        my $meth = lc("_gen_$backend");
        $meth =~ s/::/_/g;
        croak "'$backend' is not supported" unless $class->can($meth);
        $GEN_UUID_CACHE{$backend} = $class->$meth($warn) or next;
        $GEN_UUID_CACHE{$backend}->{GEN_UUID_BACKEND} = sub() { $backend };
        return $GEN_UUID_CACHE{$backend};
    }
    croak "No UUID generator found, please install one of these: UUID, Data::UUID::MT, Data::UUID, or UUID::Tiny. ('UUID' is preferred over the others)\n";
}
sub _gen_uuid {
    my $class = shift;
    my ($warn) = @_;
    local $@;
    return undef unless eval { require UUID; 1 };
    unless (eval { UUID->VERSION('0.35'); 1 }) {
        warn "UUID version is too old, need 0.35 or greater to avoid a fork related bug. Please upgrade the UUID module.\n"
            if $warn;
        return;
    }
    return {
        gen_uuid => sub { uc(UUID::uuid7->()) },
        bin2uuid => sub { my $out; UUID::unparse($_[0], $out); uc($out) },
        uuid2bin => sub { my $out; UUID::parse($_[0], $out); $out },
    };
}
sub _gen_data_uuid_mt {
    my $class = shift;
    my ($warn) = @_;
    local $@;
    return undef unless eval { require Data::UUID::MT; 1 };
    my $ug = Data::UUID::MT->new(version => 4);
    my $out = {
        gen_uuid => sub { uc($ug->create_string()) },
    };
    if (eval { require UUID::Tiny; 1 }) {
        $out->{uuid2bin} = sub { UUID::Tiny::string_to_uuid($_[0]) },
        $out->{bin2uuid} = sub { uc(UUID::Tiny::uuid_to_string($_[0])) },
    }
    return $out;
}
sub _gen_uuid_tiny {
    my $class = shift;
    my ($warn) = @_;
    local $@;
    return undef unless eval { require UUID::Tiny; 1 };
    warn "Using UUID::Tiny for uuid generation. UUID::Tiny is significantly slower than the 'UUID' or 'Data::UUID::MT' modules, please install 'UUID' or 'Data::UUID::MT' if possible. If you insist on using UUID::Tiny you can set the TEST2_UUID_NO_WARN environment variable.\n"
        if $warn;
    return {
        gen_uuid => sub { uc(UUID::Tiny::create_uuid_as_string(UUID::Tiny::UUID_V4())) },
        bin2uuid => sub { uc(UUID::Tiny::uuid_to_string($_[0])) },
        uuid2bin => sub { UUID::Tiny::string_to_uuid($_[0]) },
    };
}
sub _gen_data_uuid {
    my $class = shift;
    my ($warn) = @_;
    local $@;
    return undef unless eval { require Data::UUID; 1 };
    warn "Using Data::UUID to generate UUIDs, this works, but the UUIDs will not be suitible as database keys. Please install the 'UUID', 'Data::UUID::MT' or the slower but pure perl 'UUID::Tiny' cpan modules for better UUIDs. If you insist on using Data::UUID you can set the TEST2_UUID_NO_WARN environment variable.\n"
        if $warn;
    my ($UG, $UG_PID);
    my $UG_INIT = sub {
        return $UG if $UG && $UG_PID && $UG_PID == $$;
        $UG_PID = $$;
        return $UG = Data::UUID->new;
    };
    # Initialize it here in this PID to start
    $UG_INIT->();
    return {
        gen_uuid => sub { uc($UG_INIT->()->create_str()) },
        bin2uuid => sub { uc($UG_INIT->()->to_string($_[0])) },
        uuid2bin => sub { $UG_INIT->()->from_string($_[0]) },
    };
}
sub looks_like_uuid {
    my ($in) = @_;
    return $in if $in && $in =~ m/^[A-F0-9]{8}-[A-F0-9]{4}-[A-F0-9]{4}-[A-F0-9]{4}-[A-F0-9]{12}$/i;
    return undef;
}
1;
__END__
HideShow 142 lines of Pod
=pod
=encoding UTF-8
=head1 NAME
Test2::Util::UUID - Utils for generating UUIDs under Test2.
=head1 DESCRIPTION
This module provides a consistent UUID source for all of Test2.
=head1 SYNOPSIS
    use Test2::Util::UUID qw/gen_uuid looks_like_uuid uuid2bin bin2uuid/;
    my $uuid = gen_uuid;
    my $bin = bin2uuid($uuid);
    my $uuid_again = uuid2bin($uuid);
=head1 UNDER THE HOOD
One of the following modules will be used under the hood, they are listed here
in order of preference.
=over 4
=item L<UUID> >= 0.35
When possible this module will use the L<UUID> cpan module, but it must be
version 0.35 or greater to avoid a fork related bug. It will generate version 7
UUIDs as they are most suitible for database entry.
=item L<Data::UUID::MT>
L<Data::UUID::MT> is the second choice for UUID generation. With this module
version 4 UUIDs are generated as they are fairly usable in databases.
=item L<UUID::Tiny> - slow
L<UUID::Tiny> is used if the previous 2 are not available. This module is pure
perl and thus could be slower than the others. Version 4 UUIDs are generated
when this module is used.
A warning will be issued with this module. You can surpress the warning with
either the C<$TEST2_UUID_NO_WARN> environment variable or the C<< warn => 0 >>
import argument.
=item L<Data::UUID> - Not Suitible for Databases
This is the last resort module. This generates UUIDs fast, but they are of a
type/version that is not suitible for database keys.
A warning will be issued with this module. You can surpress the warning with
either the C<$TEST2_UUID_NO_WARN> environment variable or the C<< warn => 0 >>
import argument.
=back
=head2 CONTROLLING WARNINGS
=head3 AT IMPORT
    use Test2::Util::UUID 'gen_uuid', warn => 0;
Passing in C<< warn => 0 >> will disable the warnings normally issued when
using L<UUID::Tiny> or L<Data::UUID> as a backend.
=head2 SELECTING A BACKEND
=head3 AT IMPORT
If you wish to override the order and specify which backend to use you may do
so by listing them during import prefixed with ':'.
    use Test2::Util::UUID 'gen_uuid', backends => [':UUID', ':UUID::Tiny'];
The above will try the L<UUID> module first, followed by the L<UUID::Tiny>
module. It will not try L<Data::UUID::MT> or L<Data::UUID>.
B<Note:> You must include these import arguments anywhere you import this
module, otherwise the other imports will use the default list, resulting in
different places using different UUIDs.
=head3 THE $TEST2_UUID_BACKEND ENV VAR
Setting the $TEST2_UUID_BACKEND env var to one of the backends, or a comma
seperated list will override the default list for all imports. It will B<NOT>
override imports that specify their own lists.
=head1 EXPORTS
=over 4
=item $uuid = gen_uuid()
Generate a UUID, always normalized to upper case.
=item $uuid_or_undef = looks_like_uuid($UUID)
Checks if the provided value looks like a UUID. Make sure it is defined, 36
characters long, has dashes, and only contains 0-9 a-f and dash (case
insensitive).
Returns the input value if it looks like a UUID, otherise it returns undef.
=back
=head1 SOURCE
The source code repository for Test2-Plugin-UUID can be found at
F<https://github.com/Test-More/Test2-Plugin-UUID/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut