paper/field_sort.pl

   1 #!/usr/local/bin/perl
   2
   3 use strict;
   4
   5 # L. Rosler, January 10, 1999
   6 # Interface modeled after
   7 http://www.effectiveperl.com/recipes/sorting.html
   8 # by Joseph Hall.
   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
  17 ],
  18 # @data);
  19
  20 sub fieldsort {
  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.
  27         @len = (0) x @$cols;
  28         my $split = sub { length $sep ? split m{$sep} : split };
  29         foreach (@_) {
  30             my @a = $split->();
  31             foreach $col (@cols) {
  32                 $len[$col - 1] = length $a[$col - 1]
  33                     if $len[$col - 1] < length $a[$col - 1];
  34             }
  35         }
  36     }
  37     my ($fixed, @packcode, @packargs) = 0;
  38     for (@$cols) {
  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';
  43             push @packargs,
  44                 "\$a[$col - 1]" . (/-/ && qq{ ^ "\\xFF" x $len[$col -
  45 1]});
  46             $fixed = -1;
  47         } elsif ($let eq 's') {   # fixed-length string or substr
  48             my ($len) = /(\d+)$/ or die "No length specified for field
  49 $col.\n";
  50             push @packcode, "A$len";
  51             push @packargs, "\$a[$col - 1]" . (/-/ && qq{ ^ "\\xFF" x
  52 $len});
  53             $fixed += $len if $fixed > -1;
  54         } elsif ($let eq 'u') {   # unsigned integer
  55             push @packcode, 'N';
  56             push @packargs, (/-/ && '-') . "\$a[$col - 1]";
  57             $fixed += 4 if $fixed > -1;
  58         } elsif ($let eq 'n') {   # signed integer
  59             push @packcode, 'N';
  60             push @packargs, (/-/ && '-') . "\$a[$col - 1] ^ (1 << 31)";
  61             $fixed += 4 if $fixed > -1;
  62         } elsif ($let eq 'f') {   # floating-point number
  63             push @packcode, 'A8';
  64             push @packargs, '_float_sort(' . (/-/ && '-') . "\$a[$col -
  65 1])";
  66             $fixed += 8 if $fixed > -1;
  67         } else { die "Unrecognized type specifier $let in field $col.\n"
  68 }
  69     }
  70     eval 'map substr($_, ' . ($fixed < 0 ? '1 + rindex $_, "\0"' :
  71 $fixed) .
  72         '), sort map { my @a = split' . (length $sep > 0 && " m{$sep}o")
  73 .
  74         ";\npack '" . join("", @packcode) .
  75             ($fixed < 0 && substr($packcode[-1], -1) ne 'x' && 'x') .
  76             join(",\n", "A*'", @packargs, '$_') . '} @_'
  77 }
  78
  79 BEGIN {
  80     my $big_endian = pack('N', 1) eq pack('L', 1);
  81     sub _float_sort {
  82         (($big_endian ? pack 'd', $_[0] : reverse pack 'd', $_[0]) ^
  83             ($_[0] < 0 ? "\xFF" x 8 : "\x80" . "\x00" x 7)) . $_[0]
  84     }
  85 }
  86
  87
  88 #         Example usage:
  89
  90 my (@data, @sorted);
  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
  96 abc+-1+zzz);
  97 print q{@sorted = fieldsort '\\+', ['3s2', '-2n', -1], @data}, "\n";
  98 @sorted = fieldsort '\\+', ['3s2', '-2n', -1], @data;
  99 print "@sorted\n";
 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;
 103 print "@sorted\n";
 104 print q{@sorted = fieldsort ':', ['-2f', -1, '3-'], @data}, "\n";
 105 @sorted = fieldsort ':', ['-2f', -1, '3-'], @data;
 106 print "@sorted\n";
 107 print q{@sorted = fieldsort ':', ['-2n', '-1s3'], @data}, "\n";
 108 @sorted = fieldsort ':', ['-2n', '-1s3'], @data;
 109 print "@sorted\n";
 110 print q{@sorted = fieldsort ':', ['-2n', -1], @data}, "\n";
 111 @sorted = fieldsort ':', ['-2n', -1], @data;
 112 print "@sorted\n";
 113
 114