local-lib5/lib/perl5/Data/Visitor.pm

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