Data::GUID - globally unique identifiers

  use Data::GUID;

  my $guid = Data::GUID->new;

  my $string = $guid->as_string; # or "$guid"

  my $other_guid = Data::GUID->from_string($string);

  if (($guid <=> $other_guid) == 0) {
    print "They're the same!\n";
  }

  my $guid = Data::GUID->new;

  my $guid = Data::GUID->from_string("B0470602-A64B-11DA-8632-93EBF1C0E05A");

  # note that a hex guid is a guid string without hyphens and with a leading 0x
  my $guid = Data::GUID->from_hex("0xB0470602A64B11DA863293EBF1C0E05A");

  my $guid = Data::GUID->from_base64("sEcGAqZLEdqGMpPr8cDgWg==");

  my $string = get_string_from_ether;

  my $guid = Data::GUID->from_any_string($string);

  my $value = get_value_from_ether;

  my $guid = Data::GUID->best_guess($value);

  B0470602-A64B-11DA-8632-93EBF1C0E05A

  0xB0470602A64B11DA863293EBF1C0E05A

  sEcGAqZLEdqGMpPr8cDgWg==

  use Data::GUID qw(guid);

  my $guid = guid;             # OK
  my $guid = Data::GUID->guid; # OK
  my $guid = Data::GUID::guid; # NOT OK

package Data::GUID;

use warnings;
use strict;

use Carp ();
use Data::UUID;
use Sub::Install;

our $VERSION = '0.046';

my $_uuid_gen = Data::UUID->new;
sub new {
  my ($class) = @_;

  return $class->from_data_uuid($_uuid_gen->create);
}

sub from_data_uuid {
  my ($class, $value) = @_;

  my $length = do { use bytes; defined $value ? length $value : 0; };
  Carp::croak "given value is not a valid Data::UUID value" if $length != 16;
  bless \$value => $class;
}

my ($hex, $base64, %type);

BEGIN { # because %type must be populated for method/exporter generation
  $hex    = qr/[0-9A-F]/i;
  $base64 = qr{[A-Z0-9+/=]}i;

  %type = ( # uuid_method  validation_regex
    string => [ 'string',     qr/\A$hex{8}-?(?:$hex{4}-?){3}$hex{12}\z/, ],
    hex    => [ 'hexstring',  qr/\A0x$hex{32}\z/,                        ],
    base64 => [ 'b64string',  qr/\A$base64{24}\z/,                       ],
  );

  for my $key (keys %type) {
    no strict 'refs';
    my $subname = "$key\_guid_regex";
    *$subname = sub { $type{ $key }[1] }
  }
}

# provided for test scripts
sub __type_regex { shift; $type{$_[0]}[1] }

sub _install_from_method {
  my ($type, $alien_method, $regex) = @_;
  my $alien_from_method = "from_$alien_method";

  my $our_from_code = sub {
    my ($class, $string) = @_;
    $string ||= q{}; # to avoid (undef =~) warning
    Carp::croak qq{"$string" is not a valid $type GUID} if $string !~ $regex;
    $class->from_data_uuid( $_uuid_gen->$alien_from_method($string) );
  };

  Sub::Install::install_sub({ code => $our_from_code, as => "from_$type" });
}

sub _install_as_method {
  my ($type, $alien_method) = @_;

  my $alien_to_method = "to_$alien_method";

  my $our_to_method = sub {
    my ($self) = @_;
    $_uuid_gen->$alien_to_method( $self->as_binary );
  };

  Sub::Install::install_sub({ code => $our_to_method, as => "as_$type" });
}

BEGIN { # possibly unnecessary -- rjbs, 2006-03-11
  do {
    while (my ($type, $profile) = each %type) {
      _install_from_method($type, @$profile);
      _install_as_method  ($type, @$profile);
    }
  };
}

sub _from_multitype {
  my ($class, $what, $types) = @_;
  sub {
    my ($class, $value) = @_;
    return $value if eval { $value->isa('Data::GUID') };

    my $value_string = defined $value ? qq{"$value"} : 'undef';

    # The only good ref is a blessed ref, and only into our denomination!
    if (my $ref = ref $value) {
      Carp::croak "a $ref reference is not a valid GUID $what"
    }

    for my $type (@$types) {
      my $from = "from_$type";
      my $guid = eval { $class->$from($value); };
      return $guid if $guid;
    }

    Carp::croak "$value_string is not a valid GUID $what";
  }
}

BEGIN { # possibly unnecessary -- rjbs, 2006-03-11
  Sub::Install::install_sub({
    code => __PACKAGE__->_from_multitype('string', [ keys %type ]),
    as   => 'from_any_string',
  });
}

BEGIN { # possibly unnecessary -- rjbs, 2006-03-11
  Sub::Install::install_sub({
    code => __PACKAGE__->_from_multitype('value', [(keys %type), 'data_uuid']),
    as   => 'best_guess',
  });
}

sub compare_to_guid {
  my ($self, $other) = @_;

  my $other_binary
    = eval { $other->isa('Data::GUID') } ? $other->as_binary : $other;

  $_uuid_gen->compare($self->as_binary, $other_binary);
}

sub as_binary {
  my ($self) = @_;
  $$self;
}

use overload
  q{""} => 'as_string',
  '<=>' => sub { ($_[2] ? -1 : 1) * $_[0]->compare_to_guid($_[1]) },
  fallback => 1;

BEGIN {
  Sub::Install::install_sub({ code => 'new', as => 'guid' });

  for my $type (keys %type) {
    my $method = "guid_$type";
    my $as     = "as_$type";

    Sub::Install::install_sub({
      as   => $method,
      code => sub {
        my ($class) = @_;
        $class->new->$as;
      },
    });
  }
}

sub _curry_class {
  my ($class, $subname, $eval) = @_;
  return $eval ? sub { eval { $class->$subname(@_) } }
               : sub { $class->$subname(@_) };
}

my %exports;
BEGIN {
  %exports
    = map { my $method = $_; $_ => sub { _curry_class($_[0], $method) } }
    ((map { "guid_$_" } keys %type), 'guid');
}

use Sub::Exporter -setup => {
  exports => {
    %exports, # defined just above
    guid_from_anything => sub { _curry_class($_[0], 'from_any_string', 1) },
  }
};

1;