File Coverage

blib/lib/Test2/Util/UUID.pm

Criterion	Covered	Total	%
statement	105	110	95.4
branch	20	38	52.6
condition	13	21	61.9
subroutine	26	26	100.0
pod	1	3	33.3
total	165	198	83.3

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__