Commit | Line | Data |
0373380c |
1 | package MooseX::Antlers::RefFilter; |
2 | |
3 | # note: we actually handle weaken as well as external refs because I intend |
4 | # to use Data::Dumper as a first pass and YAML::XS as a second and neither |
5 | # of them know how to deal with weak references |
6 | # |
7 | # better still, neither actually does the bloody cross refs properly - Dumper |
8 | # emits them but the nature of the beast is that they don't eval back in |
9 | # right, YAML::XS seems to make two aliases to one ref (Data::Alias-ish) |
10 | # since when I weaken one both copies disappear on me. sigh. |
11 | # |
12 | # on the upside, we can use a really dumb dumper for the rest - JSON::XS |
13 | # strikes me as an interesting possibility for speed reasons |
14 | |
15 | use Moose; |
16 | use Scalar::Util qw(refaddr isweak); |
17 | use namespace::clean -except => 'meta'; |
18 | |
19 | extends 'Data::Visitor'; |
20 | |
21 | # we need name tracking but have to apply the role at the end of the file |
22 | # so that our around modifiers end up within the name tracking around |
23 | # instead of outside - otherwise e.g. array value weakening goes wrong |
24 | |
25 | has 'external_mappings' => (is => 'ro', lazy => 1, default => sub { {} }); |
26 | has '_internal_mappings' => (is => 'ro', lazy => 1, default => sub { {} }); |
27 | has 'weaken_these' => (is => 'ro', lazy => 1, default => sub { {} }); |
28 | has 'map_these' => (is => 'ro', lazy => 1, default => sub { {} }); |
29 | |
30 | around visit => sub { |
31 | my ($orig, $self) = (shift, shift); |
32 | my $value = $_[0]; |
33 | |
34 | # note that we can't localize this one since it needs to be global |
35 | # across the entire structure - we could consider a weakref based trick |
36 | # like we use in the recorder but I don't -think- there's any need |
37 | |
38 | # if we've already seen this reference, register a mapping for this |
39 | # copy of it so we fix it up afterwards (see visit_ref for the same process |
40 | # being used for references to be supplied externally at deserialize time |
41 | # and the top of the class for notes on how much I love serializers) |
42 | |
43 | if (ref($value) && (my $m = $self->_internal_mappings->{refaddr $value})) { |
44 | $self->map_these->{$self->_current_trace_name} = $m; |
45 | return undef; |
46 | } |
47 | |
48 | return $self->$orig(@_); |
49 | }; |
50 | |
51 | around visit_ref => sub { |
52 | my ($orig, $self) = (shift, shift); |
53 | my $value = $_[0]; |
54 | |
55 | # if we've got a mapping for a reference (i.e. it's supplied from |
56 | # somewhere else) then we need to record where we are and then |
57 | # return undef for the fmap process so we serialize an undefined |
58 | # value and the fixup puts the external reference back in later |
59 | |
60 | if (my $m = $self->external_mappings->{refaddr $value}) { |
61 | $self->map_these->{$self->_current_trace_name} = $m; |
62 | return undef; |
63 | } |
64 | |
65 | $self->_internal_mappings->{refaddr $value} = $self->_current_trace_name; |
66 | |
67 | return $self->$orig(@_); |
68 | }; |
69 | |
70 | around visit_hash_value => sub { |
71 | my ($orig, $self) = (shift, shift); |
72 | my ($value, $key, $hash) = @_; |
73 | if (isweak $hash->{$key}) { |
74 | $self->weaken_these->{$self->_current_trace_name} = 1; |
75 | } |
76 | return $self->$orig(@_); |
77 | }; |
78 | |
79 | around visit_array_entry => sub { |
80 | my ($orig, $self) = (shift, shift); |
81 | my ($value, $index, $array) = @_; |
82 | if (isweak $array->[$index]) { |
83 | $self->weaken_these->{$self->_current_trace_name} = 1; |
84 | } |
85 | return $self->$orig(@_); |
86 | }; |
87 | |
88 | around visit_scalar => sub { |
89 | my ($orig, $self) = (shift, shift); |
90 | my $scalar = $_[0]; |
91 | if (isweak $$scalar) { |
92 | $self->weaken_these->{$self->_current_trace_name} = 1; |
93 | } |
94 | return $self->$orig(@_); |
95 | }; |
96 | |
97 | # now it's safe to apply the role |
98 | |
99 | with 'MooseX::Antlers::Visitor::NameTracking'; |
100 | |
101 | sub fixup_code { |
102 | my $self = shift; |
103 | join("\n\n", |
104 | grep defined, |
105 | map $self->${\"_fixup_code_for_$_"}, |
106 | qw(externals weakrefs) |
107 | ); |
108 | } |
109 | |
110 | sub _fixup_code_for_externals { |
111 | my $self = shift; |
112 | my $ext = $self->map_these; |
113 | return unless keys %$ext; |
114 | join("\n", |
115 | qq{# fixup code for external references}, |
116 | map { |
117 | my ($l, $r) = ($_, $ext->{$_}); |
118 | # if the LHS is a scalarref deref then we actually |
119 | # need to strip that bit off and push the enref to the RHS since |
120 | # ${\undef} = "foo" |
121 | # is an attempt to modify a readonly value and perl will burst into tears |
c8414da4 |
122 | # $whatever = \"foo" |
123 | # is ok so if the match succeeds switch it to that |
0373380c |
124 | if ($l =~ m/^\${(.*)}$/) { $l = $1; $r = "\\".$r; } |
125 | $l.' = '.$r.';'; |
126 | } |
127 | sort keys %$ext |
128 | ); |
129 | } |
130 | |
131 | sub _fixup_code_for_weakrefs { |
132 | my $self = shift; |
133 | my $weaken = $self->weaken_these; |
134 | return unless keys %$weaken; |
135 | join("\n", |
136 | qq{# fixup code for weak references}, |
137 | 'use Scalar::Util ();', |
138 | map { |
139 | 'Scalar::Util::weaken('.$_.');'; |
140 | } |
141 | sort keys %$weaken |
142 | ); |
143 | } |
144 | |
145 | # force recursion into objects (Data::Visitor doesn't by default) |
146 | |
147 | sub visit_object { shift->visit_ref(@_) } |
148 | |
149 | 1; |