File Coverage

blib/lib/Data/ULID.pm

Criterion	Covered	Total	%
statement	87	98	88.7
branch	15	26	57.6
condition	3	8	37.5
subroutine	25	27	92.5
pod	0	5	0.0
total	130	164	79.2

package Data::ULID;

use strict;
use warnings;

our $VERSION = '1.2.1';

use base qw(Exporter);
our @EXPORT_OK = qw/ulid binary_ulid ulid_date ulid_to_uuid uuid_to_ulid/;
our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );

use Time::HiRes qw/time/;
use Crypt::PRNG qw/random_bytes/;

use constant HAS_DATETIME => eval { require DateTime; 1 };

BEGIN {
    use Config;
    use constant CAN_SKIP_BIGINTS => $Config{ivsize} >= 8;

    if (!CAN_SKIP_BIGINTS) {
        require Math::BigInt;
        Math::BigInt->VERSION(1.999808);
        Math::BigInt->import(try => 'GMP,LTM');
    }
}

### EXPORTED ULID FUNCTIONS

sub ulid {
    return _encode(_ulid(shift));
}

sub binary_ulid {
    return _pack(_ulid(shift));
}

sub ulid_date {
    my $ulid = shift;

    die "ulid_date() requires DateTime module" unless HAS_DATETIME;
    die "ulid_date() needs a normal or binary ULID as parameter" unless $ulid;

    my ($ts, $rand) = _ulid($ulid);

    return DateTime->from_epoch(epoch => _unfix_ts($ts));
}

sub ulid_to_uuid {
    my $ulid = shift or die "Need ULID to convert";
    my $bin = _pack(_ulid($ulid));
    return _uuid_bin2str($bin)
}

sub uuid_to_ulid {
    my $uuid = shift or die "Need UUID to convert";
    my $bin_uuid = _uuid_str2bin($uuid);
    return _encode(_ulid($bin_uuid));
}

### HELPER FUNCTIONS

sub _uuid_bin2str {
    my $uuid = shift;

    return $uuid if length($uuid) == 36;
    die "Invalid uuid" unless length $uuid == 16;
    my @offsets = (4, 2, 2, 2, 6);

    return join(
        '-',
        map { unpack 'H*', $_ }
        map { substr $uuid, 0, $_, ''}
        @offsets);
}

sub _uuid_str2bin {
    my $uuid = shift;

    return $uuid if length $uuid == 16;
    $uuid =~ s/-//g;

    return pack 'H*', $uuid;
}

sub _ulid {
    my $arg = shift;
    my $ts;

    if ($arg) {
        if (ref $arg && $arg->isa('DateTime')) {
            $ts = $arg->hires_epoch;
        }
        elsif (length($arg) == 16) {
            return _unpack($arg);
        }
        else {
            $arg = _normalize($arg);
            die "Invalid ULID supplied: wrong length" unless length($arg) == 26;
            return _decode($arg);
        }
    }

    return (_fix_ts($ts || time()), random_bytes(10));
}

sub _pack {
    my ($ts, $rand) = @_;
    return _zero_pad($ts, 6, "\x00") . _zero_pad($rand, 10, "\x00");
}

sub _unpack {
    my ($ts, $rand) = unpack 'a6a10', shift;
    return ($ts, $rand);
}

sub _fix_ts {
    my $ts = shift;

    if (CAN_SKIP_BIGINTS) {
        $ts = int($ts * 1000);
        return pack 'Nn', $ts >> 16, $ts & 0xffff;
    } else {
        $ts .= '000';
        $ts =~ s/\.(\d{3}).*$/$1/;
        return Math::BigInt->new($ts)->to_bytes;
    }
}

sub _unfix_ts {
    my $ts = shift;

    if (CAN_SKIP_BIGINTS) {
        my ($high, $low) = unpack 'Nn', $ts;
        return (($high << 16) + $low) / 1000;
    } else {
        $ts = Math::BigInt->from_bytes($ts);
        $ts =~ s/(\d{3})$/.$1/;
        return $ts;
    }
}

sub _encode {
    my ($ts, $rand) = @_;
    return sprintf('%010s%016s', _encode_b32($ts), _encode_b32($rand));
}

sub _decode {
    my ($ts, $rand) = map { _decode_b32($_) } unpack 'A10A16', shift;
    return ($ts, $rand);
}

sub _zero_pad {
    # this function is used a lot. Keep it as lean as possible
    # my ($value, $character_multiplier, $padding_character) = @_;
    my $value = shift;

    my $padded = length($value) % $_[0];
    return $value if $padded == 0;

    $_[1] ||= 0;
    my $padding = substr $value, 0, $padded, '';

    return $value if $padding eq $_[1] x $padded;
    return $_[1] x ($_[0] - $padded) . $padding . $value;
}

### BASE32 ENCODER / DECODER

my $ALPHABET = '0123456789ABCDEFGHJKMNPQRSTVWXYZ';

my %ALPHABET_MAP = do {
    my $num = 0;
    map { $_ => substr sprintf('0000%b', $num++), -5 } split //, $ALPHABET;
};

my %ALPHABET_MAP_REVERSE = map { $ALPHABET_MAP{$_} => $_ } keys %ALPHABET_MAP;

sub _normalize {
    my $s = uc(shift);
    my $re = "[^$ALPHABET]";

    $s =~ s/$re//g;
    return $s;
}

sub _encode_b32 {
    my $bits = _zero_pad(unpack('B*', shift), 5);
    my $len = length $bits;

    my $result = '';
    for (my $i = 0; $i < $len; $i += 5) {
        $result .= $ALPHABET_MAP_REVERSE{substr $bits, $i, 5};
    }
    return $result;
}

sub _decode_b32 {
    my $encoded = join '', map { $ALPHABET_MAP{$_} } split //, uc shift;
    return pack 'B*', _zero_pad($encoded, 8);
}

1;

__END__