1package Sort::Key::Types;
2
3our $VERSION = '1.30';
4
5use strict;
6use warnings;
7use Carp;
8
9require Exporter;
10our @ISA = qw(Exporter);
11our @EXPORT_OK = qw(register_type);
12
13our $DEBUG;
14$DEBUG ||= 0;
15
16# this hash is also used from Sort::Key::Multi to find out which
17# letters can be used as types:
18
19our %mktypes = ( s => 0,
20                 l => 1,
21                 n => 2,
22                 i => 3,
23                 u => 4 );
24
25sub _mks2n {
26    if (my ($rev, $key)=$_[0]=~/^([-+]?)(.)$/) {
27	exists $mktypes{$key}
28	    or croak "invalid multi-key type '$_[0]'";
29	my $n = $mktypes{$key};
30	$n+=128 if $rev eq '-';
31	return $n
32    }
33    die "internal error, bad key '$_[0]'";
34}
35
36our %mkmap = qw(str s
37		string s
38		locale l
39		loc l
40		lstr l
41		int i
42		integer i
43		uint u
44		unsigned_integer u
45		number n
46		num n);
47
48$_ = [$_] for (values %mkmap);
49our %mksub = map { $_ => undef } keys %mkmap;
50
51sub _get_map {
52    my ($rev, $name) = $_[0]=~/^([+-]?)(.*)$/;
53    exists $mkmap{$name}
54	or croak "unknown key type '$name'\n";
55    if ($rev eq '-') {
56	return map { /^-(.*)$/ ? $1 : "-$_" } @{$mkmap{$name}}
57    }
58    @{$mkmap{$name}}
59}
60
61sub _get_sub {
62    $_[0]=~/^[+-]?(.*)$/;
63    exists $mksub{$1}
64	or croak "unknown key type '$1'\n";
65    return $mksub{$1}
66}
67
68sub _combine_map { map { _get_map $_ } @_ }
69
70use constant _nl => "\n";
71
72sub combine_types { pack('C*', (map { _mks2n $_ } _combine_map(@_))) }
73
74sub combine_sub {
75    my $sub = shift;
76    my $for = shift;
77    $for = defined $for ? " for $for" : "";
78
79    my @subs = map { _get_sub $_ } @_;
80
81    if ($sub) {
82	my $code = 'sub { '._nl;
83	if (ref $sub eq 'CODE') {
84	    unless (grep { defined $_ } @subs) {
85		return $sub
86	    }
87	    $code.= 'my @keys = &{$sub};'._nl;
88	}
89	else {
90	    if ($sub eq '@_') {
91		return undef unless grep {defined $_} @subs;
92	    }
93	    $code.= 'my @keys = '.$sub.';'._nl;
94	}
95	$code.= 'print "in: |@keys|\n";'._nl if $DEBUG;
96
97	$code.= '@keys == '.scalar(@_)
98	  . ' or croak "wrong number of keys generated$for '
99	    . '(expected '.scalar(@_).', returned ".scalar(@keys).")";'._nl;
100
101	{ # new scope so @map doesn't get captured
102	    my @map = _combine_map @_;
103	    if (@map==@_) {
104		for my $i (0..$#_) {
105		    if (defined $subs[$i]) {
106			$code.= '{ local $_ = $keys['.$i.']; ($keys['.$i.']) = &{$subs['.$i.']}() }'._nl;
107		    }
108		}
109		$code.='print "out: |@keys|\n";'._nl if $DEBUG;
110		$code.='return @keys'._nl;
111	    }
112	    else {
113		$code.='my @keys1;'._nl;
114		for my $i (0..$#_) {
115		    if (defined $subs[$i]) {
116			$code.= '{ local $_ = shift @keys; push @keys1, &{$subs['.$i.']}() }'._nl;
117		    }
118		    else {
119			$code.= 'push @keys1, shift @keys;'._nl;
120		    }
121		}
122		$code.='print "out: |@keys1|\n";'._nl if $DEBUG;
123		$code.='return @keys1'._nl;
124	    }
125	}
126	$code.='}'._nl;
127	print "CODE$for:\n$code----\n" if $DEBUG >= 2;
128	my $map = eval $code;
129	$@ and die "internal error: code generation failed ($@)";
130	return $map;
131    }
132    else {
133	@_==1 or croak "too many keys or keygen subroutine undefined$for";
134	return @subs;
135    }
136}
137
138sub register_type {
139    my $name = shift;
140    my $sub = shift;
141    $name=~/^\w+(?:::\w+)*$/
142	or croak "invalid type name '$name'";
143    @_ or
144	croak "too few keys";
145    (exists $mkmap{$name} or exists $mktypes{$name})
146	and croak "type '$name' already registered or reserved in ".__PACKAGE__;
147    $mkmap{$name} = [ _combine_map @_ ];
148    $mksub{$name} = combine_sub $sub, $name, @_;
149    ()
150}
151
152
1531;
154
155__END__
156
157=head1 Sort::Key::Types - handle Sort::Key data types
158
159=head1 SYNOPSIS
160
161  use Sort::Key::Types qw(register_type);
162  register_type(Color => sub { $_->R, $_->G, $_->B }, qw(int, int, int));
163
164  # you better
165  # use Sort::Key::Register ...
166
167
168=head1 DESCRIPTION
169
170The L<Sort::Key> family of modules can be extended to support new key
171types using this module (or the more friendly L<Sort::Key::Register>).
172
173=head2 FUNCTIONS
174
175The following functions are provided:
176
177=over 4
178
179=item Sort::Key::register_type($name, \&gensubkeys, @subkeystypes)
180
181registers a new datatype named C<$name> defining how to convert it to
182a multi-key.
183
184C<&gensubkeys> should convert the object of type C<$name> passed on
185C<$_> to a list of values composing the multi-key.
186
187C<@subkeystypes> is the list of types for the generated multi-keys.
188
189For instance:
190
191  Sort::Key::Types::register_type
192                 'Person',
193                 sub { $_->surname,
194                       $_->name,
195                       $_->middlename },
196                 qw(str str str);
197
198  Sort::Key::Types::register_type
199                 'Color',
200                 sub { $_->R, $_->G, $_->B },
201                 qw(int int int);
202
203Once a datatype has been registered it can be used in the same way
204as types supported natively, even for defining new types, i.e.:
205
206  Sort::Key::Types::register_type
207                 'Family',
208                 sub { $_->father, $_->mother },
209                 qw(Person Person);
210
211=back
212
213=head1 SEE ALSO
214
215L<Sort::Key>, L<Sort::Key::Merger>, L<Sort::Key::Register>.
216
217=head1 COPYRIGHT AND LICENSE
218
219Copyright (C) 2005-2007, 2014 by Salvador FandiE<ntilde>o,
220E<lt>sfandino@yahoo.comE<gt>.
221
222This library is free software; you can redistribute it and/or modify
223it under the same terms as Perl itself, either Perl version 5.8.4 or,
224at your option, any later version of Perl 5 you may have available.
225
226=cut
227