From: Yuval Kogman <nothingmuch@woobling.org>
Date: Sat, 15 Jul 2006 00:18:21 +0000 (+0000)
Subject: Iterators for Class::MOP
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7f22116397f82f3274c6381ce4b922430e147aeb;p=gitmo%2FClass-MOP.git

Iterators for Class::MOP
---

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 612642f..5b91132 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -14,6 +14,7 @@ our $VERSION = '0.16';
 use base 'Class::MOP::Module';
 
 use Class::MOP::Instance;
+use Class::MOP::Iterator;
 
 # Self-introspection 
 
@@ -311,7 +312,12 @@ sub superclasses {
         # 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 {
@@ -323,12 +329,25 @@ 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
@@ -486,7 +505,8 @@ sub remove_method {
 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 {
@@ -497,22 +517,36 @@ 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 {
@@ -609,7 +643,8 @@ sub remove_attribute {
 
 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 {
@@ -620,17 +655,32 @@ 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;    
 }
 
diff --git a/lib/Class/MOP/Iterator.pm b/lib/Class/MOP/Iterator.pm
new file mode 100644
index 0000000..dda6f2e
--- /dev/null
+++ b/lib/Class/MOP/Iterator.pm
@@ -0,0 +1,226 @@
+#!/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
+
+
diff --git a/t/001_basic.t b/t/001_basic.t
index a4b837c..db09ddd 100644
--- a/t/001_basic.t
+++ b/t/001_basic.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 19;
+use Test::More tests => 30;
 use Test::Exception;
 
 BEGIN {
@@ -35,6 +35,12 @@ is($Bar->version, undef, '... Bar->version == undef');
 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');
@@ -48,7 +54,17 @@ is_deeply(
     [ $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(
diff --git a/t/003_methods.t b/t/003_methods.t
index d807876..147f876 100644
--- a/t/003_methods.t
+++ b/t/003_methods.t
@@ -203,7 +203,7 @@ is_deeply(
     
 is_deeply(
     [ sort { $a->{name} cmp $b->{name} } $Bar->compute_all_applicable_methods() ],
-    [
+    [ sort { $a->{name} cmp $b->{name} }
         {
             name  => 'bang',
             class => 'Foo',
diff --git a/t/090_iterators.t b/t/090_iterators.t
new file mode 100644
index 0000000..456c2b6
--- /dev/null
+++ b/t/090_iterators.t
@@ -0,0 +1,65 @@
+#!/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",
+);
+