File Coverage

blib/lib/Sqids.pm

Criterion	Covered	Total	%
statement	124	124	100.0
branch	48	52	92.3
condition	9	9	100.0
subroutine	19	19	100.0
pod	2	7	28.5
total	202	211	95.7

package Sqids;
use 5.008001;
use strict;
use warnings;
use bignum;
use Carp 'croak';
use Encode qw(encode_utf8);
use List::Util qw(first min reduce);
use Sqids::Constants;
use Class::Tiny {
    alphabet => Sqids::Constants::DEFAULT_ALPHABET,
    min_length => Sqids::Constants::DEFAULT_MIN_LENGTH,
    blocklist => sub { Sqids::Constants::DEFAULT_BLOCKLIST },
};

our $VERSION = "0.03";

sub BUILD {
    my ($self, $args) = @_;

    my $alphabet = $self->alphabet;
    my $min_length = $self->min_length;
    my $blocklist = $self->blocklist;

    croak 'Alphabet cannot contain multibyte characters' if length $alphabet != length encode_utf8 $alphabet;

    croak 'Alphabet length must be at least 3' if length $alphabet < 3;

    my %alphabet_hash = map { $_ => undef } split '', $alphabet;
    croak 'Alphabet must contain unique characters' if keys %alphabet_hash != length $alphabet;

    my $min_length_limit = 255;
    croak "Minimum length has to be between 0 and $min_length_limit" if $min_length < 0 || $min_length > $min_length_limit;

    # clean up blocklist:
    # 1. all blocklist words should be lowercase
    # 2. no words less than 3 chars
    # 3. if some words contain chars that are not in the alphabet, remove those
    my $alphabet_lower = quotemeta lc $alphabet;
    @$blocklist =
        grep { length >= 3 && /^[$alphabet_lower]+$/ }
        map { lc } @$blocklist;

    $self->alphabet($self->shuffle($alphabet));
}

# Encodes an array of unsigned integers into an ID
#
# These are the cases where encoding might fail:
# - One of the numbers passed is smaller than 0
# - An n-number of attempts has been made to re-generated the ID, where n is alphabet length + 1
#
# @param {array.} numbers Non-negative integers to encode into an ID (or an arrayref)
# @returns {string} Generated ID

sub encode {
    my ($self, @numbers) = @_;

    # if no numbers passed, return an empty string
    return '' unless @numbers;

    # Convert to array if arrayref provided
    @numbers = @{$numbers[0]} if ref $numbers[0] eq 'ARRAY';

    croak "Encoding only supports non-negative numbers" if first { $_ < 0 } @numbers;

    return $self->_encode_numbers(0, @numbers);
}

# Internal function that encodes an array of unsigned integers into an ID
#
# @param {number} increment An internal number used to modify the `offset` variable in order to re-generate the ID
# @param {array.} numbers Non-negative integers to encode into an ID
# @returns {string} Generated ID

sub _encode_numbers {
    my ($self, $increment, @numbers) = @_;

    # if increment is greater than alphabet length, we've reached max attempts
    my $alphabet = $self->alphabet;
    my $length = length $alphabet;
    croak 'Reached max attempts to re-generate the ID' if $increment > $length;

    # get a semi-random offset from input numbers
    my $offset = @numbers;
    for (0..$#numbers) {
        $offset += ord(substr($alphabet, $numbers[$_] % $length, 1)) + $_;
    }

    # if there is a non-zero `increment`, it's an internal attempt to re-generated the ID
    $offset = ($offset + $increment) % $length;

    # re-arrange alphabet so that second-half goes in front of the first-half
    $alphabet = substr($alphabet, $offset) . substr($alphabet, 0, $offset);

    # `prefix` is the first character in the generated ID, used for randomization
    my $prefix = substr($alphabet, 0, 1);

    # reverse alphabet (otherwise for [0, x] `offset` and `separator` will be the same char)
    $alphabet = reverse $alphabet;

    # final ID will always have the `prefix` character at the beginning
    my @ret = ($prefix);

    # encode input array
    for (0..$#numbers) {
        # the first character of the alphabet is going to be reserved for the `separator`
        push @ret, $self->to_id($numbers[$_], substr($alphabet, 1));

        # if not the last number
        if ($_ < @numbers - 1) {
            # `separator` character is used to isolate numbers within the ID
            push @ret, substr($alphabet, 0, 1);

            # shuffle on every iteration
            $alphabet = $self->shuffle($alphabet);
        }
    }

    # join all the parts to form an ID
    my $id = join('', @ret);

    # handle `min_length` requirement, if the ID is too short
    if ($self->min_length > length $id) {
        # append a separator
        $id .= substr($alphabet, 0, 1);

        # keep appending `separator` + however much alphabet is needed
        # for decoding: two separators next to each other is what tells us the rest are junk characters
        while ($self->min_length - length $id > 0) {
            $alphabet = $self->shuffle($alphabet);
            $id .= substr($alphabet, 0, min(length $alphabet, $self->min_length - length $id));
        }
    }

    # if ID has a blocked word anywhere, restart with a +1 increment
    if ($self->is_blocked_id($id)) {
        $id = $self->_encode_numbers($increment + 1, @numbers);
    }

    return $id;
}

# Decodes an ID back into an array of unsigned integers
#
# These are the cases where the return value might be an empty array:
# - Empty ID / empty string
# - Non-alphabet character is found within ID
#
# @param {string} id Encoded ID
# @returns {array.} Array of unsigned integers

sub decode {
    my ($self, $id) = @_;

    return if $id eq '';
    return unless defined wantarray;

    # if a character is not in the alphabet, return
    my $alphabet = quotemeta $self->alphabet;
    return if $id =~ /[^$alphabet]/;

    # first character is always the `prefix`
    my $prefix = substr($id, 0, 1);

    # `offset` is the semi-random position that was generated during encoding
    my $offset = index $self->alphabet, $prefix;

    # re-arrange alphabet back into its original form
    $alphabet = substr($self->alphabet, $offset) . substr($self->alphabet, 0, $offset);

    # reverse alphabet
    $alphabet = reverse $alphabet;

    # now it's safe to remove the prefix character from ID, it's not needed anymore
    $id = substr($id, 1);

    # decode
    my @ret;
    while (length $id) {
        my $separator = substr($alphabet, 0, 1);

        # we need the first part to the left of the separator to decode the number
        my @chunks = split /\Q$separator\E/, $id, -1;
        if (@chunks) {
            # if chunk is empty, we are done (the rest are junk characters)
            return @ret if $chunks[0] eq '';

            # decode the number without using the `separator` character
            push @ret, $self->to_number($chunks[0], substr($alphabet, 1));

            # if this ID has multiple numbers, shuffle the alphabet because that's what encoding function did
            if (@chunks > 1) {
                $alphabet = $self->shuffle($alphabet);
            }
        }

        # `id` is now going to be everything to the right of the `separator`
        $id = join($separator, @chunks[1..$#chunks]);
    }

    return wantarray ? @ret : @ret == 1 ? $ret[0] : \@ret;
}

# consistent shuffle (always produces the same result given the input)
sub shuffle {
    my ($self, $alphabet) = @_;
    my @chars = split '', $alphabet;

    for (my ($i, $j) = (0, @chars-1); $j>0; $i++, $j--) {
        my $r = ($i * $j + ord($chars[$i]) + ord($chars[$j])) % @chars;
        @chars[$i,$r] = @chars[$r,$i];
    }

    return join('', @chars);
}

sub to_id {
    my ($self, $num, $alphabet) = @_;
    my @id;
    my $result = $num;
    my $length = length $alphabet;

    do {
        unshift @id, substr($alphabet, $result % $length, 1);
        $result = int($result / $length);
    } while ($result > 0);

    return join('', @id);
}

sub to_number {
    my ($self, $id, $alphabet) = @_;
    reduce { $a * length($alphabet) + index($alphabet, $b) } 0, split '', $id;
}

sub is_blocked_id {
    my ($self, $id) = @_;
    $id = lc $id;

    foreach my $word (@{$self->blocklist}) {
        # no point in checking words that are longer than the ID
        next unless length $word <= length $id;
        if (length $id <= 3 || length $word <= 3) {
            # short words have to match completely; otherwise, too many matches
            return 1 if $id eq $word;
        } elsif ($word =~ /\d/) {
            # words with leet speak replacements are visible mostly on the ends of the ID
            return 1 if $id =~ /^\Q$word\E/ || $id =~ /\Q$word\E$/;
        } elsif ($id =~ /\Q$word\E/) {
            # otherwise, check for blocked word anywhere in the string
            return 1;
        }
    }

    return 0;
}

1;
__END__