in reply to Re: searching for an object reference
in thread searching for an object reference

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;

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

Replies are listed 'Best First'.
Re^3: searching for an object reference
by simonm (Vicar) on Jul 08, 2005 at 23:52 UTC
    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;
}

    [download]

    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;

    [download]

[reply]
[d/l]
[select]
      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 );

      [download]

      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($_)' );

      [download]

      (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.)

[reply]
[d/l]
[select]

In Section Seekers of Perl Wisdom