Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Half assed dispatch table support ripped from KiokuDB::TypeMap

  • Loading branch information...
commit 0fc71043565f615810a3c1061a9a5eff2bc9eb58 1 parent 13087d3
Yuval Kogman authored August 28, 2012
46  lib/Data/Visitor.pm
@@ -9,6 +9,8 @@ use Symbol ();
9 9
 use Class::Load 'load_optional_class';
10 10
 use Tie::ToObject;
11 11
 
  12
+use Data::Visitor::DispatchTable;
  13
+
12 14
 no warnings 'recursion';
13 15
 
14 16
 use namespace::clean -except => 'meta';
@@ -30,6 +32,24 @@ has weaken => (
30 32
 	default => 0,
31 33
 );
32 34
 
  35
+has dispatch_table => (
  36
+	isa => "Data::Visitor::DispatchTable",
  37
+	is  => "ro",
  38
+	lazy_build => 1,
  39
+);
  40
+
  41
+sub _build_dispatch_table {
  42
+	Data::Visitor::DispatchTable->new;
  43
+}
  44
+
  45
+has _dispatch_table_cache => (
  46
+	isa => "HashRef",
  47
+	is  => "ro",
  48
+	lazy_build => 1,
  49
+);
  50
+
  51
+sub _build__dispatch_table_cache { return {} }
  52
+
33 53
 sub trace {
34 54
 	my ( $self, $category, @msg ) = @_;
35 55
 
@@ -98,16 +118,30 @@ sub _register_mapping {
98 118
 	$self->{_seen}{ refaddr($data) } = $new_data;
99 119
 }
100 120
 
  121
+sub dispatch_table_entry_for {
  122
+	my ( $self, $data ) = @_;
  123
+
  124
+	my $class = ref $data;
  125
+
  126
+	$self->_dispatch_table_cache->{$class} ||= $self->dispatch_table->resolve($class);
  127
+}
  128
+
101 129
 sub visit_no_rec_check {
102 130
 	my ( $self, $data ) = @_;
103 131
 
104  
-	if ( blessed($data) ) {
105  
-		return $self->visit_object($_[1]);
106  
-	} elsif ( ref $data ) {
107  
-		return $self->visit_ref($_[1]);
  132
+	if ( ref $data ) {
  133
+		if ( my $dispatch_entry = $self->dispatch_table_entry_for($data) ) {
  134
+			return $self->$dispatch_entry($_[1]);
  135
+		} else {
  136
+			if ( blessed($data) ) {
  137
+				return $self->visit_object($_[1]);
  138
+			} else {
  139
+				return $self->visit_ref($_[1]);
  140
+			}
  141
+		}
  142
+	} else {
  143
+		return $self->visit_value($_[1]);
108 144
 	}
109  
-
110  
-	return $self->visit_value($_[1]);
111 145
 }
112 146
 
113 147
 sub visit_object {
206  lib/Data/Visitor/DispatchTable.pm
... ...
@@ -0,0 +1,206 @@
  1
+#!/usr/bin/perl
  2
+
  3
+package Data::Visitor::DispatchTable;
  4
+use Moose;
  5
+
  6
+use MooseX::Types::Moose qw(ArrayRef HashRef Str CodeRef);
  7
+use Moose::Util::TypeConstraints qw(duck_type);
  8
+
  9
+use Carp qw(croak);
  10
+
  11
+use namespace::autoclean;
  12
+
  13
+no warnings 'recursion';
  14
+
  15
+has [qw(entries isa_entries)] => (
  16
+	isa => HashRef[CodeRef|Str],
  17
+	is	=> "ro",
  18
+	lazy_build => 1,
  19
+);
  20
+
  21
+sub _build_entries { +{} }
  22
+sub _build_isa_entries { +{} }
  23
+
  24
+has [qw(all_entries all_isa_entries)] => (
  25
+	isa => HashRef,
  26
+	is	=> "ro",
  27
+	lazy_build => 1,
  28
+);
  29
+
  30
+has all_isa_entry_classes => (
  31
+	isa => ArrayRef[Str],
  32
+	is	=> "ro",
  33
+	lazy_build => 1,
  34
+);
  35
+
  36
+has includes => (
  37
+	isa => ArrayRef[duck_type([qw(resolve)])],
  38
+	is	=> "ro",
  39
+	lazy_build => 1,
  40
+);
  41
+
  42
+sub _build_includes { [] }
  43
+
  44
+sub resolve {
  45
+	my ( $self, $class ) = @_;
  46
+
  47
+	if ( my $entry = $self->all_entries->{$class} || $self->all_isa_entries->{$class} ) {
  48
+		return $entry;
  49
+	} else {
  50
+		foreach my $superclass ( @{ $self->all_isa_entry_classes } ) {
  51
+			if ( $class->isa($superclass) ) {
  52
+				return $self->all_isa_entries->{$superclass};
  53
+			}
  54
+		}
  55
+	}
  56
+
  57
+	return;
  58
+}
  59
+
  60
+sub BUILD {
  61
+	my $self = shift;
  62
+
  63
+	# verify that there are no conflicting internal definitions
  64
+	my $reg = $self->entries;
  65
+	foreach my $key ( keys %{ $self->isa_entries } ) {
  66
+		if ( exists $reg->{$key} ) {
  67
+			croak "isa entry $key already present in plain entries";
  68
+		}
  69
+	}
  70
+
  71
+	# Verify that there are no conflicts between the includesd type maps
  72
+	my %seen;
  73
+	foreach my $map ( @{ $self->includes } ) {
  74
+		foreach my $key ( keys %{ $map->all_entries } ) {
  75
+			if ( $seen{$key} ) {
  76
+				croak "entry $key found in $map conflicts with $seen{$key}";
  77
+			}
  78
+
  79
+			$seen{$key} = $map;
  80
+		}
  81
+
  82
+		foreach my $key ( keys %{ $map->all_isa_entries } ) {
  83
+			if ( $seen{$key} ) {
  84
+				croak "isa entry $key found in $map conflicts with $seen{$key}";
  85
+			}
  86
+
  87
+			$seen{$key} = $map;
  88
+		}
  89
+	}
  90
+}
  91
+
  92
+sub _build_all_entries {
  93
+	my $self = shift;
  94
+
  95
+	return {
  96
+		map { %$_ } (
  97
+			( map { $_->all_entries } @{ $self->includes } ),
  98
+			$self->entries,
  99
+		),
  100
+	};
  101
+}
  102
+
  103
+sub _build_all_isa_entries {
  104
+	my $self = shift;
  105
+
  106
+	return {
  107
+		map { %$_ } (
  108
+			( map { $_->all_isa_entries } @{ $self->includes } ),
  109
+			$self->isa_entries,
  110
+		),
  111
+	};
  112
+}
  113
+
  114
+sub _build_all_isa_entry_classes {
  115
+	my $self = shift;
  116
+
  117
+	return [
  118
+		sort { !$a->isa($b) <=> !$b->isa($a) } # least derived first
  119
+		keys %{ $self->all_isa_entries }
  120
+	];
  121
+}
  122
+
  123
+__PACKAGE__->meta->make_immutable;
  124
+
  125
+__PACKAGE__
  126
+
  127
+__END__
  128
+
  129
+=pod
  130
+
  131
+=head1 NAME
  132
+
  133
+Data::Visitor::DispatchTable - cleaner dispatch table support than Data::Visitor::Callback.
  134
+
  135
+=head1 SYNOPSIS
  136
+
  137
+	use Data::Visitor;
  138
+
  139
+	Data::Visitor->new(
  140
+		dispatch_table => Data::Visitor::DispatchTable->new(
  141
+			entries => {
  142
+				Foo => sub { warn "I'm visiting $_[1] and its reftype is 'Foo'" },
  143
+			},
  144
+			isa_entries => {
  145
+				Bar => visit_ref, # all objects that isa Bar will have their data violated
  146
+			},
  147
+			includes => [
  148
+				# you can delegate to other dispatch tables too
  149
+				$foo,
  150
+				$bar,
  151
+			],
  152
+		),
  153
+	);
  154
+
  155
+=head1 DESCRIPTION
  156
+
  157
+This code is ripped out of L<KiokuDB::TypeMap>.
  158
+
  159
+The mapping is by class, and entries can be keyed normally (using
  160
+C<ref $object> equality) or by filtering on C<< $object->isa($class) >>
  161
+(C<isa_entries>).
  162
+
  163
+Entries are anything that can be used as a method, i.e. strings used as method
  164
+names on the visitor, or code references.
  165
+
  166
+=head1 ATTRIBUTES
  167
+
  168
+=over 4
  169
+
  170
+=item entries
  171
+
  172
+A hash of normal entries.
  173
+
  174
+=item isa_entries
  175
+
  176
+A hash of C<< $object->isa >> based entries.
  177
+
  178
+=item includes
  179
+
  180
+A list of parent typemaps to inherit entries from.
  181
+
  182
+=back
  183
+
  184
+=head1 METHODS
  185
+
  186
+=over 4
  187
+
  188
+=item resolve $class
  189
+
  190
+Given a class returns the dispatch table entry for that class.
  191
+
  192
+=item all_entries
  193
+
  194
+Returns the merged C<entries> from this typemap and all the included tables.
  195
+
  196
+=item all_isa_entries
  197
+
  198
+Returns the merged C<isa_entries> from this typemap and all the included
  199
+tables.
  200
+
  201
+=item all_isa_entry_classes
  202
+
  203
+An array reference of all the classes in C<all_isa_entries>, sorted from least
  204
+derived to most derived.
  205
+
  206
+=back
37  t/dispatch_table.t
... ...
@@ -0,0 +1,37 @@
  1
+#!/usr/bin/perl
  2
+
  3
+use strict;
  4
+use warnings;
  5
+
  6
+use Test::More;
  7
+use Test::MockObject::Extends;
  8
+
  9
+use ok "Data::Visitor";
  10
+
  11
+my $v = Data::Visitor->new(
  12
+	dispatch_table => Data::Visitor::DispatchTable->new(
  13
+		entries => {
  14
+			"Some::Class", => sub { $_->{count}++; $_ },
  15
+		},
  16
+		isa_entries => {
  17
+			Bar => sub { $_->{count}++; $_ },
  18
+		}
  19
+	),
  20
+);
  21
+
  22
+{ package Bar };
  23
+@Some::Other::Class::ISA = qw(Bar);
  24
+
  25
+my @things = ( "foo", 1, undef, 0, {}, [], do { my $x = "blah"; \$x }, my $ref = bless({}, "Some::Class"), my $isa = bless({}, "Some::Other::Class") );
  26
+
  27
+$v->visit($_) for @things; # no explosions in void context
  28
+
  29
+is( $ref->{count}, 1 );
  30
+is( $isa->{count}, 1 );
  31
+
  32
+is_deeply( $v->visit( $_ ), $_, "visit returns value unlatered" ) for @things;
  33
+
  34
+is( $ref->{count}, 2 );
  35
+is( $isa->{count}, 2 );
  36
+
  37
+done_testing;

0 notes on commit 0fc7104

Please sign in to comment.
Something went wrong with that request. Please try again.