File Coverage

blib/lib/Data/Miscellany.pm

Criterion	Covered	Total	%
statement	51	72	70.8
branch	31	48	64.5
condition	15	29	51.7
subroutine	12	17	70.5
pod	11	11	100.0
total	120	177	67.8

use 5.008;
use strict;
use warnings;

package Data::Miscellany;
our $VERSION = '1.100850';
# ABSTRACT: Collection of miscellaneous subroutines

use Exporter qw(import);
our %EXPORT_TAGS = (
    util => [
        qw/
          set_push flex_grep flatten is_deeply eq_array eq_hash
          is_defined value_of str_value_of class_map trim
          /
    ],
);
our @EXPORT_OK = @{ $EXPORT_TAGS{all} = [ map { @$_ } values %EXPORT_TAGS ] };

# Like push, but only pushes the item(s) onto the list indicated by the list
# ref (first param) if the list doesn't already contain it.
# Originally, I used Storable::freeze to see whether two structures where the
# same, but this didn't work for all cases, so I switched to is_deeply().
sub set_push (\@@) {
    my ($list, @items) = @_;
  ITEM:
    for my $item (@items) {
        for my $el (@$list) {
            next ITEM if is_deeply($item, $el);
        }
        push @$list, $item;
    }
}

sub flatten {
    ref $_[0] eq 'ARRAY' ? @{ $_[0] }
      : defined $_[0] ? @_
      :                 ();
}

# Start of code adapted from Test::More
#
# In set_push and other places within the framework, we need to compare
# structures deeply, so here are the relevant methods copied from Test::More
# with the test-specific code removed.
sub is_deeply {
    my ($this, $that) = @_;
    return _deep_check($this, $that) if ref $this && ref $that;
    return $this eq $that if defined $this && defined $that;

    # undef only matches undef and nothing else
    return !defined $this && !defined $that;
}

sub _deep_check {
    my ($e1, $e2) = @_;

    # Quiet uninitialized value warnings when comparing undefs.
    local $^W = 0;
    return 1 if $e1 eq $e2;
    return eq_array($e1, $e2)
      if UNIVERSAL::isa($e1, 'ARRAY') && UNIVERSAL::isa($e2, 'ARRAY');
    return eq_hash($e1, $e2)
      if UNIVERSAL::isa($e1, 'HASH') && UNIVERSAL::isa($e2, 'HASH');
    return _deep_check($$e1, $$e2)
      if UNIVERSAL::isa($e1, 'REF') && UNIVERSAL::isa($e2, 'REF');
    return _deep_check($$e1, $$e2)
      if UNIVERSAL::isa($e1, 'SCALAR') && UNIVERSAL::isa($e2, 'SCALAR');
    return 0;
}

sub eq_array {
    my ($a1, $a2) = @_;
    return 1 if $a1 eq $a2;
    return 0 unless $#$a1 == $#$a2;
    for (0 .. $#$a1) {
        return 0 unless is_deeply($a1->[$_], $a2->[$_]);
    }
    return 1;
}

sub eq_hash {
    my ($a1, $a2) = @_;
    return 1 if $a1 eq $a2;
    return 0 unless keys %$a1 == keys %$a2;
    foreach my $k (keys %$a1) {
        return 0 unless exists $a2->{$k};
        return 0 unless is_deeply($a1->{$k}, $a2->{$k});
    }
    return 1;
}

# End of code adapted from Test::More
# Handle value objects as well as normal scalars
sub is_defined ($) {
    my $value = shift;

    # restrict the method call to objects of type Class::Value, because we
    # want to avoid deep recursion that could happen if is_defined() is
    # imported into a package and then someone else calls is_defined() on an
    # object of that package.
    ref($value)
      && UNIVERSAL::isa($value, 'Class::Value')
      && UNIVERSAL::can($value, 'is_defined')
      ? $value->is_defined
      : defined($value);
}

sub value_of ($) {
    my $value = shift;

    # Explicitly return undef unless the value is_defined, because it could
    # still be a value object, in which case the value we want isn't the value
    # object itself, but 'undef'
    is_defined $value ? "$value" : undef;
}

sub str_value_of ($) {
    my $value = shift;
    is_defined $value ? "$value" : '';
}

sub flex_grep {
    my $wanted = shift;
    return grep { $_ eq $wanted }
      map { flatten($_) } @_;
}

sub class_map {
    my ($class, $map, $seen) = @_;

    # circularities
    $seen ||= {};

    # so we can pass an object as well as a class name:
    $class = ref $class if ref $class;
    return if $seen->{$class}++;
    my $val = $map->{$class};
    return $val if defined $val;

    # If there's no direct mapping for an exception class, check its
    # superclasses. Assumes that the classes are loaded, of course.
    no strict 'refs';
    for my $super (@{"$class\::ISA"}) {
        my $found = class_map($super, $map, $seen);

        # we will return UNIVERSAL if everything fails - so skip it.
        return $found if defined $found && $found ne $map->{UNIVERSAL};
    }
    return $map->{UNIVERSAL};
}

sub trim {
    my $s = shift;
    $s =~ s/^\s+//;
    $s =~ s/\s+$//;
    $s;
}
1;



__END__