File Coverage

blib/lib/List/Maker.pm

Criterion	Covered	Total	%
statement	88	89	98.8
branch	40	44	90.9
condition	39	48	81.2
subroutine	15	15	100.0
pod	1	1	100.0
total	183	197	92.8

package List::Maker;

our $VERSION = '0.005';

use warnings;
use strict;
use Carp;
use List::Util qw;

# Handle contextual returns
sub _context {
    # Return original list in list context...
    return @_ if (caller 1)[5];

    # Otherwise, Anglicize list...
    return ""                   if @_ == 0;
    return "$_[0]"              if @_ == 1;
    return "$_[0] and $_[1]"    if @_ == 2;

    my $sep = grep(/,/, @_) ? q{; } : q{, };
    return join($sep, @_[0..@_-2]) . $sep . "and $_[-1]";
}

# General filters that can be applied...
my %selector_sub = (
    pick => sub {
        return (shuffle @_)[0..shift()-1]
    },

    roll => sub {
        return map { $_[rand @_] } 1..shift;
    },

    all => sub {
        shift; return @_;
    },
);
# Regexes to parse the acceptable list syntaxes...
my $NUM      = qr{\s* [+-]? \d+ (?:\.\d*)? \s* }xms;
my $TO       = qr{\s* \.\. \s*}xms;
my $FILTER   = qr{ (?: : (?! \s* (?:pick|roll)) (.*?) )? }xms;
my $SELECTOR = qr{ (?: : \s* (pick|roll) \s* (\d*) )? \s* }xms;

# Mappings from specifications to handlers...
my @handlers = (
    # <1, 2 .. 10>
    { pat => qr{\A ($NUM) , ($NUM) ,? $TO (\^?) ($NUM) $FILTER $SELECTOR \Z}xms,
      gen => sub{ _gen_range({
                    from=>$1, to=>$4, by=>$2-$1, exto=>$3,
                    filter=>$5, selector => $6, count => $7,
                  })
             },
    },

    # <1 .. 10 by 2>
    { pat => qr{\A ($NUM) (\^?) $TO (\^?) ($NUM) (?:(?:x|by) ($NUM))? $FILTER $SELECTOR \Z}xms,
      gen => sub{ _gen_range({
                    from=>$1, to=>$4, by=>$5, exfrom=>$2, exto=>$3,
                    filter=>$6, selector => $7, count => $8,
                  });
             },
    },

    # <^7 by 2>
    { pat => qr{\A \s* \^ ($NUM) \s* (?:(?:x|by) \s* ($NUM))? $FILTER $SELECTOR \Z}xms,
      gen => sub{ _gen_range({
                    from=>0, to=>$1, by=>$2, exto=>1,
                    filter=>$3, selector => $4, count => $5,
                  });
             },
    },

    # <^@foo>
    { pat => qr{\A \s* \^ \s* ( (?:\S+\s+)* \S+) \s* \Z}xms,
      gen => sub{
                my $specification = $1;
                $specification =~ s{$SELECTOR \Z}{}x;
                my ($selector, $count) = ($selector_sub{$1||'all'}, $2||1);

                my @array = split /\s+/, $specification;
                $selector->($count, _gen_range( {from=>0, to=>@array-1}));
             },
    },

    # MINrMAX random range notation
    { pat => qr/^\s* ([+-]?\d+(?:[.]\d*)?|[.]\d+) \s* r \s* ([+-]?\d+(?:[.]\d*)?|[.]\d+) \s* $/xms,
      gen => sub {
        my ($min, $max) = ($1 < $2) ? ($1,$2) : ($2,$1);
        return $min + rand($max - $min);
      }
    },

    # NdS dice notation
    { pat => qr/^\s* (\d+(?:[.]\d*)?|[.]\d+) \s* d \s* (\d+(?:[.]\d*)?|[.]\d+) \s* $/xms,
      gen => sub {
        my ($count, $sides) = ($1, $2);

        # Non-integer counts require an extra random (partial) value...
        if ($count =~ /[.]/) {
            $count++;
        }

        # Generate random values...
        my @rolls = $sides =~ /[.]/ ? map { rand $sides} 1..$count
                  :                   map {1 + int rand $sides} 1..$count
                  ;

        # Handle a non-integer count by scaling final random (partial) value...
        if ($count =~ /([.].*)/) {
            my $fraction = $1;
            $rolls[-1] *= $fraction;
        }

        return @rolls if wantarray;
        return sum @rolls;
      }
    },

    # Perl 6 xx operator on 'strings'...
    { pat => qr/^ \s* ' ( [^']* ) ' \s* xx \s* (\d+) \s* $/xms,
      gen => sub {
        my ($string, $repetitions) = ($1, $2);
        return ($string) x $repetitions;
      }
    },

    # Perl 6 xx operator on "strings"...
    { pat => qr/^ \s* " ( [^"]* ) " \s* xx \s* (\d+) \s* $/xms,
      gen => sub {
        my ($string, $repetitions) = ($1, $2);
        return ($string) x $repetitions;
      }
    },

    # Perl 6 xx operator on numbers...
    { pat => qr/^ \s* ( [+-]?(?:\d+(?:\.\d*)?|\.\d+)(?:[eE][+-]?\d+)? ) \s* xx \s* (\d+) \s* $/xms,
      gen => sub {
        my ($number, $repetitions) = ($1, $2);
        return (0+$number) x $repetitions;
      }
    },
);

my %caller_expecting_special_behaviour;
my @user_handlers;

# This does the magic...
my $list_maker_sub = sub {
    my ($listspec) = @_;

    # If it doesn't match a special form, it's a < word list >...
    for my $handler (@user_handlers, @handlers) {
        next if $listspec !~ m{$handler->{pat} }xms;
        return $handler->{gen}();
    }

    return _context _qww($listspec);
};

sub import {
    shift; # Don't need package name
    my $caller = caller;

    # Note lexical scope of import...
    $^H{'List::Maker::is_active'} = 1;

    # Explicit export(s) requested...
    if (@_) {
        for my $name (@_) {
            no strict 'refs';
            *{$caller.'::'.$name} = $list_maker_sub;
        }
    }

    # Otherwise use 'glob' (to provide magic behaviour as well)...
    else {
        my ($package, $file) = caller;

        # Get as close to lexical behavior as per-5.10 will allow...
        $caller_expecting_special_behaviour{ $package, $file } = 1;

        no strict 'refs';
        *{$caller.'::glob'} = \&_glob_replacement;
    }
}

# Users can add their own handlers...
sub add_handler {
    while (my ($regex, $sub) = splice @_, 0, 2) {
        croak "Usage: List::Make::add_handler(qr/.../, sub{...})\nError"
            if ref($regex) ne 'Regexp' || ref($sub) ne 'CODE';
        push @user_handlers, { pat=>$regex, gen=>$sub };
    }
    return;
}



# This sub is used instead of globs the special behaviours...
no warnings 'redefine';
sub _glob_replacement {
    # Don't be magical in those files that haven't loaded the module...
    my ($package, $file, $scope_ref) = (caller 0)[0,1,10];

    # Check for lexical scoping (only works in 5.10 and later)...
    my $in_scope = $] < 5.010 || $scope_ref && $scope_ref->{'List::Maker::is_active'};

    # If not being magical...
    if (!$caller_expecting_special_behaviour{$package, $file} || !$in_scope ) {
        # Use any overloaded version of glob...
        goto &CORE::GLOBAL::glob if exists &CORE::GLOBAL::glob;

        # Otherwise, use the core glob behaviour...
        use File::Glob 'csh_glob';
        return &csh_glob;
    }

    # Otherwise, be magical...
    else {
        goto &{$list_maker_sub};
    }
};

# Generate a range of values, selected or filtered as appropriate...
sub _gen_range {
    my ($from, $to, $incr, $filter, $exfrom, $exto, $selector, $count)
        = @{shift()}{ qw };

    # Trim leading and trailing whitespace from endpoints...
    s/^ \s+ | \s+ $//gxms for $from, $to;

    # Default increment is +/- 1, depending on end-points...
    if (!defined $incr) {
        $incr = -($from <=> $to);
    }

    # Default count is 1...
    $count ||= 1;

    # Check for nonsensical increments (zero or the wrong sign)...
    my $delta = $to - $from;
    croak sprintf "Sequence <%s, %s, %s...> will never reach %s",
        $from, $from+$incr, $from+2*$incr, $to
            if $incr == 0 && $from != $to || $delta * $incr < 0;

    # Generate unfiltered list of values...
    $from += $incr if $exfrom;
    my @vals;
    #
    if ($incr==0) {
        @vals = $exto || $exfrom ? () : $from;
    }

    #
    elsif ($incr>0) {
        while (1) {
            last if  $exto && ($from >= $to || $from eq $to)
                 || !$exto && $from > $to;
            push @vals, $from;
            $from += $incr;
        }
    }

    #
    elsif ($incr<0) {
        while (1) {
            last if  $exto && ($from <= $to || $from eq $to)
                 || !$exto && $from < $to;
            push @vals, $from;
            $from += $incr;
        }
    }

    # Apply any filter before returning the values...
    if (defined $filter) {
        (my $trans_filter = $filter) =~ s/\b[A-Z]\b/\$_/g;
        @vals = eval "grep {package ".caller(2)."; $trans_filter } \@vals";
        croak "Bad filter ($filter): $@" if $@;
    }

    # Apply any selector before returning values...
    if (defined $selector) {
        @vals = $selector_sub{$selector}->($count, @vals);
    }

    return @vals;
};

# Simulate a Perl 6 <<...>> construct...
sub _qww {
    my ($content) = @_;

    # Strip any filter...
    $content =~ s{$SELECTOR \Z}{}x;
    my ($selector, $count) = ($selector_sub{$1||'all'}, $2||1);

    # Break into words (or "w o r d s" or 'w o r d s') and strip quoters...
    return $selector->( $count,
            grep { defined($_) }
                    $content =~ m{ " ( [^\\"]* (?:\\. [^\\"]*)* ) "
                                 | ' ( [^\\']* (?:\\. [^\\']*)* ) '
                                 |   ( \S+                      )
                                 }gxms
    );
}


1; # Magic true value required at end of module
__END__