File Coverage

blib/lib/Data/RandomPerson.pm

Criterion	Covered	Total	%
statement	107	116	92.2
branch	39	42	92.8
condition			n/a
subroutine	23	23	100.0
pod	3	3	100.0
total	172	184	93.4

package Data::RandomPerson;

use strict;
use warnings;

use Data::Random qw(rand_date);
use Data::RandomPerson::Choice;
use Module::Find;

our $VERSION = '0.60';

sub new {
    my ( $class, %args ) = @_;

    my $self = bless {}, $class;

    ##
    ## Set up the defaults for the various name classes
    ## and see if they are being overwritten
    ##

    my $base_class = 'Data::RandomPerson::Names';

    my $male_class   = $base_class . '::Male';
    my $female_class = $base_class . '::Female';
    my $last_class   = $base_class . '::Last';

    foreach my $key ( sort keys %args ) {
        if ( lc $key eq 'male' ) {
            $male_class = $args{$key};
            delete( $args{$key} );
        }
        elsif ( lc $key eq 'female' ) {
            $female_class = $args{$key};
            delete( $args{$key} );
        }
        elsif ( lc $key eq 'last' ) {
            $last_class = $args{$key};
            delete( $args{$key} );
        }
        elsif ($key eq 'type') {
            $male_class   = $base_class . '::' . $args{$key} . 'Male';
            $female_class = $base_class . '::' . $args{$key} . 'Female';
            $last_class   = $base_class . '::' . $args{$key} . 'Last';
        }
        else {
            die "Unknown argument '$key' passed to new";
        }
    }

    ##
    ## Now load the classes
    ##

    eval "use $male_class;";
	die "Unable to load '$male_class': $@" if $@;

    eval "use $female_class;";
	die "Unable to load '$female_class': $@" if $@;

    eval "use $last_class;";
	die "Unable to load '$last_class': $@" if $@;

    $self->{mn} = $male_class->new();
    $self->{fn} = $female_class->new();
    $self->{ln} = $last_class->new();

    return $self;
}

################################################################################
# Subclass these if you want to change the gender, age and title calculated
################################################################################

sub _pick_gender {
    my ($self) = @_;

    return ( rand() < 0.5 ) ? 'm' : 'f';
}

sub _pick_age {
    my ($self) = @_;

    return int( rand() * 100 ) + 1;
}

sub _pick_title {
    my ($self) = @_;

    my $choice = Data::RandomPerson::Choice->new();

    if ( $self->{gender} eq 'm' ) {
        $choice->add( 'mr', 30 );
        $choice->add('dr')   if $self->{age} > 26;
        $choice->add('prof') if $self->{age} > 34;
        $choice->add('rev')  if $self->{age} > 34;
    }
    else {
        $choice->add('miss');
        $choice->add('ms') if $self->{age} > 16;
        $choice->add( 'mrs', 20 ) if $self->{age} > 16;
        $choice->add('dr')   if $self->{age} > 26;
        $choice->add('prof') if $self->{age} > 34;
        $choice->add('rev')  if $self->{age} > 34;
    }

    return ucfirst $choice->pick();
}

################################################################################
# These methods do not, typically, need to be overridden
################################################################################

sub _pick_lastname {
    my ($self) = @_;

    return $self->{ln}->get();
}

sub _pick_firstname {
    my ($self) = @_;

    return ( $self->{gender} eq 'm' ) ? $self->{mn}->get() : $self->{fn}->get();
}

sub _pick_dob {
    my ($self) = @_;

    my $year = ( localtime() )[5] + 1900 - $self->{age};
    my $dob  = rand_date(min => "$year-01-01", max => "$year-12-31");

    return $dob;
}

sub create {
    my ($self) = @_;

    ## These settings have no prerequisites

    $self->{gender}   = $self->_pick_gender();
    $self->{age}      = $self->_pick_age();
    $self->{dob}      = $self->_pick_dob();
    $self->{lastname} = $self->_pick_lastname();

    ## This setting requires gender

    $self->{firstname} = $self->_pick_firstname();

    ## This setting requires gender and age

    $self->{title} = $self->_pick_title();

    return { dob => $self->{dob}, gender => $self->{gender}, age => $self->{age}, firstname => $self->{firstname}, lastname => $self->{lastname}, title => $self->{title} };
}

sub available_types {
    my @backends = sort { $a cmp $b } findsubmod Data::RandomPerson::Names;
    my %backends = map {$_ => 1} @backends;
    my @available;
    for my $backend (grep {/Last$/} @backends) {
        if ($backend =~ /::(\w+)Last$/) {
            next if !$backends{'Data::RandomPerson::Names::' . $1 . 'Female'};
            next if !$backends{'Data::RandomPerson::Names::' . $1 . 'Male'};
            push @available, $1;
        }
    }
    return @available;
}

1;

__END__