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

   1 #!/usr/bin/perl
   2
   3 package Data::Visitor::Callback;
   4 use Moose;
   5
   6 use Data::Visitor ();
   7
   8 use Carp qw(carp);
   9 use Scalar::Util qw/blessed refaddr reftype/;
  10
  11 no warnings 'recursion';
  12
  13 use namespace::clean -except => 'meta';
  14
  15 use constant DEBUG => Data::Visitor::DEBUG();
  16 use constant FIVE_EIGHT => ( $] >= 5.008 );
  17
  18 extends qw(Data::Visitor);
  19
  20 has callbacks => (
  21         isa => "HashRef",
  22         is  => "rw",
  23         default => sub { {} },
  24 );
  25
  26 has class_callbacks => (
  27         isa => "ArrayRef",
  28         is  => "rw",
  29         default => sub { [] },
  30 );
  31
  32 has ignore_return_values => (
  33         isa => "Bool",
  34         is  => "rw",
  35 );
  36
  37 sub BUILDARGS {
  38         my ( $class, @args ) = @_;
  39
  40         my $args = $class->SUPER::BUILDARGS(@args);
  41
  42         my %init_args = map { $_->init_arg => undef } $class->meta->get_all_attributes;
  43
  44         my %callbacks = map { $_ => $args->{$_} } grep { not exists $init_args{$_} } keys %$args;
  45
  46         my @class_callbacks = do {
  47                 no strict 'refs';
  48                 grep {
  49                         # this check can be half assed because an ->isa check will be
  50                         # performed later. Anything that cold plausibly be a class name
  51                         # should be included in the list, even if the class doesn't
  52                         # actually exist.
  53
  54                         m{ :: | ^[A-Z] }x # if it looks kinda lack a class name
  55                                 or
  56                         scalar keys %{"${_}::"} # or it really is a class
  57                 } keys %callbacks;
  58         };
  59
  60         # sort from least derived to most derived
  61         @class_callbacks = sort { !$a->isa($b) <=> !$b->isa($a) } @class_callbacks;
  62
  63         return {
  64                 %$args,
  65                 callbacks       => \%callbacks,
  66                 class_callbacks => \@class_callbacks,
  67         };
  68 }
  69
  70 sub visit {
  71         my $self = shift;
  72
  73         my $replaced_hash = local $self->{_replaced} = ($self->{_replaced} || {}); # delete it after we're done with the whole visit
  74
  75         my @ret;
  76
  77         for my $data (@_) {
  78                 my $refaddr = ref($data) && refaddr($data); # we need this early, it may change by the time we write replaced hash
  79
  80                 local *_ = \$data; # alias $_
  81
  82                 if ( $refaddr and exists $replaced_hash->{ $refaddr } ) {
  83                         if ( FIVE_EIGHT ) {
  84                                 $self->trace( mapping => replace => $data, with => $replaced_hash->{$refaddr} ) if DEBUG;
  85                                 push @ret, $data = $replaced_hash->{$refaddr};
  86                                 next;
  87                         } else {
  88                                 carp(q{Assignment of replacement value for already seen reference } . overload::StrVal($data) . q{ to container doesn't work on Perls older than 5.8, structure shape may have lost integrity.});
  89                         }
  90                 }
  91
  92                 my $ret;
  93
  94                 if ( defined wantarray ) {
  95                         $ret = $self->SUPER::visit( $self->callback( visit => $data ) );
  96                 } else {
  97                         $self->SUPER::visit( $self->callback( visit => $data ) );
  98                 }
  99
 100                 $replaced_hash->{$refaddr} = $_ if $refaddr and ( not ref $_ or $refaddr ne refaddr($_) );
 101
 102                 push @ret, $ret if defined wantarray;
 103         }
 104
 105         return ( @_ == 1 ? $ret[0] : @ret );
 106 }
 107
 108 sub visit_ref {
 109         my ( $self, $data ) = @_;
 110
 111         my $mapped = $self->callback( ref => $data );
 112
 113         if ( ref $mapped ) {
 114                 return $self->SUPER::visit_ref($mapped);
 115         } else {
 116                 return $self->visit($mapped);
 117         }
 118 }
 119
 120 sub visit_seen {
 121         my ( $self, $data, $result ) = @_;
 122
 123         my $mapped = $self->callback( seen => $data, $result );
 124
 125         no warnings 'uninitialized';
 126         if ( refaddr($mapped) == refaddr($data) ) {
 127                 return $result;
 128         } else {
 129                 return $mapped;
 130         }
 131 }
 132
 133 sub visit_value {
 134         my ( $self, $data ) = @_;
 135
 136         $data = $self->callback_and_reg( value => $data );
 137         $self->callback_and_reg( ( ref($data) ? "ref_value" : "plain_value" ) => $data );
 138 }
 139
 140 sub visit_object {
 141         my ( $self, $data ) = @_;
 142
 143         $self->trace( flow => visit_object => $data ) if DEBUG;
 144
 145         $data = $self->callback_and_reg( object => $data );
 146
 147         my $class_cb = 0;
 148
 149         foreach my $class ( @{ $self->class_callbacks } ) {
 150                 last unless blessed($data);
 151                 next unless $data->isa($class);
 152                 $self->trace( flow => class_callback => $class, on => $data ) if DEBUG;
 153
 154                 $class_cb++;
 155                 $data = $self->callback_and_reg( $class => $data );
 156         }
 157
 158         $data = $self->callback_and_reg( object_no_class => $data ) unless $class_cb;
 159
 160         $data = $self->callback_and_reg( object_final => $data )
 161                 if blessed($data);
 162
 163         $data;
 164 }
 165
 166 sub visit_scalar {
 167         my ( $self, $data ) = @_;
 168         my $new_data = $self->callback_and_reg( scalar => $data );
 169         if ( (reftype($new_data)||"") =~ /^(?: SCALAR | REF | LVALUE | VSTRING ) $/x ) {
 170                 my $visited = $self->SUPER::visit_scalar( $new_data );
 171
 172                 no warnings "uninitialized";
 173                 if ( refaddr($visited) != refaddr($data) ) {
 174                         return $self->_register_mapping( $data, $visited );
 175                 } else {
 176                         return $visited;
 177                 }
 178         } else {
 179                 return $self->_register_mapping( $data, $self->visit( $new_data ) );
 180         }
 181 }
 182
 183 sub subname { $_[1] }
 184
 185 BEGIN {
 186         eval {
 187                 require Sub::Name;
 188                 no warnings 'redefine';
 189                 *subname = \&Sub::Name::subname;
 190         };
 191
 192         foreach my $reftype ( qw/array hash glob code/ ) {
 193                 my $name = "visit_$reftype";
 194                 no strict 'refs';
 195                 *$name = subname(__PACKAGE__ . "::$name", eval '
 196                         sub {
 197                                 my ( $self, $data ) = @_;
 198                                 my $new_data = $self->callback_and_reg( '.$reftype.' => $data );
 199                                 if ( "'.uc($reftype).'" eq (reftype($new_data)||"") ) {
 200                                         my $visited = $self->SUPER::visit_'.$reftype.'( $new_data );
 201
 202                                         no warnings "uninitialized";
 203                                         if ( refaddr($visited) != refaddr($data) ) {
 204                                                 return $self->_register_mapping( $data, $visited );
 205                                         } else {
 206                                                 return $visited;
 207                                         }
 208                                 } else {
 209                                         return $self->_register_mapping( $data, $self->visit( $new_data ) );
 210                                 }
 211                         }
 212                 ' || die $@);
 213         }
 214 }
 215
 216 sub visit_hash_entry {
 217         my ( $self, $key, $value, $hash ) = @_;
 218
 219         my ( $new_key, $new_value ) = $self->callback( hash_entry => $_[1], $_[2], $_[3] );
 220
 221         unless ( $self->ignore_return_values ) {
 222                 no warnings 'uninitialized';
 223                 if ( ref($value) and refaddr($value) != refaddr($new_value) ) {
 224                         $self->_register_mapping( $value, $new_value );
 225                         if ( $key ne $new_key ) {
 226                                 return $self->SUPER::visit_hash_entry($new_key, $new_value, $_[3]);
 227                         } else {
 228                                 return $self->SUPER::visit_hash_entry($_[1], $new_value, $_[3]);
 229                         }
 230                 } else {
 231                         if ( $key ne $new_key ) {
 232                                 return $self->SUPER::visit_hash_entry($new_key, $_[2], $_[3]);
 233                         } else {
 234                                 return $self->SUPER::visit_hash_entry($_[1], $_[2], $_[3]);
 235                         }
 236                 }
 237         } else {
 238                 return $self->SUPER::visit_hash_entry($_[1], $_[2], $_[3]);
 239         }
 240 }
 241
 242 sub callback {
 243         my ( $self, $name, $data, @args ) = @_;
 244
 245         if ( my $code = $self->callbacks->{$name} ) {
 246                 $self->trace( flow => callback => $name, on => $data ) if DEBUG;
 247                 if ( wantarray ) {
 248                         my @ret = $self->$code( $data, @args );
 249                         return $self->ignore_return_values ? ( $data, @args ) : @ret;
 250                 } else {
 251                         my $ret = $self->$code( $data, @args );
 252                         return $self->ignore_return_values ? $data : $ret ;
 253                 }
 254         } else {
 255                 return wantarray ? ( $data, @args ) : $data;
 256         }
 257 }
 258
 259 sub callback_and_reg {
 260         my ( $self, $name, $data, @args ) = @_;
 261
 262         my $new_data = $self->callback( $name, $data, @args );
 263
 264         unless ( $self->ignore_return_values ) {
 265                 no warnings 'uninitialized';
 266                 if ( ref $data ) {
 267                         if ( refaddr($data) != refaddr($new_data) ) {
 268                                 return $self->_register_mapping( $data, $new_data );
 269                         }
 270                 }
 271
 272                 return $new_data;
 273         }
 274
 275         return $data;
 276 }
 277
 278 sub visit_tied {
 279         my ( $self, $tied, @args ) = @_;
 280         $self->SUPER::visit_tied( $self->callback_and_reg( tied => $tied, @args ), @args );
 281 }
 282
 283 __PACKAGE__->meta->make_immutable if __PACKAGE__->meta->can("make_immutable");
 284
 285 __PACKAGE__
 286
 287 __END__
 288
 289 =pod
 290
 291 =head1 NAME
 292
 293 Data::Visitor::Callback - A Data::Visitor with callbacks.
 294
 295 =head1 SYNOPSIS
 296
 297         use Data::Visitor::Callback;
 298
 299         my $v = Data::Visitor::Callback->new(
 300                 value => sub { ... },
 301                 array => sub { ... },
 302                 object => "visit_ref", # can also use method names
 303         );
 304
 305         $v->visit( $some_perl_value );
 306
 307 =head1 DESCRIPTION
 308
 309 This is a L<Data::Visitor> subclass that lets you invoke callbacks instead of
 310 needing to subclass yourself.
 311
 312 =head1 METHODS
 313
 314 =over 4
 315
 316 =item new %opts, %callbacks
 317
 318 Construct a new visitor.
 319
 320 The options supported are:
 321
 322 =over 4
 323
 324 =item ignore_return_values
 325
 326 When this is true (off by default) the return values from the callbacks are
 327 ignored, thus disabling the fmapping behavior as documented in
 328 L<Data::Visitor>.
 329
 330 This is useful when you want to modify $_ directly
 331
 332 =item tied_as_objects
 333
 334 Whether ot not to visit the L<perlfunc/tied> of a tied structure instead of
 335 pretending the structure is just a normal one.
 336
 337 See L<Data::Visitor/visit_tied>.
 338
 339 =back
 340
 341 =back
 342
 343 =head1 CALLBACKS
 344
 345 Use these keys for the corresponding callbacks.
 346
 347 The callback is in the form:
 348
 349         sub {
 350                 my ( $visitor, $data ) = @_;
 351
 352                 # or you can use $_, it's aliased
 353
 354                 return $data; # or modified data
 355         }
 356
 357 Within the callback $_ is aliased to the data, and this is also passed in the
 358 parameter list.
 359
 360 Any method can also be used as a callback:
 361
 362         object => "visit_ref", # visit objects anyway
 363
 364 =over 4
 365
 366 =item visit
 367
 368 Called for all values
 369
 370 =item value
 371
 372 Called for non objects, non container (hash, array, glob or scalar ref) values.
 373
 374 =item ref_value
 375
 376 Called after C<value>, for references to regexes, globs and code.
 377
 378 =item plain_value
 379
 380 Called after C<value> for non references.
 381
 382 =item object
 383
 384 Called for blessed objects.
 385
 386 Since L<Data::Visitor/visit_object> will not recurse downwards unless you
 387 delegate to C<visit_ref>, you can specify C<visit_ref> as the callback for
 388 C<object> in order to enter objects.
 389
 390 It is reccomended that you specify the classes (or base classes) you want
 391 though, instead of just visiting any object forcefully.
 392
 393 =item Some::Class
 394
 395 You can use any class name as a callback. This is colled only after the
 396 C<object> callback.
 397
 398 If the object C<isa> the class then the callback will fire.
 399
 400 These callbacks are called from least derived to most derived by comparing the
 401 classes' C<isa> at construction time.
 402
 403 =item object_no_class
 404
 405 Called for every object that did not have a class callback.
 406
 407 =item object_final
 408
 409 The last callback called for objects, useful if you want to post process the
 410 output of any class callbacks.
 411
 412 =item array
 413
 414 Called for array references.
 415
 416 =item hash
 417
 418 Called for hash references.
 419
 420 =item glob
 421
 422 Called for glob references.
 423
 424 =item scalar
 425
 426 Called for scalar references.
 427
 428 =item tied
 429
 430 Called on the return value of C<tied> for all tied containers. Also passes in
 431 the variable as the second argument.
 432
 433 =item seen
 434
 435 Called for a reference value encountered a second time.
 436
 437 Passes in the result mapping as the second argument.
 438
 439 =back
 440
 441 =head1 AUTHOR
 442
 443 Yuval Kogman <nothingmuch@woobling.org>
 444
 445 =head1 COPYRIGHT & LICENSE
 446
 447         Copyright (c) 2006 Yuval Kogman. All rights reserved
 448         This program is free software; you can redistribute
 449         it and/or modify it under the same terms as Perl itself.
 450
 451 =cut
 452
 453