Perl сортировка; аккуратно работать с глобальными пакетами $ a, $ b в пространствах имен

Question

Предположим, у меня есть служебная библиотека (other), содержащая подпрограмму (sort_it), который я хочу использовать для возврата произвольно отсортированных данных. Это, вероятно, сложнее, чем это, но это иллюстрирует ключевые понятия:

#!/usr/local/bin/perl

use strict;

package other;

sub sort_it {
  my($data, $sort_function) = @_;

  return([sort $sort_function @$data]);
}

Теперь давайте использовать его в другом пакете.

package main;
use Data::Dumper;

my($data) = [
        {'animal' => 'bird',            'legs' => 2},
        {'animal' => 'black widow',     'legs' => 8},
        {'animal' => 'dog',             'legs' => 4},
        {'animal' => 'grasshopper',     'legs' => 6},
        {'animal' => 'human',           'legs' => 2},
        {'animal' => 'mosquito',        'legs' => 6},
        {'animal' => 'rhino',           'legs' => 4},
        {'animal' => 'tarantula',       'legs' => 8},
        {'animal' => 'tiger',           'legs' => 4},
        ],

my($sort_by_legs_then_name) = sub {
    return ($a->{'legs'}   <=> $b->{'legs'} ||
            $a->{'animal'} cmp $b->{'animal'});
};

print Dumper(other::sort_it($data, $sort_by_legs_then_name));

Это не работает из-за тонкой проблемы. $a и $b это пакет Глобал. Они ссылаются на $main::a и $main::b, когда завернуты в закрытие.

Мы могли бы исправить это, сказав вместо этого:

my($sort_by_legs_then_name) = sub {
    return ($other::a->{'legs'}   <=> $other::b->{'legs'} ||
            $other::a->{'animal'} cmp $other::b->{'animal'});
};

Это работает, но вынуждает нас жестко закодировать название нашего пакета утилит везде. Если бы это изменилось, нам нужно помнить, чтобы изменить код, а не просто оператор use other qw(sort_it);, который, скорее всего, присутствовать в реальном мире.

Вы можете сразу подумать, чтобы попытаться использовать __PACKAGE__. Это ветры до оценки до "основного". Так же, как и eval("__PACKAGE__");.

Есть хитрость, использующая caller, которая работает:

my($sort_by_legs_then_name) = sub {
  my($context) = [caller(0)]->[0];
  my($a) = eval("\$$context" . "::a");
  my($b) = eval("\$$context" . "::b");

  return ($a->{'legs'}   <=> $b->{'legs'} ||
          $a->{'animal'} cmp $b->{'animal'});
};

Но это скорее чёрно-магическое. Кажется, должно быть лучшее решение для этого. Но я не нашел или не понял это еще нет.

Answer 1

Используйте прототип (решение, первоначально предложенное в Usenet, публикующем от ysth ).

Работает на Perl> = 5.10.1 (не уверен ранее).

my($sort_by_legs_then_name) = sub ($$) {
    my ($a1,$b1) = @_;
    return ( $a1->{'legs'} <=> $b1->{'legs'} ||
            $a1->{'animal'} cmp $b1->{'animal'});
};

В результате получаю:

$VAR1 = [
      {
        'legs' => 2,
        'animal' => 'bird'
      },
      {
        'legs' => 2,
        'animal' => 'human'
      },
      {
        'legs' => 4,
        'animal' => 'dog'
      },
      {
        'legs' => 4,
        'animal' => 'rhino'
      },
      {
        'legs' => 4,
        'animal' => 'tiger'
      },
      {
        'legs' => 6,
        'animal' => 'grasshopper'
      },
      {
        'legs' => 6,
        'animal' => 'mosquito'
      },
      {
        'legs' => 8,
        'animal' => 'black widow'
      },
      {
        'legs' => 8,
        'animal' => 'tarantula'
      }
    ];

Answer 2

Попробуйте:

sub sort_it {
  my($data, $sort_function) = @_;
  my($context) = [caller(0)]->[0];
  no strict 'refs';
  local *a = "${context}::a";
  local *b = "${context}::b";
  return([sort $sort_function @$data]);
}

И вы не будете платить за каждый звонок.

Но я бы предпочел

sub sort_it (&@) {
  my $sort_function = shift;
  my($context) = [caller(0)]->[0];
  no strict 'refs';
  local *a = "${context}::a";
  local *b = "${context}::b";
  return([sort $sort_function @_]);
}

Answer 3

Вот как это сделать:

sub sort_it {
    my ($data, $sort) = @_;
    my $caller = caller;
    eval "package $caller;"    # enter caller's package
       . '[sort $sort @$data]' # sort at full speed
      or die $@                # rethrow any errors
}

eval здесь необходимо, потому что package принимает только пустое имя пакета, а не переменную.