File Coverage

blib/lib/Number/RecordLocator.pm
Criterion Covered Total %
statement 58 58 100.0
branch 7 10 70.0
condition n/a
subroutine 10 10 100.0
pod 5 5 100.0
total 80 83 96.3


line stmt bran cond sub pod time code
1             package Number::RecordLocator;
2              
3             our $VERSION = '0.005';
4              
5 2     2   21586 use warnings;
  2         4  
  2         74  
6 2     2   11 use strict;
  2         3  
  2         65  
7 2     2   10 use Carp;
  2         9  
  2         173  
8 2     2   218154 use bigint;
  2         12159  
  2         10  
9              
10 2     2   129502 use vars qw/%CHAR_TO_INT %INT_TO_CHAR $INITIALIZED %CHAR_REMAP/;
  2         6  
  2         286  
11              
12             =head1 NAME
13              
14             Number::RecordLocator - Encodes integers into a short and easy to read and pronounce "locator string"
15              
16              
17             =head1 SYNOPSIS
18              
19             use Number::RecordLocator;
20              
21             my $generator = Number::RecordLocator->new();
22             my $string = $generator->encode("123456");
23              
24             # $string = "5RL2";
25              
26             my $number = $generator->decode($string);
27            
28             # $number = "123456";
29              
30            
31             =head1 DESCRIPTION
32              
33             C encodes integers into a 32 character "alphabet"
34             designed to be short and easy to read and pronounce. The encoding maps:
35            
36             0 to O
37             1 to I
38             S to F
39             B to P
40              
41             With a 32 bit encoding, you can map 33.5 million unique ids into a 5 character
42             code.
43            
44             This certainly isn't an exact science and I'm not yet 100% sure of the encoding.
45             Feedback is much appreciated.
46              
47              
48             =cut
49              
50              
51             =head2 new
52              
53             Instantiate a new C object. Right now, we don't
54             actually store any object-specific data, but in the future, we might.
55              
56              
57             =cut
58              
59             sub new {
60 2     2 1 992 my $class = shift;
61 2         5 my $self = {};
62 2         5 bless $self => $class;
63 2 50       15 $self->init unless ($INITIALIZED);
64 2         6 return $self;
65             }
66              
67              
68             =head2 init
69              
70             Initializes our integer to character and character to integer mapping tables.
71              
72             =cut
73              
74             sub init {
75              
76 2     2 1 5 my $counter = 0;
77 2         8 for ( 2 .. 9, 'A', 'C' .. 'R', 'T' .. 'Z' ) {
78 64         2430 $CHAR_TO_INT{$_} = $counter;
79 64         202 $INT_TO_CHAR{$counter} = $_;
80 64         8697 $counter++;
81             }
82              
83 2         74 $CHAR_REMAP{'0'} = 'O';
84 2         4 $CHAR_REMAP{'1'} = 'I';
85 2         4 $CHAR_REMAP{'S'} = 'F';
86 2         7 $CHAR_REMAP{'B'} = 'P';
87              
88 2         10 while (my ($from, $to) = each %CHAR_REMAP) {
89 8         40 $CHAR_TO_INT{$from} = $CHAR_TO_INT{$to};
90             }
91 2         14 $INITIALIZED = 1;
92             }
93              
94             =head2 encode INTEGER
95              
96             Takes an integer. Returns a Record Locator string.
97              
98             =cut
99              
100             sub encode {
101 6     6 1 1126 my $self = shift;
102 6         10 my $integer = shift;
103 6 100       31 return undef unless ($integer =~ /^\d+$/);
104 5         6 my @numbers;
105 5         17 while ( $integer != 0 ) {
106 24         2512 unshift @numbers, $integer % 32;
107 24         7033 $integer = int( $integer / 32 );
108             }
109              
110 5         491 my $str = join( '', map { $INT_TO_CHAR{$_} } @numbers );
  24         324  
111 5         128 return $str;
112             }
113              
114             =head2 decode STRING
115              
116             Takes a record locator string and returns an integer. If you pass in
117             a string containing an invalid character, it returns undef.
118              
119             =cut
120              
121             sub decode {
122 7     7 1 11 my $self = shift;
123 7         10 my $str = uc(shift);
124 7         8 my $integer = 0;
125 7         21 foreach my $char (split(//,$str)){
126 36         3163 my $char = $CHAR_TO_INT{$char};
127 36 50       68 return undef unless defined $char;
128 36         69 $integer = ($integer * 32) + $char;
129             }
130 7         754 return $integer;
131             }
132              
133             =head2 canonicalize STRING
134              
135             To compare a Record Locator string with another you can do:
136              
137             print "ALWAYS TRUE\n" if $generator->decode("B0") == $generator->decode("PO");
138              
139             However, this method provides an alternative:
140              
141             my $rl_string = $generator->encode(725);
142             print "ALWAYS TRUE\n" if $generator->canonicalize("b0") eq $rl_string;
143             print "ALWAYS TRUE\n" if $generator->canonicalize("BO") eq $rl_string;
144             print "ALWAYS TRUE\n" if $generator->canonicalize("P0") eq $rl_string;
145             print "ALWAYS TRUE\n" if $generator->canonicalize("po") eq $rl_string;
146              
147             This is primarily useful if you store the record locator rather than just the
148             original integer and don't want to have to decode your strings to do
149             comparisons.
150              
151             Takes a general Record Locator string and returns one with character mappings
152             listed in L applied to it. This allows string comparisons to work.
153             This returns C if a non-alphanumeric character is found in the string.
154              
155             =cut
156              
157             sub canonicalize {
158 4     4 1 10 my $self = shift;
159 4         9 my $str = uc(shift);
160 4         5 my $result = '';
161 4         10 for my $char (split(//,$str)) { # Would tr/// be better?
162 16 50       37 return undef unless defined $CHAR_TO_INT{$char};
163 16 100       30 my $char = defined $CHAR_REMAP{$char} ? $CHAR_REMAP{$char} : $char;
164 16         22 $result .= $char;
165             }
166 4         19 return $result;
167             }
168              
169             =head1 BUGS AND LIMITATIONS
170              
171             No bugs have been reported.
172              
173             Please report any bugs or feature requests to
174             C, or through the web interface at
175             L.
176              
177              
178             =head1 AUTHOR
179              
180             Jesse Vincent C<< >>
181              
182              
183             =head1 LICENCE AND COPYRIGHT
184              
185             Copyright (c) 2006, Best Practical Solutions, LLC. All rights reserved.
186              
187             This module is free software; you can redistribute it and/or
188             modify it under the same terms as Perl itself. See L.
189              
190             =cut
191              
192             1;