Data-Identifier
view release on metacpan or search on metacpan
lib/Data/Identifier/Generate.pm view on Meta::CPAN
},
);
my %_hash_type_to_utag = (
'8238da08-ca93-4d67-bf40-54818aa94405' => { # rfc9530-digest-identifier
'md5' => 'md-5-128',
'sha' => 'sha-1-160',
'sha-256' => 'sha-2-256',
'sha-512' => 'sha-2-512',
},
'0d4ef6fa-0f9a-4bc8-9fc1-e4f00725397e' => { # openpgp-digest-identifier
1 => 'md-5-128',
2 => 'sha-1-160',
3 => 'ripemd-1-160',
# 4 - 7
8 => 'sha-2-256',
9 => 'sha-2-384',
10 => 'sha-2-512',
11 => 'sha-2-224',
12 => 'sha-3-256',
# 13
14 => 'sha-3-512',
},
'039e0bb7-5dd3-40ee-a98c-596ff6cce405' => { # sirtx-numerical-identifier
185 => 'sha-1-160',
186 => 'sha-3-512',
},
);
my %_hash_utag_to_type = map {
my $x = $_;
$x => {map {$_hash_type_to_utag{$x}{$_} => $_} keys %{$_hash_type_to_utag{$x}}},
} keys %_hash_type_to_utag;
my %_hash_type_aliases = (
rfc9530 => '8238da08-ca93-4d67-bf40-54818aa94405',
openpgp => '0d4ef6fa-0f9a-4bc8-9fc1-e4f00725397e',
sni => '039e0bb7-5dd3-40ee-a98c-596ff6cce405',
);
#@returns Data::Identifier
sub integer {
my ($pkg, $request, %opts) = @_;
$opts{request} = $request.'';
$opts{displayname}//= $request.'';
$opts{generator} = $request >= 0 ? WK_UNSIGNED_INTEGER_GENERATOR : WK_SIGNED_INTEGER_GENERATOR;
# We currently don't set one for $request == 0
if ($request > 0) {
$opts{icontext} //= "\N{DOUBLE-STRUCK CAPITAL N}";
} elsif ($request < 0) {
$opts{icontext} //= "\N{DOUBLE-STRUCK CAPITAL Z}";
}
return $pkg->generic(%opts);
}
#@returns Data::Identifier
sub unicode_character {
my ($pkg, $type, $request, %opts) = @_;
my Data::Identifier $ret;
my $unicode_cp;
my $unicode_cp_str;
my $tagname;
croak 'No type given' unless defined $type;
croak 'No/Bad request given' unless defined($request) && length($request);
if ($type eq 'unicode') {
if ($request =~ /^[Uu]\+([0-9a-fA-F]+)$/) {
$unicode_cp = hex($1);
} elsif ($request =~ /^[0-9]+\z/) {
$unicode_cp = int($request);
} else {
croak 'Bad request given: '.$request;
}
} elsif ($type eq 'ascii') {
if ($request =~ /^[0-9]+\z/) {
$unicode_cp = int($request);
} else {
croak 'Bad request given: '.$request;
}
croak 'US-ASCII character out of range: '.$unicode_cp if $unicode_cp < 0 || $unicode_cp > 0x7F;
} elsif ($type eq 'raw') {
croak 'Raw value is not exactly one character long' unless length($request) == 1;
$unicode_cp = ord($request);
} else {
croak 'Bad type given: '.$type;
}
croak 'Unicode character out of range: '.$unicode_cp if $unicode_cp < 0 || $unicode_cp > 0x10FFFF;
$unicode_cp_str = sprintf('U+%04X', $unicode_cp);
if ($unicode_cp == 0xFFFC || $unicode_cp == 0xFFFD || $unicode_cp == 0xFEFF || $unicode_cp == 0xFFFE) {
croak 'Rejected use of special character: '.$unicode_cp_str unless $opts{allow_special};
}
if ($unicode_cp > 31 && $unicode_cp != 127) {
$tagname = eval {
require charnames;
charnames::viacode($unicode_cp);
};
}
$opts{displayname} //= $tagname // $unicode_cp_str;
$ret = Data::Identifier->new(unicodecp => $unicode_cp_str, displayname => $opts{displayname}, generator => WK_UNICODE_CHARACTER_GENERATOR, request => $unicode_cp_str);
$ret->_add_tagnames($tagname) if defined $tagname;
return $ret;
}
#@returns Data::Identifier
sub colour {
my ($pkg, $colour, %opts) = @_;
$opts{request} = $colour;
$opts{generator} = WK_RGB_COLOUR_GENERATOR;
return $pkg->generic(%opts);
}
#@returns Data::Identifier
sub date {
my ($pkg, $request, %opts) = @_;
my ($year, $month, $day);
my $precision;
if (ref($request)) {
if (eval {$request->can('epoch')}) {
$request = $request->epoch;
} else {
return $pkg->date(scalar($request->()), %opts);
}
}
($year, $month, $day) = $request =~ /^([12][0-9]{3})(?:-([01][0-9])(?:-([0-3][0-9]))?)?Z$/;
unless (length($year // '') == 4) {
if ($request eq 'now' || $request eq 'today') {
$request = time();
} elsif ($request =~ /^(?:0|-?[1-9][0-9]*)$/) {
$request = int($request);
if ($request > 32503680000) {
croak 'Unlikely far date given. Likely miliseconds are passed as seconds?';
}
} else {
croak 'Invalid format';
}
(undef,undef,undef,$day,$month,$year) = gmtime($request);
$year += 1900;
$month += 1;
}
foreach my $entry ($year, $month, $day) {
$entry = int($entry // 0);
}
croak 'Invalid year' if $year && ($year < 1583 || $year > 9999);
croak 'Invalid month' if $month && ($month < 1 || $month > 12);
croak 'Invalid day' if $day && ($day < 1 || $day > 31);
$month = 0 unless $year;
$day = 0 unless $month;
$precision = $opts{precision} // ($day ? 'day' : undef) // ($month ? 'month' : undef) // 'year';
lib/Data/Identifier/Generate.pm view on Meta::CPAN
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Data::Identifier::Generate - format independent identifier object
=head1 VERSION
version v0.36
=head1 SYNOPSIS
use Data::Identifier::Generate;
This module allows generation of instances of L<Data::Identifier> from common non-identifier values.
For generation of UUIDs from identifier values see L<Data::Identifier/uuid>.
The generated identifiers are of type UUID.
This can be used standalone if only an identifier for the given value is needed or as part of a generation logic.
The methods of this module might perform (limited and quick) checks for validity of the given data.
If a request is found invalid the method C<die>s.
However it is in the responsibility of the caller to ensure the data is correct. Any checks by this module
are solely meant as a last resort to finding obvious errors.
The method may also perform auto-correction. This may for example the case a obsolete value is passed and a
more current value is known.
See also:
L<Data::TagDB::Factory>.
=head1 METHODS
=head2 integer
my Data::Identifier $identifier = Data::Identifier::Generate->integer($int [, %opts] );
Creates an identifier for the given integer.
The following options (all optional) are supported:
=over
=item C<displayname>
The displayname as to be used for the identifier.
This is the same as defined by L<Data::Identifier/new>.
Defaults to the passed number.
=back
=head2 unicode_character
my Data::Identifier $identifier = Data::Identifier::Generate->unicode_character($type => $request [, %opts] );
# e.g.:
my Data::Identifier $identifier = Data::Identifier::Generate->unicode_character(unicode => 0x1F981);
# or:
my Data::Identifier $identifier = Data::Identifier::Generate->unicode_character(unicode => 'U+1F981');
Creates an identifier for the given unicode character.
The following types are supported:
=over
=item C<unicode>
The unicode code point as a number (e.g. C<0x1F981>) or as in the standard format (e.g. C<'U+1F981'>).
=item C<ascii>
The US-ASCII code point (e.g. C<65>).
=item C<raw>
A perl string with exactly one character. The character is
=back
The following options (all optional) are supported:
=over
=item C<allow_special>
If special characters are allowed.
This setting is a protection against false results,
specifically with C<REPLACEMENT CHARACTER> and similar characters.
Defaults to false.
=item C<displayname>
The displayname as to be used for the identifier.
This is the same as defined by L<Data::Identifier/new>.
Defaults to the data from the request.
=back
=head2 colour
my Data::Identifier $identifier = Data::Identifier::Generate->colour($colour [, %opts ] );
# e.g.:
my Data::Identifier $identifier = Data::Identifier::Generate->colour('#decc9c');
Generates an identifier for a given colour.
Currently the colour must be given as a string in form C<#RRGGBB>.
The following options (all optional) are supported:
=over
=item C<displayname>
The displayname as to be used for the identifier.
This is the same as defined by L<Data::Identifier/new>.
Defaults to the data from the request.
=back
B<Note:>
When L<Data::URIID::Colour> is loaded, it is used to generate a displaycolour value.
=head2 date
my Data::Identifier $identifier = Data::Identifier::Generate->date($date [, %opts ] );
( run in 0.456 second using v1.01-cache-2.11-cpan-aadc1410aed )