How can I easily generate a Perl function depending on name of the importing class? - perl

Question

I want to export a function which depends on name of class where is exported into. I thought that it should be easy with Sub::Exporter but unfortunately the into key is not passed to generators. I have ended up with those ugly example code:
use strict;
use warnings;
package MyLog;
use Log::Log4perl qw(:easy get_logger);
use Sub::Exporter -setup => {
exports => [
log => \&gen_log,
audit_log => \&gen_log,
],
groups => [ default => [qw(log audit_log)] ],
collectors => ['category'],
installer => \&installer, # tunnel `into` value into generators
};
if ( not Log::Log4perl->initialized() ) {
#easy init if not initialised
Log::Log4perl->easy_init($ERROR);
}
sub gen_log {
my ( $class, $name, $arg, $global ) = #_;
my $category = $arg->{category};
$category = $global->{category}{$name} unless defined $category;
return sub { # return generator
my $into = shift; # class name passed by `installer`
$category = $name eq 'audit_log' ? "audit_log.$into" : $into
if !defined $category; # set default category
# lazy logger
my $logger;
return sub {
$logger or $logger = get_logger($category);
};
};
}
sub installer {
my ( $args, $todo ) = #_;
# each even value is still generator thus generate final function
my $i;
1 & $i++ and $_ = $_->( $args->{into} ) for #$todo;
Sub::Exporter::default_installer(#_);
}
1;
Is there better way how to do it without sacrifice all this rich Sub::Exporter abilities?
For example I would like to use one of those:
use MyLog category => { log => 'foo', audit_log => 'bar' };
use MyLog -default => { -prefix => 'my_' };
use MyLog
audit_log => { -as => 'audit' },
log => { -as => 'my_log', category => 'my.log' };
Edit: Added Sub::Exporter abilities requirement to question.
Edit2: Added usage examples.

Answer 1

You aren't clear how you want to determine the name. If I understand you correctly, this does what you want.
my %sub_for = (
foo => \&foo,
#...
);
sub install_as {
my ($package, $exported_name, $sub) = #_;
no strict 'refs';
*{"$package\::$exported_name"} = $sub;
return;
}
sub get_name_for {
my ($package, $name) = #_;
#... your code here
}
sub import {
my $class = shift;
my $package = caller;
for my $internal_name (#_) {
install_as($package, get_name_for($package, $internal_name), $get_sub_for{$name});
}
return;
}