File Coverage

blib/lib/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

package Unique;

use warnings;
use strict;
use Carp;
use Data::Dumper;
use Digest::MD5 qw(md5_base64);

use constant DEBUG => 0;

=head1 NAME

Unique - A source of deterministic pseudorandom strings [DPS]. Objects of
this class will generate a series of DPS of a set length for a set 2 char
'salt' [similar to UNIX crypt's salt] and resettable string that is
assumed to be a date string [although this is not enforced].

Note that if the date string is changed, the object resets itself and begins
to generate a new series for the new date string.


=head1 VERSION

Version 1.02

=cut

our $VERSION = '1.02';

=head1 SYNOPSIS

    use Unique;

    my $dayrefs = Unique->new({characterCount => 11, salt => 'AT',});
    my $string = $dayrefs->getStringByIndex(9999);
    ...

=cut

{    # OO closure block

    my %charCount_of;
    my %salt_of;
    my %dateStructure_of;

=pod

=head1 METHODS

=head2 new

Class constructor new

Requires a hash ref containing a salt, string length and date

=cut

    sub new {
        my ( $class, $parms ) = @_;
        if (DEBUG) {
            print STDERR "Unique::new($class,)\n    ";
            print STDERR Dumper($parms), "\n\n";
        }
        croak('A 2 character salt is required for object of this class')
          unless ( exists( $parms->{salt} )
            && ( $parms->{salt} =~ m{ \A \w \w \z }xms ) );
        croak('A starting date is required for object of this class')
          unless ( exists( $parms->{date} ) );
        croak(
            'characterCount is a required paramater for objects of this class')
          unless ( exists( $parms->{characterCount} )
            && $parms->{characterCount} );
        $parms->{characterCount} =~ s{ [^\d] }{}xmsg;  # only the digits, please
        croak('Parameter characterCount must be numeric')
          unless ( $parms->{characterCount} );
        croak(  'Cowardly refusing to create a generator '
              . 'producing less than 6 charactor strings' )
          if ( $parms->{characterCount} < 6 );
        my $self = bless \do { my $fly_wieght }, $class;
        my $ident = $self->ident();
        $salt_of{$ident}      = $parms->{salt};
        $charCount_of{$ident} = $parms->{characterCount};

        $self->_initializeDay( $parms->{date} );
        if (DEBUG && DEBUG > 2) {
            print STDERR Dumper($self), "\n\n";
            print STDERR Dumper( \%dateStructure_of ),;
        }
        return $self;
    }

=pod

=head2 reset

Reset the day structure for date.

=cut

    sub reset {
        my ( $self, $date ) = @_;
        if (DEBUG) {
            print STDERR "Unique::reset(\$self, $date, ";
            print STDERR ")\n";
        }

	return $self->_initializeDay($date);
    }

=pod

=head2 getStringByIndex

Return the unique string in the [index] sequence for the given date or today is date
is not supplied. This seldom used class method is optimized for memory not speed.


=cut

    sub getStringByIndex {
        my ( $self, $index, $date ) = @_;
        if (DEBUG) {
            print STDERR "Unique::getStringByIndex(\$self, $index, ";
            print STDERR "$date" if defined $date;
            print STDERR ")\n";
        }
        my $ident = $self->ident();

        if ( !exists $dateStructure_of{$ident}->{$date} ) {
            $self->_initializeDay($date);
        }
        my $daystruct = $dateStructure_of{$ident}->{$date};
        if (DEBUG && DEBUG > 2) {
            print STDERR "DATE: $date\n";
            print STDERR "\%dateStructure_of:", Dumper( \%dateStructure_of ),
              "\n";
            print STDERR "daystruct:", Dumper($daystruct), "\n\n";
        }
        while ( $daystruct->{INDEX} <= $index ) {
            $self->_newUniqueString($date);
        }

        # This is a wastefull sequential search for the index value
	eval {keys %{ $daystruct->{STRINGS} }} ; # RESET the iterator!
        while ( my ( $key, $value ) = each %{ $daystruct->{STRINGS} } ) {
#	    print STDERR "\$key => $key, \$value => $value, \$index => $index\n";
            if ( $index == $value ) {
                return $key;
            }
        }
        croak "INDEX failure ", Dumper $daystruct;
        return;
    }

=pod

=head2 getIndexByString

Return  [index] for the unique string in the sequence for the given dat. This seldom used class method is optimized for memory not speed.


=cut

    sub getIndexByString {
        my ( $self, $parms) = @_;
        if (DEBUG) {
            print STDERR "Unique::getIndexByString(\$self,\n";
            print STDERR Dumper($parms);
            print STDERR "\n)\n";
        }

	return unless(
		      exists $parms->{target} && $parms->{target}
		      && exists $parms->{max} && $parms->{max}
		      && exists $parms->{date} && $parms->{date}
		      );

	my $index;
	my $target = $parms->{target};
	my $maxIndex = $parms->{max};
	my $date = $parms->{date};
        my $ident = $self->ident();

        if ( !exists $dateStructure_of{$ident}->{$date} ) {
            $self->_initializeDay($date);
        }
        my $daystruct = $dateStructure_of{$ident}->{$date};
        if (DEBUG && DEBUG > 2) {
            print STDERR "DATE: $date\n";
            print STDERR "\%dateStructure_of:", Dumper( \%dateStructure_of ),
              "\n";
            print STDERR "daystruct:", Dumper($daystruct), "\n\n";
        }
	eval {keys %{$daystruct->{STRINGS}};};  #Reset the iterator
	while (my($str,$ndx) = each %{$daystruct->{STRINGS}}) {
	    if($str eq $target) {
		return $ndx;
	    }
	}
        while ( $daystruct->{INDEX} < $maxIndex) {
            if ($self->getNextString($date) eq $target) {
		return ($daystruct->{INDEX} -1);
	    };
        }

        # This is a wastefull sequential search for the index value
        if (DEBUG) {
	    carp "INDEX failure ", Dumper $daystruct;
	}
        return;
    }

=pod

=head2 getNextString

The primary method of this class. In scalar context returns the next entry in the
daily queue of pseudorandom strings, in list context returns the next entry and
the  day of year as a 3 digit string ie '012' == January 13th.

=cut

    sub getNextString {
        my ( $self, $date ) = @_;
        if (DEBUG && DEBUG > 1) {
            print STDERR "Unique::getNextString($self, $date)\n";
        }
        my $ident = $self->ident();
        if ( !exists $dateStructure_of{$ident}->{$date} ) {
            my @keys = keys %{ $dateStructure_of{$ident} };
            for my $key (@keys) {
                delete $dateStructure_of{$ident}->{$key};
            }
            $self->_initializeDay($date);
        }
        return $self->_newUniqueString($date);
    }

=pod

=head2 _initializeDay

Private class method; sets up the queue for date $datestring

=cut

    sub _initializeDay {
        my ( $self, $datestring ) = @_;
        if (DEBUG) {
            print STDERR "Unique::_initializeDay(\$self,$datestring)\n";
        }
        my $ident = $self->ident();
	for my $ds (keys %{$dateStructure_of{$ident}}) {
	    delete $dateStructure_of{$ident}->{$ds};
	}

# Every date format string supplied generates a date structure
# which is a hash ref.
# The fields of this hash are as follows:
# SEED    => the actual date string supplied, as formatted.
# OFFSET  => the number of times we have called md5_base64
#            for this sequence
# INDEX   => the number of the current string in the sequence
# STRINGS => a hash of the strings generated to the resepctive INDEX

        $dateStructure_of{$ident}->{$datestring} = {
            SEED    => $datestring,
            OFFSET  => 0,
            INDEX   => 0,
            STRINGS => {},
        };
    }

=pod

=head2 _newUniqueString

Private class method; returns the next unique string in date: $datstring-s Queue

=cut

    sub _newUniqueString {
        my ( $self, $datestring ) = @_;
        if (DEBUG && DEBUG > 1) {
            print STDERR "Unique::_newUniqueString(\$self,$datestring)\n";
        }
        my $ident = $self->ident();
        croak "Request for string from non-initialized date"
          unless ( exists $dateStructure_of{$ident}->{$datestring} );
        my $daystruct = $dateStructure_of{$ident}->{$datestring};
        my $canidate  = $self->_randCharString($datestring);

# This while loop is what makes entries in this series 'Unique'.
        while ( exists $daystruct->{STRINGS}->{$canidate} ) {
            $canidate = $self->_randCharString($datestring);
        }
        $daystruct->{STRINGS}->{$canidate} = $daystruct->{INDEX};
        $daystruct->{INDEX}++;
        return $canidate;
    }

=pod

=head2 _randCharString

Private class method; returns a candidate string

=cut

    sub _randCharString {
        my ( $self, $datestring ) = @_;
        if (DEBUG && DEBUG > 1) {
            print STDERR "Unique::_randCharString(\$self,$datestring)\n";
        }
        my $ident = $self->ident();
        croak "Request for string from non-initialized date"
          unless ( exists $dateStructure_of{$ident}->{$datestring} );
        my $daystruct = $dateStructure_of{$ident}->{$datestring};
        my $rv = q{};    # Empty string to start
        while ( length $rv < $charCount_of{$ident} ) {
            $rv .=
              md5_base64( $salt_of{$ident}
                  . sprintf( "%07d", $daystruct->{OFFSET}++ )
                  . $daystruct->{SEED} );
            $rv =~ s{ [a-z+\/] }{}xmsg;
        }
#	print STDERR  "\n\$charCount_of{\$ident} => $charCount_of{$ident}\n";
        $rv = substr( $rv, 0, $charCount_of{$ident} );
        if (DEBUG && DEBUG > 1) {
            print STDERR "   _randCharString returns $rv\n";
        }
        return $rv;
    }

=pod

=head2 ident
Class method ident returns a string that uniquely identifies the object supplied

=cut

    sub ident {
        my ($self) = @_;
        if (DEBUG && DEBUG > 2) {
            print STDERR "Unique::ident(\$self)\n";
        }
        return unless defined $self;
        my $ident = "$self";
        if (
            $ident =~ s{ \A [\w\=]+ \( 0x ([0-9a-f]+) \) .* \z}
                       {$1}xms
          )
        {
            return $ident;
        }
        return;
    }

sub dump {
        my ($self) = @_;
        my $ident = $self->ident();
	my $rv = {
	    charCount_of  =>  $charCount_of{$ident},
	    salt_of =>  $salt_of{$ident},
	    dateStructure_of => $dateStructure_of{$ident},
	};
        return $rv;
    }



    sub DESTROY {
        my ($self) = @_;
        my $ident = $self->ident();
        delete $charCount_of{$ident};
        delete $salt_of{$ident};
        delete $dateStructure_of{$ident};
        return 1;
    }


}

=head1 AUTHOR

 Christian Werner Sr, <<  >>

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L.  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 Unique


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back


=head1 COPYRIGHT & LICENSE

Copyright 2007,2008 Wells Fargo, all rights reserved.
Copyright 2011 Christian Werner Sr.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;    # End of Unique