I have noticed a strange behavior on different versions of Perl (namely v5.16.3 vs. v5.26.2). To illustrate I made a minimal working example which is not that small in this case since it deals with a sorting of a list of items in Tk.
#!/perl
use strict;
use warnings FATAL => qw(all);
use Tk;
use Tk::HList;
use Tk::BrowseEntry;
use Tk::DialogBox;
use Text::CSV_XS;
use FindBin qw($Bin);
my $csv_par =
{
binary => 1, auto_diag => 1, allow_whitespace => 1,
sep_char => ';', eol => $/, quote_char => undef, #
};
open my $in, "<", "$Bin/test.csv" or die "$!";
my $csv = Text::CSV_XS->new($csv_par);
my @header = @{$csv->getline($in)};
my %sort_order;
@sort_order{@header} = (1, 0, 1);
my %field_nr;
@field_nr{@header} = 0 .. $#header;
my %rec;
$csv->bind_columns(\@rec{@header});
my @data;
while ( $csv->getline($in) )
{
push @data, [@rec{@header}];
}
my $mw = MainWindow->new();
my $frame0 = $mw->Frame(-borderwidth => 2, -relief => 'groove',
)->pack(-side => 'top', -expand => 1, -fill => 'both');
my $hlist = $frame0->Scrolled("HList",
-header => 1,
-columns => 3,
-scrollbars => 'osoe',
)->pack( -side => 'left', -expand => 1, -fill => 'both');
_filling($hlist, [@data]);
$hlist->header('create', 0, -text => 'ID');
$hlist->header('create', 1, -text => 'Name');
$hlist->header('create', 2, -text => 'Date');
my $menuitems = [
[Cascade => "~Sort and Filter", -menuitems =>
[
[Button => "~Advanced sorting", -command => \&_dialog,],
[Separator => ""],
[Button => "~Quit", -command => sub{$mw->destroy;}],
],
],
];
my $menu = $mw->Menu(-menuitems => $menuitems);
$mw->configure(-menu => $menu);
MainLoop();
sub _filling
{
my ($this_hlist, $this_aref) = @_;
$this_hlist->delete('all');
for my $index (0..$#$this_aref)
{
$this_hlist->add($index);
for my $textin (0.. $#{$this_aref->[$index]})
{
$this_hlist->itemCreate(
$index, $textin,-text => $this_aref->[$index][$textin],);
}
}
}
sub _dialog
{
my(@popup_opts) = (-popover => undef,
qw/-overanchor c -popanchor c/);
my $d1 = $mw->DialogBox( -title => 'Advanced Sorting',
@popup_opts,
-default_button => 'Sort', -buttons => [ 'Back', 'Sort'],
);
my @sorts = ('') x 3;
my @orders = (0) x 3;
my $be1 = $d1->BrowseEntry(-variable => \$sorts[0],
-choices => [@header],);
my $cb1 = $d1->Checkbutton(-text => 'Z>A',
-variable => \$orders[0]);
my $be2 = $d1->BrowseEntry(-variable => \$sorts[1],
-choices => [@header],);
my $cb2 = $d1->Checkbutton(-text => 'Z>A',
-variable => \$orders[1]);
my $be3 = $d1->BrowseEntry(-variable => \$sorts[2],
-choices => [@header],);
my $cb3 = $d1->Checkbutton(-text => 'Z>A',
-variable => \$orders[2]);
$be1->grid( -row => 0, -column => 0);
$cb1->grid( -row => 0, -column => 1);
$be2->grid( -row => 1, -column => 0);
$cb2->grid( -row => 1, -column => 1);
$be3->grid( -row => 2, -column => 0);
$cb3->grid( -row => 2, -column => 1);
my $answer = $d1->Show || ''; #
if ( $answer eq 'Sort' )
{
_after_dialog([@sorts], [@orders]);
}
}
sub _after_dialog
{
my @choices = @{$_[0]};
my @ord = @{$_[1]};
@choices = grep {length($_)} _uniq(@choices);
@ord = @ord[0..$#choices];
if ( scalar @choices)
{
@data = sort {_custom_sort($a, $b, [@choices], [@ord])}
@data;
_filling($hlist, [@data]);
}
}
sub _uniq
{
my %seen; grep !$seen{$_}++, @_;
}
sub _custom_sort # https://stackoverflow.com/questions/24154744/dynami
+cally-sorting-array-of-hash-by-multiple-keys-in-perl --- with some ad
+ditions.
{
my ($x, $y, $keyref, $ordref) = @_;
my @keys = @$keyref;
my @ords = @$ordref;
for my $key_idx ( 0 .. $#keys )
{
my $key = $keys[$key_idx];
my $direction = $ords[$key_idx];
my $key_nr = $field_nr{$key};
my $cmp;
if ( $sort_order{$key} == 1 )
{
if ( $direction == 0 )
{
$cmp = $x->[$key_nr] <=> $y->[$key_nr];
}
else
{
$cmp = $y->[$key_nr] <=> $x->[$key_nr];
}
}
elsif ( $sort_order{$key} == 0 )
{
if ( $direction == 0 )
{
$cmp = $x->[$key_nr] cmp $y->[$key_nr];
}
else
{
$cmp = $y->[$key_nr] cmp $x->[$key_nr];
}
}
return $cmp if $cmp;
}
return 0;
}