Data-Identifier
view release on metacpan or search on metacpan
lib/Data/Identifier/Generate.pm view on Meta::CPAN
minimum => '4.3',
);
my %_multiplicity_names = (
0 => 'noone',
1 => 'solo',
2 => 'duo',
3 => 'trio',
);
my %_multiplicity_generators = (
total => WK_MULTIPLICITY_GENERATOR,
minimum => WK_MINIMUM_MULTIPLICITY_GENERATOR,
);
my %_gte_simple_profiles = (
'ab332382-a6f8-4a24-914d-5f823dd866c1' => {
namespace => 'a13377a3-88d4-484e-90a8-245afb22a793',
order => 'MFHCSmfhcs',
case_folding => undef,
strip_slash => undef,
strip_spaces => undef,
},
'e537db94-85b9-4125-972a-cc2ea1fdf51d' => {
namespace => '52f20647-1dc7-4234-81ad-0639ab6cef60',
order => 'FAfa',
case_folding => undef,
strip_slash => undef,
strip_spaces => undef,
},
'60764502-18cb-41c9-8531-e4c8b43140b9' => {
namespace => '1e2edf8d-d459-47cb-9d6e-0690f404fadf',
order => 'MFHCSmfhcs',
case_folding => undef,
strip_slash => undef,
strip_spaces => undef,
},
'5aad9d75-7020-41a4-8ec6-2bf09566f985' => {
namespace => 'fc9741b4-2ac7-412b-9d36-2b675fc0482b',
order => 'NDTBndtb',
case_folding => undef,
strip_slash => undef,
strip_spaces => undef,
},
);
#@returns Data::Identifier
sub integer {
my ($pkg, $request, %opts) = @_;
$opts{request} = $request;
$opts{style} = 'integer-based';
$opts{namespace} = Data::Identifier->NS_INT();
$opts{displayname}//= $request;
$opts{generator} = $request >= 0 ? WK_UNSIGNED_INTEGER_GENERATOR : WK_SIGNED_INTEGER_GENERATOR;
return $pkg->generic(%opts);
}
sub unicode_character {
my ($pkg, $type, $request, %opts) = @_;
my $unicode_cp;
my $unicode_cp_str;
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};
}
$opts{displayname} //= $unicode_cp_str;
return Data::Identifier->new(unicodecp => $unicode_cp_str, displayname => $opts{displayname}, generator => WK_UNICODE_CHARACTER_GENERATOR, request => $unicode_cp_str);
}
#@returns Data::Identifier
sub colour {
my ($pkg, $colour, %opts) = @_;
$opts{request} = $colour;
$opts{style} = 'colour';
$opts{namespace} = '88d3944f-a13b-4e35-89eb-e3c1fbe53e76';
$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';
if ($precision eq 'day' && $day) {
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.30
=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
=head2 date
my Data::Identifier $identifier = Data::Identifier::Generate->date($date [, %opts ] );
Generates an identifier for a given date.
( run in 1.418 second using v1.01-cache-2.11-cpan-140bd7fdf52 )