Comment puis-je générer facilement une fonction Perl en fonction du nom de la classe importatrice?

Question

Je veux exporter une fonction qui dépend du nom de la classe dans laquelle elle est exportée. Je pensais que ce devrait être facile avec Sub::Exporter mais malheureusement la clé into n'est pas transmise aux générateurs. J'ai fini avec les exemples de code laid:

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; 

Y at-il une meilleure façon comment le faire sans sacrifier tout ce Sub::Exporter riches capacités?

Par exemple, je voudrais utiliser l'un de ceux:

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' }; 

Modifier: Ajout Sub::Exporter exigence de capacités à la question.

Édition2: Ajout d'exemples d'utilisation.

Answer 1

Vous ne savez pas exactement comment vous voulez déterminer le nom. Si je vous comprends bien, cela fait ce que vous voulez.

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; 
}