File Coverage

blib/lib/Data/Reach.pm

Criterion	Covered	Total	%
statement	69	73	94.5
branch	41	52	78.8
condition	17	18	94.4
subroutine	11	11	100.0
pod	1	1	100.0
total	139	155	89.6

package Data::Reach;
use strict;
use warnings;
use Carp         qw/carp croak/;
use Scalar::Util qw/blessed reftype/;
use overload;

our $VERSION    = '1.00';

# main entry point
sub reach ($@) {
  my ($root, @path) = @_;

  # loop until either @path or the datastructure under $root is exhausted
  while (1) {

    # exit conditions
    return undef             if !defined $root;
    return $root             if !@path;
    my $path0 = shift @path;
    return undef             if !defined $path0;

    # otherwise, walk down one step into the datastructure and loop again
    $root = blessed $root ? _step_down_obj($root, $path0)
                          : _step_down_raw($root, $path0);
  }
}

# get inner data within a raw datastructure
sub _step_down_raw {
  my ($data, $key) = @_;

  my $reftype = reftype $data || '';

  if ($reftype eq 'HASH') {
    return $data->{$key};
  }
  elsif ($reftype eq 'ARRAY') {
    if ($key =~ /^-?\d+$/) {
      return $data->[$key];
    }
    else {
      croak "cannot reach index '$key' within an array";
    }
  }
  else {
    my $kind = $reftype          ? "${reftype}REF"
             : defined ref $data ? "SCALAR"
             :                     "undef";
    my $article = $kind =~ /^[aeiou]/i ? "an" : "a";
    croak "cannot reach '$key' within $article $kind";
  }
}


# get inner data within an object
sub _step_down_obj {
  my ($obj, $key) = @_;

  # pragmata that may modify our algorithm -- see L
  my $hint_hash = (caller(1))[10];
  my $use_overloads = $hint_hash->{'Data::Reach::use_overloads'} // 1; # default
  my $peek_blessed  = $hint_hash->{'Data::Reach::peek_blessed'}  // 1; # default

  # choice 1 : call named method in object
  my @call_method = split $;, $hint_hash->{'Data::Reach::call_method'} || '';
 METH_NAME:
  foreach my $meth_name (@call_method) {
    my $meth =$obj->can($meth_name)
      or next METH_NAME;
    return $obj->$meth($key);
  }

  # choice 2 : use overloaded methods -- active by default
  if ($use_overloads) {
    return $obj->[$key] if overload::Method($obj, '@{}')
                        && $key =~ /^-?\d+$/;
    return $obj->{$key} if overload::Method($obj, '%{}');
  }

  # choice 3 : use the object's internal representation -- active by default
  if ($peek_blessed) {
    return _step_down_raw($obj, $key);
  }
  else {
    croak "cannot reach '$key' within an object of class " . ref $obj;
  }
}



# the 'import' method does 2 things : a) export the 'reach' function,
# like the regular Exporter, but possibly with a change of name;
# b) implement optional changes to the algorithm, lexically scoped
# through the %^H hint hash (see L).

my %seen_pkg; # remember which packages we already exported into

sub import {
  my $class = shift;
  my $pkg = caller;
  my $export_as;

  # cheap parsing of import parameters -- I wish I could implement that
  # with given/when, but unfortunately those constructs were dropped in v5.18.
  while (my $option = shift) {
    if ($option eq 'reach') {
      $export_as = 'reach';
    }
    elsif ($option eq 'as') {
      $export_as = shift;
      defined $export_as
        or croak "use Data::Reach : no export name after 'as'";
    }
    elsif ($option eq 'call_method') {
      my $methods = shift
        or croak "use Data::Reach : no method name after 'call_method'";
      $methods = join $;, @$methods if (ref $methods || '') eq 'ARRAY';
      $^H{"Data::Reach::call_method"} = $methods;
    }
    elsif ($option eq 'peek_blessed') {
      $^H{"Data::Reach::peek_blessed"} = 1;
    }
    elsif ($option eq 'use_overloads') {
      $^H{"Data::Reach::use_overloads"} = 1;
    }
    else {
      croak "use Data::Reach : unknown option : $option";
    }
  }

  # export the 'reach' function into caller's package, under name $export_as
  if (! exists $seen_pkg{$pkg}) {
    $export_as //= 'reach'; # default export name
    if ($export_as) {       # because it could be an empty string
      no strict 'refs';
      *{$pkg . "::" . $export_as} = \&reach;
    }
    $seen_pkg{$pkg} = $export_as;
  }
  elsif ($export_as && $export_as ne $seen_pkg{$pkg}) {
    carp "ignored request to import Data::Reach::reach as '$export_as' into "
       . "package $pkg, because it was already imported as '$seen_pkg{$pkg}'!";
  }
}


sub unimport {
  my $class = shift;
  while (my $option = shift) {
    $^H{"Data::Reach::$option"} = '';
    # NOTE : mark with a false value, instead of deleting from the
    # hint hash, in order to distinguish options explicitly turned off
    # from default options
  }
}


1;


__END__