File Coverage

blib/lib/Sort/Key/Merger.pm

Criterion	Covered	Total	%
statement	118	121	97.5
branch	21	30	70.0
condition	2	4	50.0
subroutine	23	24	95.8
pod	4	4	100.0
total	168	183	91.8

package Sort::Key::Merger;

our $VERSION = '0.08';

use strict;
use warnings;
use Carp;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(keymerger nkeymerger
		    filekeymerger nfilekeymerger);

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 KEY => 0;
use constant KEY1 => 1;
use constant VALUE => 2;
use constant FILE => 3;
use constant SCRATCHPAD => 4;
use constant RS => 4;

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

    use locale;
    $locale_hints = $locale::hint_bits || 0x4;

    # print STDERR "locale: $locale_hints, int: $int_hints\n";
}

sub _merger_maker {
    my ($cmp, $sub, @args)=@_;
    my @src;
    my $i=0;
    for (@args) {
	my $scratchpad;
	if (my ($k, $v) = &{$sub}($scratchpad)) {
	    unshift @src, [$k, $i++, $v, $_, $scratchpad];
	    _resort($cmp, \@src);
	}
    }
    my $gen;
    $gen = sub {
	if (wantarray) {
	    my @all;
	    my $next;
	    while(defined($next = &$gen)) {
		push @all, $next;
	    }
	    return @all;
	}
	else {
	    my $old_v;
	    if (@src) {
		my $src=$src[KEY];
		$old_v=$src->[VALUE];
		for ($src[0][FILE]) {
		    if (my @kv = &{$sub}($src->[SCRATCHPAD])) {
			@kv == 2 or croak 'wrong number of return values from merger callback';
			@{$src}[KEY, VALUE] = @kv;
			_resort($cmp, \@src);
		    }
		    else {
			shift @src;
		    }
		}
	    }
	    return $old_v;
	}
    };
}

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

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



sub _file_merger_maker {
    my ($cmp, $sub, @args)=@_;
    my @src;
    my $i = 0;
    for my $file (@args) {
	my $fh;
	if (UNIVERSAL::isa($file, 'GLOB')) {
	    $fh=$file;
	}
	else {
	    open $fh, '<', $file
		or croak "unable to open '$file'";
	}
	local $/ = $/;
	local $_;
	while(<$fh>) {
	    if (defined(my $k = &{$sub})) {
		unshift @src, [$k, $i++, $_, $fh, $/];
		_resort($cmp, \@src);
		last;
	    }
	}
    }

    # print Dumper(\@src);

    my $gen;
    $gen = sub {
	if (wantarray) {
	    my @all;
	    while(@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 (defined ($src->[KEY]=&{$sub})) {
			_resort($cmp, \@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;
    _file_merger_maker( $sort, @_ )
}

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


1;
__END__