Re: searching for an object reference

[simonm]

Updated: minor code changes and test harness added.

sub deep_search {
  my $target = shift;
  my $test = shift;
  
  # Avoid infinite loops by maintaining map of objects encountered
  local %SearchCache = ( undef => undef ) unless ( exists $SearchCache
+{undef} );
  return if ( $SearchCache{ $target } ++ );
  
  # Determine data type of unblessed reference or blessed object
  my $ref = ref( $target );
  if ( "$target" =~ /^\Q$ref\E\=([A-Z]+)\(0x[0-9a-f]+\)$/ ) { $ref = $
+1 }
  
  ( $test->( $target ) ? $target : () ), 
  ( map { deep_search($_, $test) } grep { ref($_) } (
    ($ref eq 'HASH') ? values %$target :
    ($ref eq 'ARRAY') ? @$target :
    ($ref eq 'REF' or $ref eq 'SCALAR') ? $$target : ()
  ) )
}

my $struct = {
  foo => bless( [ 0, 1, 2 ], 'Foo' ),
  bar => bless( [ 3, 4, 5 ], 'Bar' ),
  foozles => [
    { foolish => bless( [ 6, 7, 8 ], 'Foo' ), }
  ],
};

print join '', map "$_\n", deep_search( $struct, sub { ref( $_[0] ) eq
+ 'Foo' } )

[Mostly Harmless]

Thanks. I ended up writing a Data::ObjSearch yes'day. However, your's look simpler. I didn't know about 'REF' and didn't handle it. Otherwise it looks similar:


package Data::ObjSearch;

use strict;
use Carp;

sub new
{
    my ($class, $sub) = @_;

    my $self = bless({}, $class);

    if (ref($sub) eq 'CODE') { $self->{sub} = $sub; }
    elsif ($sub and !ref($sub))
    {
        $self->{sub} = sub { return UNIVERSAL::isa($_[0], $sub); };
    }
    else
    {
        croak "Pass a subroutine reference or package name.\n";
    }

    $self->{records} = [];
    $self->{seen}    = {};
    return $self;
}

sub search
{
  my ($class, $ref, $sub) = @_;

  my $self = ref($class) ? $class : $class->new($sub);
  $self->analyze($ref);
  return @{$self->{records}};
}

sub analyze
{
  my ($self, $data) = @_;

  my $ref = ref($data);
  return if (!$ref);

  my ($pack, $type, $id) = $data =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/
+;
  return if ($id && $self->{seen}->{$id});

  $pack && ($self->check_and_push($data), $ref = $type);
  $id && ($self->{seen}->{$id} = 1);

  if ($ref eq 'HASH')
  {
      while (my ($key, $val) = each %{$data}) { $self->analyze($val); 
+}
  }
  elsif ($ref eq 'ARRAY')  { map { $self->analyze($_) } @$data; }
  elsif ($ref eq 'SCALAR') { map { $self->analyze($_) } $$data; }
}

sub check_and_push
{
  my ($self, $data) = @_;
  push(@{$self->{records}}, $data) if $self->{sub}->($data);
}

1;

I was thinking of uploading it to CPAN to avoid maintaining too generic code with our application codebase.

[simonm]

Unless you have some expectaton of subclassing this, the object orientation seems like overkill.

Also, for general purpose use, UNIVERSAL is probably better than the stringification/regex approach, as it plays better with string overloading.

A further speed improvement can be gained by using list processing to avoid recursive calling:

use strict;
use UNIVERSAL 'isa';

sub deep_grep (&@) {
  my $test = shift;
  
  my ( @results, %seen );
  
  while ( scalar @_ ) {
    my $target = shift @_;
    
    push @results, grep $test->( $_ ), $target; 
    
    unshift @_, $seen{$target} ++        ? ()              : 
                  isa($target, 'HASH')   ? values %$target :
                  isa($target, 'ARRAY')  ? @$target        :
                  isa($target, 'REF')    ? $$target        :
                  isa($target, 'SCALAR') ? $$target        : ();
  }
  return @results;
}

The prototype allows you to call it blockwise, like the builtin grep, but isn't needed:

my @loggers = deep_grep( sub { isa( $_, 'Log' ) }, $target );

my @loggers = deep_grep { isa( $_, 'Log' ) } $target;

[simonm]

A further level of abstraction and optimization can be provided by custom-compiling a subroutine optimized to perform the necessary task:

use strict;
use UNIVERSAL 'isa';

sub build_deep_sub {
  my %options = @_;
  
  my $sub = q/ sub / . ( $options{proto} ? "($options{proto})" : '' ) 
+. q/ {
    / . ( $options{init} ) . q/
    my ( @results, %seen );
    
    while ( scalar @_ ) {
      my $target = shift;
      / . ( $options{guard} ? "next unless grep { $options{guard} } \$
+target;" : "" ) . q/
      push @results, / . ( $options{map} ) . q/ $target;
      
      / . ( $options{post_order} ? 'push' : 'unshift' ) . q/  @_,
      / . ( $options{guard} ? "  grep { $options{guard} }" : "" ) . q/
    $seen{$target} ++        ? ()       :    
      isa($target, 'HASH')   ? %$target :
      isa($target, 'ARRAY')  ? @$target :
      isa($target, 'REF')    ? $$target :
      isa($target, 'SCALAR') ? $$target : ();
    }
    @results;
  } /;
  eval $sub or die "$@: $sub";
}

my $type_search = build_deep_sub( init => 'my $type = shift;', map => 
+'grep isa( $_, $type ), ', guard => 'ref($_)' );

my @loggers = $type_search->( 'Log', $target );

The speed improvement of eliminating a round of subroutine calls will outway the one-time cost of the string eval unless your data structure to be searched is very small.

A library based on this approach could pre-generate a number of generally useful subroutines:

  *{'deep_walk'} = build_deep_sub();
  *{'deep_map'} = build_deep_sub( init => 'my $test = shift;', map => 
+'map $test->($_),' );
  *{'deep_grep'} = build_deep_sub( init => 'my $test = shift;', map =>
+ 'grep $test->($_),' );
  *{'deep_grep_refs'} = build_deep_sub( init => 'my $test = shift;', m
+ap => 'grep $test->($_),', guard => 'ref($_)' );
  *{'deep_grep_type'} = build_deep_sub( init => 'my $type = shift;', m
+ap => 'grep isa( $_, $type ), ', guard => 'ref($_)' );

(For what it's worth, the prototypes generated above don't seem to be quite right, but I'm sure that could be figured out with a bit of experimentation.)

[pemungkah]

Perhaps you might want to attack this from the other end. Instead of deep-searching to find references to the class, just dynamically update the log class to point where you want, overriding only the critical methods:

package Log;

sub new { 
  my ($class) = shift;
  bless {}, $class;
}

sub write {
  print "write old\n";
}

sub open {
  print  "open old\n";
}

sub close {
  print "close old\n";
}
1;

package NewLog;

sub import {
  for my $sub (qw(new write open)) {
    no strict 'refs';
    *{'Log::'.$sub} = *{'NewLog::'.$sub};
  }
}

sub new { 
  my ($class) = shift;
  bless {}, $class;
}

sub write {
  print "write new\n";
}

sub open {
  print  "open new\n";
}
1;

use Log;
use NewLog;

my $log = new Log;
$log->open;
$log->write;
$log->close;

If you run this, you'll see the following output:

open new
write new
close old

Note that open and write are overridden, and close is not. This incurs less overhead if you've got a lot of Log objects, or if your objects using them are very deeply nested.

[Mostly Harmless]

Thanks, that's a good idea. However I can't use it in my case, as there are too many methods in Log.pm to override - they all use couple of instance variables, which should have new values. Ideally this would work for me:


package Redirector;

my $new_obj;
# Redirect all methods calls of object A to object B.
sub redirect
{
  my $new_obj = shift;
  my @methods = @_ || 'all';
  <instrument the methods so that Redirector::foo is called
  instead of old_obj::foo>
}

sub print
{
  my $real_obj = shift;
  # Conveniently switch the object.
  $new_obj->print(@_);
}

The issue with the above is keeping track of $new_obj. This needs to be a package variable, and the class itself has to be a singleton - unless a hash with package names as keys. Any ideas ? For now, deepcopying looks the simplest solution to me, as the data to be traversed is small in size. But I think your idea can be generalized to a Redirector CPAN module !