File Coverage

blib/lib/String/Unique.pm
Criterion Covered Total %
statement 101 136 74.2
branch 14 32 43.7
condition 2 21 9.5
subroutine 14 17 82.3
pod 6 7 85.7
total 137 213 64.3


line stmt bran cond sub pod time code
1             package String::Unique;
2              
3 4     4   103919 use warnings;
  4         9  
  4         118  
4 4     4   18 use strict;
  4         16  
  4         109  
5 4     4   18 use Carp;
  4         12  
  4         329  
6 4     4   3975 use Data::Dumper;
  4         41214  
  4         325  
7 4     4   32 use Digest::MD5 qw(md5_base64);
  4         8  
  4         225  
8              
9 4     4   19 use constant DEBUG => 0;
  4         6  
  4         11292  
10              
11             =head1 NAME
12              
13             String::Unique - A source of deterministic pseudorandom strings [DPS]. Objects
14             of this class will generate a series of DPS of a set length for a set 2 char
15             'salt' [similar to UNIX crypt's salt] and resettable string that is
16             assumed to be a date string [although this is not enforced].
17              
18             Note that if the date string is changed, the object resets itself and begins
19             to generate a new series for the new date string.
20              
21              
22             =head1 VERSION
23              
24             Version 1.10
25              
26             =cut
27              
28             our $VERSION = '1.10';
29              
30             =head1 SYNOPSIS
31              
32             use String::Unique;
33              
34             my $dayrefs = String::Unique->new({characterCount => 11, salt => 'AT',});
35             my $string = $dayrefs->getStringByIndex(9999);
36             ...
37              
38             =cut
39              
40             { # OO closure block
41              
42             my %charCount_of;
43             my %salt_of;
44             my %dateStructure_of;
45              
46             =pod
47              
48             =head1 METHODS
49              
50             =head2 new
51              
52             Class constructor new
53              
54             Requires a hash ref containing a salt, string length and date
55              
56             =cut
57              
58             sub new {
59 12     12 1 68 my ( $class, $parms ) = @_;
60 12         21 if (DEBUG) {
61             print STDERR "String::Unique::new($class,)\n ";
62             print STDERR Dumper($parms), "\n\n";
63             }
64 12 50 33     136 croak('A 2 character salt is required for object of this class')
65             unless ( exists( $parms->{salt} )
66             && ( $parms->{salt} =~ m{ \A \w \w \z }xms ) );
67 12 50       48 croak('A starting date is required for object of this class')
68             unless ( exists( $parms->{date} ) );
69 12 50 33     77 croak(
70             'characterCount is a required paramater for objects of this class')
71             unless ( exists( $parms->{characterCount} )
72             && $parms->{characterCount} );
73 12         42 $parms->{characterCount} =~ s{ [^\d] }{}xmsg; # only the digits, please
74 12 50       50 croak('Parameter characterCount must be numeric')
75             unless ( $parms->{characterCount} );
76 12 50       36 croak( 'Cowardly refusing to create a generator '
77             . 'producing less than 6 charactor strings' )
78             if ( $parms->{characterCount} < 6 );
79 12         19 my $self = bless \do { my $fly_wieght }, $class;
  12         49  
80 12         38 my $ident = $self->ident();
81 12         53 $salt_of{$ident} = $parms->{salt};
82 12         46 $charCount_of{$ident} = $parms->{characterCount};
83              
84 12         45 $self->_initializeDay( $parms->{date} );
85 12         14 if (DEBUG && DEBUG > 2) {
86             print STDERR Dumper($self), "\n\n";
87             print STDERR Dumper( \%dateStructure_of ),;
88             }
89 12         34 return $self;
90             }
91              
92             =pod
93              
94             =head2 reset
95              
96             Reset the day structure for date.
97              
98             =cut
99              
100             sub reset {
101 0     0 1 0 my ( $self, $date ) = @_;
102 0         0 if (DEBUG) {
103             print STDERR "String::Unique::reset(\$self, $date, ";
104             print STDERR ")\n";
105             }
106            
107 0         0 return $self->_initializeDay($date);
108             }
109              
110             =pod
111              
112             =head2 getStringByIndex
113              
114             Return the unique string in the [index] sequence for the given date or today is date
115             is not supplied. This seldom used class method is optimized for memory not speed.
116              
117              
118             =cut
119              
120             sub getStringByIndex {
121 10     10 1 54 my ( $self, $index, $date ) = @_;
122 10         13 if (DEBUG) {
123             print STDERR "String::Unique::getStringByIndex(\$self, $index, ";
124             print STDERR "$date" if defined $date;
125             print STDERR ")\n";
126             }
127 10         20 my $ident = $self->ident();
128              
129 10 50       37 if ( !exists $dateStructure_of{$ident}->{$date} ) {
130 10         34 $self->_initializeDay($date);
131             }
132 10         20 my $daystruct = $dateStructure_of{$ident}->{$date};
133 10         35 if (DEBUG && DEBUG > 2) {
134             print STDERR "DATE: $date\n";
135             print STDERR "\%dateStructure_of:", Dumper( \%dateStructure_of ),
136             "\n";
137             print STDERR "daystruct:", Dumper($daystruct), "\n\n";
138             }
139 10         31 while ( $daystruct->{INDEX} <= $index ) {
140 26585         47137 $self->_newUniqueString($date);
141             }
142              
143             # This is a wastefull sequential search for the index value
144 10         21 eval {keys %{ $daystruct->{STRINGS} }} ; # RESET the iterator!
  10         11  
  10         25  
145 10         18 while ( my ( $key, $value ) = each %{ $daystruct->{STRINGS} } ) {
  7860         17829  
146             # print STDERR "\$key => $key, \$value => $value, \$index => $index\n";
147 7860 100       13156 if ( $index == $value ) {
148 10         122 return $key;
149             }
150             }
151 0         0 croak "INDEX failure ", Dumper $daystruct;
152 0         0 return;
153             }
154              
155             =pod
156              
157             =head2 getIndexByString
158              
159             Return [index] for the unique string in the sequence for the given dat. This seldom used class method is optimized for memory not speed.
160              
161              
162             =cut
163              
164             sub getIndexByString {
165 0     0 1 0 my ( $self, $parms) = @_;
166 0         0 if (DEBUG) {
167             print STDERR "String::Unique::getIndexByString(\$self,\n";
168             print STDERR Dumper($parms);
169             print STDERR "\n)\n";
170             }
171              
172             return unless(
173 0 0 0     0 exists $parms->{target} && $parms->{target}
      0        
      0        
      0        
      0        
174             && exists $parms->{max} && $parms->{max}
175             && exists $parms->{date} && $parms->{date}
176             );
177              
178 0         0 my $index;
179 0         0 my $target = $parms->{target};
180 0         0 my $maxIndex = $parms->{max};
181 0         0 my $date = $parms->{date};
182 0         0 my $ident = $self->ident();
183              
184 0 0       0 if ( !exists $dateStructure_of{$ident}->{$date} ) {
185 0         0 $self->_initializeDay($date);
186             }
187 0         0 my $daystruct = $dateStructure_of{$ident}->{$date};
188 0         0 if (DEBUG && DEBUG > 2) {
189             print STDERR "DATE: $date\n";
190             print STDERR "\%dateStructure_of:", Dumper( \%dateStructure_of ),
191             "\n";
192             print STDERR "daystruct:", Dumper($daystruct), "\n\n";
193             }
194 0         0 eval {keys %{$daystruct->{STRINGS}};}; #Reset the iterator
  0         0  
  0         0  
195 0         0 while (my($str,$ndx) = each %{$daystruct->{STRINGS}}) {
  0         0  
196 0 0       0 if($str eq $target) {
197 0         0 return $ndx;
198             }
199             }
200 0         0 while ( $daystruct->{INDEX} < $maxIndex) {
201 0 0       0 if ($self->getNextString($date) eq $target) {
202 0         0 return ($daystruct->{INDEX} -1);
203             };
204             }
205              
206             # This is a wastefull sequential search for the index value
207 0         0 if (DEBUG) {
208             carp "INDEX failure ", Dumper $daystruct;
209             }
210 0         0 return;
211             }
212              
213             =pod
214              
215             =head2 getNextString
216              
217             The primary method of this class. In scalar context returns the next entry in the
218             daily queue of pseudorandom strings, in list context returns the next entry and
219             the day of year as a 3 digit string ie '012' == January 13th.
220              
221             =cut
222              
223             sub getNextString {
224 19     19 1 49 my ( $self, $date ) = @_;
225 19         21 if (DEBUG && DEBUG > 1) {
226             print STDERR "String::Unique::getNextString($self, $date)\n";
227             }
228 19         42 my $ident = $self->ident();
229 19 100       62 if ( !exists $dateStructure_of{$ident}->{$date} ) {
230 4         6 my @keys = keys %{ $dateStructure_of{$ident} };
  4         14  
231 4         7 for my $key (@keys) {
232 4         60 delete $dateStructure_of{$ident}->{$key};
233             }
234 4         12 $self->_initializeDay($date);
235             }
236 19         46 return $self->_newUniqueString($date);
237             }
238              
239             =pod
240              
241             =head2 _initializeDay
242              
243             Private class method; sets up the queue for date $datestring
244              
245             =cut
246              
247             sub _initializeDay {
248 26     26   38 my ( $self, $datestring ) = @_;
249 26         32 if (DEBUG) {
250             print STDERR "String::Unique::_initializeDay(\$self,$datestring)\n";
251             }
252 26         44 my $ident = $self->ident();
253 26         47 for my $ds (keys %{$dateStructure_of{$ident}}) {
  26         92  
254 10         39 delete $dateStructure_of{$ident}->{$ds};
255             }
256              
257             # Every date format string supplied generates a date structure
258             # which is a hash ref.
259             # The fields of this hash are as follows:
260             # SEED => the actual date string supplied, as formatted.
261             # OFFSET => the number of times we have called md5_base64
262             # for this sequence
263             # INDEX => the number of the current string in the sequence
264             # STRINGS => a hash of the strings generated to the resepctive INDEX
265              
266 26         184 $dateStructure_of{$ident}->{$datestring} = {
267             SEED => $datestring,
268             OFFSET => 0,
269             INDEX => 0,
270             STRINGS => {},
271             };
272             }
273              
274             =pod
275              
276             =head2 _newUniqueString
277              
278             Private class method; returns the next unique string in date: $datstring-s Queue
279              
280             =cut
281              
282             sub _newUniqueString {
283 26604     26604   32016 my ( $self, $datestring ) = @_;
284 26604         21922 if (DEBUG && DEBUG > 1) {
285             print STDERR "String::Unique::_newUniqueString(\$self,$datestring)\n";
286             }
287 26604         47135 my $ident = $self->ident();
288 26604 50       71253 croak "Request for string from non-initialized date"
289             unless ( exists $dateStructure_of{$ident}->{$datestring} );
290 26604         52288 my $daystruct = $dateStructure_of{$ident}->{$datestring};
291 26604         46454 my $canidate = $self->_randCharString($datestring);
292              
293             # This while loop is what makes entries in this series 'Unique'.
294 26604         79795 while ( exists $daystruct->{STRINGS}->{$canidate} ) {
295 0         0 $canidate = $self->_randCharString($datestring);
296             }
297 26604         72874 $daystruct->{STRINGS}->{$canidate} = $daystruct->{INDEX};
298 26604         27982 $daystruct->{INDEX}++;
299 26604         69735 return $canidate;
300             }
301              
302             =pod
303              
304             =head2 _randCharString
305              
306             Private class method; returns a candidate string
307              
308             =cut
309              
310             sub _randCharString {
311 26604     26604   30945 my ( $self, $datestring ) = @_;
312 26604         24010 if (DEBUG && DEBUG > 1) {
313             print STDERR "String::Unique::_randCharString(\$self,$datestring)\n";
314             }
315 26604         41507 my $ident = $self->ident();
316 26604 50       70049 croak "Request for string from non-initialized date"
317             unless ( exists $dateStructure_of{$ident}->{$datestring} );
318 26604         38181 my $daystruct = $dateStructure_of{$ident}->{$datestring};
319 26604         27755 my $rv = q{}; # Empty string to start
320 26604         53908 while ( length $rv < $charCount_of{$ident} ) {
321 35332         173836 $rv .=
322             md5_base64( $salt_of{$ident}
323             . sprintf( "%07d", $daystruct->{OFFSET}++ )
324             . $daystruct->{SEED} );
325 35332         306450 $rv =~ s{ [a-z+\/] }{}xmsg;
326             }
327             # print STDERR "\n\$charCount_of{\$ident} => $charCount_of{$ident}\n";
328 26604         48436 $rv = substr( $rv, 0, $charCount_of{$ident} );
329 26604         23469 if (DEBUG && DEBUG > 1) {
330             print STDERR " _randCharString returns $rv\n";
331             }
332 26604         56438 return $rv;
333             }
334              
335             =pod
336              
337             =head2 ident
338             Class method ident returns a string that uniquely identifies the object supplied
339              
340             =cut
341              
342             sub ident {
343 53287     53287 1 55169 my ($self) = @_;
344 53287         46023 if (DEBUG && DEBUG > 2) {
345             print STDERR "String::Unique::ident(\$self)\n";
346             print STDERR "$self\n";
347             }
348 53287 50       91928 return unless defined $self;
349 53287         102358 my $ident = "$self";
350              
351 53287 50       280630 if (
352             $ident =~ s{ \A [\w\=\:]+ \( 0x ([0-9a-f]+) \) .* \z}
353             {$1}xms
354             )
355             {
356 53287         111715 return $ident;
357             }
358 0         0 return;
359             }
360              
361             sub dump {
362 0     0 0 0 my ($self) = @_;
363 0         0 my $ident = $self->ident();
364 0         0 my $rv = {
365             charCount_of => $charCount_of{$ident},
366             salt_of => $salt_of{$ident},
367             dateStructure_of => $dateStructure_of{$ident},
368             };
369 0         0 return $rv;
370             }
371              
372              
373              
374             sub DESTROY {
375 12     12   1318 my ($self) = @_;
376 12         34 my $ident = $self->ident();
377 12         36 delete $charCount_of{$ident};
378 12         25 delete $salt_of{$ident};
379 12         9268 delete $dateStructure_of{$ident};
380 12         400 return 1;
381             }
382              
383              
384             }
385              
386             =head1 AUTHOR
387              
388             Christian Werner Sr, << >>
389              
390             =head1 BUGS
391              
392             Please report any bugs or feature requests to C, or through
393             the web interface at L. I will be notified, and then you'll
394             automatically be notified of progress on your bug as I make changes.
395              
396              
397             =head1 SUPPORT
398              
399             You can find documentation for this module with the perldoc command.
400              
401             perldoc String::Unique
402              
403              
404             You can also look for information at:
405              
406             =over 4
407              
408             =item * RT: CPAN's request tracker (report bugs here)
409              
410             L
411              
412             =item * AnnoCPAN: Annotated CPAN documentation
413              
414             L
415              
416             =item * CPAN Ratings
417              
418             L
419              
420             =item * Search CPAN
421              
422             L
423              
424             =back
425              
426             =head1 ACKNOWLEDGEMENTS
427              
428             This module was adopted from the module Unique by the same author,
429             developed for Wells Fargo, see license and copyright
430              
431             =head1 COPYRIGHT & LICENSE
432              
433             Copyright 2007,2008 Wells Fargo, all rights reserved.
434             Copyright 2011 Christian Werner Sr.
435              
436             This program is free software; you can redistribute it and/or modify it
437             under the same terms as Perl itself.
438              
439             =cut
440              
441             1; # End of String::Unique