File Coverage

blib/lib/Sort/Key/Merger.pm

Criterion	Covered	Total	%
statement	132	160	82.5
branch	25	52	48.0
condition	9	13	69.2
subroutine	25	39	64.1
pod	17	17	100.0
total	208	281	74.0

package Sort::Key::Merger;

our $VERSION = '0.10_02';

use strict;
use warnings;
use Carp;

use Sort::Key::Types;
our @CARP_NOT = qw(Sort::Key::Types);

# use Data::Dumper qw(Dumper);

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(keymerger nkeymerger ikeymerger ukeymerger
                    rkeymerger rnkeymerger rikeymerger rukeymerger
		    filekeymerger nfilekeymerger ifilekeymerger ufilekeymerger
		    rfilekeymerger rnfilekeymerger rifilekeymerger rufilekeymerger);

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

use constant STR_SORT => 0;
use constant LOC_STR_SORT => 1;
use constant NUM_SORT => 2;
use constant INT_SORT => 3;
use constant UINT_SORT => 4;
use constant REV_SORT => 128;


use constant VALUE => 0;
use constant FILE => 1;
use constant SCRATCHPAD => 2;
use constant RS => 2;
use constant KEY0 => 3;

my ($int_hints, $locale_hints);
BEGIN {
    use integer;
    $int_hints = $integer::hint_bits || 0x1;
    use locale;
    $locale_hints = $locale::hint_bits || 0x4;
}

sub _make_merger {
    my $types = shift;
    my $typessub = shift;
    my $vkgen = shift;
    my $typeslen = length $types;
    my $typesu = "$types\x04";
    my @src;
    my $i = 0;
    for (@_) {
	my $scratchpad;
	if (my ($v, @k) = &{$vkgen}($scratchpad)) {
            if ($typessub) {
                @k = $typessub->(@k);
            }
            else {
                @k == $typeslen
                    or croak "wrong number of keys generated (expected "
                        .($typeslen - 1).", returned ".(@k - 1).")";
            }
	    unshift @src, [$v, $_, $scratchpad, @k, $i++];
	    _resort($typesu, \@src);
	}
    }
    sub {
        my $max = @_ ? $_[0] : 1;
        my @ret;
        while (@src and $max--) {
            my $src = $src[0];
            push @ret, $src->[VALUE];
            for ($src[0][FILE]) {
                if (my ($v, @k) = &{$vkgen}($src->[SCRATCHPAD])) {
                    if ($typessub) {
                        @k = $typessub->(@k);
                    }
                    else {
                        @k == $typeslen
                            or croak "wrong number of keys generated (expected "
                                .($typeslen - 1).", returned ".(@k - 1).")";
                    }
                    $src->[VALUE] = $v;
                    splice @$src, KEY0, $typeslen, @k;
                    _resort($typesu, \@src);
                }
                else {
                    shift @src;
                }
	    }
	}
        wantarray ? @ret : $ret[-1];
    };
}

sub multikeymerger (&@) {
    my $vkgen = shift;
    my $types = shift;

    ref($types) eq 'ARRAY'
        or croak "Usage: \$merger = multikeymerger { value_key() } \\\@types, \@args";

    my $ptypes = Sort::Key::Types::combine_types(@$types);
    my $typessub = Sort::Key::Types::combine_sub('@_', undef, @$types);

    _make_merger($ptypes, $typessub, $vkgen, @_);
}

sub keymerger (&@) {
    my $sort = ((caller(0))[8] & $locale_hints)
	? LOC_STR_SORT : STR_SORT;
    _make_merger( pack(C => $sort), undef, @_ )
}

sub rkeymerger (&@) {
    my $sort = ((caller(0))[8] & $locale_hints)
	? LOC_STR_SORT : STR_SORT;
    _make_merger( pack(C => $sort|REV_SORT), undef, @_ )
}

sub nkeymerger (&@) {
    my $sort = ((caller(0))[8] & $int_hints)
	? INT_SORT : NUM_SORT;
    _make_merger( pack(C => $sort), undef, @_ )
}

sub rnkeymerger (&@) {
    my $sort = ((caller(0))[8] & $int_hints)
	? INT_SORT : NUM_SORT;
    _make_merger( pack(C => $sort|REV_SORT), undef, @_ )
}


sub ikeymerger (&@) {
    _make_merger( pack(C => UINT_SORT), undef, @_ )
}

sub rikeymerger (&@) {
    _make_merger( pack(C => UINT_SORT|REV_SORT), undef, @_ )
}

sub ukeymerger (&@) {
    _make_merger( pack(C => UINT_SORT), undef, @_ )
}

sub rukeymerger (&@) {
    _make_merger( pack(C => UINT_SORT|REV_SORT), undef, @_ )
}

sub _make_file_merger {
    my $types = shift;
    my $kgen = shift;
    my $typeslen = length $types;
    my $typesu = "$types\x04";
    my @src;
    my $i = 0;
    for my $file (@_) {
	my $fh;
	if (UNIVERSAL::isa($file, 'GLOB')) {
	    $fh = $file;
	}
	else {
	    open $fh, '<', $file
		or croak "unable to open '$file'";
	}
	local $/ = $/;
	local $_;
	while(<$fh>) {
            if (my @k = $kgen->()) {
                @k == $typeslen
                    or croak "wrong number of return values from merger callback, $typeslen expected, "
                        . scalar(@k) . " found";
		unshift @src, [$_, $fh, $/, @k, $i++];
		_resort($typesu, \@src);
		last;
	    }
	}
    }

    my $gen;
    $gen = sub {
	if (wantarray) {
	    my @all;
            my $max = @_ ? $_[0] : 1;
	    while((!defined $max or $max--) and @src) {
		push @all, scalar(&$gen);
	    }
	    return @all;
	}
	else {
	    if (@src) {
		my $src = $src[0];
		my $old_v = $src->[VALUE];
		local *_ = \($src->[VALUE]);
		local */ = \($src->[RS]);   # emacs syntax higlighting breaks here/;
		my $fh = $src->[FILE];
		while(<$fh>) {
                    if (my @k = &{$kgen}) {
                        @k == $typeslen
                            or croak "wrong number of return values from merger callback, $typeslen expected, "
                                . scalar(@k) . " found";
                        $src->[VALUE] = $_;
                        splice @$src, KEY0, $typeslen, @k;
                        _resort($typesu, \@src);
                        return $old_v;
                    }
		}
		shift @src;
		return $old_v;
	    }
	    return undef
	}
    };
}

sub filekeymerger (&@) {
    my $sort = ((caller(0))[8] & $locale_hints)
	? LOC_STR_SORT : STR_SORT;
    _make_file_merger( pack(C => $sort), @_ )
}

sub rfilekeymerger (&@) {
    my $sort = ((caller(0))[8] & $locale_hints)
	? LOC_STR_SORT : STR_SORT;
    _make_file_merger( pack(C => $sort|REV_SORT), @_ )
}

sub nfilekeymerger (&@) {
    my $sort = ((caller(0))[8] & $int_hints)
	? INT_SORT : NUM_SORT;
    _make_file_merger( pack(C => $sort), @_ )
}

sub rnfilekeymerger (&@) {
    my $sort = ((caller(0))[8] & $int_hints)
	? INT_SORT : NUM_SORT;
    _make_file_merger( pack(C => $sort|REV_SORT), @_ )
}

sub ifilekeymerger (&@) {
    _make_file_merger( pack(C => INT_SORT), @_ )
}

sub rifilekeymerger (&@) {
    _make_file_merger( pack(C => INT_SORT|REV_SORT), @_ )
}

sub ufilekeymerger (&@) {
    _make_file_merger( pack(C => INT_SORT), @_ )
}

sub rufilekeymerger (&@) {
    _make_file_merger( pack(C => INT_SORT|REV_SORT), @_ )
}


1;
__END__