5 # L. Rosler, January 10, 1999
6 # Interface modeled after
7 http://www.effectiveperl.com/recipes/sorting.html
9 # @sorted = fieldsort( ['optional split pattern as string',]
10 # [ anon array of specifiers (strings or optionally signed integers)
11 # including, in any order:
12 # optional '-' for reverse sort order,
13 # required integer for field number (1 = first),
14 # optional letter for field type: none = string;
15 # 'sN' = first N chars of string; 'n' = optionally signed integer;
16 # 'u' = unsigned integer; 'f' = optionally signed floating-point number
21 my ($col, $cols, @len);
22 my $sep = !ref $_[0] && shift;
23 ref($cols = shift) eq 'ARRAY' or
24 die "Field specifiers must be in an anon array.\n";
25 my @cols = map { /^-(\d+)$|^(\d+)-$/ ? $+ : () } @$cols;
26 if (@cols) { # Preprocess variable-width negated string sorts.
28 my $split = sub { length $sep ? split m{$sep} : split };
31 foreach $col (@cols) {
32 $len[$col - 1] = length $a[$col - 1]
33 if $len[$col - 1] < length $a[$col - 1];
37 my ($fixed, @packcode, @packargs) = 0;
39 my ($col) = /(\d+)/ or die "No field specifier in $_.\n";
40 my ($let) = /([a-z])/;
41 unless ($let) { # variable-length string
42 push @packcode, 'A*x';
44 "\$a[$col - 1]" . (/-/ && qq{ ^ "\\xFF" x $len[$col -
47 } elsif ($let eq 's') { # fixed-length string or substr
48 my ($len) = /(\d+)$/ or die "No length specified for field
50 push @packcode, "A$len";
51 push @packargs, "\$a[$col - 1]" . (/-/ && qq{ ^ "\\xFF" x
53 $fixed += $len if $fixed > -1;
54 } elsif ($let eq 'u') { # unsigned integer
56 push @packargs, (/-/ && '-') . "\$a[$col - 1]";
57 $fixed += 4 if $fixed > -1;
58 } elsif ($let eq 'n') { # signed integer
60 push @packargs, (/-/ && '-') . "\$a[$col - 1] ^ (1 << 31)";
61 $fixed += 4 if $fixed > -1;
62 } elsif ($let eq 'f') { # floating-point number
64 push @packargs, '_float_sort(' . (/-/ && '-') . "\$a[$col -
66 $fixed += 8 if $fixed > -1;
67 } else { die "Unrecognized type specifier $let in field $col.\n"
70 eval 'map substr($_, ' . ($fixed < 0 ? '1 + rindex $_, "\0"' :
72 '), sort map { my @a = split' . (length $sep > 0 && " m{$sep}o")
74 ";\npack '" . join("", @packcode) .
75 ($fixed < 0 && substr($packcode[-1], -1) ne 'x' && 'x') .
76 join(",\n", "A*'", @packargs, '$_') . '} @_'
80 my $big_endian = pack('N', 1) eq pack('L', 1);
82 (($big_endian ? pack 'd', $_[0] : reverse pack 'd', $_[0]) ^
83 ($_[0] < 0 ? "\xFF" x 8 : "\x80" . "\x00" x 7)) . $_[0]
91 @data = ('abc 2 zzz', 'abc 10 zzz', 'def 2 zzz');
92 print q{@sorted = fieldsort [2, 1], @data}, "\n";
93 @sorted = fieldsort [2, 1], @data;
94 { local $" = '|'; print "@sorted\n"; }
95 @data = qw(abc+2+zzz abc+10+zzz abc+2+aaxx abc+2+ab def+2+zzz
97 print q{@sorted = fieldsort '\\+', ['3s2', '-2n', -1], @data}, "\n";
98 @sorted = fieldsort '\\+', ['3s2', '-2n', -1], @data;
100 @data = qw(abc:2:zzz abc:10:zzz abc:2:aaaa def:2:zzz abc:-1:zzz);
101 print q{@sorted = fieldsort ':', ['2n', -1], @data}, "\n";
102 @sorted = fieldsort ':', ['2n', -1], @data;
104 print q{@sorted = fieldsort ':', ['-2f', -1, '3-'], @data}, "\n";
105 @sorted = fieldsort ':', ['-2f', -1, '3-'], @data;
107 print q{@sorted = fieldsort ':', ['-2n', '-1s3'], @data}, "\n";
108 @sorted = fieldsort ':', ['-2n', '-1s3'], @data;
110 print q{@sorted = fieldsort ':', ['-2n', -1], @data}, "\n";
111 @sorted = fieldsort ':', ['-2n', -1], @data;