view release on metacpan or  search on metacpan

misc/t-reorder.pl  view on Meta::CPAN

    my $offset = 0;
    foreach my $newpos (0 .. $#$aref) {
      my $oldpos = $aref->[$newpos];
      if ($newpos != $oldpos + $offset) {
        my $item = $children[$oldpos];
        move (\@widget, $item, $newpos);
        $offset -= ($newpos <=> $oldpos+$offset);
      }

      if (DEBUG) { print "  ",join(' ', map {$_->[0]} @widget),
                     "   newpos $newpos offset $offset\n"; }
    }
  }

  #   print Dumper ($aref);
  #   print Dumper (\@widget);
  if (DEBUG)  {
    print join(' ',@$aref), ' -> ', join(' ',map{$_->[0]}@widget), "\n";
  }

  foreach my $i (0 .. $#$aref) {
    my $got = $widget[$i]->[0] - 10;
    my $want = $aref->[$i];
    if ($got != $want) {
      print "  wrong at $i (got $got, want $want)\n";
      print Dumper($aref);
      print Dumper(\@widget);
      exit 0;
    }
  }
}

# [-1..-1]
foreach my $perm (@perms) {
  reorder ($perm);
}

exit 0;



#------------------------------------------------------------------------------
# reorder helper
#
# make_reorder_test() returns a code ref procedure to test whether
# successive entries in a TreeModel style reorder array need to be applied.
#
# The procedure should be called $test->($newpos,$oldpos) on newpos values 0
# to N successively, with oldpos the position before any reordering.  It
# returns true if a move should be applied.  Eg.
#
#     $test = make_reorder_test();
#     foreach my $newpos (0 .. $#$reorder_array) {
#       my $oldpos = $reorder_array->[$newpos];
#       if ($test->($newpos,$oldpos)) {
#         my $item = $original_items[$oldpos];
#         move ($item, $newpos);
#       }
#     }
#
# The move is expected to be in the style of Gtk2::Menu::reorder_child(),
# shifting items at and beyond $newpos upwards.
#
# Basically $test keeps track of how much items at and beyond newpos have
# been moved up due to that shifting.  If an item is in its correct position
# due to that shifting then there's no need for a move() call.
#
# This move call suppression is geared towards Gtk2::Menu::reorder_child()
# because as of Gtk 2.12 that function doesn't notice when a reorder request
# is asking for an unchanged position, it does some linear time linked-list
# searches anyway, and looping that over 0 to N ends up as O(N^2) time.  A
# loop over 0 to N is not optimal, but it's simple, and in particular the
# supression test 


sub make_reorder_test {
  my $offset = 0;
  return sub {
    my ($newpos, $oldpos) = @_;
    my $cmp = ($oldpos+$offset <=> $newpos);
    $offset += $cmp;
    return $cmp;
  }
}



  # When visible, shuffle around according to reorder array.
  # For a big lot of moves maybe a re-setup would be better, though for a
  # small shuffle in the list a $menu->reorder_child should be best.
  #
  my ($tearoff, @children) = _tearoff_and_children ($self);
  if (@children < @$aref) {
    carp __PACKAGE__.': oops, reorder array bigger than num children ('
      . scalar(@$aref) . ',' . scalar(@children) . ')';
    _recover_after_inconsistency ($self);
    return;
  }

  my $test = make_reorder_test();
  foreach my $newpos (0 .. $#$aref) {
    my $oldpos = $aref->[$newpos];
    if ($test->($newpos,$oldpos)) {
      my $item = $children[$oldpos];
      if ($item) {
        $self->reorder_child ($item, $newpos + $tearoff);
      } else {
        carp __PACKAGE__.": oops, reorder array bad oldpos $oldpos";
        _recover_after_inconsistency ($self);
        return;
      }
    }
  }