Perl: Как перебрать таблицу символов, чтобы найти все загруженные подклассы Foo::Bar?

У меня есть модуль, который определяет исключения для пакета, частью которого он является. Исключения объявляются с Exception::Class::Nested,

В целях обсуждения, скажем, что этот модуль назван Foo::Bar::Exceptionи что все исключения, которые он определяет, являются подклассами первого уровня этого (например, Foo::Bar::Exception:DoNotDoThat). Все исключения, которые меня волнуют, определены в этом файле модуля; Я не заинтересован в каких-либо дополнительных подклассах любого другого модуля.

Для меня import метод, я хочу создать список всех определяемых исключений, и я хотел бы сделать это путем обхода таблицы символов, а не сохранять жестко закодированный список, который может быть не синхронизирован с определениями и должен быть поддерживается вручную.

Итак, как можно Foo::Bar::Exception->import перебрать Foo::Bar::Exceptionтаблицу символов, чтобы найти все исключения (подклассы первого уровня), которые были объявлены в модуле? Меня интересует только активная загруженная таблица символов; нет поиска в файловой системе или тому подобное.

Спасибо!

[приложение]

Поскольку все мои имена подклассов исключений заканчиваются на Exception или же Errorпохоже, это приближается к тому, что я хочу:

my %symtable = eval("'%' . __PACKAGE__ . '::'");
my @shortnames = grep(m!(?:Error|Exception)::$!, keys(%symtable));
@shortnames = ( map { $_ =~ s/::$//; $_; } @shortnames );
my @longnames = ( map { __PACKAGE__ . '::' . $_ } @shortnames );

Некоторые скобки не нужны, но я добавил их для ясности относительно контекста массива.

Источник

3 ответа

Решение

Таблица символов для Foo::Bar::Exception является %Foo::Bar::Exception::так что вы могли бы написать:

sub import {
    for my $key (keys %Foo::Bar::Exception::) {
        if (my ($name) = $key =~ /(.+)::$/) {
           my $pkg = 'Foo::Bar::Exception::'.$name;
           no strict 'refs';
           *{caller()."::$name"} = sub () {$pkg};
        }
    }
}
Источник 
use MRO::Compat;
my @classes = @{ mro::get_isarev("Foo::Bar::Exception") };
@classes = grep $_->isa("Foo::Bar::Exception"), @classes;

MRO::Compat включает API mro на prel 5.10, которые в противном случае не имели бы его (хотя get_isarev намного быстрее на 5.10+), get_isarev возвращает классы, которые наследуют (прямо или косвенно) от именованного класса, а последний grep get_isarev это эвристический тип функции - он никогда не пропустит класс, который наследует тот, который вы указали, но перед лицом времени выполнения @ISA модификация может сообщать о классе, который на самом деле больше не наследует ваш класс. Итак ->isa check проверяет, что класс все еще существует и все еще является подклассом.

Редактировать: только что заметил ту часть, где вас интересуют только пакеты, находящиеся под пространством имен, но я все же думаю, что использование mro API - хорошая основа для их поиска - просто нажмите на grep /^Foo::Bar::Exception::/ также:)

Источник

Из-за проблем с наследованием Exception::Class или же Exception::Class::Nested), Я пошел с чистым маршрутом таблицы символов.

Оба длинных имени (например, Foo::Bar::Exception:DoNotDoThat) и короткие имена (DoNotDoThat) экспортируются; длинные имена экспортируются по умолчанию. (Неясно, если это необходимо, но, похоже, это не навредит.)

Если короткие имена экспортируются, это помогает:

my $caller = caller();
$caller ||= 'main';
my @snames = @{$EXPORT_TAGS{shortnames}};
for my $short (@snames) {
    my $exc = __PACKAGE__ . '::' . $short;
    no strict 'refs';
    *{"$caller\::$short"} = sub () { $exc };
}

что довольно близко к ответу @ Эрика, но получено до того, как я увидел его.

Спасибо всем!

Источник
Другие вопросы по тегам