File Coverage

blib/lib/Data/Visitor.pm
Criterion Covered Total %
statement 2 4 50.0
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 4 6 66.6


line stmt bran cond sub pod time code
1             package Data::Visitor;
2             BEGIN {
3 3     3   112960 $Data::Visitor::AUTHORITY = 'cpan:NUFFIN';
4             }
5             {
6             $Data::Visitor::VERSION = '0.30';
7             }
8 3     3   6675 use Moose;
  0            
  0            
9             # ABSTRACT: Visitor style traversal of Perl data structures
10              
11             use Scalar::Util qw/blessed refaddr reftype weaken isweak/;
12             use overload ();
13             use Symbol ();
14              
15             use Class::Load 'load_optional_class';
16             use Tie::ToObject;
17              
18             no warnings 'recursion';
19              
20             use namespace::clean -except => 'meta';
21              
22             # the double not makes this no longer undef, so exempt from useless constant warnings in older perls
23             use constant DEBUG => not not our $DEBUG || $ENV{DATA_VISITOR_DEBUG};
24              
25             use constant HAS_DATA_ALIAS => load_optional_class('Data::Alias');
26              
27             has tied_as_objects => (
28             isa => "Bool",
29             is => "rw",
30             );
31              
32             # currently broken
33             has weaken => (
34             isa => "Bool",
35             is => "rw",
36             default => 0,
37             );
38              
39             sub trace {
40             my ( $self, $category, @msg ) = @_;
41              
42             our %DEBUG;
43              
44             if ( $DEBUG{$category} or !exists($DEBUG{$category}) ) {
45             $self->_print_trace("$self: " . join("",
46             ( " " x ( $self->{depth} - 1 ) ),
47             ( join(" ", "$category:", map { overload::StrVal($_) } @msg) ),
48             ));
49             }
50             }
51              
52             sub _print_trace {
53             my ( $self, @msg ) = @_;
54             warn "@msg\n";
55             }
56              
57             sub visit {
58             my $self = shift;
59              
60             local $self->{depth} = (($self->{depth}||0) + 1) if DEBUG;
61             my $seen_hash = local $self->{_seen} = ($self->{_seen} || {}); # delete it after we're done with the whole visit
62              
63             my @ret;
64              
65             foreach my $data ( @_ ) {
66             $self->trace( flow => visit => $data ) if DEBUG;
67              
68             if ( my $refaddr = ref($data) && refaddr($data) ) { # only references need recursion checks
69             $seen_hash->{weak} ||= isweak($data) if $self->weaken;
70              
71             if ( exists $seen_hash->{$refaddr} ) {
72             $self->trace( mapping => found_mapping => from => $data, to => $seen_hash->{$refaddr} ) if DEBUG;
73             push @ret, $self->visit_seen( $data, $seen_hash->{$refaddr} );
74             next;
75             } else {
76             $self->trace( mapping => no_mapping => $data ) if DEBUG;
77             }
78             }
79              
80             if ( defined wantarray ) {
81             push @ret, scalar($self->visit_no_rec_check($data));
82             } else {
83             $self->visit_no_rec_check($data);
84             }
85             }
86              
87             return ( @_ == 1 ? $ret[0] : @ret );
88             }
89              
90             sub visit_seen {
91             my ( $self, $data, $result ) = @_;
92             return $result;
93             }
94              
95             sub _get_mapping {
96             my ( $self, $data ) = @_;
97             $self->{_seen}{ refaddr($data) };
98             }
99              
100             sub _register_mapping {
101             my ( $self, $data, $new_data ) = @_;
102             return $new_data unless ref $data;
103             $self->trace( mapping => register_mapping => from => $data, to => $new_data, in => (caller(1))[3] ) if DEBUG;
104             $self->{_seen}{ refaddr($data) } = $new_data;
105             }
106              
107             sub visit_no_rec_check {
108             my ( $self, $data ) = @_;
109              
110             if ( blessed($data) ) {
111             return $self->visit_object($_[1]);
112             } elsif ( ref $data ) {
113             return $self->visit_ref($_[1]);
114             }
115              
116             return $self->visit_value($_[1]);
117             }
118              
119             sub visit_object {
120             my ( $self, $object ) = @_;
121             $self->trace( flow => visit_object => $object ) if DEBUG;
122              
123             if ( not defined wantarray ) {
124             $self->_register_mapping( $object, $object );
125             $self->visit_value($_[1]);
126             return;
127             } else {
128             return $self->_register_mapping( $object, $self->visit_value($_[1]) );
129             }
130             }
131              
132             sub visit_ref {
133             my ( $self, $data ) = @_;
134              
135             local $self->{depth} = (($self->{depth}||0) + 1) if DEBUG;
136              
137             $self->trace( flow => visit_ref => $data ) if DEBUG;
138              
139             my $reftype = reftype $data;
140              
141             $reftype = "SCALAR" if $reftype =~ /^(?:REF|LVALUE|VSTRING)$/;
142              
143             my $method = $self->can(lc "visit_$reftype") || "visit_value";
144              
145             return $self->$method($_[1]);
146             }
147              
148             sub visit_value {
149             my ( $self, $value ) = @_;
150             $self->trace( flow => visit_value => $value ) if DEBUG;
151             return $value;
152             }
153              
154             sub visit_hash {
155             my ( $self, $hash ) = @_;
156              
157             local $self->{depth} = (($self->{depth}||0) + 1) if DEBUG;
158              
159             if ( defined(tied(%$hash)) and $self->tied_as_objects ) {
160             return $self->visit_tied_hash(tied(%$hash), $_[1]);
161             } else {
162             return $self->visit_normal_hash($_[1]);
163             }
164             }
165              
166             sub visit_normal_hash {
167             my ( $self, $hash ) = @_;
168              
169             if ( defined wantarray ) {
170             my $new_hash = {};
171             $self->_register_mapping( $hash, $new_hash );
172              
173             %$new_hash = $self->visit_hash_entries($_[1]);
174              
175             return $self->retain_magic( $_[1], $new_hash );
176             } else {
177             $self->_register_mapping($hash, $hash);
178             $self->visit_hash_entries($_[1]);
179             return;
180             }
181             }
182              
183             sub visit_tied_hash {
184             my ( $self, $tied, $hash ) = @_;
185              
186             if ( defined wantarray ) {
187             my $new_hash = {};
188             $self->_register_mapping( $hash, $new_hash );
189              
190             if ( blessed(my $new_tied = $self->visit_tied($_[1], $_[2])) ) {
191             $self->trace( data => tying => var => $new_hash, to => $new_tied ) if DEBUG;
192             tie %$new_hash, 'Tie::ToObject', $new_tied;
193             return $self->retain_magic($_[2], $new_hash);
194             } else {
195             return $self->visit_normal_hash($_[2]);
196             }
197             } else {
198             $self->_register_mapping($hash, $hash);
199             $self->visit_tied($_[1], $_[2]);
200             return;
201             }
202             }
203              
204             sub visit_hash_entries {
205             my ( $self, $hash ) = @_;
206              
207             if ( not defined wantarray ) {
208             $self->visit_hash_entry( $_, $hash->{$_}, $hash ) for keys %$hash;
209             } else {
210             return map { $self->visit_hash_entry( $_, $hash->{$_}, $hash ) } keys %$hash;
211             }
212             }
213              
214             sub visit_hash_entry {
215             my ( $self, $key, $value, $hash ) = @_;
216              
217             $self->trace( flow => visit_hash_entry => key => $key, value => $value ) if DEBUG;
218              
219             if ( not defined wantarray ) {
220             $self->visit_hash_key($key,$value,$hash);
221             $self->visit_hash_value($_[2],$key,$hash);
222             } else {
223             return (
224             $self->visit_hash_key($key,$value,$hash),
225             $self->visit_hash_value($_[2],$key,$hash),
226             );
227             }
228             }
229              
230             sub visit_hash_key {
231             my ( $self, $key, $value, $hash ) = @_;
232             $self->visit($key);
233             }
234              
235             sub visit_hash_value {
236             my ( $self, $value, $key, $hash ) = @_;
237             $self->visit($_[1]);
238             }
239              
240             sub visit_array {
241             my ( $self, $array ) = @_;
242              
243             if ( defined(tied(@$array)) and $self->tied_as_objects ) {
244             return $self->visit_tied_array(tied(@$array), $_[1]);
245             } else {
246             return $self->visit_normal_array($_[1]);
247             }
248             }
249              
250             sub visit_normal_array {
251             my ( $self, $array ) = @_;
252              
253             if ( defined wantarray ) {
254             my $new_array = [];
255             $self->_register_mapping( $array, $new_array );
256              
257             @$new_array = $self->visit_array_entries($_[1]);
258              
259             return $self->retain_magic( $_[1], $new_array );
260             } else {
261             $self->_register_mapping( $array, $array );
262             $self->visit_array_entries($_[1]);
263              
264             return;
265             }
266             }
267              
268             sub visit_tied_array {
269             my ( $self, $tied, $array ) = @_;
270              
271             if ( defined wantarray ) {
272             my $new_array = [];
273             $self->_register_mapping( $array, $new_array );
274              
275             if ( blessed(my $new_tied = $self->visit_tied($_[1], $_[2])) ) {
276             $self->trace( data => tying => var => $new_array, to => $new_tied ) if DEBUG;
277             tie @$new_array, 'Tie::ToObject', $new_tied;
278             return $self->retain_magic($_[2], $new_array);
279             } else {
280             return $self->visit_normal_array($_[2]);
281             }
282             } else {
283             $self->_register_mapping( $array, $array );
284             $self->visit_tied($_[1], $_[2]);
285              
286             return;
287             }
288             }
289              
290             sub visit_array_entries {
291             my ( $self, $array ) = @_;
292              
293             if ( not defined wantarray ) {
294             $self->visit_array_entry( $array->[$_], $_, $array ) for 0 .. $#$array;
295             } else {
296             return map { $self->visit_array_entry( $array->[$_], $_, $array ) } 0 .. $#$array;
297             }
298             }
299              
300             sub visit_array_entry {
301             my ( $self, $value, $index, $array ) = @_;
302             $self->visit($_[1]);
303             }
304              
305             sub visit_scalar {
306             my ( $self, $scalar ) = @_;
307              
308             if ( defined(tied($$scalar)) and $self->tied_as_objects ) {
309             return $self->visit_tied_scalar(tied($$scalar), $_[1]);
310             } else {
311             return $self->visit_normal_scalar($_[1]);
312             }
313             }
314              
315             sub visit_normal_scalar {
316             my ( $self, $scalar ) = @_;
317              
318             if ( defined wantarray ) {
319             my $new_scalar;
320             $self->_register_mapping( $scalar, \$new_scalar );
321              
322             $new_scalar = $self->visit( $$scalar );
323              
324             return $self->retain_magic($_[1], \$new_scalar);
325             } else {
326             $self->_register_mapping( $scalar, $scalar );
327             $self->visit( $$scalar );
328             return;
329             }
330              
331             }
332              
333             sub visit_tied_scalar {
334             my ( $self, $tied, $scalar ) = @_;
335              
336             if ( defined wantarray ) {
337             my $new_scalar;
338             $self->_register_mapping( $scalar, \$new_scalar );
339              
340             if ( blessed(my $new_tied = $self->visit_tied($_[1], $_[2])) ) {
341             $self->trace( data => tying => var => $new_scalar, to => $new_tied ) if DEBUG;
342             tie $new_scalar, 'Tie::ToObject', $new_tied;
343             return $self->retain_magic($_[2], \$new_scalar);
344             } else {
345             return $self->visit_normal_scalar($_[2]);
346             }
347             } else {
348             $self->_register_mapping( $scalar, $scalar );
349             $self->visit_tied($_[1], $_[2]);
350             return;
351             }
352             }
353              
354             sub visit_code {
355             my ( $self, $code ) = @_;
356             $self->visit_value($_[1]);
357             }
358              
359             sub visit_glob {
360             my ( $self, $glob ) = @_;
361              
362             if ( defined(tied(*$glob)) and $self->tied_as_objects ) {
363             return $self->visit_tied_glob(tied(*$glob), $_[1]);
364             } else {
365             return $self->visit_normal_glob($_[1]);
366             }
367             }
368              
369             sub visit_normal_glob {
370             my ( $self, $glob ) = @_;
371              
372             if ( defined wantarray ) {
373             my $new_glob = Symbol::gensym();
374             $self->_register_mapping( $glob, $new_glob );
375              
376             no warnings 'misc'; # Undefined value assigned to typeglob
377             *$new_glob = $self->visit( *$glob{$_} || next ) for qw/SCALAR ARRAY HASH/;
378              
379             return $self->retain_magic($_[1], $new_glob);
380             } else {
381             $self->_register_mapping( $glob, $glob );
382             $self->visit( *$glob{$_} || next ) for qw/SCALAR ARRAY HASH/;
383             return;
384             }
385             }
386              
387             sub visit_tied_glob {
388             my ( $self, $tied, $glob ) = @_;
389              
390             if ( defined wantarray ) {
391             my $new_glob = Symbol::gensym();
392             $self->_register_mapping( $glob, \$new_glob );
393              
394             if ( blessed(my $new_tied = $self->visit_tied($_[1], $_[2])) ) {
395             $self->trace( data => tying => var => $new_glob, to => $new_tied ) if DEBUG;
396             tie *$new_glob, 'Tie::ToObject', $new_tied;
397             return $self->retain_magic($_[2], $new_glob);
398             } else {
399             return $self->visit_normal_glob($_[2]);
400             }
401             } else {
402             $self->_register_mapping( $glob, $glob );
403             $self->visit_tied($_[1], $_[2]);
404             return;
405             }
406             }
407              
408             sub retain_magic {
409             my ( $self, $proto, $new ) = @_;
410              
411             if ( blessed($proto) and !blessed($new) ) {
412             $self->trace( data => blessing => $new, ref $proto ) if DEBUG;
413             bless $new, ref $proto;
414             }
415              
416             my $seen_hash = $self->{_seen};
417             if ( $seen_hash->{weak} ) {
418             if (HAS_DATA_ALIAS) {
419             my @weak_refs;
420             foreach my $value ( Data::Alias::deref($proto) ) {
421             if ( ref $value and isweak($value) ) {
422             push @weak_refs, refaddr $value;
423             }
424             }
425              
426             if ( @weak_refs ) {
427             my %targets = map { refaddr($_) => 1 } @{ $self->{_seen} }{@weak_refs};
428             foreach my $value ( Data::Alias::deref($new) ) {
429             if ( ref $value and $targets{refaddr($value)}) {
430             push @{ $seen_hash->{weakened} ||= [] }, $value; # keep a ref around
431             weaken($value);
432             }
433             }
434             }
435             }
436             else {
437             die "Found a weak reference, but Data::Alias is not installed. You must install Data::Alias in order for this to work.";
438             }
439             }
440              
441             # FIXME real magic, too
442              
443             return $new;
444             }
445              
446             sub visit_tied {
447             my ( $self, $tied, $var ) = @_;
448             $self->trace( flow => visit_tied => $tied ) if DEBUG;
449             $self->visit($_[1]); # as an object eventually
450             }
451              
452             __PACKAGE__->meta->make_immutable if __PACKAGE__->meta->can("make_immutable");
453              
454             __PACKAGE__;
455              
456             __END__
457              
458             =pod
459              
460             =head1 NAME
461              
462             Data::Visitor - Visitor style traversal of Perl data structures
463              
464             =head1 VERSION
465              
466             version 0.30
467              
468             =head1 SYNOPSIS
469              
470             # NOTE
471             # You probably want to use Data::Visitor::Callback for trivial things
472              
473             package FooCounter;
474             use Moose;
475              
476             extends qw(Data::Visitor);
477              
478             has number_of_foos => (
479             isa => "Int",
480             is => "rw",
481             default => 0,
482             );
483              
484             sub visit_value {
485             my ( $self, $data ) = @_;
486              
487             if ( defined $data and $data eq "foo" ) {
488             $self->number_of_foos( $self->number_of_foos + 1 );
489             }
490              
491             return $data;
492             }
493              
494             my $counter = FooCounter->new;
495              
496             $counter->visit( {
497             this => "that",
498             some_foos => [ qw/foo foo bar foo/ ],
499             the_other => "foo",
500             });
501              
502             $counter->number_of_foos; # this is now 4
503              
504             =head1 DESCRIPTION
505              
506             This module is a simple visitor implementation for Perl values.
507              
508             It has a main dispatcher method, C<visit>, which takes a single perl value and
509             then calls the methods appropriate for that value.
510              
511             It can recursively map (cloning as necessary) or just traverse most structures,
512             with support for per object behavior, circular structures, visiting tied
513             structures, and all ref types (hashes, arrays, scalars, code, globs).
514              
515             L<Data::Visitor> is meant to be subclassed, but also ships with a callback
516             driven subclass, L<Data::Visitor::Callback>.
517              
518             =encoding utf8
519              
520             =head1 METHODS
521              
522             =over 4
523              
524             =item visit $data
525              
526             This method takes any Perl value as it's only argument, and dispatches to the
527             various other visiting methods using C<visit_no_rec_check>, based on the data's
528             type.
529              
530             If the value is a reference and has already been seen then C<visit_seen> is
531             called.
532              
533             =item visit_seen $data, $first_result
534              
535             When an already seen value is encountered again it's typically replaced with
536             the result of the first visitation of that value. The value and the result of
537             the first visitation are passed as arguments.
538              
539             Returns C<$first_result>.
540              
541             =item visit_no_rec_check $data
542              
543             Called for any value that has not yet been seen. Does the actual type based
544             dispatch for C<visit>.
545              
546             Should not be called directly unless forcing a circular structure to be
547             unfolded. Use with caution as this may cause infinite recursion.
548              
549             =item visit_object $object
550              
551             If the value is a blessed object, C<visit> calls this method. The base
552             implementation will just forward to C<visit_value>.
553              
554             =item visit_ref $value
555              
556             Generic recursive visitor. All non blessed values are given to this.
557              
558             C<visit_object> can delegate to this method in order to visit the object
559             anyway.
560              
561             This will check if the visitor can handle C<visit_$reftype> (lowercase), and if
562             not delegate to C<visit_value> instead.
563              
564             =item visit_array $array_ref
565              
566             =item visit_hash $hash_ref
567              
568             =item visit_glob $glob_ref
569              
570             =item visit_code $code_ref
571              
572             =item visit_scalar $scalar_ref
573              
574             These methods are called for the corresponding container type.
575              
576             =item visit_value $value
577              
578             If the value is anything else, this method is called. The base implementation
579             will return $value.
580              
581             =item visit_hash_entries $hash
582              
583             =item visit_hash_entry $key, $value, $hash
584              
585             Delegates to C<visit_hash_key> and C<visit_hash_value>. The value is passed as
586             C<$_[2]> so that it is aliased.
587              
588             =item visit_hash_key $key, $value, $hash
589              
590             Calls C<visit> on the key and returns it.
591              
592             =item visit_hash_value $value, $key, $hash
593              
594             The value will be aliased (passed as C<$_[1]>).
595              
596             =item visit_array_entries $array
597              
598             =item visit_array_entry $value, $index, $array
599              
600             Delegates to C<visit> on value. The value is passed as C<$_[1]> to retain
601             aliasing.
602              
603             =item visit_tied $object, $var
604              
605             When C<tied_as_objects> is enabled and a tied variable (hash, array, glob or
606             scalar) is encountered this method will be called on the tied object. If a
607             valid mapped value is returned, the newly constructed result container will be
608             tied to the return value and no iteration of the contents of the data will be
609             made (since all storage is delegated to the tied object).
610              
611             If a non blessed value is returned from C<visit_tied> then the structure will
612             be iterated normally, and the result container will not be tied at all.
613              
614             This is because tying to the same class and performing the tie operations will
615             not yield the same results in many cases.
616              
617             =item retain_magic $orig, $copy
618              
619             Copies over magic from C<$orig> to C<$copy>.
620              
621             Currently only handles C<bless>. In the future this might be expanded using
622             L<Variable::Magic> but it isn't clear what the correct semantics for magic
623             copying should be.
624              
625             =item trace
626              
627             Called if the C<DEBUG> constant is set with a trace message.
628              
629             =back
630              
631             =head1 RETURN VALUE
632              
633             This object can be used as an C<fmap> of sorts - providing an ad-hoc functor
634             interface for Perl data structures.
635              
636             In void context this functionality is ignored, but in any other context the
637             default methods will all try to return a value of similar structure, with it's
638             children also fmapped.
639              
640             =head1 SUBCLASSING
641              
642             Data::Visitor is a L<Moose> class, so it should be subclassed using Moose.
643              
644             Then override the callback methods in any way you like. To retain visitor
645             behavior, make sure to retain the functionality of C<visit_array> and
646             C<visit_hash>.
647              
648             =head1 TODO
649              
650             =over 4
651              
652             =item *
653              
654             Add support for "natural" visiting of trees.
655              
656             =item *
657              
658             Expand C<retain_magic> to support tying at the very least, or even more with
659             L<Variable::Magic> if possible.
660              
661             =back
662              
663             =head1 SEE ALSO
664              
665             L<Data::Rmap>, L<Tree::Simple::VisitorFactory>, L<Data::Traverse>
666              
667             L<http://en.wikipedia.org/wiki/Visitor_pattern>,
668             L<http://www.ninebynine.org/Software/Learning-Haskell-Notes.html#functors>,
669             L<http://en.wikipedia.org/wiki/Functor>
670              
671             =for Pod::Coverage HAS_DATA_ALIAS
672             visit_normal_array
673             visit_normal_glob
674             visit_normal_hash
675             visit_normal_scalar
676             visit_tied_array
677             visit_tied_glob
678             visit_tied_hash
679             visit_tied_scalar
680              
681             =head1 AUTHORS
682              
683             =over 4
684              
685             =item *
686              
687             Yuval Kogman <nothingmuch@woobling.org>
688              
689             =item *
690              
691             Marcel Grünauer <marcel@cpan.org>
692              
693             =back
694              
695             =head1 COPYRIGHT AND LICENSE
696              
697             This software is copyright (c) 2013 by Yuval Kogman.
698              
699             This is free software; you can redistribute it and/or modify it under
700             the same terms as the Perl 5 programming language system itself.
701              
702             =cut