Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Half assed dispatch table support ripped from KiokuDB::TypeMap

  • Loading branch information...
commit 0fc71043565f615810a3c1061a9a5eff2bc9eb58 1 parent 13087d3
@nothingmuch authored
View
46 lib/Data/Visitor.pm
@@ -9,6 +9,8 @@ use Symbol ();
use Class::Load 'load_optional_class';
use Tie::ToObject;
+use Data::Visitor::DispatchTable;
+
no warnings 'recursion';
use namespace::clean -except => 'meta';
@@ -30,6 +32,24 @@ has weaken => (
default => 0,
);
+has dispatch_table => (
+ isa => "Data::Visitor::DispatchTable",
+ is => "ro",
+ lazy_build => 1,
+);
+
+sub _build_dispatch_table {
+ Data::Visitor::DispatchTable->new;
+}
+
+has _dispatch_table_cache => (
+ isa => "HashRef",
+ is => "ro",
+ lazy_build => 1,
+);
+
+sub _build__dispatch_table_cache { return {} }
+
sub trace {
my ( $self, $category, @msg ) = @_;
@@ -98,16 +118,30 @@ sub _register_mapping {
$self->{_seen}{ refaddr($data) } = $new_data;
}
+sub dispatch_table_entry_for {
+ my ( $self, $data ) = @_;
+
+ my $class = ref $data;
+
+ $self->_dispatch_table_cache->{$class} ||= $self->dispatch_table->resolve($class);
+}
+
sub visit_no_rec_check {
my ( $self, $data ) = @_;
- if ( blessed($data) ) {
- return $self->visit_object($_[1]);
- } elsif ( ref $data ) {
- return $self->visit_ref($_[1]);
+ if ( ref $data ) {
+ if ( my $dispatch_entry = $self->dispatch_table_entry_for($data) ) {
+ return $self->$dispatch_entry($_[1]);
+ } else {
+ if ( blessed($data) ) {
+ return $self->visit_object($_[1]);
+ } else {
+ return $self->visit_ref($_[1]);
+ }
+ }
+ } else {
+ return $self->visit_value($_[1]);
}
-
- return $self->visit_value($_[1]);
}
sub visit_object {
View
206 lib/Data/Visitor/DispatchTable.pm
@@ -0,0 +1,206 @@
+#!/usr/bin/perl
+
+package Data::Visitor::DispatchTable;
+use Moose;
+
+use MooseX::Types::Moose qw(ArrayRef HashRef Str CodeRef);
+use Moose::Util::TypeConstraints qw(duck_type);
+
+use Carp qw(croak);
+
+use namespace::autoclean;
+
+no warnings 'recursion';
+
+has [qw(entries isa_entries)] => (
+ isa => HashRef[CodeRef|Str],
+ is => "ro",
+ lazy_build => 1,
+);
+
+sub _build_entries { +{} }
+sub _build_isa_entries { +{} }
+
+has [qw(all_entries all_isa_entries)] => (
+ isa => HashRef,
+ is => "ro",
+ lazy_build => 1,
+);
+
+has all_isa_entry_classes => (
+ isa => ArrayRef[Str],
+ is => "ro",
+ lazy_build => 1,
+);
+
+has includes => (
+ isa => ArrayRef[duck_type([qw(resolve)])],
+ is => "ro",
+ lazy_build => 1,
+);
+
+sub _build_includes { [] }
+
+sub resolve {
+ my ( $self, $class ) = @_;
+
+ if ( my $entry = $self->all_entries->{$class} || $self->all_isa_entries->{$class} ) {
+ return $entry;
+ } else {
+ foreach my $superclass ( @{ $self->all_isa_entry_classes } ) {
+ if ( $class->isa($superclass) ) {
+ return $self->all_isa_entries->{$superclass};
+ }
+ }
+ }
+
+ return;
+}
+
+sub BUILD {
+ my $self = shift;
+
+ # verify that there are no conflicting internal definitions
+ my $reg = $self->entries;
+ foreach my $key ( keys %{ $self->isa_entries } ) {
+ if ( exists $reg->{$key} ) {
+ croak "isa entry $key already present in plain entries";
+ }
+ }
+
+ # Verify that there are no conflicts between the includesd type maps
+ my %seen;
+ foreach my $map ( @{ $self->includes } ) {
+ foreach my $key ( keys %{ $map->all_entries } ) {
+ if ( $seen{$key} ) {
+ croak "entry $key found in $map conflicts with $seen{$key}";
+ }
+
+ $seen{$key} = $map;
+ }
+
+ foreach my $key ( keys %{ $map->all_isa_entries } ) {
+ if ( $seen{$key} ) {
+ croak "isa entry $key found in $map conflicts with $seen{$key}";
+ }
+
+ $seen{$key} = $map;
+ }
+ }
+}
+
+sub _build_all_entries {
+ my $self = shift;
+
+ return {
+ map { %$_ } (
+ ( map { $_->all_entries } @{ $self->includes } ),
+ $self->entries,
+ ),
+ };
+}
+
+sub _build_all_isa_entries {
+ my $self = shift;
+
+ return {
+ map { %$_ } (
+ ( map { $_->all_isa_entries } @{ $self->includes } ),
+ $self->isa_entries,
+ ),
+ };
+}
+
+sub _build_all_isa_entry_classes {
+ my $self = shift;
+
+ return [
+ sort { !$a->isa($b) <=> !$b->isa($a) } # least derived first
+ keys %{ $self->all_isa_entries }
+ ];
+}
+
+__PACKAGE__->meta->make_immutable;
+
+__PACKAGE__
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Data::Visitor::DispatchTable - cleaner dispatch table support than Data::Visitor::Callback.
+
+=head1 SYNOPSIS
+
+ use Data::Visitor;
+
+ Data::Visitor->new(
+ dispatch_table => Data::Visitor::DispatchTable->new(
+ entries => {
+ Foo => sub { warn "I'm visiting $_[1] and its reftype is 'Foo'" },
+ },
+ isa_entries => {
+ Bar => visit_ref, # all objects that isa Bar will have their data violated
+ },
+ includes => [
+ # you can delegate to other dispatch tables too
+ $foo,
+ $bar,
+ ],
+ ),
+ );
+
+=head1 DESCRIPTION
+
+This code is ripped out of L<KiokuDB::TypeMap>.
+
+The mapping is by class, and entries can be keyed normally (using
+C<ref $object> equality) or by filtering on C<< $object->isa($class) >>
+(C<isa_entries>).
+
+Entries are anything that can be used as a method, i.e. strings used as method
+names on the visitor, or code references.
+
+=head1 ATTRIBUTES
+
+=over 4
+
+=item entries
+
+A hash of normal entries.
+
+=item isa_entries
+
+A hash of C<< $object->isa >> based entries.
+
+=item includes
+
+A list of parent typemaps to inherit entries from.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item resolve $class
+
+Given a class returns the dispatch table entry for that class.
+
+=item all_entries
+
+Returns the merged C<entries> from this typemap and all the included tables.
+
+=item all_isa_entries
+
+Returns the merged C<isa_entries> from this typemap and all the included
+tables.
+
+=item all_isa_entry_classes
+
+An array reference of all the classes in C<all_isa_entries>, sorted from least
+derived to most derived.
+
+=back
View
37 t/dispatch_table.t
@@ -0,0 +1,37 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::MockObject::Extends;
+
+use ok "Data::Visitor";
+
+my $v = Data::Visitor->new(
+ dispatch_table => Data::Visitor::DispatchTable->new(
+ entries => {
+ "Some::Class", => sub { $_->{count}++; $_ },
+ },
+ isa_entries => {
+ Bar => sub { $_->{count}++; $_ },
+ }
+ ),
+);
+
+{ package Bar };
+@Some::Other::Class::ISA = qw(Bar);
+
+my @things = ( "foo", 1, undef, 0, {}, [], do { my $x = "blah"; \$x }, my $ref = bless({}, "Some::Class"), my $isa = bless({}, "Some::Other::Class") );
+
+$v->visit($_) for @things; # no explosions in void context
+
+is( $ref->{count}, 1 );
+is( $isa->{count}, 1 );
+
+is_deeply( $v->visit( $_ ), $_, "visit returns value unlatered" ) for @things;
+
+is( $ref->{count}, 2 );
+is( $isa->{count}, 2 );
+
+done_testing;
Please sign in to comment.
Something went wrong with that request. Please try again.