view release on metacpan or  search on metacpan

lib/Data/SmartMunge.pm  view on Meta::CPAN

use 5.008;
use strict;
use warnings;

package Data::SmartMunge;
BEGIN {
  $Data::SmartMunge::VERSION = '1.101612';
}

# ABSTRACT: Munge scalars, hashes and arrays in flexible ways
use Exporter qw(import);
our %EXPORT_TAGS = (util => [qw(smart_munge delete_matching)],);
our @EXPORT_OK = @{ $EXPORT_TAGS{all} = [ map { @$_ } values %EXPORT_TAGS ] };
my %munger_dispatch = (
    STRING_CODE => sub { $_[1]->($_[0]) },
    ARRAY_CODE  => sub { $_[1]->($_[0]) },
    HASH_CODE   => sub { $_[1]->($_[0]) },
    HASH_HASH   => sub { +{ %{ $_[0] }, %{ $_[1] } } },  # overlay
);

sub smart_munge {
    my ($data, $munger) = @_;

    unless (defined $munger) {
        return $data unless wantarray;
        return @$data if ref $data eq 'ARRAY';
        return %$data if ref $data eq 'HASH';
    }

    my $data_ref   = ref $data   || 'STRING';
    my $munger_ref = ref $munger || 'STRING';
    if (my $handler = $munger_dispatch{ $data_ref . '_' . $munger_ref }) {
        my $result = $handler->($data, $munger);
        return $result unless wantarray;
        return @$result if ref $result eq 'ARRAY';
        return %$result if ref $result eq 'HASH';
    } else {
        die "can't munge $data_ref with $munger_ref";
    }
}

sub delete_matching {
    my ($re, $flags) = @_;
    $flags = '' unless defined $flags;
    return $flags =~ s/g//
        ?  sub { $_[0] =~ s/$re//g; $_[0] }
        :  sub { $_[0] =~ s/$re//; $_[0] };
}


__END__
=pod

=head1 NAME

Data::SmartMunge - Munge scalars, hashes and arrays in flexible ways

=head1 VERSION

version 1.101612

=head1 SYNOPSIS

    use Data::SmartMunge qw(:all);

    my $s  = smart_munge('foo bar baz', sub { uc $_[0] });
    my $s2 = smart_munge('foo bar baz bar baz', delete_matching(qr/bar\s*/, 'g'));

    my $a_ref = smart_munge([ 1 .. 4 ], sub { [ reverse @{ $_[0] } ] });
    my @a = smart_munge([ 1 .. 4 ], sub { [ reverse @{ $_[0] } ] });

    my %h = smart_munge(
        { a => 'foo', b => 'bar' },
        sub {
            +{ map { $_ => uc $_[0]->{$_} } keys %{ $_[0] } };
        },
    );