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