File Coverage

blib/lib/Sort/Key/Types.pm

Criterion	Covered	Total	%
statement	77	81	95.0
branch	31	50	62.0
condition	1	3	33.3
subroutine	11	11	100.0
pod	1	3	33.3
total	121	148	81.7

package Sort::Key::Types;

our $VERSION = '1.30';

use strict;
use warnings;
use Carp;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(register_type);

our $DEBUG;
$DEBUG ||= 0;

# this hash is also used from Sort::Key::Multi to find out which
# letters can be used as types:

our %mktypes = ( s => 0,
                 l => 1,
                 n => 2,
                 i => 3,
                 u => 4 );

sub _mks2n {
    if (my ($rev, $key)=$_[0]=~/^([-+]?)(.)$/) {
	exists $mktypes{$key}
	    or croak "invalid multi-key type '$_[0]'";
	my $n = $mktypes{$key};
	$n+=128 if $rev eq '-';
	return $n
    }
    die "internal error, bad key '$_[0]'";
}

our %mkmap = qw(str s
		string s
		locale l
		loc l
		lstr l
		int i
		integer i
		uint u
		unsigned_integer u
		number n
		num n);

$_ = [$_] for (values %mkmap);
our %mksub = map { $_ => undef } keys %mkmap;

sub _get_map {
    my ($rev, $name) = $_[0]=~/^([+-]?)(.*)$/;
    exists $mkmap{$name}
	or croak "unknown key type '$name'\n";
    if ($rev eq '-') {
	return map { /^-(.*)$/ ? $1 : "-$_" } @{$mkmap{$name}}
    }
    @{$mkmap{$name}}
}

sub _get_sub {
    $_[0]=~/^[+-]?(.*)$/;
    exists $mksub{$1}
	or croak "unknown key type '$1'\n";
    return $mksub{$1}
}

sub _combine_map { map { _get_map $_ } @_ }

use constant _nl => "\n";

sub combine_types { pack('C*', (map { _mks2n $_ } _combine_map(@_))) }

sub combine_sub {
    my $sub = shift;
    my $for = shift;
    $for = defined $for ? " for $for" : "";

    my @subs = map { _get_sub $_ } @_;

    if ($sub) {
	my $code = 'sub { '._nl;
	if (ref $sub eq 'CODE') {
	    unless (grep { defined $_ } @subs) {
		return $sub
	    }
	    $code.= 'my @keys = &{$sub};'._nl;
	}
	else {
	    if ($sub eq '@_') {
		return undef unless grep {defined $_} @subs;
	    }
	    $code.= 'my @keys = '.$sub.';'._nl;
	}
	$code.= 'print "in: |@keys|\n";'._nl if $DEBUG;

	$code.= '@keys == '.scalar(@_)
	  . ' or croak "wrong number of keys generated$for '
	    . '(expected '.scalar(@_).', returned ".scalar(@keys).")";'._nl;

	{ # new scope so @map doesn't get captured
	    my @map = _combine_map @_;
	    if (@map==@_) {
		for my $i (0..$#_) {
		    if (defined $subs[$i]) {
			$code.= '{ local $_ = $keys['.$i.']; ($keys['.$i.']) = &{$subs['.$i.']}() }'._nl;
		    }
		}
		$code.='print "out: |@keys|\n";'._nl if $DEBUG;
		$code.='return @keys'._nl;
	    }
	    else {
		$code.='my @keys1;'._nl;
		for my $i (0..$#_) {
		    if (defined $subs[$i]) {
			$code.= '{ local $_ = shift @keys; push @keys1, &{$subs['.$i.']}() }'._nl;
		    }
		    else {
			$code.= 'push @keys1, shift @keys;'._nl;
		    }
		}
		$code.='print "out: |@keys1|\n";'._nl if $DEBUG;
		$code.='return @keys1'._nl;
	    }
	}
	$code.='}'._nl;
	print "CODE$for:\n$code----\n" if $DEBUG >= 2;
	my $map = eval $code;
	$@ and die "internal error: code generation failed ($@)";
	return $map;
    }
    else {
	@_==1 or croak "too many keys or keygen subroutine undefined$for";
	return @subs;
    }
}

sub register_type {
    my $name = shift;
    my $sub = shift;
    $name=~/^\w+(?:::\w+)*$/
	or croak "invalid type name '$name'";
    @_ or
	croak "too few keys";
    (exists $mkmap{$name} or exists $mktypes{$name})
	and croak "type '$name' already registered or reserved in ".__PACKAGE__;
    $mkmap{$name} = [ _combine_map @_ ];
    $mksub{$name} = combine_sub $sub, $name, @_;
    ()
}


1;

__END__