eric256 has asked for the wisdom of the Perl Monks concerning the following question:
I got the idea recently when looking at a recent obfuscation. The poster used eval to check if the all, any, none where true though and i didn't care for that much. It seemed a good chance to learn some operator overloading and module pratice so i sat down and coded away. I now have the following code and was hoping for a kind of peer reveiw. How does it look, any obvious problems etc. I have a test suite i've been running agianst it and a kinda play script and it seems well behaved. Comparisons between two sets (i.e. any(1..5) > all(1,3) result in a third set that evaluates true or false in boolean state, and has all the elements that made it either true or false. Here is the module:
package Func; use Data::Dumper; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(none any all); 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}->[int rand scalar @{$this->{data +}}] if $this->{type} eq 'any'; return ''; }, 'bool', sub {my $this = shift; return $this->{bool}; } ); use vars qw/ $comparisons /; 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 { handle( '$op', " . '@_' . ") };" +; }; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $type = shift || 'any'; return bless { type => $type , data => [@_], }, $class; } sub any { Func->new('any',@_); } sub all { Func->new('all',@_); } sub none { Func->new('none',@_); } sub true { my $self = shift; $self->{bool} = 1; return $self;} sub false { my $self = shift; $self->{bool} = 0; return $self;} sub handle { my ($how,$self,$compare, $reverse) = @_; my $true = all()->true(); my $false = 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; } 1;
Here is a script to test some features
use strict; use warnings; use Data::Dumper; use Func; print any(1..6) > all(1..3,5) , "\n"; my @numbers = (1..10); print any(@numbers) >= all(@numbers), "\n"; my $t = all('a' .. 'z') ne all('g','a','b'); print "These matched: $t \n" if $t; print "These caused the failure: $t\n" unless $t; my @admins = ("eric","wappoo","tony"); my $test = any(@admins); print "You are an admin.\n" if any(@admins) eq "eric"; print "There are scores over 5\n" if any(1 .. 5, 10) > 5; print "All scores are over 0\n" if all(1 .. 5, 10) > 0; print "Some scores are over last times scores \n" if any(1 .. 5, 10) > + all(3..7); print "No scores are over 100\n" if none(1 .. 5, 10) > 100; print "Any 1..10 = " . any(1..10) . "\n"; print "All 1..10 = " . all(1..10) . "\n"; print "Any " . any( qw/hi hello dude cool/ ) . "\n";
That script tests some but now all of the features (there is a test script but i will save you from it for now)
Any input and advice for a first time module writer would be greatly appreciated. I am also hoping to think of a name in the List::* area but nothing comes to mind at the moment. Thanks for taking the time to help.
|
|---|
| Replies are listed 'Best First'. | |
|---|---|
|
Re: List module providing any,all and none
by kvale (Monsignor) on Apr 15, 2004 at 17:49 UTC | |
by eric256 (Parson) on Apr 15, 2004 at 17:58 UTC | |
|
Re: List module providing any,all and none
by tilly (Archbishop) on Apr 15, 2004 at 17:48 UTC | |
by eric256 (Parson) on Apr 15, 2004 at 17:49 UTC | |
by Anonymous Monk on Apr 15, 2004 at 18:15 UTC | |
by eric256 (Parson) on Apr 15, 2004 at 18:56 UTC | |
by Anonymous Monk on Apr 15, 2004 at 20:56 UTC | |
|