[Perl]Exporter::Global-任意の関数をグローバルにエクスポートする

[Perl]useなしでどこでもDump(@INCにオブジェクトを格納するパターン）でやった@INCにオブジェクトを格納するコードを使って任意関数をグローバルにエクスポートするモジュールを作ってみました。名づけてExporter::Global

例えばErrorモジュールのtry catchを使いたいけどuse Error qw(:try)するのが面倒だとか、アプリケーション内で標準で使うことにしているようなケースで以下のようにしておくとどこでもtry - catch構文が使えるようになります。

# まずはエクスポートしたい関数を定義（またはインポート）する
use Error qw(:try)
# Exporter::Globalにエクスポートしたい関数を渡す
use Exporter::Global qw(try finally with);
# これ以降ロードされるモジュールではすべてtry catchが使える
no Exporter::Global; # Exporter::Globalをオフにする

また、;で区切ってエイリアスをつけられるようにしているので

perl -MYAML -MExporter::Global=YAML::Dump;p

や

perl -MData::Dumper -MExporter::Global=Data::Dumper::Dump;p

といった感じで任意のDump関数を指定することができます。また、前記事では想定されていなかった１ファイル内に複数のパッケージがあるケースにも対応しています。

ソース

package Exporter::Global;

use warnings;
use strict;
use Carp;
use Fatal qw(open close);

sub import {
    my $class = shift;
    my $args = ref $_[0] eq 'HASH'
             ? $_[0] : { subroutines => [ @_ ] };

    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
    unshift @INC, $class->new($args)
        unless (grep {ref $_ eq $class } @INC);
}

sub unimport {
    my $class = shift;

    @INC = grep { ref $_ ne $class } @INC;
}

sub new {
    my $class = shift;
    my $self = { %{ _parse_arguments(@_) } };
    croak "Pass the export subroutines"
        unless (@ { $self->{subroutines} });

    bless $self, $class;
    $self->{modules} ||= [];
    $self->{caller_pkg} ||= caller($Carp::CarpLevel);

    return $self;
}

sub _parse_arguments {
    my (@args) = @_;
    my $h;
    if (ref $args[0] eq 'HASH') {
        $h = $args[0];
    } else {
        my @subrutines = map { split /[\s,]+/, $_ } @args;
        $h = {
            subroutines => \@subrutines,
        };
    }
    return $h;
}

sub Exporter::Global::INC {
    my $self = shift;
    my $module = shift;

    my $mod_name = _mod_name($module);
    return unless ($self->_is_export_target($mod_name));

    my @pkgs = ($mod_name);
    push @pkgs, $self->_find_inner_packages($module);

    for my $export_sub ( @{ $self->{subroutines} } ){
        my ($import_sym_name, $export_alias)
            = $self->_extract_sym_name($export_sub);

        for my $pkg (@pkgs) {
            no strict 'refs';
            *{"$pkg\::$export_alias"} = \&{"$import_sym_name"};
        }
    }
    return;
}

sub _is_export_target {
    my $self = shift;
    my $mod_name = shift;

    if (my @modules = @{ $self->{modules} }) {
        return unless ( grep { $mod_name =~ qr($_) } @modules);
    }
    return 1;
}

sub _mod_name {
    (my $mod_name = shift) =~ s|/|::|g;
    $mod_name =~ s|\.pm$||;
    return $mod_name;
}

sub _extract_sym_name {
    my $self = shift;
    my $export_sub = shift;
    
    my ($sub_name, $alias) = split /;/, $export_sub, 2;
    die "Can't extract subroutine name" unless ($sub_name);

    $alias ||= $sub_name;

    my $import_sym_name 
        = $sub_name =~ /::/ ? $sub_name : "$self->{caller_pkg}::$sub_name";

    return ($import_sym_name, $alias);
}

sub _find_inner_packages {
    my $self = shift;
    my $module = shift;

    my $mod_name = _mod_name($module);

    my @pkg;
    for my $inc (@INC) {
        next if (ref $inc);
        my $path = $inc;
        $path .= '/' unless ($path =~ m|/$|);
        $path .= $module;
        next unless (-e $path);
        open (my $fh, $path);
        while (<$fh>) {
            next if (/^=(?!cut)/ .. /^=cut/);
            last if (/^__END__$/);
            if (my ($pkg) = m|^package\s+(.+?);|) {
                next unless ($self->_is_export_target($pkg));
                next if ($mod_name eq $pkg);
                push @pkg, $pkg;
            }
        }
        close $fh;
    }
    return @pkg;
}
1; # End of Exporter::Global