use base 'Class::MOP::Module';
use Class::MOP::Instance;
+use Class::MOP::Iterator;
# Self-introspection
# we don't know about
$self->check_metaclass_compatability();
}
- @{$self->name . '::ISA'};
+
+ my @superclasses = @{$self->name . '::ISA'};
+
+ wantarray
+ ? @superclasses
+ : Class::MOP::Iterator->from_list( @superclasses );
}
sub class_precedence_list {
# suggestions are welcome.
{ ($self->name || return)->isa('This is a test for circular inheritance') }
# ... and now back to our regularly scheduled program
- (
- $self->name,
- map {
- $self->initialize($_)->class_precedence_list()
- } $self->superclasses()
- );
+
+ if ( wantarray ) {
+ return (
+ $self->name,
+ map {
+ $self->initialize($_)->class_precedence_list()
+ } $self->superclasses()
+ );
+ } else {
+ return Class::MOP::Iterator->cons(
+ $self->name,
+ Class::MOP::Iterator->flatten(
+ Class::MOP::Iterator->map(
+ sub { scalar($self->initialize($_)->class_precedence_list()) },
+ scalar($self->superclasses),
+ ),
+ ),
+ );
+ }
}
## Methods
sub get_method_list {
my $self = shift;
no strict 'refs';
- grep { $self->has_method($_) } keys %{$self->name . '::'};
+ my @methods = grep { $self->has_method($_) } keys %{$self->name . '::'};
+ wantarray ? @methods : Class::MOP::Iterator->from_list(@methods);
}
sub compute_all_applicable_methods {
# inheritence issues because we are
# using the &class_precedence_list
my (%seen_class, %seen_method);
- foreach my $class ($self->class_precedence_list()) {
- next if $seen_class{$class};
- $seen_class{$class}++;
- # fetch the meta-class ...
- my $meta = $self->initialize($class);
- foreach my $method_name ($meta->get_method_list()) {
- next if exists $seen_method{$method_name};
- $seen_method{$method_name}++;
- push @methods => {
- name => $method_name,
- class => $class,
- code => $meta->get_method($method_name)
- };
- }
- }
- return @methods;
+
+ my $i = Class::MOP::Iterator->flatten(
+ Class::MOP::Iterator->map(
+ sub {
+ my $class = shift;
+ my $meta = $self->initialize($class);
+
+ return Class::MOP::Iterator->map(
+ sub {
+ my $method_name = shift;
+ return {
+ name => $method_name,
+ class => $class,
+ code => $meta->get_method($method_name)
+ };
+ },
+ Class::MOP::Iterator->grep(
+ sub { !$seen_method{$_}++ },
+ scalar($meta->get_method_list),
+ ),
+ ),
+ },
+ Class::MOP::Iterator->grep(
+ sub { !$seen_class{$_}++ },
+ scalar($self->class_precedence_list()),
+ ),
+ ),
+ );
+
+ wantarray ? $i->all : $i;
}
sub find_all_methods_by_name {
sub get_attribute_list {
my $self = shift;
- keys %{$self->get_attribute_map};
+ my @attr_names = keys %{$self->get_attribute_map};
+ wantarray ? @attr_names : Class::MOP::Iterator->from_list(@attr_names);
}
sub compute_all_applicable_attributes {
# inheritence issues because we are
# using the &class_precedence_list
my (%seen_class, %seen_attr);
- foreach my $class ($self->class_precedence_list()) {
- next if $seen_class{$class};
- $seen_class{$class}++;
- # fetch the meta-class ...
- my $meta = $self->initialize($class);
- foreach my $attr_name ($meta->get_attribute_list()) {
- next if exists $seen_attr{$attr_name};
- $seen_attr{$attr_name}++;
- push @attrs => $meta->get_attribute($attr_name);
- }
- }
+
+ # FIXME
+ # i'm not sure attrs mask out each other even if their
+ # names are diff.
+ # while this is true for construction, it's not true for accessors
+
+ my $i = Class::MOP::Iterator->flatten(
+ Class::MOP::Iterator->map(
+ sub {
+ my $class = shift;
+ my $meta = $self->initialize($class);
+
+ return Class::MOP::Iterator->map(
+ sub { $meta->get_attribute($_) },
+ Class::MOP::Iterator->grep(
+ sub { !$seen_attr{$_}++ },
+ scalar($meta->get_attribute_list),
+ ),
+ );
+ },
+ Class::MOP::Iterator->grep(
+ sub { !$seen_class{$_}++ },
+ scalar($self->class_precedence_list()),
+ ),
+ ),
+ );
return @attrs;
}
--- /dev/null
+#!/usr/bin/perl
+
+package Class::MOP::Iterator;
+
+use strict;
+use warnings;
+
+use base 'Class::MOP::Module';
+
+sub meta {
+ require Class::MOP::Class;
+ Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
+}
+
+sub new {
+ my ( $class, %options ) = @_;
+
+ my @missing;
+ for ( qw/generator predicate/ ) {
+ push @missing, $_ unless $options{$_}
+ }
+ die "Missing: @missing" if @missing;
+
+ bless \%options, $class;
+}
+
+sub from_list {
+ my ( $class, @list ) = @_;
+ return $class->new(
+ generator => sub { shift @list },
+ predicate => sub { scalar(@list) },
+ __list => \@list,
+ );
+}
+
+sub concat {
+ my ( $class, @iters ) = @_;
+
+ my $next_iter;
+ my $get_next_iter = sub {
+ while ( !$next_iter or $next_iter->is_done ) {
+ undef $next_iter;
+ return unless @iters;
+ $next_iter = shift @iters;
+ }
+
+ return $next_iter;
+ };
+
+ return $class->new(
+ predicate => sub { ( $get_next_iter->() || return )->check_predicate },
+ generator => sub { ( $get_next_iter->() || return )->next },
+ );
+}
+
+sub cons {
+ my ( $class, $item, $iter ) = @_;
+
+ $class->new(
+ predicate => sub { 1 },
+ generator => sub {
+ my $self = shift;
+
+ # replace the current iter stuff for the next value
+ $self->predicate( $iter->predicate );
+ $self->generator( $iter->generator );
+
+ return $item;
+ },
+ );
+}
+
+sub map {
+ my ( $class, $map, @iters ) = @_;
+
+ my $caller = join(" ", (caller)[0 .. 2]);
+
+ my $iter = ( ( @iters == 1 ) ? $iters[0] : $class->concat(@iters) );
+
+ return $class->new(
+ predicate => sub { $iter->check_predicate },
+ generator => sub {
+ unless ( $iter->is_done ) {
+ my $next = $iter->next;
+ local $_ = $next;
+ return $map->($next);
+ }
+
+ return
+ },
+ );
+}
+
+sub grep {
+ my ( $class, $filter, @iters ) = @_;
+
+ my $iter = ( ( @iters == 1 ) ? $iters[0] : $class->concat(@iters) );
+
+ use Data::Dumper;
+ $Data::Dumper::Deparse = 1;
+ #warn "got iter to filter: ". Dumper($iter, $filter);
+
+ die Carp::longmess unless $iter->isa(__PACKAGE__);
+
+ my $have_next; # always know if there's a next match for predicate
+ my $next_value; # if we had to look ahead, this is where we keep it
+
+ my $filter_next = sub {
+ if ( !$have_next ) {
+ until ( $iter->is_done ) {
+ my $next = $iter->next;
+
+ local $_ = $next;
+ if ( $filter->( $next ) ) {
+ $have_next = 1;
+ return $next_value = $next;
+ }
+ }
+ }
+ };
+
+ return $class->new(
+ predicate => sub {
+ $filter_next->() unless $have_next;
+ return $have_next;
+ },
+ generator => sub {
+ $filter_next->() unless $have_next;
+ if ( $have_next ) {
+ $have_next = 0;
+ return $next_value;
+ } else {
+ return;
+ }
+ },
+ );
+}
+
+sub flatten {
+ my ( $class, @iters ) = @_;
+
+ my $iter_of_iters = ( ( @iters == 1 ) ? $iters[0] : $class->concat(@iters) );
+
+ my $next_iter;
+ my $get_next_iter = sub {
+ while ( !$next_iter or $next_iter->is_done ) {
+ undef $next_iter;
+ return if $iter_of_iters->is_done;
+ $next_iter = $iter_of_iters->next;
+ }
+
+ return $next_iter;
+ };
+
+ $class->new(
+ predicate => sub { ( $get_next_iter->() || return )->check_predicate },
+ generator => sub { ( $get_next_iter->() || return )->next },
+ );
+}
+
+sub predicate {
+ my $self = shift;
+ $self->{predicate} = shift if @_;
+ $self->{predicate};
+}
+
+sub generator {
+ my $self = shift;
+ $self->{generator} = shift if @_;
+ $self->{generator};
+}
+
+sub check_predicate {
+ my $self = shift;
+
+ my $pred = $self->predicate;
+ return $self->$pred(@_);
+}
+
+sub is_done {
+ my $self = shift;
+ not($self->check_predicate);
+}
+
+sub next {
+ my $self = shift;
+
+ my $gen = $self->generator;
+ $self->$gen(@_);
+}
+
+sub all {
+ my $self = shift;
+
+ my @ret;
+ push @ret, $self->next until $self->is_done;
+
+ return @ret;
+}
+
+__PACKAGE__;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Iterator - Composable iterators for Class::MOP return values.
+
+=head1 SYNOPSIS
+
+ use Class::MOP::Iterator;
+
+=head1 DESCRIPTION
+
+These are not the loveliest iterators since they are not purely functional.
+
+That ought to be fixed, but note that the predicate/generator are invoked as
+methods so that they may replace theselves.
+
+A nice alternative would be for someone to write L<Inline::GHC>.
+
+=cut
+
+
use strict;
use warnings;
-use Test::More tests => 19;
+use Test::More tests => 30;
use Test::Exception;
BEGIN {
is_deeply([$Foo->superclasses], [], '... Foo has no superclasses');
is_deeply([$Bar->superclasses], ['Foo'], '... Bar->superclasses == (Foo)');
+isa_ok( scalar($Foo->superclasses), "Class::MOP::Iterator" );
+is_deeply( [ $Foo->superclasses->all ], [], "no superclasses" );
+
+isa_ok( scalar($Bar->superclasses), "Class::MOP::Iterator" );
+is_deeply( [ $Bar->superclasses->all ], ['Foo'], "Bar superclasses in iter" );
+
$Foo->superclasses('UNIVERSAL');
is_deeply([$Foo->superclasses], ['UNIVERSAL'], '... Foo->superclasses == (UNIVERSAL) now');
[ $Bar->class_precedence_list ],
[ 'Bar', 'Foo', 'UNIVERSAL' ],
'... Bar->class_precedence_list == (Bar, Foo, UNIVERSAL)');
-
+
+my $i = $Bar->class_precedence_list;
+
+ok( !$i->is_done, "iterator not done" );
+is( $i->next, 'Bar', "next class in iterator" );
+ok( !$i->is_done, "iterator not done" );
+is( $i->next, 'Foo', "next class in iterator" );
+ok( !$i->is_done, "iterator not done" );
+is( $i->next, 'UNIVERSAL', "next class in iterator" );
+ok( $i->is_done, "iterator done" );
+
# create a class using Class::MOP::Class ...
my $Baz = Class::MOP::Class->create(
is_deeply(
[ sort { $a->{name} cmp $b->{name} } $Bar->compute_all_applicable_methods() ],
- [
+ [ sort { $a->{name} cmp $b->{name} }
{
name => 'bang',
class => 'Foo',
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+use Test::Deep;
+
+BEGIN {
+ use_ok("Class::MOP::Iterator");
+}
+
+my @lists = ( [ ], [qw/foo bar gorch/], [undef, 0, 1] );
+
+foreach my $list ( @lists ) {
+ is_deeply(
+ [ Class::MOP::Iterator->from_list(@$list)->all ],
+ $list,
+ "from list round trips",
+ );
+
+ foreach my $filter ( sub { defined($_) }, sub { $_ }, sub { no warnings 'uninitialized'; /foo/ }, sub { 0 } ) {
+ is_deeply(
+ [ Class::MOP::Iterator->grep( $filter, Class::MOP::Iterator->from_list(@$list) )->all ],
+ [ grep { $filter->() } @$list ],
+ "grep iterator vs list is the same",
+ );
+ }
+
+ foreach my $map ( sub { 42 }, sub { [$_] } ) {
+ is_deeply(
+ [ Class::MOP::Iterator->map( $map, Class::MOP::Iterator->from_list(@$list) )->all ],
+ [ map { $map->() } @$list ],
+ "map iterator vs list is the same",
+ );
+ }
+
+ is_deeply(
+ [ Class::MOP::Iterator->cons( "foo", Class::MOP::Iterator->from_list(@$list) )->all ],
+ [ "foo", @$list ],
+ "cons",
+ );
+
+}
+
+my @iters = map { Class::MOP::Iterator->from_list(@$_) } @lists;
+
+is_deeply(
+ [ Class::MOP::Iterator->concat( @iters )->all ],
+ [ map { @$_ } @lists ],
+ "concat",
+);
+
+# the hard way to concat ;-)
+is_deeply(
+ [ Class::MOP::Iterator->flatten(
+ Class::MOP::Iterator->map(
+ sub { Class::MOP::Iterator->from_list(@$_) },
+ Class::MOP::Iterator->from_list(@lists),
+ )
+ )->all ],
+ [ map { @$_ } @lists ],
+ "flatten",
+);
+
projects / gitmo/Class-MOP.git / commitdiff