File Coverage

blib/lib/AutoCurry.pm

Criterion	Covered	Total	%
statement	42	42	100.0
branch	6	8	75.0
condition	3	6	50.0
subroutine	15	15	100.0
pod	2	6	33.3
total	68	77	88.3

package AutoCurry;

# Tom Moertel
# 2005-02-17

=head1 NAME

AutoCurry - automatically create currying variants of functions

=head1 SYNOPSIS

    use AutoCurry qw( foo );  # pass :all to curry all functions

    sub foo { print "@_\n"; }
    # currying variant, foo_c, is created automatically

    my $hello = foo_c("Hello, ");
    $hello->("world!");       # Hello, world!
    $hello->("Pittsburgh!");  # Hello, Pittsburgh!

=cut

use Carp;

use warnings;
use strict;

our $VERSION = "0.1003";
our $suffix  = "_c";

my $PKG = __PACKAGE__;

sub _debug { print STDERR "AutoCurry: @_\n" if $ENV{AUTOCURRY_DEBUG} }

sub curry {
    my $f = shift;
    my $args = \@_;
    sub { $f->(@$args, @_) };
}

sub curry_package {
    my $pkg = shift || caller;
    curry_named_functions_from_package( $pkg,
        get_function_names_from_package( $pkg )
    );
}

sub curry_named_functions {
    return curry_named_functions_from_package( scalar caller(), @_ );
}

sub curry_named_functions_from_package {
    no strict 'refs';
    my $pkg = shift() . "::";
    map {
        my $curried_name = $_ . $suffix;
        carp "$PKG: currying $_ over existing $curried_name"
            if *$curried_name{CODE};
        _debug("making $curried_name");
        *$curried_name = curry( \&curry, \&$_ );
        $curried_name;
    } map { /::/ ? $_ : "$pkg$_" } @_;
}

sub get_function_names_from_package {
    no strict 'refs';
    my $pkg = shift || caller;
    my $symtab = *{ $pkg . "::" }{HASH};
    sort grep *$_{CODE},      # drop symbols w/o code
        map  $pkg."::$_",     # fully qualify
        grep !/^_|^[_A-Z]+$/, # drop _underscored & ALL_CAPS
        keys %$symtab;        # get all symbols for package
}

my @init;

sub import {
    shift;  # don't need self
    my $caller = caller;
    push @init, curry_package_c($caller) if grep /^:all$/, @_;
    curry_named_functions_from_package($caller, grep !/^:/, @_);
}

INIT { finish_initialization() }

sub finish_initialization {
    $_->() for @init; @init = ();
}

# physician, curry thyself!

curry_named_functions(qw(
    curry_package
));


1;

__END__