Perl sorting; dealing with $a, $b package globals across namespaces cleanly

Suppose I have a utility library (other) containing a subroutine (sort_it) which I want to use to return arbitrarily sorted data. It's probably more complicated than this, but this illustrates the key concepts:

#!/usr/local/bin/perl

use strict;

package other;

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

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

Now let's use it in another package.

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

This doesn't work, due to a subtle problem. $a and $b are package globals. They refer to $main::a and $main::b when wrapped up in the closure.

We could fix this by saying, instead:

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

This works, but forces us to hardcode the name of our utility package everywhere. Were that to change, we'd need to remember to change the code, not just the use other qw(sort_it); statement that would likely be present in the real world.

You might immediately think to try using __PACKAGE__. That winds up evaluating to "main". So does eval("__PA开发者_如何学编程CKAGE__");.

There's a trick using caller that works:

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

But this is rather black-magical. It seems like there ought to be some better solution to this. But I haven't found it or figured it out yet.

Use the prototype (solution originally proposed in Usenet posting by ysth).

Works on Perl >= 5.10.1 (not sure about earlier).

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

I get as a result:

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

Try this:

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

And you will not pay overhead in each call.

But I would prefer

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 @_]);
}

Here is how to do it:

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 is needed here because package only takes a bare package name, not a variable.