my $curried_foo = curry( \&foo, args... );
####
sub log_to_handle {
my ($fh, $heading, $message) = @_;
print $fh "$heading: $message", $/;
}
##
##
my $app_server = AppServer->new( logger => $mylogger, ... );
##
##
sub app_server_diagnostic_logger {
log_to_handle( *STDERR, "app server", @_ );
}
$app_server = AppServer->new(
logger => \&app_server_diagnostic_logger, ...
);
##
##
$app_server = AppServer->new(
logger => sub {
log_to_handle( *STDERR, "app-server", @_ )
}, ...
);
##
##
$app_server = AppServer->new(
logger => curry( \&log_to_handle, *STDERR, "app-server" ),
...
);
##
##
$app_server = AppServer->new(
logger => log_to_handle( *STDERR, "app-server" ),
...
);
##
##
$app_server = AppServer->new(
logger => log_to_handle_c( *STDERR, "app-server" ),
...
);
##
##
sub curry {
my $f = shift;
my $args = \@_;
sub { $f->(@$args, @_) };
}
##
##
*log_to_handle_c = curry( \&curry, \&log_to_handle );
##
##
sub get_function_names_from_package {
no strict 'refs';
my $pkg = shift || caller;
my $symtab = *{ $pkg . "::" }{HASH};
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
}
##
##
{ package Test;
sub one { }
sub two { }
sub three { }
$Test::not_a_function = 1;
}
my @names = get_function_names_from_package("Test");
print "@names", $/;
# Test::three Test::one Test::two
##
##
for (@names) {
no strict 'refs';
my $curried_name = $_ . "_c";
*$curried_name = curry( \&curry, \&$_ );
}
##
##
use AutoCurry qw( foo ); # pass ':all' to curry all functions
sub foo { print "@_$/"; }
# currying variant, foo_c, is created automatically
##
##
package AutoCurry;
# Tom Moertel
# 2004-11-16
# $Id: AutoCurry.pm,v 1.3 2004/11/17 04:56:17 thor Exp $
=head1 NAME
AutoCurry - automatically create currying variants of functions
=head1 SYNOPSIS
use AutoCurry qw( foo ); # pass :all to curry all functions
sub foo { print "@_$/"; }
# currying variant, foo_c, is created automatically
my $hello = foo_c("Hello,");
$hello->("world!"); # Hello, world!
$hello->("Pittsburgh!"); # Hello, Pittsburgh!
=cut
use Carp;
my $PKG = __PACKAGE__;
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 {
curry_named_functions_from_package( scalar caller(), @_ );
}
sub curry_named_functions_from_package {
no strict 'refs';
my $pkg = shift() . "::";
map {
my $curried_name = $_ . "_c";
carp "$PKG: currying $_ over existing $curried_name"
if *$curried_name{CODE};
*$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};
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, a currying variant 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, and then calls the original C, giving it both the
captured and new arguments.
If C is a function and C is its currying variant, then the
following are equivalent for all argument lists C<@a> and C<@b>:
foo(@a, @b);
foo_c(@a, @b)->();
foo_c()->(@a, @b);
foo_c(@a)->(@b);
do { my $foo1 = foo_c(@a); $foo1->(@b) };
=head2 use AutoCurry I
You can create currying variants at C