view release on metacpan or  search on metacpan

lib/AutoCurry.pm  view on Meta::CPAN

package AutoCurry;

# Tom Moertel <tom@moertel.com>
# 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__

=head1 DESCRIPTION

This module automatically creates currying variants of functions.  For
each function C<foo>, a currying variant C<foo_c> will be created that
(1) captures whatever arguments are passed to it and (2) returns a new
function.  The new function awaits any new arguments that are passed
to I<it>, and then calls the original C<foo>, giving it both the
captured and new arguments.