package String::FriendlyID;

use warnings;
use strict;
use Moose;

=head1 NAME 

String::FriendlyID - A slightly modified perl port of Will Hardy's "Friendly ID" (http://www.djangosnippets.org/snippets/1249/) 

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.011';


=head1 SYNOPSIS

    use String::FriendlyID;

    my $fid = FriendlyID->new();
        # or set a size 
        #   my $fid = FriendlyID->new( size => 9999 )
        # or set a select chars to be used
        #   my $fid = FriendlyID->new( valid_chars => [ qw/A B C D 1 2 3/ ] )
        # or set both
        #   my $fid = FriendlyID->new( 
        #       valid_chars => [ qw/E F G H 4 5 6 7 8 9/ ], 
        #       size => 9999, 
        #   );
    my $some_string = '12345';
    my $friendly_id = $fid->encode($some_string);

=head1 SIGNIFICANCE / USES

=head2 Original Usage (excerpt from Will Hardy's pydoc)

"Description: Invoice numbers like "0000004" are unprofessional in that they 
expose how many sales a system has made, and can be used to monitor
the rate of sales over a given time.  They are also harder for 
customers to read back to you, especially if they are 10 digits long.  
These functions convert an integer (from eg an ID AutoField) to a
short unique string. This is done simply using a perfect hash
function and converting the result into a string of user friendly
characters."

=head2 Other Uses

=over 2

=item * URL Shortening

    use String::FriendlyID;

    my $domain = 'http://shorter.url/';
    my $fid = FriendlyID->new();
    my $some_url = 'http://somedomain.com/with/a/very/long/url/i/dont/know/why/';
    my $short_code = $fid->encode($some_url);
    my $short_url = join( '/', $domain, $short_code );

=item * Unique Coupon / Promo Code

    use String::FriendlyID;

    my $nickname = 'Atan';
    my $phone_number = '09177654321';
    my $unique_identifier = join( '-', $nickname, $phone_number );
    my $coupon_code_generator_tied_to_id = FriendlyID->new();
    my $coupon_code = $coupon_code_generator_tied_to_id->encode( $unique_identifier );

    store_in_coupon_db($coupon_code);

=back

=head1 ATTRIBUTES

=head2 valid_chars 

Default: [ qw/3 4 5 6 7 8 9 A C D E F G H J K L Q R S T U V W X Y/ ]

Alpha numeric characters, only uppercase, no confusing values (eg 1/I,0/O,Z/2) 
Remove some letters if you prefer more numbers in your strings
You may wish to remove letters that sound similar, to avoid confusion when a
customer calls on the phone (B/P, M/N, 3/C/D/E/G/T/V)

=cut

has 'valid_chars' => (
    is              => 'ro',
    isa             => 'ArrayRef',
    lazy            => 1,
    default         => sub { [ qw/3 4 5 6 7 8 9 A C D E F G H J K L Q R S T U V W X Y/ ] },
);

=head2 size

Default: 999999999999

Keep this small for shorter strings, but big enough to avoid changing
it later.

=cut

has 'size' => (
    is              => 'ro',
    isa             => 'Int',
    lazy            => 1,
    default         => sub { 999999999999 },
);

=head2 period

Automatically find a suitable period to use.
Factors are best, because they will have 1 left over when 
dividing SIZE+1.
This only needs to be run once, on import.

=cut

has 'period' => (
    is              => 'ro',
    isa             => 'Int',
    lazy            => 1,
    default         => sub {

        my $self   = shift;

        # The highest acceptable factor will be the square root of the size.
        my $highest_acceptable_factor = int(sqrt(int($self->size))); 

        # my $end = (int(length($self->valid_chars)) > 14) && (int(length($self->valid_chars))/2) || 13; 
        my $end = (length($self->valid_chars) > 14) ? int(length($self->valid_chars))/2 : 13; 
        my $start_point = 8;
        my @candidates = ();
        foreach (reverse $start_point..$end) {
            next unless (defined($_));
            push @candidates,$_;
        } 

        my $end_point = $highest_acceptable_factor; 
        $start_point = int($end)+2;
        foreach (reverse $start_point..$end_point) {
            next unless (defined($_));
            push @candidates,$_;
        } 

        $end_point = 6; 
        $start_point = 2;
        foreach (reverse $start_point..$end_point) {
            next unless (defined($_));
            push @candidates,$_;
        } 

        foreach my $p (@candidates){
            if ((int($self->size) % $p) == 0){
                return $p;
            }
        }

        warn "No valid period could be found for" . $self->size . "Try avoiding prime numbers!";
        return undef;

    },
);

=head1 SUBROUTINES/METHODS

=head2 friendly_number

Convert a base 10 number to a base X string.
Characters from valid_chars are chosen, to convert the number 
to eg base 24, if there are 24 characters to choose from.
Use valid chars to choose characters that are friendly, avoiding
ones that could be confused in print or over the phone.

=cut

sub friendly_number {
    my $self   = shift;
    my $num    = shift; 

    my $string = '';

    do {
        my $x = int($num) % int(scalar(@{$self->valid_chars}));
        $string = join('', $self->valid_chars->[int($x)], $string);
        $num = int($num) / int(scalar(@{$self->valid_chars}));
    } while ( ( int(scalar(@{$self->valid_chars})) ** int(length($string)) ) <= $self->size );

    return $string;
}

=head2 perfect_hash

Translate a string to another unique string, using a perfect hash function.
Only meaningful where 0 <= num <= SIZE.

=cut

sub perfect_hash {
    my $self   = shift;
    my $num    = shift; 

    # return ((num+OFFSET)*(SIZE/PERIOD)) % (SIZE+1) + 1
    my $offset = int($self->size) / (2 - 1);
    return (((int($num) + int($offset))*(int($self->size)/int($self->period))) % (int($self->size) + 1) + 1)

}


=head2 encode

Encode a simple number, using a perfect hash and converting to a 
more user friendly string of characters.

=cut

sub encode {
    my $self   = shift;
    my $num    = shift; 

    return ( ($num > $self->size) or ($num < 0) ) ? undef : $self->friendly_number( $self->perfect_hash($num) ); 

}

=head1 AUTHOR

Jonathan D. Gutierrez, C<< <atanation at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-friendlyid at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=FriendlyID>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.


=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc String::FriendlyID


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=String-FriendlyID>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/String-FriendlyID>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/String-FriendlyID>

=item * Search CPAN

L<http://search.cpan.org/dist/String-FriendlyID/>

=back


=head1 ACKNOWLEDGEMENTS

Thanks to Will Hardy (http://www.djangosnippets.org/snippets/1249/) and his Friendly ID

=head1 LICENSE AND COPYRIGHT

Copyright 2010 Jonathan D. Gutierrez.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

no Moose;
__PACKAGE__->meta->make_immutable;

1; # End of String::FriendlyID