File Coverage

blib/lib/Sort/Naturally.pm

Criterion	Covered	Total	%
statement	131	147	89.1
branch	75	98	76.5
condition	17	39	43.5
subroutine	11	11	100.0
pod	2	2	100.0
total	236	297	79.4

require 5;
package Sort::Naturally;  # Time-stamp: "2004-12-29 18:30:03 AST"
$VERSION = '1.03';
@EXPORT = ('nsort', 'ncmp');
require Exporter;
@ISA = ('Exporter');

use strict;
use locale;
use integer;

#-----------------------------------------------------------------------------
# constants:
BEGIN { *DEBUG = sub () {0} unless defined &DEBUG }

use Config ();
BEGIN {
  # Make a constant such that if a whole-number string is that long
  #  or shorter, we KNOW it's treatable as an integer
  no integer;
  my $x = length(256 ** $Config::Config{'intsize'} / 2) - 1;
  die "Crazy intsize: <$Config::Config{'intsize'}>" if $x < 4;
  eval 'sub MAX_INT_SIZE () {' . $x . '}';
  die $@ if $@;
  print "intsize $Config::Config{'intsize'} => MAX_INT_SIZE $x\n" if DEBUG;
}

sub X_FIRST () {-1}
sub Y_FIRST () { 1}

my @ORD = ('same', 'swap', 'asis');

#-----------------------------------------------------------------------------
# For lack of a preprocessor:

my($code, $guts);
$guts = <<'EOGUTS';  # This is the guts of both ncmp and nsort:

    if($x eq $y) {
      # trap this expensive case first, and then fall thru to tiebreaker
      $rv = 0;

    # Convoluted hack to get numerics to sort first, at string start:
    } elsif($x =~ m/^\d/s) {
      if($y =~ m/^\d/s) {
        $rv = 0;    # fall thru to normal comparison for the two numbers
      } else {
        $rv = X_FIRST;
        DEBUG > 1 and print "Numeric-initial $x trumps letter-initial $y\n";
      }
    } elsif($y =~ m/^\d/s) {
      $rv = Y_FIRST;
      DEBUG > 1 and print "Numeric-initial $y trumps letter-initial $x\n";
    } else {
      $rv = 0;
    }

    unless($rv) {
      # Normal case:
      $rv = 0;
      DEBUG and print "<$x> and <$y> compared...\n";

     Consideration:
      while(length $x and length $y) {

        DEBUG > 2 and print " <$x> and <$y>...\n";

        # First, non-numeric comparison:
        $x2 = ($x =~ m/^(\D+)/s) ? length($1) : 0;
        $y2 = ($y =~ m/^(\D+)/s) ? length($1) : 0;
        # Now make x2 the min length of the two:
        $x2 = $y2 if $x2 > $y2;
        if($x2) {
          DEBUG > 1 and printf " <%s> and <%s> lexically for length $x2...\n",
            substr($x,0,$x2), substr($y,0,$x2);
          do {
           my $i = substr($x,0,$x2);
           my $j = substr($y,0,$x2);
           my $sv = $i cmp $j;
           print "SCREAM! on <$i><$j> -- $sv != $rv \n" unless $rv == $sv;
           last;
          }


           if $rv =
           # The ''. things here force a copy that seems to work around a
           #  mysterious intermittent bug that 'use locale' provokes in
           #  many versions of Perl.
                   $cmp
                   ? $cmp->(substr($x,0,$x2) . '',
                            substr($y,0,$x2) . '',
                           )
                   :
                   scalar(( substr($x,0,$x2) . '' ) cmp
                          ( substr($y,0,$x2) . '' )
                          )
          ;
          # otherwise trim and keep going:
          substr($x,0,$x2) = '';
          substr($y,0,$x2) = '';
        }

        # Now numeric:
        #  (actually just using $x2 and $y2 as scratch)

        if( $x =~ s/^(\d+)//s ) {
          $x2 = $1;
          if( $y =~ s/^(\d+)//s ) {
            # We have two numbers here.
            DEBUG > 1 and print " <$x2> and <$1> numerically\n";
            if(length($x2) < MAX_INT_SIZE and length($1) < MAX_INT_SIZE) {
              # small numbers: we can compare happily
              last if $rv = $x2 <=> $1;
            } else {
              # ARBITRARILY large integers!

              # This saves on loss of precision that could happen
              #  with actual stringification.
              # Also, I sense that very large numbers aren't too
              #  terribly common in sort data.

              # trim leading 0's:
              ($y2 = $1) =~ s/^0+//s;
              $x2 =~ s/^0+//s;
              print "   Treating $x2 and $y2 as bigint\n" if DEBUG;

              no locale; # we want the dumb cmp back.
              last if $rv = (
                 # works only for non-negative whole numbers:
                 length($x2) <=> length($y2)
                   # the longer the numeral, the larger the value
                 or $x2 cmp $y2
                   # between equals, compare lexically!!  amazing but true.
              );
            }
          } else {
            # X is numeric but Y isn't
            $rv = Y_FIRST;
            last;
          }
        } elsif( $y =~ s/^\d+//s ) {  # we don't need to capture the substring
          $rv = X_FIRST;
          last;
        }
         # else one of them is 0-length.

       # end-while
      }
    }
EOGUTS

sub maker {
  my $code = $_[0];
  $code =~ s/~COMPARATOR~/$guts/g || die "Can't find ~COMPARATOR~";
  eval $code;
  die $@ if $@;
}

##############################################################################

maker(<<'EONSORT');
sub nsort {
  # get options:
  my($cmp, $lc);
  ($cmp,$lc) = @{shift @_} if @_ and ref($_[0]) eq 'ARRAY';

  return @_ unless @_ > 1 or wantarray; # be clever

  my($x, $x2, $y, $y2, $rv);  # scratch vars

  # We use a Schwartzian xform to memoize the lc'ing and \W-removal

  map $_->[0],
  sort {
    if($a->[0] eq $b->[0]) { 0 }   # trap this expensive case
    else {

    $x = $a->[1];
    $y = $b->[1];

~COMPARATOR~

    # Tiebreakers...
    DEBUG > 1 and print " -<${$a}[0]> cmp <${$b}[0]> is $rv ($ORD[$rv])\n";
    $rv ||= (length($x) <=> length($y))  # shorter is always first
        ||  ($cmp and $cmp->($x,$y) || $cmp->($a->[0], $b->[0]))
        ||  ($x      cmp $y     )
        ||  ($a->[0] cmp $b->[0])
    ;

    DEBUG > 1 and print "  <${$a}[0]> cmp <${$b}[0]> is $rv ($ORD[$rv])\n";
    $rv;
  }}

  map {;
    $x = $lc ? $lc->($_) : lc($_); # x as scratch
    $x =~ s/\W+//s;
    [$_, $x];
  }
  @_
}
EONSORT

#-----------------------------------------------------------------------------
maker(<<'EONCMP');
sub ncmp {
  # The guts are basically the same as above...

  # get options:
  my($cmp, $lc);
  ($cmp,$lc) = @{shift @_} if @_ and ref($_[0]) eq 'ARRAY';

  if(@_ == 0) {
    @_ = ($a, $b); # bit of a hack!
    DEBUG > 1 and print "Hacking in <$a><$b>\n";
  } elsif(@_ != 2) {
    require Carp;
    Carp::croak("Not enough options to ncmp!");
  }
  my($a,$b) = @_;
  my($x, $x2, $y, $y2, $rv);  # scratch vars

  DEBUG > 1 and print "ncmp args <$a><$b>\n";
  if($a eq $b) { # trap this expensive case
    0;
  } else {
    $x = ($lc ? $lc->($a) : lc($a));
    $x =~ s/\W+//s;
    $y = ($lc ? $lc->($b) : lc($b));
    $y =~ s/\W+//s;

~COMPARATOR~


    # Tiebreakers...
    DEBUG > 1 and print " -<$a> cmp <$b> is $rv ($ORD[$rv])\n";
    $rv ||= (length($x) <=> length($y))  # shorter is always first
        ||  ($cmp and $cmp->($x,$y) || $cmp->($a,$b))
        ||  ($x cmp $y)
        ||  ($a cmp $b)
    ;

    DEBUG > 1 and print "  <$a> cmp <$b> is $rv\n";
    $rv;
  }
}
EONCMP

# clean up:
undef $guts;
undef &maker;

#-----------------------------------------------------------------------------
1;

############### END OF MAIN SOURCE ###########################################
__END__