1 package MooseX::Antlers::RefFilter;
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
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.
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
16 use Scalar::Util qw(refaddr isweak);
17 use namespace::clean -except => 'meta';
19 extends 'Data::Visitor';
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
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 { {} });
31 my ($orig, $self) = (shift, shift);
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
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)
43 if (ref($value) && (my $m = $self->_internal_mappings->{refaddr $value})) {
44 $self->map_these->{$self->_current_trace_name} = $m;
48 return $self->$orig(@_);
51 around visit_ref => sub {
52 my ($orig, $self) = (shift, shift);
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
60 if (my $m = $self->external_mappings->{refaddr $value}) {
61 $self->map_these->{$self->_current_trace_name} = $m;
65 $self->_internal_mappings->{refaddr $value} = $self->_current_trace_name;
67 return $self->$orig(@_);
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;
76 return $self->$orig(@_);
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;
85 return $self->$orig(@_);
88 around visit_scalar => sub {
89 my ($orig, $self) = (shift, shift);
91 if (isweak $$scalar) {
92 $self->weaken_these->{$self->_current_trace_name} = 1;
94 return $self->$orig(@_);
97 # now it's safe to apply the role
99 with 'MooseX::Antlers::Visitor::NameTracking';
105 map $self->${\"_fixup_code_for_$_"},
106 qw(externals weakrefs)
110 sub _fixup_code_for_externals {
112 my $ext = $self->map_these;
113 return unless keys %$ext;
115 qq{# fixup code for external references},
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
121 # is an attempt to modify a readonly value and perl will burst into tears
123 # is ok so if the match succeeds switch it to that
124 if ($l =~ m/^\${(.*)}$/) { $l = $1; $r = "\\(".$r.")"; }
131 sub _fixup_code_for_weakrefs {
133 my $weaken = $self->weaken_these;
134 return unless keys %$weaken;
136 qq{# fixup code for weak references},
137 'use Scalar::Util ();',
139 'Scalar::Util::weaken('.$_.');';
145 # force recursion into objects (Data::Visitor doesn't by default)
147 sub visit_object { shift->visit_ref(@_) }