| 1 |
|
|---|
| 2 | require 5;
|
|---|
| 3 | package Sort::Naturally; # Time-stamp: "2004-12-29 18:30:03 AST"
|
|---|
| 4 | $VERSION = '1.03';
|
|---|
| 5 | @EXPORT = ('nsort', 'ncmp');
|
|---|
| 6 | require Exporter;
|
|---|
| 7 | @ISA = ('Exporter');
|
|---|
| 8 |
|
|---|
| 9 | use strict;
|
|---|
| 10 | use locale;
|
|---|
| 11 | use integer;
|
|---|
| 12 |
|
|---|
| 13 | #-----------------------------------------------------------------------------
|
|---|
| 14 | # constants:
|
|---|
| 15 | BEGIN { *DEBUG = sub () {0} unless defined &DEBUG }
|
|---|
| 16 |
|
|---|
| 17 | use Config ();
|
|---|
| 18 | BEGIN {
|
|---|
| 19 | # Make a constant such that if a whole-number string is that long
|
|---|
| 20 | # or shorter, we KNOW it's treatable as an integer
|
|---|
| 21 | no integer;
|
|---|
| 22 | my $x = length(256 ** $Config::Config{'intsize'} / 2) - 1;
|
|---|
| 23 | die "Crazy intsize: <$Config::Config{'intsize'}>" if $x < 4;
|
|---|
| 24 | eval 'sub MAX_INT_SIZE () {' . $x . '}';
|
|---|
| 25 | die $@ if $@;
|
|---|
| 26 | print "intsize $Config::Config{'intsize'} => MAX_INT_SIZE $x\n" if DEBUG;
|
|---|
| 27 | }
|
|---|
| 28 |
|
|---|
| 29 | sub X_FIRST () {-1}
|
|---|
| 30 | sub Y_FIRST () { 1}
|
|---|
| 31 |
|
|---|
| 32 | my @ORD = ('same', 'swap', 'asis');
|
|---|
| 33 |
|
|---|
| 34 | #-----------------------------------------------------------------------------
|
|---|
| 35 | # For lack of a preprocessor:
|
|---|
| 36 |
|
|---|
| 37 | my($code, $guts);
|
|---|
| 38 | $guts = <<'EOGUTS'; # This is the guts of both ncmp and nsort:
|
|---|
| 39 |
|
|---|
| 40 | if($x eq $y) {
|
|---|
| 41 | # trap this expensive case first, and then fall thru to tiebreaker
|
|---|
| 42 | $rv = 0;
|
|---|
| 43 |
|
|---|
| 44 | # Convoluted hack to get numerics to sort first, at string start:
|
|---|
| 45 | } elsif($x =~ m/^\d/s) {
|
|---|
| 46 | if($y =~ m/^\d/s) {
|
|---|
| 47 | $rv = 0; # fall thru to normal comparison for the two numbers
|
|---|
| 48 | } else {
|
|---|
| 49 | $rv = X_FIRST;
|
|---|
| 50 | DEBUG > 1 and print "Numeric-initial $x trumps letter-initial $y\n";
|
|---|
| 51 | }
|
|---|
| 52 | } elsif($y =~ m/^\d/s) {
|
|---|
| 53 | $rv = Y_FIRST;
|
|---|
| 54 | DEBUG > 1 and print "Numeric-initial $y trumps letter-initial $x\n";
|
|---|
| 55 | } else {
|
|---|
| 56 | $rv = 0;
|
|---|
| 57 | }
|
|---|
| 58 |
|
|---|
| 59 | unless($rv) {
|
|---|
| 60 | # Normal case:
|
|---|
| 61 | $rv = 0;
|
|---|
| 62 | DEBUG and print "<$x> and <$y> compared...\n";
|
|---|
| 63 |
|
|---|
| 64 | Consideration:
|
|---|
| 65 | while(length $x and length $y) {
|
|---|
| 66 |
|
|---|
| 67 | DEBUG > 2 and print " <$x> and <$y>...\n";
|
|---|
| 68 |
|
|---|
| 69 | # First, non-numeric comparison:
|
|---|
| 70 | $x2 = ($x =~ m/^(\D+)/s) ? length($1) : 0;
|
|---|
| 71 | $y2 = ($y =~ m/^(\D+)/s) ? length($1) : 0;
|
|---|
| 72 | # Now make x2 the min length of the two:
|
|---|
| 73 | $x2 = $y2 if $x2 > $y2;
|
|---|
| 74 | if($x2) {
|
|---|
| 75 | DEBUG > 1 and printf " <%s> and <%s> lexically for length $x2...\n",
|
|---|
| 76 | substr($x,0,$x2), substr($y,0,$x2);
|
|---|
| 77 | do {
|
|---|
| 78 | my $i = substr($x,0,$x2);
|
|---|
| 79 | my $j = substr($y,0,$x2);
|
|---|
| 80 | my $sv = $i cmp $j;
|
|---|
| 81 | print "SCREAM! on <$i><$j> -- $sv != $rv \n" unless $rv == $sv;
|
|---|
| 82 | last;
|
|---|
| 83 | }
|
|---|
| 84 |
|
|---|
| 85 |
|
|---|
| 86 | if $rv =
|
|---|
| 87 | # The ''. things here force a copy that seems to work around a
|
|---|
| 88 | # mysterious intermittent bug that 'use locale' provokes in
|
|---|
| 89 | # many versions of Perl.
|
|---|
| 90 | $cmp
|
|---|
| 91 | ? $cmp->(substr($x,0,$x2) . '',
|
|---|
| 92 | substr($y,0,$x2) . '',
|
|---|
| 93 | )
|
|---|
| 94 | :
|
|---|
| 95 | scalar(( substr($x,0,$x2) . '' ) cmp
|
|---|
| 96 | ( substr($y,0,$x2) . '' )
|
|---|
| 97 | )
|
|---|
| 98 | ;
|
|---|
| 99 | # otherwise trim and keep going:
|
|---|
| 100 | substr($x,0,$x2) = '';
|
|---|
| 101 | substr($y,0,$x2) = '';
|
|---|
| 102 | }
|
|---|
| 103 |
|
|---|
| 104 | # Now numeric:
|
|---|
| 105 | # (actually just using $x2 and $y2 as scratch)
|
|---|
| 106 |
|
|---|
| 107 | if( $x =~ s/^(\d+)//s ) {
|
|---|
| 108 | $x2 = $1;
|
|---|
| 109 | if( $y =~ s/^(\d+)//s ) {
|
|---|
| 110 | # We have two numbers here.
|
|---|
| 111 | DEBUG > 1 and print " <$x2> and <$1> numerically\n";
|
|---|
| 112 | if(length($x2) < MAX_INT_SIZE and length($1) < MAX_INT_SIZE) {
|
|---|
| 113 | # small numbers: we can compare happily
|
|---|
| 114 | last if $rv = $x2 <=> $1;
|
|---|
| 115 | } else {
|
|---|
| 116 | # ARBITRARILY large integers!
|
|---|
| 117 |
|
|---|
| 118 | # This saves on loss of precision that could happen
|
|---|
| 119 | # with actual stringification.
|
|---|
| 120 | # Also, I sense that very large numbers aren't too
|
|---|
| 121 | # terribly common in sort data.
|
|---|
| 122 |
|
|---|
| 123 | # trim leading 0's:
|
|---|
| 124 | ($y2 = $1) =~ s/^0+//s;
|
|---|
| 125 | $x2 =~ s/^0+//s;
|
|---|
| 126 | print " Treating $x2 and $y2 as bigint\n" if DEBUG;
|
|---|
| 127 |
|
|---|
| 128 | no locale; # we want the dumb cmp back.
|
|---|
| 129 | last if $rv = (
|
|---|
| 130 | # works only for non-negative whole numbers:
|
|---|
| 131 | length($x2) <=> length($y2)
|
|---|
| 132 | # the longer the numeral, the larger the value
|
|---|
| 133 | or $x2 cmp $y2
|
|---|
| 134 | # between equals, compare lexically!! amazing but true.
|
|---|
| 135 | );
|
|---|
| 136 | }
|
|---|
| 137 | } else {
|
|---|
| 138 | # X is numeric but Y isn't
|
|---|
| 139 | $rv = Y_FIRST;
|
|---|
| 140 | last;
|
|---|
| 141 | }
|
|---|
| 142 | } elsif( $y =~ s/^\d+//s ) { # we don't need to capture the substring
|
|---|
| 143 | $rv = X_FIRST;
|
|---|
| 144 | last;
|
|---|
| 145 | }
|
|---|
| 146 | # else one of them is 0-length.
|
|---|
| 147 |
|
|---|
| 148 | # end-while
|
|---|
| 149 | }
|
|---|
| 150 | }
|
|---|
| 151 | EOGUTS
|
|---|
| 152 |
|
|---|
| 153 | sub maker {
|
|---|
| 154 | my $code = $_[0];
|
|---|
| 155 | $code =~ s/~COMPARATOR~/$guts/g || die "Can't find ~COMPARATOR~";
|
|---|
| 156 | eval $code;
|
|---|
| 157 | die $@ if $@;
|
|---|
| 158 | }
|
|---|
| 159 |
|
|---|
| 160 | ##############################################################################
|
|---|
| 161 |
|
|---|
| 162 | maker(<<'EONSORT');
|
|---|
| 163 | sub nsort {
|
|---|
| 164 | # get options:
|
|---|
| 165 | my($cmp, $lc);
|
|---|
| 166 | ($cmp,$lc) = @{shift @_} if @_ and ref($_[0]) eq 'ARRAY';
|
|---|
| 167 |
|
|---|
| 168 | return @_ unless @_ > 1 or wantarray; # be clever
|
|---|
| 169 |
|
|---|
| 170 | my($x, $x2, $y, $y2, $rv); # scratch vars
|
|---|
| 171 |
|
|---|
| 172 | # We use a Schwartzian xform to memoize the lc'ing and \W-removal
|
|---|
| 173 |
|
|---|
| 174 | map $_->[0],
|
|---|
| 175 | sort {
|
|---|
| 176 | if($a->[0] eq $b->[0]) { 0 } # trap this expensive case
|
|---|
| 177 | else {
|
|---|
| 178 |
|
|---|
| 179 | $x = $a->[1];
|
|---|
| 180 | $y = $b->[1];
|
|---|
| 181 |
|
|---|
| 182 | ~COMPARATOR~
|
|---|
| 183 |
|
|---|
| 184 | # Tiebreakers...
|
|---|
| 185 | DEBUG > 1 and print " -<${$a}[0]> cmp <${$b}[0]> is $rv ($ORD[$rv])\n";
|
|---|
| 186 | $rv ||= (length($x) <=> length($y)) # shorter is always first
|
|---|
| 187 | || ($cmp and $cmp->($x,$y) || $cmp->($a->[0], $b->[0]))
|
|---|
| 188 | || ($x cmp $y )
|
|---|
| 189 | || ($a->[0] cmp $b->[0])
|
|---|
| 190 | ;
|
|---|
| 191 |
|
|---|
| 192 | DEBUG > 1 and print " <${$a}[0]> cmp <${$b}[0]> is $rv ($ORD[$rv])\n";
|
|---|
| 193 | $rv;
|
|---|
| 194 | }}
|
|---|
| 195 |
|
|---|
| 196 | map {;
|
|---|
| 197 | $x = $lc ? $lc->($_) : lc($_); # x as scratch
|
|---|
| 198 | $x =~ s/\W+//s;
|
|---|
| 199 | [$_, $x];
|
|---|
| 200 | }
|
|---|
| 201 | @_
|
|---|
| 202 | }
|
|---|
| 203 | EONSORT
|
|---|
| 204 |
|
|---|
| 205 | #-----------------------------------------------------------------------------
|
|---|
| 206 | maker(<<'EONCMP');
|
|---|
| 207 | sub ncmp {
|
|---|
| 208 | # The guts are basically the same as above...
|
|---|
| 209 |
|
|---|
| 210 | # get options:
|
|---|
| 211 | my($cmp, $lc);
|
|---|
| 212 | ($cmp,$lc) = @{shift @_} if @_ and ref($_[0]) eq 'ARRAY';
|
|---|
| 213 |
|
|---|
| 214 | if(@_ == 0) {
|
|---|
| 215 | @_ = ($a, $b); # bit of a hack!
|
|---|
| 216 | DEBUG > 1 and print "Hacking in <$a><$b>\n";
|
|---|
| 217 | } elsif(@_ != 2) {
|
|---|
| 218 | require Carp;
|
|---|
| 219 | Carp::croak("Not enough options to ncmp!");
|
|---|
| 220 | }
|
|---|
| 221 | my($a,$b) = @_;
|
|---|
| 222 | my($x, $x2, $y, $y2, $rv); # scratch vars
|
|---|
| 223 |
|
|---|
| 224 | DEBUG > 1 and print "ncmp args <$a><$b>\n";
|
|---|
| 225 | if($a eq $b) { # trap this expensive case
|
|---|
| 226 | 0;
|
|---|
| 227 | } else {
|
|---|
| 228 | $x = ($lc ? $lc->($a) : lc($a));
|
|---|
| 229 | $x =~ s/\W+//s;
|
|---|
| 230 | $y = ($lc ? $lc->($b) : lc($b));
|
|---|
| 231 | $y =~ s/\W+//s;
|
|---|
| 232 |
|
|---|
| 233 | ~COMPARATOR~
|
|---|
| 234 |
|
|---|
| 235 |
|
|---|
| 236 | # Tiebreakers...
|
|---|
| 237 | DEBUG > 1 and print " -<$a> cmp <$b> is $rv ($ORD[$rv])\n";
|
|---|
| 238 | $rv ||= (length($x) <=> length($y)) # shorter is always first
|
|---|
| 239 | || ($cmp and $cmp->($x,$y) || $cmp->($a,$b))
|
|---|
| 240 | || ($x cmp $y)
|
|---|
| 241 | || ($a cmp $b)
|
|---|
| 242 | ;
|
|---|
| 243 |
|
|---|
| 244 | DEBUG > 1 and print " <$a> cmp <$b> is $rv\n";
|
|---|
| 245 | $rv;
|
|---|
| 246 | }
|
|---|
| 247 | }
|
|---|
| 248 | EONCMP
|
|---|
| 249 |
|
|---|
| 250 | # clean up:
|
|---|
| 251 | undef $guts;
|
|---|
| 252 | undef &maker;
|
|---|
| 253 |
|
|---|
| 254 | #-----------------------------------------------------------------------------
|
|---|
| 255 | 1;
|
|---|
| 256 |
|
|---|
| 257 | ############### END OF MAIN SOURCE ###########################################
|
|---|
| 258 | __END__
|
|---|
| 259 |
|
|---|
| 260 | =head1 NAME
|
|---|
| 261 |
|
|---|
| 262 | Sort::Naturally -- sort lexically, but sort numeral parts numerically
|
|---|
| 263 |
|
|---|
| 264 | =head1 SYNOPSIS
|
|---|
| 265 |
|
|---|
| 266 | @them = nsort(qw(
|
|---|
| 267 | foo12a foo12z foo13a foo 14 9x foo12 fooa foolio Foolio Foo12a
|
|---|
| 268 | ));
|
|---|
| 269 | print join(' ', @them), "\n";
|
|---|
| 270 |
|
|---|
| 271 | Prints:
|
|---|
| 272 |
|
|---|
| 273 | 9x 14 foo fooa foolio Foolio foo12 foo12a Foo12a foo12z foo13a
|
|---|
| 274 |
|
|---|
| 275 | (Or "foo12a" + "Foo12a" and "foolio" + "Foolio" and might be
|
|---|
| 276 | switched, depending on your locale.)
|
|---|
| 277 |
|
|---|
| 278 | =head1 DESCRIPTION
|
|---|
| 279 |
|
|---|
| 280 | This module exports two functions, C<nsort> and C<ncmp>; they are used
|
|---|
| 281 | in implementing my idea of a "natural sorting" algorithm. Under natural
|
|---|
| 282 | sorting, numeric substrings are compared numerically, and other
|
|---|
| 283 | word-characters are compared lexically.
|
|---|
| 284 |
|
|---|
| 285 | This is the way I define natural sorting:
|
|---|
| 286 |
|
|---|
| 287 | =over
|
|---|
| 288 |
|
|---|
| 289 | =item *
|
|---|
| 290 |
|
|---|
| 291 | Non-numeric word-character substrings are sorted lexically,
|
|---|
| 292 | case-insensitively: "Foo" comes between "fish" and "fowl".
|
|---|
| 293 |
|
|---|
| 294 | =item *
|
|---|
| 295 |
|
|---|
| 296 | Numeric substrings are sorted numerically:
|
|---|
| 297 | "100" comes after "20", not before.
|
|---|
| 298 |
|
|---|
| 299 | =item *
|
|---|
| 300 |
|
|---|
| 301 | \W substrings (neither words-characters nor digits) are I<ignored>.
|
|---|
| 302 |
|
|---|
| 303 | =item *
|
|---|
| 304 |
|
|---|
| 305 | Our use of \w, \d, \D, and \W is locale-sensitive: Sort::Naturally
|
|---|
| 306 | uses a C<use locale> statement.
|
|---|
| 307 |
|
|---|
| 308 | =item *
|
|---|
| 309 |
|
|---|
| 310 | When comparing two strings, where a numeric substring in one
|
|---|
| 311 | place is I<not> up against a numeric substring in another,
|
|---|
| 312 | the non-numeric always comes first. This is fudged by
|
|---|
| 313 | reading pretending that the lack of a number substring has
|
|---|
| 314 | the value -1, like so:
|
|---|
| 315 |
|
|---|
| 316 | foo => "foo", -1
|
|---|
| 317 | foobar => "foo", -1, "bar"
|
|---|
| 318 | foo13 => "foo", 13,
|
|---|
| 319 | foo13xyz => "foo", 13, "xyz"
|
|---|
| 320 |
|
|---|
| 321 | That's so that "foo" will come before "foo13", which will come
|
|---|
| 322 | before "foobar".
|
|---|
| 323 |
|
|---|
| 324 | =item *
|
|---|
| 325 |
|
|---|
| 326 | The start of a string is exceptional: leading non-\W (non-word,
|
|---|
| 327 | non-digit)
|
|---|
| 328 | components are are ignored, and numbers come I<before> letters.
|
|---|
| 329 |
|
|---|
| 330 | =item *
|
|---|
| 331 |
|
|---|
| 332 | I define "numeric substring" just as sequences matching m/\d+/ --
|
|---|
| 333 | scientific notation, commas, decimals, etc., are not seen. If
|
|---|
| 334 | your data has thousands separators in numbers
|
|---|
| 335 | ("20,000 Leagues Under The Sea" or "20.000 lieues sous les mers"),
|
|---|
| 336 | consider stripping them before feeding them to C<nsort> or
|
|---|
| 337 | C<ncmp>.
|
|---|
| 338 |
|
|---|
| 339 | =back
|
|---|
| 340 |
|
|---|
| 341 | =head2 The nsort function
|
|---|
| 342 |
|
|---|
| 343 | This function takes a list of strings, and returns a copy of the list,
|
|---|
| 344 | sorted.
|
|---|
| 345 |
|
|---|
| 346 | This is what most people will want to use:
|
|---|
| 347 |
|
|---|
| 348 | @stuff = nsort(...list...);
|
|---|
| 349 |
|
|---|
| 350 | When nsort needs to compare non-numeric substrings, it
|
|---|
| 351 | uses Perl's C<lc> function in scope of a <use locale>.
|
|---|
| 352 | And when nsort needs to lowercase things, it uses Perl's
|
|---|
| 353 | C<lc> function in scope of a <use locale>. If you want nsort
|
|---|
| 354 | to use other functions instead, you can specify them in
|
|---|
| 355 | an arrayref as the first argument to nsort:
|
|---|
| 356 |
|
|---|
| 357 | @stuff = nsort( [
|
|---|
| 358 | \&string_comparator, # optional
|
|---|
| 359 | \&lowercaser_function # optional
|
|---|
| 360 | ],
|
|---|
| 361 | ...list...
|
|---|
| 362 | );
|
|---|
| 363 |
|
|---|
| 364 | If you want to specify a string comparator but no lowercaser,
|
|---|
| 365 | then the options list is C<[\&comparator, '']> or
|
|---|
| 366 | C<[\&comparator]>. If you want to specify no string comparator
|
|---|
| 367 | but a lowercaser, then the options list is
|
|---|
| 368 | C<['', \&lowercaser]>.
|
|---|
| 369 |
|
|---|
| 370 | Any comparator you specify is called as
|
|---|
| 371 | C<$comparator-E<gt>($left, $right)>,
|
|---|
| 372 | and, like a normal Perl C<cmp> replacement, must return
|
|---|
| 373 | -1, 0, or 1 depending on whether the left argument is stringwise
|
|---|
| 374 | less than, equal to, or greater than the right argument.
|
|---|
| 375 |
|
|---|
| 376 | Any lowercaser function you specify is called as
|
|---|
| 377 | C<$lowercased = $lowercaser-E<gt>($original)>. The routine
|
|---|
| 378 | must not modify its C<$_[0]>.
|
|---|
| 379 |
|
|---|
| 380 | =head2 The ncmp function
|
|---|
| 381 |
|
|---|
| 382 | Often, when sorting non-string values like this:
|
|---|
| 383 |
|
|---|
| 384 | @objects_sorted = sort { $a->tag cmp $b->tag } @objects;
|
|---|
| 385 |
|
|---|
| 386 | ...or even in a Schwartzian transform, like this:
|
|---|
| 387 |
|
|---|
| 388 | @strings =
|
|---|
| 389 | map $_->[0]
|
|---|
| 390 | sort { $a->[1] cmp $b->[1] }
|
|---|
| 391 | map { [$_, make_a_sort_key_from($_) ]
|
|---|
| 392 | @_
|
|---|
| 393 | ;
|
|---|
| 394 |
|
|---|
| 395 | ...you wight want something that replaces not C<sort>, but C<cmp>.
|
|---|
| 396 | That's what Sort::Naturally's C<ncmp> function is for. Call it with
|
|---|
| 397 | the syntax C<ncmp($left,$right)> instead of C<$left cmp $right>,
|
|---|
| 398 | but otherwise it's a fine replacement:
|
|---|
| 399 |
|
|---|
| 400 | @objects_sorted = sort { ncmp($a->tag,$b->tag) } @objects;
|
|---|
| 401 |
|
|---|
| 402 | @strings =
|
|---|
| 403 | map $_->[0]
|
|---|
| 404 | sort { ncmp($a->[1], $b->[1]) }
|
|---|
| 405 | map { [$_, make_a_sort_key_from($_) ]
|
|---|
| 406 | @_
|
|---|
| 407 | ;
|
|---|
| 408 |
|
|---|
| 409 | Just as with C<nsort> can take different a string-comparator
|
|---|
| 410 | and/or lowercaser, you can do the same with C<ncmp>, by passing
|
|---|
| 411 | an arrayref as the first argument:
|
|---|
| 412 |
|
|---|
| 413 | ncmp( [
|
|---|
| 414 | \&string_comparator, # optional
|
|---|
| 415 | \&lowercaser_function # optional
|
|---|
| 416 | ],
|
|---|
| 417 | $left, $right
|
|---|
| 418 | )
|
|---|
| 419 |
|
|---|
| 420 | You might get string comparators from L<Sort::ArbBiLex|Sort::ArbBiLex>.
|
|---|
| 421 |
|
|---|
| 422 | =head1 NOTES
|
|---|
| 423 |
|
|---|
| 424 | =over
|
|---|
| 425 |
|
|---|
| 426 | =item *
|
|---|
| 427 |
|
|---|
| 428 | This module is not a substitute for
|
|---|
| 429 | L<Sort::Versions|Sort::Versions>! If
|
|---|
| 430 | you just need proper version sorting, use I<that!>
|
|---|
| 431 |
|
|---|
| 432 | =item *
|
|---|
| 433 |
|
|---|
| 434 | If you need something that works I<sort of> like this module's
|
|---|
| 435 | functions, but not quite the same, consider scouting thru this
|
|---|
| 436 | module's source code, and adapting what you see. Besides
|
|---|
| 437 | the functions that actually compile in this module, after the POD,
|
|---|
| 438 | there's several alternate attempts of mine at natural sorting
|
|---|
| 439 | routines, which are not compiled as part of the module, but which you
|
|---|
| 440 | might find useful. They should all be I<working> implementations of
|
|---|
| 441 | slightly different algorithms
|
|---|
| 442 | (all of them based on Martin Pool's C<nsort>) which I eventually
|
|---|
| 443 | discarded in favor of my algorithm. If you are having to
|
|---|
| 444 | naturally-sort I<very large> data sets, and sorting is getting
|
|---|
| 445 | ridiculously slow, you might consider trying one of those
|
|---|
| 446 | discarded functions -- I have a feeling they might be faster on
|
|---|
| 447 | large data sets. Benchmark them on your data and see. (Unless
|
|---|
| 448 | you I<need> the speed, don't bother. Hint: substitute C<sort>
|
|---|
| 449 | for C<nsort> in your code, and unless your program speeds up
|
|---|
| 450 | drastically, it's not the sorting that's slowing things down.
|
|---|
| 451 | But if it I<is> C<nsort> that's slowing things down, consider
|
|---|
| 452 | just:
|
|---|
| 453 |
|
|---|
| 454 | if(@set >= SOME_VERY_BIG_NUMBER) {
|
|---|
| 455 | no locale; # vroom vroom
|
|---|
| 456 | @sorted = sort(@set); # feh, good enough
|
|---|
| 457 | } elsif(@set >= SOME_BIG_NUMBER) {
|
|---|
| 458 | use locale;
|
|---|
| 459 | @sorted = sort(@set); # feh, good enough
|
|---|
| 460 | } else {
|
|---|
| 461 | # but keep it pretty for normal cases
|
|---|
| 462 | @sorted = nsort(@set);
|
|---|
| 463 | }
|
|---|
| 464 |
|
|---|
| 465 | =item *
|
|---|
| 466 |
|
|---|
| 467 | If you do adapt the routines in this module, email me; I'd
|
|---|
| 468 | just be interested in hearing about it.
|
|---|
| 469 |
|
|---|
| 470 | =item *
|
|---|
| 471 |
|
|---|
| 472 | Thanks to the EFNet #perl people for encouraging this module,
|
|---|
| 473 | especially magister and a-mused.
|
|---|
| 474 |
|
|---|
| 475 | =back
|
|---|
| 476 |
|
|---|
| 477 | =head1 COPYRIGHT AND DISCLAIMER
|
|---|
| 478 |
|
|---|
| 479 | Copyright 2001, Sean M. Burke C<[email protected]>, all rights
|
|---|
| 480 | reserved. This program is free software; you can redistribute it
|
|---|
| 481 | and/or modify it under the same terms as Perl itself.
|
|---|
| 482 |
|
|---|
| 483 | This program is distributed in the hope that it will be useful, but
|
|---|
| 484 | without any warranty; without even the implied warranty of
|
|---|
| 485 | merchantability or fitness for a particular purpose.
|
|---|
| 486 |
|
|---|
| 487 | =head1 AUTHOR
|
|---|
| 488 |
|
|---|
| 489 | Sean M. Burke C<[email protected]>
|
|---|
| 490 |
|
|---|
| 491 | =cut
|
|---|
| 492 |
|
|---|
| 493 | ############ END OF DOCS ############
|
|---|
| 494 |
|
|---|
| 495 | ############################################################################
|
|---|
| 496 | ############################################################################
|
|---|
| 497 |
|
|---|
| 498 | ############ BEGIN OLD STUFF ############
|
|---|
| 499 |
|
|---|
| 500 | # We can't have "use integer;", or else (5 <=> 5.1) comes out "0" !
|
|---|
| 501 |
|
|---|
| 502 | #-----------------------------------------------------------------------------
|
|---|
| 503 | sub nsort {
|
|---|
| 504 | my($cmp, $lc);
|
|---|
| 505 | return @_ if @_ < 2; # Just to be CLEVER.
|
|---|
| 506 |
|
|---|
| 507 | my($x, $i); # scratch vars
|
|---|
| 508 |
|
|---|
| 509 | # And now, the GREAT BIG Schwartzian transform:
|
|---|
| 510 |
|
|---|
| 511 | map
|
|---|
| 512 | $_->[0],
|
|---|
| 513 |
|
|---|
| 514 | sort {
|
|---|
| 515 | # Uses $i as the index variable, $x as the result.
|
|---|
| 516 | $x = 0;
|
|---|
| 517 | $i = 1;
|
|---|
| 518 | DEBUG and print "\nComparing ", map("{$_}", @$a),
|
|---|
| 519 | ' : ', map("{$_}", @$b), , "...\n";
|
|---|
| 520 |
|
|---|
| 521 | while($i < @$a and $i < @$b) {
|
|---|
| 522 | DEBUG and print " comparing $i: {$a->[$i]} cmp {$b->[$i]} => ",
|
|---|
| 523 | $a->[$i] cmp $b->[$i], "\n";
|
|---|
| 524 | last if ($x = ($a->[$i] cmp $b->[$i])); # lexicographic
|
|---|
| 525 | ++$i;
|
|---|
| 526 |
|
|---|
| 527 | DEBUG and print " comparing $i: {$a->[$i]} <=> {$b->[$i]} => ",
|
|---|
| 528 | $a->[$i] <=> $b->[$i], "\n";
|
|---|
| 529 | last if ($x = ($a->[$i] <=> $b->[$i])); # numeric
|
|---|
| 530 | ++$i;
|
|---|
| 531 | }
|
|---|
| 532 |
|
|---|
| 533 | DEBUG and print "{$a->[0]} : {$b->[0]} is ",
|
|---|
| 534 | $x || (@$a <=> @$b) || 0
|
|---|
| 535 | ,"\n"
|
|---|
| 536 | ;
|
|---|
| 537 | $x || (@$a <=> @$b) || ($a->[0] cmp $b->[0]);
|
|---|
| 538 | # unless we found a result for $x in the while loop,
|
|---|
| 539 | # use length as a tiebreaker, otherwise use cmp
|
|---|
| 540 | # on the original string as a fallback tiebreaker.
|
|---|
| 541 | }
|
|---|
| 542 |
|
|---|
| 543 | map {
|
|---|
| 544 | my @bit = ($x = defined($_) ? $_ : '');
|
|---|
| 545 |
|
|---|
| 546 | if($x =~ m/^[+-]?(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?\z/s) {
|
|---|
| 547 | # It's entirely purely numeric, so treat it specially:
|
|---|
| 548 | push @bit, '', $x;
|
|---|
| 549 | } else {
|
|---|
| 550 | # Consume the string.
|
|---|
| 551 | while(length $x) {
|
|---|
| 552 | push @bit, ($x =~ s/^(\D+)//s) ? lc($1) : '';
|
|---|
| 553 | push @bit, ($x =~ s/^(\d+)//s) ? $1 : 0;
|
|---|
| 554 | }
|
|---|
| 555 | }
|
|---|
| 556 | DEBUG and print "$bit[0] => ", map("{$_} ", @bit), "\n";
|
|---|
| 557 |
|
|---|
| 558 | # End result: [original bit , (text, number), (text, number), ...]
|
|---|
| 559 | # Minimally: [0-length original bit,]
|
|---|
| 560 | # Examples:
|
|---|
| 561 | # ['10' => '' , 10, ]
|
|---|
| 562 | # ['fo900' => 'fo' , 900, ]
|
|---|
| 563 | # ['foo10' => 'foo', 10, ]
|
|---|
| 564 | # ['foo9.pl' => 'foo', 9, , '.pl', 0 ]
|
|---|
| 565 | # ['foo32.pl' => 'foo', 32, , '.pl', 0 ]
|
|---|
| 566 | # ['foo325.pl' => 'foo', 325, , '.pl', 0 ]
|
|---|
| 567 | # Yes, always an ODD number of elements.
|
|---|
| 568 |
|
|---|
| 569 | \@bit;
|
|---|
| 570 | }
|
|---|
| 571 | @_;
|
|---|
| 572 | }
|
|---|
| 573 |
|
|---|
| 574 | #-----------------------------------------------------------------------------
|
|---|
| 575 | # Same as before, except without the pure-number trap.
|
|---|
| 576 |
|
|---|
| 577 | sub nsorts {
|
|---|
| 578 | return @_ if @_ < 2; # Just to be CLEVER.
|
|---|
| 579 |
|
|---|
| 580 | my($x, $i); # scratch vars
|
|---|
| 581 |
|
|---|
| 582 | # And now, the GREAT BIG Schwartzian transform:
|
|---|
| 583 |
|
|---|
| 584 | map
|
|---|
| 585 | $_->[0],
|
|---|
| 586 |
|
|---|
| 587 | sort {
|
|---|
| 588 | # Uses $i as the index variable, $x as the result.
|
|---|
| 589 | $x = 0;
|
|---|
| 590 | $i = 1;
|
|---|
| 591 | DEBUG and print "\nComparing ", map("{$_}", @$a),
|
|---|
| 592 | ' : ', map("{$_}", @$b), , "...\n";
|
|---|
| 593 |
|
|---|
| 594 | while($i < @$a and $i < @$b) {
|
|---|
| 595 | DEBUG and print " comparing $i: {$a->[$i]} cmp {$b->[$i]} => ",
|
|---|
| 596 | $a->[$i] cmp $b->[$i], "\n";
|
|---|
| 597 | last if ($x = ($a->[$i] cmp $b->[$i])); # lexicographic
|
|---|
| 598 | ++$i;
|
|---|
| 599 |
|
|---|
| 600 | DEBUG and print " comparing $i: {$a->[$i]} <=> {$b->[$i]} => ",
|
|---|
| 601 | $a->[$i] <=> $b->[$i], "\n";
|
|---|
| 602 | last if ($x = ($a->[$i] <=> $b->[$i])); # numeric
|
|---|
| 603 | ++$i;
|
|---|
| 604 | }
|
|---|
| 605 |
|
|---|
| 606 | DEBUG and print "{$a->[0]} : {$b->[0]} is ",
|
|---|
| 607 | $x || (@$a <=> @$b) || 0
|
|---|
| 608 | ,"\n"
|
|---|
| 609 | ;
|
|---|
| 610 | $x || (@$a <=> @$b) || ($a->[0] cmp $b->[0]);
|
|---|
| 611 | # unless we found a result for $x in the while loop,
|
|---|
| 612 | # use length as a tiebreaker, otherwise use cmp
|
|---|
| 613 | # on the original string as a fallback tiebreaker.
|
|---|
| 614 | }
|
|---|
| 615 |
|
|---|
| 616 | map {
|
|---|
| 617 | my @bit = ($x = defined($_) ? $_ : '');
|
|---|
| 618 |
|
|---|
| 619 | while(length $x) {
|
|---|
| 620 | push @bit, ($x =~ s/^(\D+)//s) ? lc($1) : '';
|
|---|
| 621 | push @bit, ($x =~ s/^(\d+)//s) ? $1 : 0;
|
|---|
| 622 | }
|
|---|
| 623 | DEBUG and print "$bit[0] => ", map("{$_} ", @bit), "\n";
|
|---|
| 624 |
|
|---|
| 625 | # End result: [original bit , (text, number), (text, number), ...]
|
|---|
| 626 | # Minimally: [0-length original bit,]
|
|---|
| 627 | # Examples:
|
|---|
| 628 | # ['10' => '' , 10, ]
|
|---|
| 629 | # ['fo900' => 'fo' , 900, ]
|
|---|
| 630 | # ['foo10' => 'foo', 10, ]
|
|---|
| 631 | # ['foo9.pl' => 'foo', 9, , '.pl', 0 ]
|
|---|
| 632 | # ['foo32.pl' => 'foo', 32, , '.pl', 0 ]
|
|---|
| 633 | # ['foo325.pl' => 'foo', 325, , '.pl', 0 ]
|
|---|
| 634 | # Yes, always an ODD number of elements.
|
|---|
| 635 |
|
|---|
| 636 | \@bit;
|
|---|
| 637 | }
|
|---|
| 638 | @_;
|
|---|
| 639 | }
|
|---|
| 640 |
|
|---|
| 641 | #-----------------------------------------------------------------------------
|
|---|
| 642 | # Same as before, except for the sort-key-making
|
|---|
| 643 |
|
|---|
| 644 | sub nsort0 {
|
|---|
| 645 | return @_ if @_ < 2; # Just to be CLEVER.
|
|---|
| 646 |
|
|---|
| 647 | my($x, $i); # scratch vars
|
|---|
| 648 |
|
|---|
| 649 | # And now, the GREAT BIG Schwartzian transform:
|
|---|
| 650 |
|
|---|
| 651 | map
|
|---|
| 652 | $_->[0],
|
|---|
| 653 |
|
|---|
| 654 | sort {
|
|---|
| 655 | # Uses $i as the index variable, $x as the result.
|
|---|
| 656 | $x = 0;
|
|---|
| 657 | $i = 1;
|
|---|
| 658 | DEBUG and print "\nComparing ", map("{$_}", @$a),
|
|---|
| 659 | ' : ', map("{$_}", @$b), , "...\n";
|
|---|
| 660 |
|
|---|
| 661 | while($i < @$a and $i < @$b) {
|
|---|
| 662 | DEBUG and print " comparing $i: {$a->[$i]} cmp {$b->[$i]} => ",
|
|---|
| 663 | $a->[$i] cmp $b->[$i], "\n";
|
|---|
| 664 | last if ($x = ($a->[$i] cmp $b->[$i])); # lexicographic
|
|---|
| 665 | ++$i;
|
|---|
| 666 |
|
|---|
| 667 | DEBUG and print " comparing $i: {$a->[$i]} <=> {$b->[$i]} => ",
|
|---|
| 668 | $a->[$i] <=> $b->[$i], "\n";
|
|---|
| 669 | last if ($x = ($a->[$i] <=> $b->[$i])); # numeric
|
|---|
| 670 | ++$i;
|
|---|
| 671 | }
|
|---|
| 672 |
|
|---|
| 673 | DEBUG and print "{$a->[0]} : {$b->[0]} is ",
|
|---|
| 674 | $x || (@$a <=> @$b) || 0
|
|---|
| 675 | ,"\n"
|
|---|
| 676 | ;
|
|---|
| 677 | $x || (@$a <=> @$b) || ($a->[0] cmp $b->[0]);
|
|---|
| 678 | # unless we found a result for $x in the while loop,
|
|---|
| 679 | # use length as a tiebreaker, otherwise use cmp
|
|---|
| 680 | # on the original string as a fallback tiebreaker.
|
|---|
| 681 | }
|
|---|
| 682 |
|
|---|
| 683 | map {
|
|---|
| 684 | my @bit = ($x = defined($_) ? $_ : '');
|
|---|
| 685 |
|
|---|
| 686 | if($x =~ m/^[+-]?(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?\z/s) {
|
|---|
| 687 | # It's entirely purely numeric, so treat it specially:
|
|---|
| 688 | push @bit, '', $x;
|
|---|
| 689 | } else {
|
|---|
| 690 | # Consume the string.
|
|---|
| 691 | while(length $x) {
|
|---|
| 692 | push @bit, ($x =~ s/^(\D+)//s) ? lc($1) : '';
|
|---|
| 693 | # Secret sauce:
|
|---|
| 694 | if($x =~ s/^(\d+)//s) {
|
|---|
| 695 | if(substr($1,0,1) eq '0' and $1 != 0) {
|
|---|
| 696 | push @bit, $1 / (10 ** length($1));
|
|---|
| 697 | } else {
|
|---|
| 698 | push @bit, $1;
|
|---|
| 699 | }
|
|---|
| 700 | } else {
|
|---|
| 701 | push @bit, 0;
|
|---|
| 702 | }
|
|---|
| 703 | }
|
|---|
| 704 | }
|
|---|
| 705 | DEBUG and print "$bit[0] => ", map("{$_} ", @bit), "\n";
|
|---|
| 706 |
|
|---|
| 707 | \@bit;
|
|---|
| 708 | }
|
|---|
| 709 | @_;
|
|---|
| 710 | }
|
|---|
| 711 |
|
|---|
| 712 | #-----------------------------------------------------------------------------
|
|---|
| 713 | # Like nsort0, but WITHOUT pure number handling, and WITH special treatment
|
|---|
| 714 | # of pulling off extensions and version numbers.
|
|---|
| 715 |
|
|---|
| 716 | sub nsortf {
|
|---|
| 717 | return @_ if @_ < 2; # Just to be CLEVER.
|
|---|
| 718 |
|
|---|
| 719 | my($x, $i); # scratch vars
|
|---|
| 720 |
|
|---|
| 721 | # And now, the GREAT BIG Schwartzian transform:
|
|---|
| 722 |
|
|---|
| 723 | map
|
|---|
| 724 | $_->[0],
|
|---|
| 725 |
|
|---|
| 726 | sort {
|
|---|
| 727 | # Uses $i as the index variable, $x as the result.
|
|---|
| 728 | $x = 0;
|
|---|
| 729 | $i = 3;
|
|---|
| 730 | DEBUG and print "\nComparing ", map("{$_}", @$a),
|
|---|
| 731 | ' : ', map("{$_}", @$b), , "...\n";
|
|---|
| 732 |
|
|---|
| 733 | while($i < @$a and $i < @$b) {
|
|---|
| 734 | DEBUG and print " comparing $i: {$a->[$i]} cmp {$b->[$i]} => ",
|
|---|
| 735 | $a->[$i] cmp $b->[$i], "\n";
|
|---|
| 736 | last if ($x = ($a->[$i] cmp $b->[$i])); # lexicographic
|
|---|
| 737 | ++$i;
|
|---|
| 738 |
|
|---|
| 739 | DEBUG and print " comparing $i: {$a->[$i]} <=> {$b->[$i]} => ",
|
|---|
| 740 | $a->[$i] <=> $b->[$i], "\n";
|
|---|
| 741 | last if ($x = ($a->[$i] <=> $b->[$i])); # numeric
|
|---|
| 742 | ++$i;
|
|---|
| 743 | }
|
|---|
| 744 |
|
|---|
| 745 | DEBUG and print "{$a->[0]} : {$b->[0]} is ",
|
|---|
| 746 | $x || (@$a <=> @$b) || 0
|
|---|
| 747 | ,"\n"
|
|---|
| 748 | ;
|
|---|
| 749 | $x || (@$a <=> @$b ) || ($a->[1] cmp $b->[1])
|
|---|
| 750 | || ($a->[2] <=> $b->[2]) || ($a->[0] cmp $b->[0]);
|
|---|
| 751 | # unless we found a result for $x in the while loop,
|
|---|
| 752 | # use length as a tiebreaker, otherwise use the
|
|---|
| 753 | # lc'd extension, otherwise the verison, otherwise use
|
|---|
| 754 | # the original string as a fallback tiebreaker.
|
|---|
| 755 | }
|
|---|
| 756 |
|
|---|
| 757 | map {
|
|---|
| 758 | my @bit = ( ($x = defined($_) ? $_ : ''), '',0 );
|
|---|
| 759 |
|
|---|
| 760 | {
|
|---|
| 761 | # Consume the string.
|
|---|
| 762 |
|
|---|
| 763 | # First, pull off any VAX-style version
|
|---|
| 764 | $bit[2] = $1 if $x =~ s/;(\d+)$//;
|
|---|
| 765 |
|
|---|
| 766 | # Then pull off any apparent extension
|
|---|
| 767 | if( $x !~ m/^\.+$/s and # don't mangle ".", "..", or "..."
|
|---|
| 768 | $x =~ s/(\.[^\.\;]*)$//sg
|
|---|
| 769 | # We could try to avoid catching all-digit extensions,
|
|---|
| 770 | # but I think that's getting /too/ clever.
|
|---|
| 771 | ) {
|
|---|
| 772 | $i = $1;
|
|---|
| 773 | if($x =~ m<[^\\\://]$>s) {
|
|---|
| 774 | # We didn't take the whole basename.
|
|---|
| 775 | $bit[1] = lc $i;
|
|---|
| 776 | DEBUG and print "Consuming extension \"$1\"\n";
|
|---|
| 777 | } else {
|
|---|
| 778 | # We DID take the whole basename. Fix it.
|
|---|
| 779 | $x = $1; # Repair it.
|
|---|
| 780 | }
|
|---|
| 781 | }
|
|---|
| 782 |
|
|---|
| 783 | push @bit, '', -1 if $x =~ m/^\./s;
|
|---|
| 784 | # A hack to make .-initial filenames sort first, regardless of locale.
|
|---|
| 785 | # And -1 is always a sort-firster, since in the code below, there's
|
|---|
| 786 | # no allowance for filenames containing negative numbers: -1.dat
|
|---|
| 787 | # will be read as string '-' followed by number 1.
|
|---|
| 788 |
|
|---|
| 789 | while(length $x) {
|
|---|
| 790 | push @bit, ($x =~ s/^(\D+)//s) ? lc($1) : '';
|
|---|
| 791 | # Secret sauce:
|
|---|
| 792 | if($x =~ s/^(\d+)//s) {
|
|---|
| 793 | if(substr($1,0,1) eq '0' and $1 != 0) {
|
|---|
| 794 | push @bit, $1 / (10 ** length($1));
|
|---|
| 795 | } else {
|
|---|
| 796 | push @bit, $1;
|
|---|
| 797 | }
|
|---|
| 798 | } else {
|
|---|
| 799 | push @bit, 0;
|
|---|
| 800 | }
|
|---|
| 801 | }
|
|---|
| 802 | }
|
|---|
| 803 |
|
|---|
| 804 | DEBUG and print "$bit[0] => ", map("{$_} ", @bit), "\n";
|
|---|
| 805 |
|
|---|
| 806 | \@bit;
|
|---|
| 807 | }
|
|---|
| 808 | @_;
|
|---|
| 809 | }
|
|---|
| 810 |
|
|---|
| 811 | # yowza yowza yowza.
|
|---|
| 812 |
|
|---|
