view release on metacpan or  search on metacpan

lib/Data/GUID.pm  view on Meta::CPAN

#pod identifiers.
#pod
#pod =head1 GETTING A NEW GUID
#pod
#pod =head2 new
#pod
#pod   my $guid = Data::GUID->new;
#pod
#pod This method returns a new globally unique identifier.
#pod
#pod =cut

my $_uuid_gen_obj;
my $_uuid_gen_pid;
my $_uuid_gen = sub {
  return $_uuid_gen_obj if $_uuid_gen_obj
                        && $_uuid_gen_pid == $$;

  $_uuid_gen_pid = $$;
  $_uuid_gen_obj = Data::UUID->new;
};

sub new {
  my ($class) = @_;

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

#pod =head1 GUIDS FROM EXISTING VALUES
#pod
#pod These method returns a new Data::GUID object for the given GUID value.  In all
#pod cases, these methods throw an exception if given invalid input.
#pod
#pod =head2 from_string
#pod
#pod   my $guid = Data::GUID->from_string("B0470602-A64B-11DA-8632-93EBF1C0E05A");
#pod
#pod =head2 from_hex
#pod
#pod   # note that a hex guid is a guid string without hyphens and with a leading 0x
#pod   my $guid = Data::GUID->from_hex("0xB0470602A64B11DA863293EBF1C0E05A");
#pod
#pod =head2 from_base64
#pod
#pod   my $guid = Data::GUID->from_base64("sEcGAqZLEdqGMpPr8cDgWg==");
#pod
#pod =head2 from_data_uuid
#pod
#pod This method returns a new Data::GUID object if given a Data::UUID value.
#pod Because Data::UUID values are not blessed and because Data::UUID provides no
#pod validation method, this method will only throw an exception if the given data
#pod is of the wrong size.
#pod
#pod =cut

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;
}

#pod =head1 IDENTIFYING GUIDS
#pod
#pod =head2 string_guid_regex
#pod
#pod =head2 hex_guid_regex
#pod
#pod =head2 base64_guid_regex
#pod
#pod These methods return regex objects that match regex strings of the appropriate
#pod type.
#pod
#pod =cut

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 );
  };