File Coverage

blib/lib/Sort/ArbBiLex.pm

Criterion	Covered	Total	%
statement	148	148	100.0
branch	66	92	71.7
condition	7	21	33.3
subroutine	21	21	100.0
pod	2	7	28.5
total	244	289	84.4

# -*-Fundamental-*-
require 5;    # Time-stamp: "2004-03-27 17:19:11 AST"
package Sort::ArbBiLex;
use strict;
use vars qw(@ISA $Debug $VERSION);
$VERSION = "4.01";
$Debug = 0;
use Carp;
use integer; # vroom vroom

BEGIN { *UNICODE = eval('chr(256)') ? sub(){1} : sub(){0} }

#POD at end
###########################################################################

sub import {
  my $class_name = shift(@_);
  my $into = scalar caller;
  return unless @_;
  croak "Argument list in 'use $class_name' must be list of pairs" if @_ % 2;
  my($sym, $spec);
  while(@_) {
    ($sym, $spec) = splice(@_,0,2);
    defined $sym  or croak "Can't use undef as the name of a sub to make";
    length $sym   or croak "Can't use \"\" as the name of a sub to make";
    defined $spec or croak "Can't use undef as a sort-order spec";
    length $sym   or croak "Can't use \"\" as a sort-order spec";
    $sym = $into . '::' . $sym unless $sym =~ m/::/ or $sym =~ m/'/;
    no strict 'refs';
    *{$sym} = maker($spec);
  }
  return;
}

#--------------------------------------------------------------------------

sub maker {
  my $subr = eval(&source_maker(@_));
  die "Compile error <$@> in eval!?!" if $@; # shouldn't be possible!
  return $subr;
}

# Implementation note:  I didn't /need/ to use eval().  I could just return
#  an appropriate closure.  But one can't do tr/$foo/$bar/ -- eval is the
#  only way to get things to (so to speak) interpolate there; and the
#  efficiency cost of requiring that Perl parse more code is offset by
#  the efficiency benefit of being able to use tr/// (instead of s///) in
#  appropriate cases.

#--------------------------------------------------------------------------

sub source_maker {
  no locale;
  my($decl) = $_[0];
  croak "usage: Sort::ArbBiLex::maker(DECLARATION).  See the docs."
   unless @_ == 1;

  my $one_level_mode = 0;
  my @decl;
  if(ref $decl) { # It's a rLoL declaration
    croak "Sort order declaration must be a string or a listref"
      unless ref($decl) eq 'ARRAY';
    print "rLoL-decl mode\n" if $Debug > 1;
    # Make @decl into a list of families
    @decl = @$decl;
     # and each one of the items in @decl must be a ref to a list of scalars
    foreach my $f (@decl) {
      croak "Each family must be a listref" unless ref($f) eq 'ARRAY';
      @$f = grep(defined($_) && length($_), @$f); # sanity
      foreach my $g (@$f) { # more sanity.
        croak "A reference found where a glyph was expected" if ref($g);
      }
    }

  } else { # It's a string-style declaration
    print "string-decl mode\n" if $Debug > 1;
    # Make @decl into a list of families
    if($decl =~ /[\cm\cj\n]/) { # It contains majors and minors
      @decl = grep /\S/, split( /[\cm\cj]+/, $decl );
    } else { # It's all majors, on one line
      print "Strangeness trap 1.\n" if $Debug;
      @decl = grep /\S/, split( /\s+/, $decl );
      $one_level_mode = 1;
    }

    # Now turn @decl into a list of lists, where each element is a
    #  family -- i.e., a ref to a list of glyphs in that family.

    print "Glyph map:\n", map("  {<$_>}\n", @decl) if $Debug > 1;
    foreach my $d (@decl) { # in place changing
      #print "  d $d -> ", map("<$_> ",grep($_ ne '',split(/\s+/, $d))), "\n";
      $d = [ grep($_ ne '', split(/\s+/, $d)) ];
      #print "  d $d -> ", map("<$_> ", @$d), "\n";
    }
  }

  @decl = grep( scalar(@{$_}), @decl); # nix empty families
  croak "No glyphs in sort order declaration!?" unless @decl;

  @decl = map [$_], @{$decl[0]}  if  @decl == 1;
   # Change it from a family of N glyphs into N families of one glyph each

  # Iterate thru the families and their glyphs and build the tables
  my(@glyphs, @major_out, @minor_out);
  my $max_glyph_length = 0;
  my $max_family_length = 0;
  my %seen;
  my($glyph, $minor); # scratch
  for (my $major = 0; $major < @decl; $major++) {
    print "Family $major\n" if $Debug;
    croak "Too many major glyphs" if !UNICODE and $major > 255;
    $max_family_length = @{ $decl[$major] }
     if  @{ $decl[$major] }  >  $max_family_length;

    for ($minor = 0; $minor < @{ $decl[$major] }; $minor++) {
      $glyph = $decl[$major][$minor];
      print "  Glyph ($major)\:$minor (", $glyph, ")\n" if $Debug;
      croak "Glyph <$glyph> appears twice in the sort order declaration!"
       if $seen{$glyph}++;
      croak "Too many minor glyphs" if !UNICODE and $minor > 255;

      $max_glyph_length = length($glyph) if length($glyph) > $max_glyph_length;

      $glyph =~ s/([^a-zA-Z0-9])/_char2esc($1)/eg;
      push @glyphs,    $glyph;
      push @major_out, _num2esc($major);
      push @minor_out, _num2esc($minor);
        #  or  unpack 'H2', pack 'C', 12   or   unpack 'H2', chr 12; ?
    }
  }
  die "Unexpected error: No glyphs?!?" if $max_glyph_length == 0;  # sanity
  $one_level_mode = 1 if $max_family_length == 1;

  #########################################################################
  # Now start building the code.

  my($prelude, $coda, $code, $minor_code, $major_code);
  if($max_glyph_length == 1) {
    # All glyphs are single characters, so we can do this all with tr's
    $prelude = "# Single character mode.";
    $coda = '';
    my $glyphs    = join '', @glyphs;
    my $major_out = join '', @major_out;
    my $minor_out = join '', @minor_out;

    $minor_code = <<"EOMN"; # contents of a FOR block mapping $$x[0] => $$x[2]
                 \$x->[2] =  \$x->[0];
                 \$x->[2] =~ tr[$glyphs][]cd;
                 \$x->[2] =~ tr[$glyphs]
                             [$minor_out];
EOMN

  $major_code = <<"EOMJ"; # expression returning a scalar as a major key
            do { # major keymaker
               my(\$key) = \$_;
               \$key =~ tr[$glyphs][]cd;
               \$key =~ tr[$glyphs]
                         [$major_out];
               scalar(\$key);
            }
EOMJ

    # End of single-glyph stuff.

  } else {
    # There are glyphs over 2 characters long -- gotta use s's.
    # End of multi-glyph stuff.
    my $glyphs    = join ',', map "\"$_\"", @glyphs;
    my $major_out = join ',', map "\"$_\"", @major_out;
    my $minor_out = join ',', map "\"$_\"", @minor_out;

    if(!$one_level_mode) {
      $prelude = <<"EOPRELUDE";
{ # Multi-character mode.  So we need a closure for these variables.
my(\%major, \%minor);
\@major{$glyphs}
 = ($major_out);
\@minor{$glyphs}
 = ($minor_out);
my \$glyph_re = join "|", map(quotemeta,
                             sort {length(\$b) <=> length(\$a)} keys \%major);
                             # put the longest glyphs first
EOPRELUDE
    } else { #  Multi-character mode
      $prelude = <<"EOPRELUDE2";
{ # Multi-character mode.  So we need a closure for these variables.
my(\%major); # just one-level mode, tho.
\@major{$glyphs}
 = ($major_out);
my \$glyph_re = join "|", map(quotemeta,
                             sort {length(\$b) <=> length(\$a)} keys \%major);
                             # put the longest glyphs first
EOPRELUDE2
}
    $coda = "} # end of closure.";

    $minor_code = <<"EOMN2"; # contents of a FOR block mapping $$x[0] => $$x[2]
                 \$x->[2] = join '',
                                map \$minor{\$_},
                                    \$x->[0] =~ m<(\$glyph_re)>go;
EOMN2

  $major_code = <<"EOMJ2"; # expression returning a scalar as a major key
            join('', map \$major{\$_}, m<(\$glyph_re)>go)  # major keymaker
EOMJ2

  }

  ###
  # Now  finish cobbling the code together.

  my $now = scalar(gmtime);

if(!$one_level_mode) {  # 2-level mode
  $code = <<"EOVOODOO";
\# Generated by Sort::ArbBiLex v$VERSION at $now GMT
$prelude
# Two-level mode
sub {   # change that to "sub whatever {" to name this function
  no locale; # we need the real 8-bit ASCIIbetical sort()
  use strict;
  return
    # map sort map is the Schwartzian Transform.  See perlfaq4.
    map { \$_->[0] }
    sort {
           \$a->[1] cmp \$b->[1] ||
           do {
             foreach my \$x (\$a, \$b) {
               if( !defined(\$x->[2]) and defined(\$x->[0]) ) {
$minor_code
               }
             }
             \$a->[2] cmp \$b->[2]; # return value of this do-block
           }
         }
    map { [ \$_,
$major_code
            , undef
          ]
        }
    \@_;
}
$coda

EOVOODOO

} else { # one-level mode

  $code = <<"EOVOODOO2";
\# Generated by Sort::ArbBiLex v$VERSION at $now GMT
$prelude
# One-level mode
sub {   # change that to "sub whatever {" to name this function
  no locale; # we need the real 8-bit ASCIIbetical sort()
  use strict;
  return
    # map sort map is the Schwartzian Transform.  See perlfaq4.
    map { \$_->[0] }
    sort { \$a->[1] cmp \$b->[1] }
    map { [ \$_,
$major_code
          ]
        }
    \@_;
}
$coda

EOVOODOO2

}

  print "\nCode to eval:\n", $code, "__ENDCODE__\n\n" if $Debug;

  return $code;
}

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

sub _char2esc {
  my $in = ord( $_[0] );
  return sprintf "\\x{%x}", $in if $in > 255;
  return sprintf "\\x%02x", $in;
}

sub _num2esc {
  my $in = $_[0];
  return sprintf "\\x{%x}", $in if $in > 255;
  return sprintf "\\x%02x", $in;
}

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

# "cmp" returns -1, 0, or 1 depending on whether the left argument is
# stringwise less than, equal to, or greater than the right argument.

sub xcmp {
  carp "usage: xcmp(\\&sorter,$a,$b)" unless @_ and ref($_[0]);
  return  0 if $_[1] eq $_[2];  # We have to trap this early.
  return  1 if $_[1] ne ( $_[0]->($_[1], $_[2]) )[0];
   # If they were switched when sorted, then the original-first was
   #  lexically GT than the original-second.
  return -1 if $_[1] eq ( $_[0]->($_[2], $_[1]) )[0];
   # If they were switched BACK when REVERSED and sorted, then the
   #  original-first was lexically LT than the original-second.
  return  0;
   # Otherwise they were lexically identical.
}

# And two actually simpler ones:

sub xlt {
  carp "usage: xlt(\\&sorter,$a,$b)" unless @_ and ref($_[0]);
  #AKA: xcmp(@_) == -1;
  return  0 if $_[1] eq $_[2];  # We have to trap this early.
  return  1 if $_[1] eq ( $_[0]->($_[2], $_[1]) )[0];
   # If they were switched BACK when REVERSED and sorted, then the
   #  original-first was lexically LT than the original-second.
  return  0;
}

sub xgt {
  carp "usage: xgt(\\&sorter,$a,$b)" unless @_ and ref($_[0]);
  #AKA: xcmp(@_) == -1;
  return  0 if $_[1] eq $_[2];  # We have to trap this early.
  return  1 if $_[1] ne ( $_[0]->($_[1], $_[2]) )[0];
   # If they were switched when sorted, then the original-first was
   #  lexically GT than the original-second.
  return  0;
}

# And then two easy ones:

sub xle {
  carp "usage: xle(\\&sorter,$a,$b)" unless @_ and ref($_[0]);
  !xgt(@_);    #AKA: xcmp(@_) <   1;
}

sub xge {
  carp "usage: xge(\\&sorter,$a,$b)" unless @_ and ref($_[0]);
  !xlt(@_);    #AKA: xcmp(@_) >  -1;
}

###########################################################################
1;

__END__