# String::Random - Generates a random string from a pattern
# Copyright (C) 1999 Steven Pritchard <steve@silug.org>
#
# This program is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#
# $Id: Random.pm,v 1.8 1999/07/08 03:39:01 steve Exp $

package String::Random;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

use Exporter ();

@ISA = qw(Exporter);
@EXPORT_OK = qw(random_string);
$VERSION = '0.196';

use Carp;

use vars qw(@upper @lower @digit @punct @any @salt %patterns);

# These are the various character sets.
@upper=("A".."Z");
@lower=("a".."z");
@digit=("0".."9");
@punct=qw x~ ` ! @ $ % ^ & * ( ) - _ + = { } [ ] | \ : ; " ' . < > ? /x;
push(@punct, "#", ","); # To avoid warnings when using -w
@any=(@upper, @lower, @digit, @punct);
@salt=(@upper, @lower, @digit, ".", "/");

# What's important is how they relate to the pattern characters.
# This could be done with anonymous array references,
# but I tend to think that this is much more readable.
%patterns = ( 'C' => \@upper,
              'c' => \@lower,
	      'n' => \@digit,
	      '!' => \@punct,
	      '.' => \@any,
	      's' => \@salt,
	      "\\d" => \@digit,
	      "\\D" => [@upper, @lower, @punct],
	      "\\w" => [@upper, @lower, @digit, "_"],
	      "\\W" => \@punct
	    );

sub new
{
    my $proto=shift;
    my $class=ref($proto) || $proto;
    my $self;
    %{$self}=%patterns; # makes $self a reference to a *copy* of %patterns
    return bless($self, $class);
}

# Returns a random string based on a regular expression.
# In theory, it should return a list of random strings if
# passed a list of regular expressions, at least in a list
# context.  In a scalar context, it should probably return
# a single string, "@return_list" perhaps?
sub randregex
{
    my $self=shift;
    croak "called without a reference" if (!ref($self));

    my ($ch, @string, $string);

    my $pattern=shift;
    #print STDERR "\$pattern=\"$pattern\"\n"; # Debugging.

    # Split the characters in the pattern
    # up into a list for easier parsing.
    my @chars=split(//, $pattern);

    while (defined($ch=shift(@chars)))
    {
        #print STDERR "\$ch=\"$ch\"\n"; # Debugging.

	if ($ch eq "\\") # First we special-case out backslash.
	{
	    if (@chars)
	    {
	        my $tmp=shift(@chars);
                #print STDERR "\$tmp=\"$tmp\"\n"; # Debugging.
		if ($tmp=~/[A-CE-VX-Za-ce-vyz89]/)
		{
		    carp "'\\$tmp' being treated as literal '$tmp'";
		    push(@string, [$tmp]);
		}
		elsif ($tmp=~/[DWdw]/)
		{
		    $ch.=$tmp;
		    push(@string, $self->{$ch});
		}
		elsif ($tmp eq "x")
		{
		    # This is supposed to be a number in hex, so
		    # there had better be at least 2 characters left.
		    $tmp=shift(@chars) . shift(@chars);
		    push(@string, [chr(hex($tmp))]);
		}
		elsif ($tmp=~/[0-7]/)
		{
		    carp "octal parsing not implemented.  treating literally.";
		    push(@string, [$tmp]);
		}
		else
		{
		    push(@string, [$tmp]);
		}
	    }
	    else
	    {
		croak "regex not terminated";
	    }
	}
	elsif ($ch eq ".") # We treat "." as "any printable character".
	{
	    push(@string, $self->{$ch});
	}
	elsif ($ch eq "[") # Character classes.
	{
	    my @tmp;
	    while (defined($ch=shift(@chars)) && ($ch ne "]"))
	    {
		#print STDERR "\$ch=\"$ch\"\n"; # Debugging
		if (($ch eq "-") && @chars && @tmp)
		{
		    $ch=shift(@chars);
		    for (my $n=ord($tmp[$#tmp]);$n<ord($ch);$n++)
		    {
			push(@tmp, chr($n+1));
		    }
		}
		else
		{
		    carp "'$ch' will be treated literally inside []"
		        if ($ch=~/\W/);
		    push(@tmp, $ch);
		}
		#print STDERR "\@tmp=\"@tmp\"\n"; # Debugging
	    }
	    croak "unmatched []" if ($ch ne "]");
	    push(@string, \@tmp);
	}
	elsif ($ch eq "{") # Repetition.
	{
	    my($n, $closed);
	    for ($n=0;$n<scalar(@chars);$n++)
	    {
		if ($chars[$n] eq "}")
		{
		    $closed++;
		    last;
		}
	    }
	    if ($closed)
	    {
	        my $tmp;
	        while (defined($ch=shift(@chars)) && ($ch ne "}"))
	        {
		    croak "'$ch' inside {} not supported" if ($ch!~/\d/);
		    $tmp.=$ch;
	        }
		croak "number inside {} must be positive" if ($tmp<1);
		my $last=$string[$#string];
		for ($n=0;$n<($tmp-1);$n++)
		{
		    push(@string, $last);
		}
	    }
	    else
	    {
		# { isn't closed, so treat it literally.
		push(@string, [$ch]);
	    }
	}
	elsif ($ch=~/[\$\^\*\(\)\+\{\}\]\|\?]/)
	{
            # At least some of these probably should have special meaning.
	    carp "'$ch' not implemented.  treating literally.";
	    push(@string, [$ch]);
	}
	else
	{
	    push(@string, [$ch]);
	}
        #print STDERR "\@string=\"@{[map { @{$_} } @string]}\"\n"; # Debugging.
    }

    foreach $ch (@string)
    {
	$string.=$ch->[int(rand(scalar(@{$ch})))];
    }

    return $string;
}

sub from_pattern
{
    my $self=shift;
    croak "called without a reference" if (!ref($self));

    return $self->randpattern(@_);
}

sub randpattern
{
    my $self=shift;
    croak "called without a reference" if (!ref($self));

    my $string;

LOOP:
    my $pattern=shift;

    foreach (split(//, $pattern))
    {
	if (defined($self->{$_}))
	{
	    $string.=$self->{$_}->[int(rand(scalar(@{$self->{$_}})))];
	}
	else
	{
	    croak qq(Unknown pattern character "$_"!);
	}
    }
    goto LOOP if (@_); # Note that this was added as an afterthought, sorry.

    return $string;
}

sub random_string
{
    my($pattern,@list)=@_;

    my($n,%foo);

    %foo=%patterns;

    for ($n=0;$n<=$#list;$n++)
    {
	@{$foo{$n}}=@{$list[$n]};
    }

    return randpattern(\%foo, $pattern);
}

1;
__END__

=head1 NAME

String::Random - Perl module to generate random strings based on a pattern

=head1 SYNOPSIS

  use String::Random;
  $foo = new String::Random;
  print $foo->randregex('\d\d\d'); # Prints 3 random digits
  print $foo->randpattern("...");  # Prints 3 random printable characters

I<or>

  use String::Random qw(random_string);
  print random_string("..."); # Also prints 3 random characters

=head1 DESCRIPTION

This module makes it trivial to generate random strings.

As an example, let's say you are writing a script that needs to generate a
random password for a user.  The relevant code might look something like
this:

  use String::Random;
  $pass = new String::Random;
  print "Your password is ", $pass->randpattern("CCcc!ccn"), "\n";

This would output something like this:

  Your password is UDwp$tj5

=head2 Patterns

The pre-defined patterns are as follows:

  c	Any lowercase character [A-Z]
  C	Any uppercase character [a-z]
  n	Any digit [0-9]
  !	A punctuation character [~`!@$%^&*()-_+={}[]|\:;"'.<>?/#,]
  .	Any of the above
  s	A "salt" character [A-Za-z0-9./]

These can be modified, but if you need a different pattern it is better to
create another pattern, possibly using one of the pre-defined as a base.
For example, if you wanted a pattern C<A> that contained all upper and lower
case letters (C<[A-Za-z]>), the following would work:

  $foo = new String::Random;
  $foo->{'A'} = [ 'A'..'Z', 'a'..'z' ];

I<or>

  $foo = new String::Random;
  $foo->{'A'} = [ @{$foo->{'C'}}, @{$foo->{'c'}} ];

The random_string function, described below, has an alternative interface
for adding patterns.

=head2 Methods

=over 8

=item randpattern LIST

The randpattern method returns a random string based on the concatenation
of all the pattern strings in the list.

Please note that in a future revision, it will return a list of random
strings corresponding to the pattern strings when used in list context.

=item randregex LIST

The randregex method returns a random string that will match the regular
expression passed in the list argument.

Please note that the arguments to randregex are not real regular
expressions.  Only a small subset of regular expression syntax is actually
supported.  So far, the following regular expression elements are
supported:

  []	Character classes
  {}    Repetition
  \w    Alphanumeric + "_".
  \d    Digits.
  \W    Printable characters other than those in \w.
  \D    Printable characters other than those in \d.

Regular expression support is still very experimental.  Currently special
characters inside [] are not supported (with the exception of "-" to denote
ranges of characters).  The parser doesn't care for spaces in the "regular
expression" either.

=back

=head2 Functions

=over 8

=item random_string PATTERN,LIST

=item random_string PATTERN

When called with a single scalar argument, random_string returns a random
string using that scalar as a pattern.  Optionally, references to lists
containing other patterns can be passed to the function.  Those lists will
be used for 0 through 9 in the pattern (meaning the maximum number of lists
that can be passed is 10).  For example, the following code:

  print random_string("0101",
                      ["a", "b", "c"],
                      ["d", "e", "f"]), "\n";

would print something like this:

  cebd

=back

=head1 BUGS

As noted above, randpattern doesn't do the right thing when called in a
list context.  Whether it does the right thing in a scalar context when
passed a list is up for debate.

I don't even want to think about what kind of bugs might be in randregex
at this point.

=head1 AUTHOR

Steven Pritchard <steve@silug.org>

=head1 SEE ALSO

perl(1).

=cut
