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

Предположим, что у меня есть библиотека утилиты (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'});
};

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

Ответ 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'
      }
    ];

Ответ 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 @_]);
}

Ответ 3

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

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

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