File Coverage

blib/lib/String/FriendlyID.pm
Criterion Covered Total %
statement 29 29 100.0
branch 3 4 75.0
condition 1 3 33.3
subroutine 6 6 100.0
pod 3 3 100.0
total 42 45 93.3


line stmt bran cond sub pod time code
1             package String::FriendlyID;
2              
3 2     2   46261 use warnings;
  2         5  
  2         80  
4 2     2   10 use strict;
  2         5  
  2         47  
5 2     2   1179 use Mouse;
  2         48690  
  2         8  
6              
7             =head1 NAME
8              
9             String::FriendlyID - use this to convert an integer (from eg an ID AutoField) to a short unique "Friendly" string ( no confusing values like 1/I/l, 0/O , Z/2 )
10              
11             =head1 VERSION
12              
13             Version 1.000
14              
15             =cut
16              
17             our $VERSION = '1.000';
18              
19             =head1 SYNOPSIS
20              
21             use String::FriendlyID;
22              
23             my $fid = String::FriendlyID->new();
24             # or set a size
25             # my $fid = String::FriendlyID->new( size => 9999 )
26             # or set a select chars to be used
27             # my $fid = String::FriendlyID->new( valid_chars => [ qw/A B C D 1 2 3/ ] )
28             # or set both
29             # my $fid = String::FriendlyID->new(
30             # valid_chars => [ qw/E F G H 4 5 6 7 8 9/ ],
31             # size => 9999,
32             # );
33             my $some_numerical_string = '12345';
34             my $friendly_id = $fid->encode($some_numerical_string);
35              
36             =head1 DESCRIPTION / USES
37              
38             This is a slightly modified perl port of Will Hardy's "Friendly ID" (http://www.djangosnippets.org/snippets/1249/) that converts an integer (from eg an ID AutoField) to a short unique "Friendly" string or ID for that matter. Excerpting Will Hardy's description (from his pydoc):
39              
40             "Description: Invoice numbers like "0000004" are unprofessional in that they
41             expose how many sales a system has made, and can be used to monitor
42             the rate of sales over a given time. They are also harder for
43             customers to read back to you, especially if they are 10 digits long.
44             These functions convert an integer (from eg an ID AutoField) to a
45             short unique string. This is done simply using a perfect hash
46             function and converting the result into a string of user friendly
47             characters."
48              
49             String::FriendlyID keeps an arrayref of valid chars that it uses to construct the friendly ID (see "valid_chars" attribute), you can override this with whatever characters you want to include (see "valid_chars" attribute for the default values).
50              
51             =head1 ATTRIBUTES
52              
53             =head2 valid_chars
54              
55             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/ ]
56              
57             Alpha numeric characters, only uppercase, no confusing values (eg 1/I,0/O,Z/2)
58             Remove some letters if you prefer more numbers in your strings
59             You may wish to remove letters that sound similar, to avoid confusion when a
60             customer calls on the phone (B/P, M/N, 3/C/D/E/G/T/V)
61              
62             =cut
63              
64             has 'valid_chars' => (
65             is => 'ro',
66             isa => 'ArrayRef',
67             lazy => 1,
68             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/ ] },
69             );
70              
71             =head2 size
72              
73             Default: 999999999999
74              
75             Keep this small for shorter strings, but big enough to avoid changing
76             it later.
77              
78             =cut
79              
80             has 'size' => (
81             is => 'rw',
82             isa => 'Int',
83             lazy => 1,
84             default => sub { 999999999999 },
85             );
86              
87             =head2 period
88              
89             Automatically find a suitable period to use.
90             Factors are best, because they will have 1 left over when
91             dividing SIZE+1.
92             This only needs to be run once, on import.
93              
94             =cut
95              
96             has 'period' => (
97             is => 'ro',
98             isa => 'Int',
99             lazy => 1,
100             default => sub {
101              
102             my $self = shift;
103              
104             # The highest acceptable factor will be the square root of the size.
105             my $highest_acceptable_factor = int(sqrt(int($self->size)));
106              
107             # my $end = (int(length($self->valid_chars)) > 14) && (int(length($self->valid_chars))/2) || 13;
108             my $end = (length($self->valid_chars) > 14) ? int(length($self->valid_chars))/2 : 13;
109             my $start_point = 8;
110             my @candidates = ();
111             foreach (reverse $start_point..$end) {
112             next unless (defined($_));
113             push @candidates,$_;
114             }
115              
116             my $end_point = $highest_acceptable_factor;
117             $start_point = int($end)+2;
118             foreach (reverse $start_point..$end_point) {
119             next unless (defined($_));
120             push @candidates,$_;
121             }
122              
123             $end_point = 6;
124             $start_point = 2;
125             foreach (reverse $start_point..$end_point) {
126             next unless (defined($_));
127             push @candidates,$_;
128             }
129              
130             foreach my $p (@candidates){
131             if ((int($self->size) % $p) == 0){
132             return $p;
133             }
134             }
135              
136             warn "No valid period could be found for size=[" . $self->size . "], try avoiding prime numbers!";
137             return undef;
138              
139             },
140             );
141              
142             =head1 SUBROUTINES/METHODS
143              
144             =head2 friendly_number
145              
146             Convert a base 10 number to a base X string.
147             Characters from valid_chars are chosen, to convert the number
148             to eg base 24, if there are 24 characters to choose from.
149             Use valid chars to choose characters that are friendly, avoiding
150             ones that could be confused in print or over the phone.
151              
152             =cut
153              
154             sub friendly_number {
155 9     9 1 91097 my $self = shift;
156 9         14 my $num = shift;
157              
158 9         16 my $string = '';
159              
160             do {
161 81         103 my $x = int($num) % int(scalar(@{$self->valid_chars}));
  81         181  
162 81         245 $string = join('', $self->valid_chars->[int($x)], $string);
163 81         115 $num = int($num) / int(scalar(@{$self->valid_chars}));
  81         226  
164 9         14 } while ( ( int(scalar(@{$self->valid_chars})) ** int(length($string)) ) <= $self->size );
  81         325  
165              
166 9         76 return $string;
167             }
168              
169             =head2 perfect_hash
170              
171             Translate a string to another unique string, using a perfect hash function.
172             Only meaningful where 0 <= num <= SIZE.
173              
174             =cut
175              
176             sub perfect_hash {
177 7     7 1 11 my $self = shift;
178 7         10 my $num = shift;
179              
180             # return ((num+OFFSET)*(SIZE/PERIOD)) % (SIZE+1) + 1
181 7         36 my $offset = int($self->size) / (2 - 1);
182 7         60 return (((int($num) + int($offset))*(int($self->size)/int($self->period))) % (int($self->size) + 1) + 1)
183              
184             }
185              
186              
187             =head2 encode
188              
189             Encode a simple number, using a perfect hash and converting to a
190             more user friendly string of characters.
191              
192             =cut
193              
194             sub encode {
195 9     9 1 27 my $self = shift;
196 9         14 my $num = shift;
197              
198 9 100       49 if ($num =~ /\D/){
199 2         25 return '';
200             }
201              
202 7 50 33     94 return ( (int($num) > int($self->size)) or (int($num) < 0) ) ? '' : $self->friendly_number( $self->perfect_hash( int($num) ) );
203              
204             }
205              
206             =head1 AUTHOR
207              
208             Jonathan D. Gutierrez, C<< >>
209              
210             =head1 BUGS
211              
212             Please report any bugs or feature requests to C, or through
213             the web interface at L. I will be notified, and then you'll
214             automatically be notified of progress on your bug as I make changes.
215              
216              
217             =head1 SUPPORT
218              
219             You can find documentation for this module with the perldoc command.
220              
221             perldoc String::FriendlyID
222              
223              
224             You can also look for information at:
225              
226             =over 4
227              
228             =item * RT: CPAN's request tracker
229              
230             L
231              
232             =item * AnnoCPAN: Annotated CPAN documentation
233              
234             L
235              
236             =item * CPAN Ratings
237              
238             L
239              
240             =item * Search CPAN
241              
242             L
243              
244             =back
245              
246              
247             =head1 ACKNOWLEDGEMENTS
248              
249             Thanks to Will Hardy (http://www.djangosnippets.org/snippets/1249/) and his Friendly ID
250              
251             =head1 LICENSE AND COPYRIGHT
252              
253             Copyright 2010 Jonathan D. Gutierrez.
254              
255             This program is free software; you can redistribute it and/or modify it
256             under the terms of either: the GNU General Public License as published
257             by the Free Software Foundation; or the Artistic License.
258              
259             See http://dev.perl.org/licenses/ for more information.
260              
261              
262             =cut
263              
264             __PACKAGE__->meta->make_immutable;
265              
266             1; # End of String::FriendlyID