File Coverage

blib/lib/Sort/Packed.pm

Criterion	Covered	Total	%
statement	44	53	83.0
branch	15	26	57.6
condition	7	15	46.6
subroutine	8	10	80.0
pod	5	5	100.0
total	79	109	72.4

package Sort::Packed;

our $VERSION = '0.08';

use strict;
use warnings;
use Carp;

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT_OK = qw( sort_packed
                     radixsort_packed
                     mergesort_packed
                     sort_packed_custom
                     mergesort_packed_custom
                     reverse_packed
                     shuffle_packed );

# byte_order:
# 0 - big endian
# 1 - little endian

# type
# 0 - unsigned
# 1 - signed
# 2 - float
# 3 - float x86

my %nv_format = ( '5839b4c876bebf3f' => 'LE',
                  '3fbfbe76c8b43958' => 'BE',
                  '83c0caa145b6f3fdfb3f0000' => 'LE_x86',
                  '3ffbfbe76c8b4395810624dd2f1a9fbe' => 'BE',
                  'be9f1a2fdd24068195438b6ce7fbfb3f' => 'LE',
                  '83c0caa145b6f3fdfb3f000000000000' => 'LE_x86');

my $double_format = $nv_format{unpack 'H*' => pack d => 0.124} || 'LE';
my $double_byte_order = ($double_format =~ /^BE/ ? 0 : 1);
my $double_type = ($double_format =~ /x86/ ? 2 : 3);

require XSLoader;
XSLoader::load('Sort::Packed', $VERSION);

my %cache;
sub _template_props {
    my ($dir, $pattern, $rep) = $_[0] =~ /^([+\-]?)(\w!?)(\d*)$/
        or croak "invalid template '$_[0]'";

    $dir = ($dir eq '-' ? -1 : 1);
    $rep ||= 1;

    $pattern =~ /^[bBhHuUwxX]/
        and croak "unsupported pack format '$pattern'";

    my ($test1, $test2, $test3);
    eval {
        no warnings;
        $test1 = pack $pattern => 0x1;
        $test2 = unpack $pattern => pack $pattern => -1;
    };
    $@ and croak "invalid pack pattern '$pattern': $@";

    my $vsize = length $test1;
    my $ix = index $test1, chr 0x1;
    my $vtype = ($test2 eq '-1' ? 1 : 0);
    my $byte_order;
    if ($pattern =~ /^[fdFD]/) {
        $vtype = $double_type;
        $byte_order = $double_byte_order;
    }
    else {
        if ($vsize == 1 or $ix == $vsize - 1) {
            $byte_order = 0;
        }
        elsif ($ix == 0) {
            $byte_order = 1;
        }
        else {
            croak "unsupported pack format '$pattern'"
        }
    }

    $dir, $vsize, $vtype, $byte_order, $rep
}

sub radixsort_packed {
    @_ == 2 or croak 'Usage: sort_packed($format, $vector)';
    my ($dir, $vsize, $vtype, $byte_order, $rep) = @{$cache{$_[0]} ||= [_template_props($_[0])]};
    _radixsort_packed($_[1], $dir, $vsize, $vtype, $byte_order, $rep);
}

sub mergesort_packed {
    @_ == 2 or croak 'Usage: radixsort_packed($format, $vector)';
    my ($dir, $vsize, $vtype, $byte_order, $rep) = @{$cache{$_[0]} ||= [_template_props($_[0])]};
    _mergesort_packed($_[1], undef, $dir, $vsize, $vtype, $byte_order, $rep);
}

*sort_packed = \&radixsort_packed;

sub mergesort_packed_custom (&@) {
    @_ == 3 or croak 'Usage: mergesort_packed_custom { cmp($a, $b) } $format, $vector';
    my ($dir, $vsize, $vtype, $byte_order, $rep) = @{$cache{$_[1]} ||= [_template_props($_[1])]};
    _mergesort_packed($_[2], $_[0], $dir, $vsize, $vtype, $byte_order, $rep);
}

*sort_packed_custom = \&radixsort_packed_custom;

sub reverse_packed {
    @_ == 2 or croak 'Usage: reverse_packed($format, $vector)';
    my (undef, $vsize, undef, undef, $rep) = @{$cache{$_[0]} ||= [_template_props($_[0])]};
    _reverse_packed($_[1], $vsize * $rep);
}

sub shuffle_packed {
    @_ == 2 or croak 'Usage: shuffle_packed($format, $vector)';
    my (undef, $vsize, undef, undef, $rep) = @{$cache{$_[0]} ||= [_template_props($_[0])]};
    _shuffle_packed($_[1], $vsize * $rep);
}

1;
__END__