package List::Junctions;

require Exporter;
@ISA    = qw(Exporter);   
@EXPORT = qw(none any all);

use strict;
use vars qw/ $comparisons $compute/;

use overload (   
    '@{}', sub { my $this = shift; return $this->{data}; },
    '""',  sub { my $this = shift;
                 return join($" , @{$this->{data}}) if $this->{type} e
+q 'all';
                 return $this->{data}->[rand @{$this->{data}}] if $thi
+s->{type} eq 'any';
                 return '';
               },
   'bool', sub {my $this = shift; return $this->{bool}; }
);

my @bins = qw(binary 3way_comparison num_comparison str_comparison);
foreach my $op (split " ", "@overload::ops{ @bins }") {
    $comparisons->{$op} = eval "sub { return shift() $op shift() }";
    eval "use overload '$op' => sub {compare( '$op', \@_) };";
};

@bins = qw(with_assign);
foreach my $op (split " ", "@overload::ops{ @bins }") {
    $compute->{$op} = eval "sub { return shift() $op shift() }";
    eval "use overload '$op' => sub { compute( '$op', \@_) };";
};

$comparisons->{regex} = sub { return regex(@_) };
  
sub new {
     my $class = shift;
   my $type  = shift || 'any';
   return bless { type => $type , data => [@_], }, $class;
}

sub any  { __PACKAGE__->new('any',@_); }
sub all  { __PACKAGE__->new('all',@_); }
sub none { __PACKAGE__->new('none',@_); }

sub true  { $_[0]->{bool} = 1; $_[0]; }
sub false { $_[0]->{bool} = 0; $_[0]; }

sub match { compare("regex",@_); }

sub compare {
    my ($how,$self,$compare, $reverse) = @_;
    my ($true,$false) = (all()->true(), all()->false());
    foreach my $item (@{$self->{data}}) {
        my $test = $reverse ? $comparisons->{$how}->($compare,$item) 
                            : $comparisons->{$how}->($item,$compare);

        if ($test) { push @{$true->{data}} , $item; }
          else     { push @{$false->{data}}, $item; }
    } 
    return $true if (($self->{type} eq 'none') && scalar @{$true}  == 
+0)
                 or (($self->{type} eq 'all')  && scalar @{$false} == 
+0)
                 or (($self->{type} eq 'any')  && scalar @{$true}  != 
+0);
    return $false;
}

sub compute {
    my ($how,$self,$compare, $reverse) = @_;
    my $new = __PACKAGE__->new($self->{type});
    foreach my $item (@{$self->{data}}) {
        my $new_item = $reverse ? $compute->{$how}->($compare,$item) 
                                : $compute->{$how}->($item,$compare);
        push @{$new->{data}}, $new_item;                              
+ 
    } 
    return $new;
}


sub regex {
    my ($item,$comparison) = @_;
    if (ref($item)             eq __PACKAGE__) {
       return $item->match($comparison);
    } elsif ( ref($comparison) eq __PACKAGE__) {
       return $comparison->match($item,1);
    } else {
       return $item =~ $comparison;
    }      
}
1;
[download]