File Coverage

blib/lib/Data/DRef.pm

Criterion	Covered	Total	%
statement	95	216	43.9
branch	31	122	25.4
condition	7	20	35.0
subroutine	23	42	54.7
pod	30	30	100.0
total	186	430	43.2

### Data::DRef - Delimited-key access to complex data structures

### Copyright 1996, 1997, 1998, 1999 Evolution Online Systems, Inc.
  # You may use this software for free under the terms of the Artistic License.

### Change History
  # 1999-02-06 Added to CPAN module list. Repackaged for distribution.
  # 1999-01-31 Collapsed Data::Collection into Data::DRef.
  # 1999-01-31 Removed Data::Collection's dependancy on Data::Sorting.
  # 1999-01-22 Revision of documentation, and improved Exporter tagging.
  # 1998-12-01 Added get_value_for_optional_dref; minor doc revisions.
  # 1998-10-15 Added explicit undef return value from get_value_for_key.
  # 1998-10-14 Added doc caveat about possible use of UNIVERSAL methods.
  # 1998-10-07 Reworked, conventionalized documentation and Exporter behaviour.
  # 1998-10-06 Refactored value_for_keys algorithm; clarified dref syntax.
  # 1998-07-16 Preliminary support for DRef pragmas: ignore (!reverse). -Simon
  # 1998-05-21 Added undef behavior in matching_keys and matching_values.
  # 1998-05-07 Replaced map with foreach in a few places.
  # 1998-04-17 Updated to use new Data::Sorting interface.
  # 1998-04-10 Added hash_by_array_key.
  # 1998-04-09 Fixed single-item problem with scalarkeysof algorithm. -Simon
  # 1998-03-12 Patched dref manipulation functions to escape separator.
  # 1998-02-24 Changed valuesof to return value of non-ref arguments. -Piglet
  # 1998-01-30 Added array_by_hash_key($) and intersperse($@) -Simon
  # 1997-12-08 Removed package Data::Types, replaced with UNIVERSAL isa.
  # 1997-12-07 Exported uniqueindexby.  -Piglet
  # 1997-11-24 Finished orderedindexby.
  # 1997-11-19 Renamed removekey function to shiftdref at Jeremy's suggestion.
  # 1997-11-14 Added resolveparens behaviour to standard syntax.
  # 1997-11-14 Added getDRef, setDRef functions as can() wrappers for get, set
  # 1997-11-13 Added orderedindexby, but it still needs a bit of work.
  # 1997-10-29 Add'l modifications; replaced recursion with iteration in get()
  # 1997-10-25 Revisions; separator changed from colon to period.
  # 1997-10-03 Refactored get and set operations
  # 1997-09-05 Package split from the original dataops.pm into Data::*.
  # 1997-04-18 Cleaned up documentation a smidge.
  # 1997-04-08 Added getbysubkeys, now called matching_values
  # 1997-01-29 Altered set to create hashes even for numerics
  # 1997-01-28 Possible fix to recurring "keysof operates on containers" error.
  # 1997-01-26 Catch bad argument types for sortby, indexby.
  # 1997-01-21 Failure for keysof, valuesof now returns () rather than undef.
  # 1997-01-21 Added scalarsof.
  # 1997-01-11 Cloned and cleaned for IWAE; removed asdf code to dictionary.pm.
  # 1996-11-18 Moved v2 code into production, additional cleanup. -Simon
  # 1996-11-13 Version 2.00, major overhaul.
  # 1996-10-29 Fixed set to handle '0' items. -Piglet
  # 1996-09-09 Various changes, esp. fixing get to handle '0' items. -Simon
  # 1996-07-24 Wrote copy, getString, added 'append' to set.
  # 1996-07-18 Wrote setData, fixed headers.  -Piglet
  # 1996-07-18 Additional Exporter fudging.
  # 1996-07-17 Globalized theData. -Simon
  # 1996-07-13 Simplified getData into get; wrote set. -Piglet
  # 1996-06-25 Various tweaks.
  # 1996-06-24 First version of dataops.pm created. -Simon

package Data::DRef;

require 5;
use strict;
use Carp;
use Exporter;

use String::Escape qw( printable unprintable );

use vars qw( $VERSION @ISA %EXPORT_TAGS );
$VERSION = 1999.02_06;

push @ISA, qw( Exporter );
%EXPORT_TAGS = (
  key_access => [ qw(
    get_keys get_values get_value_for_key set_value_for_key
    get_or_create_value_for_key get_reference_for_key
    get_value_for_keys set_value_for_keys
  ) ],
  dref_syntax => [ qw(
    $Separator $DRefPrefix dref_from_keys keys_from_dref
    join_drefs unshift_dref_key shift_dref_key resolve_pragmas
  ) ],
  dref_access => [ qw(
    get_key_drefs get_value_for_dref set_value_for_dref
  ) ],
  root_dref => [ qw(
    $Root get_value_for_root_dref set_value_for_root_dref
  ) ],
  'select' => [ qw(
    matching_keys matching_values
  ) ],
  'index' => [ qw(
    index_by_drefs unique_index_by_drefs ordered_index_by_drefs
  ) ],
  'leaf' => [ qw(
    leaf_drefs leaf_values leaf_drefs_and_values
  ) ],
  compat => [ qw(
    getData setData getDRef setDRef joindref shiftdref $Root get set
    $Separator splitdref keysof valuesof scalarkeysof scalarkeysandvalues
    matching_values matching_keys indexby uniqueindexby orderedindexby
  ) ],
);
Exporter::export_ok_tags( keys %EXPORT_TAGS );

### Value-For-Key Interface

# @keys = get_keys($target)
sub get_keys {
  my $target = shift;

  if ( UNIVERSAL::can($target, 'm_get_keys') ) {
    return $target->m_get_keys(@_);
  } elsif ( UNIVERSAL::isa($target, 'HASH') ) {
    return keys %$target;
  } elsif ( UNIVERSAL::isa($target, 'ARRAY') ) {
    return ( 0 .. $#$target );
  } else {
    return ();
  }
}

# @values = get_values($target)
  # Returns a list of scalar values in a referenced hash or list
sub get_values {
  my $target = shift;

  if ( UNIVERSAL::can($target, 'm_get_values') ) {
    return $target->m_get_values(@_);
  } elsif ( UNIVERSAL::isa($target, 'HASH') ) {
    return values %$target;
  } elsif ( UNIVERSAL::isa($target, 'ARRAY') ) {
    return @$target;
  } elsif ( ! ref $target ) {
    return $target;
  } else {
    return ();
  }
}

# $value = get_value_for_key($target, $key);
sub get_value_for_key ($$) {
  my $target = shift;
  croak "get called without target \n" unless (defined $target);

  my $key = shift;

  if ( UNIVERSAL::can($target, 'm_get_value_for_key') ) {
    return $target->m_get_value_for_key($key);
  } elsif ( UNIVERSAL::isa($target, 'HASH') ) {
    return $target->{$key} if (exists $target->{$key});
  } elsif ( UNIVERSAL::isa($target, 'ARRAY') ) {
    carp "Use of non-numeric key '$key'" unless ( $key eq '0' or $key > 0 );
    return $target->[$key] if ($key >= 0 and $key < scalar @$target);
  } else {
    carp "'$target' can't get_value_for_key '$key'\n";
  }
  return undef;
}

# set_value_for_key($target, $key, $value);
sub set_value_for_key ($$$) {
  my $target = shift;
  croak "set_value_for_key called without target \n" unless (defined $target);

  if ( UNIVERSAL::can($target, 'm_set_value_for_key') ) {
    return $target->m_set_value_for_key(@_);
  } elsif ( UNIVERSAL::isa($target, 'HASH') ) {
    $target->{ $_[0] } = $_[1];
  } elsif ( UNIVERSAL::isa($target, 'ARRAY') ) {
    $target->[ $_[0] ] = $_[1];
  } else {
    # We do not natively support set() on anything else.
    carp "'$target' can't set_value_for_key '$_[0]'\n";
  }
}

# $value = get_or_create_value_for_key($target, $key);
sub get_or_create_value_for_key {
  my $target = shift;
  my $key = shift;

  return $target->m_get_or_create_value_for_key($key)
	if ( UNIVERSAL::can($target, 'm_get_or_create_value_for_key') );

  my $value = get_value_for_key($target, $key);

  unless (defined $value) {
    $value = {};
    set_value_for_key($target, $key, $value);
  }

  return $value;
}

# $value_reference = get_reference_for_key($target, $key);
sub get_reference_for_key ($$) {
  my $target = shift;
  croak "get_reference_for_key called w/o target\n" unless (defined $target);

  my $key = shift;

  if ( UNIVERSAL::can($target, 'm_get_reference_for_key') ) {
    return $target->m_get_reference_for_key($key);
  } elsif ( UNIVERSAL::isa($target, 'HASH') ) {
    return \${$target}{$key};
  } elsif ( UNIVERSAL::isa($target, 'ARRAY') ) {
    return \${$target}[$key];
  } else {
    carp "'$target' can't get_reference_for_key '$_[0]'\n";
  }
}

### Multiple-Key Chaining
  #
  # These functions allow access through a series of keys. Generally, the list
  # of keys is interpreted each starting from the result of the previous one.

# $value = get_value_for_keys($target, @keys);
sub get_value_for_keys ($@) {
  my $target = shift;
  croak "get_value_for_keys called without target \n" unless (defined $target);
  croak "get_value_for_keys called without keys \n" unless (scalar @_);

  while ( scalar @_ ) {
    # If we've got keys remaining, use the appropriate get method...
    return $target->m_get_value_for_keys(@_)
	if UNIVERSAL::can($target, 'm_get_value_for_keys');

    my $key = shift @_;
    my $result = get_value_for_key($target, $key);

    # If there aren't any more keys, we're done!
    return $result unless (scalar @_);

    # We can't keep going without a ref value, despite the remaining keys
    return undef unless (ref $result);

    # ... or select the target and iterate through another key
    $target = $result;
  }
}

# set_value_for_keys($target, $value, @keys);
sub set_value_for_keys {
  my $target = shift;
  my $value = shift;

  croak "set_value_for_keys called without target \n" unless (defined $target);
  croak "set_value_for_keys called without keys \n" unless (scalar @_);

  while ( scalar @_ ) {
    return $target->m_set_value_for_keys($value, @_)
	  if UNIVERSAL::can($target, 'm_set_value_for_keys');

    my $key = shift @_;

    # Last key -- we're at the end of the line
    return set_value_for_key($target, $key, $value) unless (scalar @_);

    # Get the value for this key, or create an empty hash ref to build into.
    my $result = get_or_create_value_for_key($target, $key);

    # We've got keys remaining, but we can't keep going
    return undef unless (ref $result);

    $target = $result;
  }
}

# $value = get_or_create_value_for_keys($target, @keys);
sub get_or_create_value_for_keys {
  my $target = shift;
  my $value = shift;

  croak "set_value_for_keys called without target \n" unless (defined $target);
  croak "set_value_for_keys called without keys \n" unless (scalar @_);

  while ( scalar @_ ) {
    return $target->m_get_or_create_value_for_keys($value, @_)
	  if UNIVERSAL::can($target, 'm_get_or_create_value_for_keys');

    my $key = shift @_;
    my $result = get_or_create_value_for_key($target, $key);

    # If there aren't any more keys, we're done!
    return $result unless (scalar @_);

    # We can't keep going without a ref value, despite the remaining keys
    return undef unless (ref $result);

    # ... or select the target and iterate through another key
    $target = $result;
  }
}

# $val_ref = get_reference_for_keys($target, @keys);
sub get_reference_for_keys {
  my $target = shift;

  croak "get_reference_for_keys called w/o target\n" unless (defined $target);
  croak "get_reference_for_keys called w/o keys \n" unless (scalar @_);

  while ( scalar @_ ) {
    return $target->m_get_reference_for_keys(@_)
	  if UNIVERSAL::can($target, 'm_get_reference_for_keys');

    my $key = shift @_;

    # Last key -- we're at the end of the line
    return get_reference_for_key($target, $key) unless (scalar @_);

    # Get the value for this key, or create an empty hash ref to build into.
    my $result = get_or_create_value_for_key($target, $key);

    # We've got keys remaining, but we can't keep going
    return undef unless (ref $result);

    $target = $result;
  }
}

### DRef Syntax
  #
  # DRef strings are dot-separated

# $Separator - Multiple-key delimiter character
use vars qw( $Separator $DRefPrefix );
$Separator = '.';
$DRefPrefix = '#';

# @drefs = get_key_drefs($target);
sub get_key_drefs {
  map { printable($_) } get_keys( @_ );
}

# $dref = dref_from_keys( @keys );
  # Return a dref composed of a list of $Separator-protected keys
sub dref_from_keys (@) {
  join $Separator, map { printable($_) } @_;
}

# @keys = keys_from_dref( $dref );
  # Return a series of key strings extracted from a dref
sub keys_from_dref ($) {
  my $dref = shift;
  my @keys;
  while ( defined $dref and length $dref ) {
    $dref =~ s/\A((?:[^\\\Q$Separator\E]+|\\.)*)(?:\Q$Separator\E|\Z)//m;
    push(@keys, unprintable($1));
  }
  return @keys;
}

# $dref = join_drefs( @drefs );
sub join_drefs (@) {
  join($Separator, @_);
}

# unshift_dref_key( $dref, $key );
  # Prepends key to dref -- modifies value of first argument
sub unshift_dref_key {
  $_[0] = join($Separator, unprintable($_[1]), $_[0]);
}

# $key = shift_dref_key( $dref );
  # Removes first key from dref -- modifies value of its argument
sub shift_dref_key {
  $_[0] =~ s/\A((?:[^\\\Q$Separator\E]+|\\.)*)(?:\Q$Separator\E|\Z)//m;
  return unprintable($1);
}

# $dref = resolve_pragmas( $dref_with_embedded_parens );
# ($dref, %options) = resolve_pragmas( $dref_with_embedded_parens );
sub resolve_pragmas ($) {
  my $path = shift;
  my $options = {};

  do {} while (
    $path =~ s/(\A|[^\\]|[^\\](?:\\{2})*)\(([\#\!])([^\(\)]+)\)
		    /$1._expand_pragma($2, $3, $options)/ex
  );

  return wantarray ? ($path, %$options) : $path;
}

sub _expand_pragma {
  my ($type, $value, $options) = @_;
  if ( $type eq $DRefPrefix ) {
    return get_value_for_root_dref($value);
  } elsif ( $type eq '!' ) {
    $options->{ $value } = 1;
  } else {
    carp "use of unsupported DRef pragma '$type$value'";
  }
  return '';
}

### DRef Access

# $value = get_value_for_dref($target, $dref);
sub get_value_for_dref {
  get_value_for_keys $_[0], keys_from_dref( (resolve_pragmas($_[1]))[0] );
}

# set_value_for_dref($target, $dref, $value);
sub set_value_for_dref {
  set_value_for_keys $_[0], $_[2], keys_from_dref((resolve_pragmas($_[1]))[0]);
}

### Shared Data Graph Entry

# $Root - Data graph entry point
use vars qw( $Root );
$Root = {};

# $value = get_value_for_root_dref($dref);
sub get_value_for_root_dref ($)  {
  get_value_for_dref($Root, @_)
}

# $value = set_value_for_root_dref($dref, $value);
sub set_value_for_root_dref ($$) {
  set_value_for_dref($Root, @_)
}

# $value = get_value_for_optional_dref($literal_or_dref_with_leading_hashmark);
sub get_value_for_optional_dref ($)  {
  $_[0] =~ /^\Q$DRefPrefix\E(.*)/o ? get_value_for_root_dref($1) : $_[0]
}

### Select by DRefs

# $key or @keys = matching_keys($target, %dref_value_criteria_pairs);
sub matching_keys {
  my($target, %kvp_criteria) = @_;
  return unless ($target and scalar %kvp_criteria);
  my ($key, $dref, @keys);
  ITEM: foreach $key (get_keys $target) {
    my $item = get_value_for_key($target,$key);
    foreach $dref (keys %kvp_criteria) {
      next ITEM unless $kvp_criteria{$dref} eq (
        defined $dref && length $dref ? get_value_for_dref($item,$dref) : $item
      );
    }
    return $key unless (wantarray);
    push @keys, $key;
  }
  return @keys;
}

# $item or @items = matching_values($target, %dref_value_criteria_pairs);
sub matching_values {
  my($target, %kvp_criteria) = @_;
  my($item, $dref, @items);
  ITEM: foreach $item ( get_values($target) ) {
    foreach $dref (keys %kvp_criteria) {
      next ITEM unless $kvp_criteria{$dref} eq (
        defined $dref && length $dref ? get_value_for_dref($item,$dref) : $item
      );
    }
    return $item unless (wantarray);
    push @items, $item;
  }
  return @items;
}

### Index by DRefs

# $index = index_by_drefs($target, @drefs)
sub index_by_drefs {
  my($target, @drefs) = @_;
  my $index = {};

  my $item;
  foreach $item ( get_values($target) ) {
    my @keys = map { get_value_for_dref($item, $_) } @drefs;
    my $grouping = get_reference_for_keys($index, @keys);
    push @$$grouping, $item;
  }

  return $index;
}

# $index = unique_index_by_drefs($target, @drefs)
sub unique_index_by_drefs {
  my($target, @drefs) = @_;
  my $index = {};

  my $item;
  foreach $item (get_values ($target)) {
    my @keys = map { get_value_for_dref($item, $_) } @drefs;
    set_value_for_keys($index, $item, @keys);
  }

  return $index;
}

# $entry_ary = ordered_index_by_drefs( $target, $index_dref );
sub ordered_index_by_drefs {
  my($target, $grouper) = @_;
  my $index = {};
  my $order = [];

  my $item;
  foreach $item ( get_values($target) ) {
    my $value = get_value_for_dref($item, $grouper);
    $value = '' unless (defined $value);
    push @$order, (
      $index->{$value} = { 'value' => $value, 'items' => [] }
    ) unless ( exists($index->{ $value }) );
    push @{ $index->{ $value }{'items'} }, $item;
  }
  return $order;
}

### DRefs to Leaf nodes

# @drefs = leaf_drefs($target);
  # Returns a list of drefs for non-ref leaves in a referenced structure.
  # Keep track of items we've visited previously to protect against loops.
sub leaf_drefs ($) {
  my $target = shift;
  my @drefs = get_key_drefs( $target );
  my %visited;
  my $i;
  for ( $i = 0; $i <= $#drefs; $i++ ) {
    my $dref = $drefs[$i];
    my $value = get_value_for_dref($target, $dref);
    next if ( ! ref $value or $visited{$value}++ );
    my @subkeys = get_key_drefs( $value );
    if ( scalar @subkeys ) {
      splice @drefs, $i, 1, map { join_drefs($dref, $_) } @subkeys;
      $i--;
    }
  }
  return @drefs;
}

# @values = leaf_values( $target )
sub leaf_values ($) {
  my $target = shift;
  map { get_value_for_dref($target, $_) } leaf_drefs( $target );
}

# %dref_value_pairs = leaf_drefs_and_values( $target )
sub leaf_drefs_and_values ($) {
  my $target = shift;
  map { $_, get_value_for_dref($target, $_) } leaf_drefs( $target );
}

### Compatiblity

*get = *get_value_for_dref;
*set = *set_value_for_dref;
*getDRef = *get_value_for_dref;
*setDRef = *set_value_for_dref;
*getData = *get_value_for_root_dref;
*setData = *set_value_for_root_dref;
*splitdref = *keys_from_dref;
*joindref = *dref_from_keys;
*shiftdref = *shift_dref_key;
*keysof = *get_keys;
*valuesof = *get_values;
*indexby = *index_by_drefs;
*uniqueindexby = *unique_index_by_drefs;
*orderedindexby = *ordered_index_by_drefs;
*scalarkeysof = *leaf_drefs;
*scalarkeysandvalues = *leaf_drefs_and_values;

### Data::DRef::MethodBased

package Data::DRef::MethodBased;

### Minimal DRef Interface for Object Methods

# @keys = $target->m_get_keys()
sub m_get_keys {
  return ();
}

# @values = $target->m_get_values()
sub m_get_values {
  my $target = shift;
  map { $target->m_get_value_for_key($_) } $target->m_get_keys;
}

# $value = $target->m_get_value_for_key($key);
sub m_get_value_for_key {
  my ($target, $key) = @_;
  return $target->$key() if ( $target->can($key) );
  die "$target is unable to get value for key '$key'\n";
}

# $target->m_set_value_for_key($key, $value);
sub m_set_value_for_key {
  my ($target, $key, $value) = @_;
  return $target->$key($value) if ( $target->can($key) );
  die "$target is unable to set value for key '$key'\n";
}

# No default implementation provided for these other supported methods...
  # $value_reference = $target->m_get_reference_for_key($key);
  # $value = $target->m_get_or_create_value_for_key($key);
  # $value = $target->m_get_value_for_keys(@keys);
  # $target->m_set_value_for_keys($value, @keys);
  # $val_ref = $target->m_get_reference_for_keys(@keys);
  # $target->m_set_value_for_keys($value, @keys);

1;

__END__