File Coverage

blib/lib/Data/GUID/Any.pm

Criterion	Covered	Total	%
statement	142	143	99.3
branch	9	12	75.0
condition	1	3	33.3
subroutine	49	49	100.0
pod			n/a
total	201	207	97.1

use 5.006;
use strict;
use warnings;
package Data::GUID::Any;
# ABSTRACT: Generic interface for GUID/UUID creation
our $VERSION = '0.004'; # VERSION

use IPC::Cmd;
use Exporter;
our @ISA = qw/Exporter/;
our @EXPORT_OK = qw/ guid_as_string v1_guid_as_string v4_guid_as_string/;

our ($Using_vX, $Using_v1, $Using_v4) = ("") x 3;
our $UC = 1;

#--------------------------------------------------------------------------#

my $hex = "a-z0-9";

# case insensitive, since used to check if generators are functioning
sub _looks_like_guid {
  my $guid = shift;
  return $guid =~ /[$hex]{8}-[$hex]{4}-[$hex]{4}-[$hex]{4}-[$hex]{12}/i;
}

#--------------------------------------------------------------------------#

sub _xc {
  return $UC ? uc($_[0]) : lc($_[0]);
}

#--------------------------------------------------------------------------#

# state variables for generator closures
my ($dumt_v1, $dumt_v4, $uuid_v1, $uuid_v4) = (undef) x 4; # reset if reloaded

my %generators = (
  # v1 or v4
  'Data::UUID::MT' => {
    type => 'module',
    v1 => sub {
      $dumt_v1 ||= Data::UUID::MT->new(version => 1);
      return _xc( $dumt_v1->create_string );
    },
    v4 => sub {
      $dumt_v4 ||= Data::UUID::MT->new(version => 4);
      return _xc( $dumt_v4->create_string );
    },
  },
  'Data::UUID::LibUUID' => {
    type => 'module',
    v1 => sub { return _xc( Data::UUID::LibUUID::new_uuid_string(2) ) },
    v4 => sub { return _xc( Data::UUID::LibUUID::new_uuid_string(4) ) },
    vX => sub { return _xc( Data::UUID::LibUUID::new_uuid_string() ) },
  },
  'UUID::Tiny' => {
    type => 'module',
    v1 => sub { return _xc( UUID::Tiny::create_UUID_as_string(UUID::Tiny::UUID_V1()) ) },
    v4 => sub { return _xc( UUID::Tiny::create_UUID_as_string(UUID::Tiny::UUID_V4()) ) },
  },
  'uuid' => {
    type => 'binary',
    v1 => sub {
      $uuid_v1 ||= IPC::Cmd::can_run('uuid');
      chomp( my $guid = qx/$uuid_v1 -v1/ ); return _xc( $guid );
    },
    v4 => sub {
      $uuid_v4 ||= IPC::Cmd::can_run('uuid');
      chomp( my $guid = qx/$uuid_v4 -v4/ ); return _xc( $guid );
    },
  },
  # v1 only
  'Data::GUID' => {
    type => 'module',
    v1 => sub { return _xc( Data::GUID->new->as_string ) },
  },
  'Data::UUID' => {
    type => 'module',
    v1 => sub { return _xc( Data::UUID->new->create_str ) },
  },
  # system dependent or custom
  'UUID' => {
    type => 'module',
    vX => sub { my ($u,$s); UUID::generate($u); UUID::unparse($u, $s); return _xc( $s ) },
  },
  'Win32' => {
    type => 'module',
    vX => sub { my $guid = Win32::GuidGen(); return _xc( substr($guid,1,-1) ) },
  },
  'APR::UUID' => {
    type => 'module',
    vX => sub { return _xc( APR::UUID->new->format ) },
  },
);

our $NO_BINARY; # for testing
sub _is_available {
  my ($name) = @_;
  if ( $generators{$name}{type} eq 'binary' ) {
    return $NO_BINARY ? undef : IPC::Cmd::can_run($name);
  }
  else {
    return eval "require $name";
  }
}

sub _best_generator {
  my ($list) = @_;
  for my $option ( @$list ) {
    my ($name, $version) = @$option;
    next unless my $g = $generators{$name};
    next unless _is_available($name);
    return ($name, $g->{$version})
      if $g->{$version} && _looks_like_guid( $g->{$version}->() );
  }
  return;
}

#--------------------------------------------------------------------------#

my %sets = (
  any => [
    ['Data::UUID::MT'       => 'v4'],
    ['Data::GUID'           => 'v1'],
    ['Data::UUID'           => 'v1'],
    ['Data::UUID::LibUUID'  => 'vX'],
    ['UUID'                 => 'vX'],
    ['Win32'                => 'vX'],
    ['uuid'                 => 'v1'],
    ['APR::UUID'            => 'vX'],
    ['UUID::Tiny'           => 'v1'],
  ],
  v1 => [
    ['Data::UUID::MT'       => 'v1'],
    ['Data::GUID'           => 'v1'],
    ['Data::UUID'           => 'v1'],
    ['Data::UUID::LibUUID'  => 'v1'],
    ['uuid'                 => 'v1'],
    ['UUID::Tiny'           => 'v1'],
  ],
  v4 => [
    ['Data::UUID::MT'       => 'v4'],
    ['Data::UUID::LibUUID'  => 'v4'],
    ['uuid'                 => 'v4'],
    ['UUID::Tiny'           => 'v4'],
  ],
);

sub _generator_set { return $sets{$_[0]} }

{
  no warnings qw/once redefine/;
  {
    my ($n, $s) = _best_generator(_generator_set("any"));
    die "Couldn't find a GUID provider" unless $n;
    *guid_as_string = $s;
    $Using_vX = $n;
  }
  {
    my ($n, $s) = _best_generator(_generator_set("v1"));
    *v1_guid_as_string = $s || sub { die "No v1 GUID provider found\n" };
    $Using_v1 = $n || '';
  }
  {
    my ($n, $s) = _best_generator(_generator_set("v4"));
    *v4_guid_as_string = $s || sub { die "No v4 GUID provider found\n" };
    $Using_v4 = $n || '';
  }
}

1;

__END__