File Coverage

blib/lib/Data/Reach.pm

Criterion	Covered	Total	%
statement	122	123	99.1
branch	87	102	85.2
condition	56	66	84.8
subroutine	15	15	100.0
pod	3	3	100.0
total	283	309	91.5

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

our $VERSION    = '2.00';


#======================================================================
# reach() and utility functions
#======================================================================
# 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 $meth_name = $hint_hash->{'Data::Reach/reach_method'} || '';
  return $obj->$meth_name($key) if $obj->can($meth_name);

  # choice 2 : use overloaded methods -- active by default
  if ($use_overloads) {
    # overloaded array dereferencing is tried first but only if the key is numeric.
    # Otherwise, the hash dereferencing is tried.
    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;
  }
}


#======================================================================
# map_paths()
#======================================================================

sub map_paths (&+;$$$); # the prototype must be declared beforehand, because the sub is recursive
sub map_paths (&+;$$$) {
  my ($coderef, $tree, $max_depth, $path, $recurse)= @_;
  $max_depth  //= -1;
  $path       //= [];                                        # only used for recursive calls
  $recurse    //= reftype $tree // '';                       # only used for recursive calls

  my $hint_hash             = (caller(1))[10];
  my $ignore_empty_subtrees = ! $hint_hash->{'Data::Reach/keep_empty_subtrees'};

  if ($max_depth) {
    if ($recurse eq 'ARRAY' and (@$tree or $ignore_empty_subtrees)) {
      return map {map_paths(\&$coderef, $tree->[$_], $max_depth-1, [@$path, $_])} 0 .. $#$tree;
    }
    elsif ($recurse eq 'HASH' and (my @k = sort keys %$tree or $ignore_empty_subtrees)) {
      return map {map_paths(\&$coderef, $tree->{$_}, $max_depth-1, [@$path, $_])} @k;
    }
    elsif (blessed $tree) {
      # try to call named method in object
      if (my $meth_name = $hint_hash->{'Data::Reach/paths_method'}) {
        if ($tree->can($meth_name)) {
          my @paths = $tree->$meth_name();
          return map {map_paths(\&$coderef, reach($tree, $_), $max_depth-1, [@$path, $_])} @paths;
        }
      }

      # otherwise, try to use overloaded methods, or else use the object's internal representation (if allowed)
      my $use_overloads = $hint_hash->{'Data::Reach/use_overloads'} // 1; # default
      my $peek_blessed  = $hint_hash->{'Data::Reach/peek_blessed'}  // 1; # default
      $recurse = $use_overloads && overload::Method($tree, '@{}') ? 'ARRAY'
               : $use_overloads && overload::Method($tree, '%{}') ? 'HASH'
               : $peek_blessed                                    ? reftype $tree
               :                                                    undef;

      # recursive call if appropriate
      return map_paths(\&$coderef, $tree, $max_depth, $path, $recurse) if $recurse;

      # if all else failed, treat this object as an opaque leaf (see base case below)
    }
  }

  # base case
  for ($tree) {return $coderef->(@$path)};                   # @_ contains the path, $_ contains the leaf
}



#======================================================================
# each_path()
#======================================================================

sub each_path (+;$) {
  my ($tree, $max_depth) = @_;
  $max_depth //= -1;
  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
  my $keep_empty_subtrees = $hint_hash->{'Data::Reach/keep_empty_subtrees'};

  # local boolean variable to avoid returning the same result multiple times
  my $is_consumed = 0;

  # closure to be used at tree leaves
  my $leaf = sub {return $is_consumed++ ? () : ([], $tree)};

  my $paths_method = $hint_hash->{'Data::Reach/paths_method'};
  my $recurse = !blessed $tree                                   ? reftype $tree
              : $paths_method  && $tree->can($paths_method)      ? 'OBJECT'
              : $use_overloads && overload::Method($tree, '@{}') ? 'ARRAY'
              : $use_overloads && overload::Method($tree, '%{}') ? 'HASH'
              : $peek_blessed                                    ? reftype $tree
              :                                                    undef;

  # either this tree is a leaf, or we must recurse into subtrees
  if (!$recurse || $recurse !~ /^(OBJECT|HASH|ARRAY)$/ || !$max_depth) {
    return $leaf;
  }
  else {
    my @paths = $recurse eq 'OBJECT' ? $tree->$paths_method()
              : $recurse eq 'HASH'   ? sort keys %$tree
              : $recurse eq 'ARRAY'  ? (0 .. $#$tree)
              :                        ();
    if (!@paths && $keep_empty_subtrees) {
      return $leaf;
    }
    else {
      my $next_subpath;                                          # iterator into next subtree

      return sub {
        while (1) {
          if (!$next_subpath) {                                  # if there is no current iterator
            if (!$is_consumed && @paths) {                       # if there is a chance to get a new iterator
              my $subtree   = reach $tree, $paths[0];
              $next_subpath = each_path($subtree, $max_depth-1); # build an iterator on next subtree
            }
            else {                                               # end of data
              $is_consumed++;
              return ();
            }
          }
          if (my ($subpath, $subval) = $next_subpath->()) {      # try to get content from the current iterator
            return ([$paths[0], @$subpath], $subval);            # found a path, return it
          }
          else {                                                 # mark that the iterator on this subtree ..
            $next_subpath = undef;                               # .. is finished and move to the next data item
            shift @paths;
          }
        }
      }
    }
  }
}




#======================================================================
# class methods: import and unimport
#======================================================================

# the 'import' method does 2 things : a) export the required functions,
# 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 $exported_functions = qr/^(?: reach | each_path | map_paths )$/x;
my $hint_options       = qr/^(?: peek_blessed | use_overloads | keep_empty_subtrees )$/x;

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

  # defaults
  my %export_as = map {($_ => $_)} qw/reach each_path map_paths/ if !@_;
  my $last_func = 'reach';

  # loop over args passed to import()
  while (my $option = shift) {
    if ($option =~ $exported_functions) {
      $export_as{$option} = $option;
      $last_func          = $option;
    }
    elsif ($option eq 'as') {
      my $alias = shift
        or croak "use Data::Reach : no export name after 'as'";
      $export_as{$last_func} = $alias;
    }
    elsif ($option =~ /^(reach|call)_method$/) {
      warn q{"use Data::Reach call_method => .." is obsolete; use "reach_method => .."} if $1 eq 'call';
      my $method = shift
        or croak "use Data::Reach : no method name after 'reach_method'";
      $^H{"Data::Reach/reach_method"} = $method;
    }
    elsif ($option eq 'paths_method') {
      my $method = shift
        or croak "use Data::Reach : no method name after 'paths_method'";
      $^H{"Data::Reach/paths_method"} = $method;
    }
    elsif ($option =~ $hint_options) {
      $^H{"Data::Reach/$option"} = 1;
    }
    else {
      croak "use Data::Reach : unknown option : $option";
    }
  }

  # export into caller's package, under the required alias names
  while (my ($func, $alias) = each %export_as) {
    no strict 'refs';
    *{$pkg . "::" . $alias} = \&$func if $alias;
  }
}


sub unimport {
  my $class = shift;
  while (my $option = shift) {
    $^H{"Data::Reach/$option"} = '' if $option =~ $hint_options;
    # 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__