home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / lib / utf8_heavy.pl < prev    next >
Perl Script  |  2000-03-12  |  5KB  |  222 lines
  1. package utf8;
  2.  
  3. my $DEBUG = 0;
  4. my $seq = "AAA0000";
  5.  
  6. sub DESTROY {}
  7.  
  8. sub croak { require Carp; Carp::croak(@_) }
  9.  
  10. sub SWASHNEW {
  11.     my ($class, $type, $list, $minbits, $none) = @_;
  12.     local $^D = 0 if $^D;
  13.     print STDERR "SWASHNEW @_\n" if $DEBUG;
  14.     my $extras;
  15.     my $bits;
  16.  
  17.     if ($type and ref ${"${class}::{$type}"} eq $class) {
  18.     warn qq/Found \${"${class}::{$type}"}\n/ if $DEBUG;
  19.     return ${"${class}::{$type}"};    # Already there...
  20.     }
  21.  
  22.     $type ||= $seq++;
  23.  
  24.     my $caller;
  25.     my $i = 0;
  26.     while (($caller = caller($i)) eq __PACKAGE__) { $i++ }
  27.     my $encoding = $enc{$caller} || "unicode";
  28.     (my $file = $type) =~ s!::!/!g;
  29.     $file =~ s#^(I[sn]|To)([A-Z].*)#$1/$2#;
  30.     $list ||= eval { $caller->$type(); }
  31.     || do "$file.pl"
  32.     || do "$encoding/$file.pl"
  33.     || do "$encoding/Is/${type}.pl"
  34.     || croak("Can't find $encoding character property definition via $caller->$type or $file.pl");
  35.  
  36.     $| = 1;
  37.  
  38.     if ($list) {
  39.     my @tmp = split(/^/m, $list);
  40.     my %seen;
  41.     no warnings;
  42.     $extras = join '', grep /^[^0-9a-fA-F]/, @tmp;
  43.     $list = join '',
  44.         sort { hex $a <=> hex $b }
  45.         grep {/^([0-9a-fA-F]+)/ and not $seen{$1}++} @tmp; # XXX doesn't do ranges right
  46.     }
  47.  
  48.     if ($none) {
  49.     my $hextra = sprintf "%04x", $none + 1;
  50.     $list =~ s/\tXXXX$/\t$hextra/mg;
  51.     }
  52.  
  53.     if ($minbits < 32) {
  54.     my $top = 0;
  55.     while ($list =~ /^([0-9a-fA-F]+)(?:\t([0-9a-fA-F]+)?)(?:\t([0-9a-fA-F]+))?/mg) {
  56.         my $min = hex $1;
  57.         my $max = hex(defined $2 ? $2 : $1);
  58.         my $val = hex(defined $3 ? $3 : "");
  59.         $val += $max - $min if defined $3;
  60.         $top = $val if $val > $top;
  61.     }
  62.     $bits =
  63.         $top > 0xffff ? 32 :
  64.         $top > 0xff ? 16 :
  65.         $top > 1 ? 8 : 1
  66.     }
  67.     $bits = $minbits if $bits < $minbits;
  68.  
  69.     my @extras;
  70.     for my $x ($extras) {
  71.     pos $x = 0;
  72.     while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) {
  73.         my $char = $1;
  74.         my $name = $2;
  75.         # print STDERR "$1 => $2\n" if $DEBUG;
  76.         if ($char =~ /[-+!]/) {
  77.         my ($c,$t) = split(/::/, $name, 2);    # bogus use of ::, really
  78.         my $subobj = $c->SWASHNEW($t, "", 0, 0, 0);
  79.         push @extras, $name => $subobj;
  80.         $bits = $subobj->{BITS} if $bits < $subobj->{BITS};
  81.         }
  82.     }
  83.     }
  84.  
  85.     print STDERR "CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none\nEXTRAS =>\n$extras\nLIST =>\n$list\n" if $DEBUG;
  86.  
  87.     ${"${class}::{$type}"} = bless {
  88.     TYPE => $type,
  89.     BITS => $bits,
  90.     EXTRAS => $extras,
  91.     LIST => $list,
  92.     NONE => $none,
  93.     @extras,
  94.     } => $class;
  95. }
  96.  
  97. # NOTE: utf8.c:swash_init() assumes entries are never modified once generated.
  98.  
  99. sub SWASHGET {
  100.     my ($self, $start, $len) = @_;
  101.     local $^D = 0 if $^D;
  102.     my $type = $self->{TYPE};
  103.     my $bits = $self->{BITS};
  104.     my $none = $self->{NONE};
  105.     print STDERR "SWASHGET @_ [$type/$bits/$none]\n" if $DEBUG;
  106.     my $end = $start + $len;
  107.     my $swatch = "";
  108.     my $key;
  109.     vec($swatch, $len - 1, $bits) = 0;    # Extend to correct length.
  110.     if ($none) {
  111.     for $key (0 .. $len - 1) { vec($swatch, $key, $bits) = $none }
  112.     }
  113.  
  114.     for ($self->{LIST}) {
  115.     pos $_ = 0;
  116.     if ($bits > 1) {
  117.       LINE:
  118.         while (/^([0-9a-fA-F]+)(?:\t([0-9a-fA-F]+)?)(?:\t([0-9a-fA-F]+))?/mg) {
  119.         my $min = hex $1;
  120.         my $max = (defined $2 ? hex $2 : $min);
  121.         my $val = hex $3;
  122.         next if $max < $start;
  123. #        print "$min $max $val\n";
  124.         if ($none) {
  125.             if ($min < $start) {
  126.             $val += $start - $min if $val < $none;
  127.             $min = $start;
  128.             }
  129.             for ($key = $min; $key <= $max; $key++) {
  130.             last LINE if $key >= $end;
  131. #            print STDERR "$key => $val\n" if $DEBUG;
  132.             vec($swatch, $key - $start, $bits) = $val;
  133.             ++$val if $val < $none;
  134.             }
  135.         }
  136.         else {
  137.             if ($min < $start) {
  138.             $val += $start - $min;
  139.             $min = $start;
  140.             }
  141.             for ($key = $min; $key <= $max; $key++, $val++) {
  142.             last LINE if $key >= $end;
  143. #            print STDERR "$key => $val\n" if $DEBUG;
  144.             vec($swatch, $key - $start, $bits) = $val;
  145.             }
  146.         }
  147.         }
  148.     }
  149.     else {
  150.       LINE:
  151.         while (/^([0-9a-fA-F]+)(?:\t([0-9a-fA-F]+))?/mg) {
  152.         my $min = hex $1;
  153.         my $max = (defined $2 ? hex $2 : $min);
  154.         next if $max < $start;
  155.         if ($min < $start) {
  156.             $min = $start;
  157.         }
  158.         for ($key = $min; $key <= $max; $key++) {
  159.             last LINE if $key >= $end;
  160. #            print STDERR "$key => 1\n" if $DEBUG;
  161.             vec($swatch, $key - $start, 1) = 1;
  162.         }
  163.         }
  164.     }
  165.     }
  166.     for my $x ($self->{EXTRAS}) {
  167.     pos $x = 0;
  168.     while ($x =~ /^([-+!])(.*)/mg) {
  169.         my $char = $1;
  170.         my $name = $2;
  171.         print STDERR "INDIRECT $1 $2\n" if $DEBUG;
  172.         my $otherbits = $self->{$name}->{BITS};
  173.         croak("SWASHGET size mismatch") if $bits < $otherbits;
  174.         my $other = $self->{$name}->SWASHGET($start, $len);
  175.         if ($char eq '+') {
  176.         if ($bits == 1 and $otherbits == 1) {
  177.             $swatch |= $other;
  178.         }
  179.         else {
  180.             for ($key = 0; $key < $len; $key++) {
  181.             vec($swatch, $key, $bits) = vec($other, $key, $otherbits);
  182.             }
  183.         }
  184.         }
  185.         elsif ($char eq '!') {
  186.         if ($bits == 1 and $otherbits == 1) {
  187.             $swatch |= ~$other;
  188.         }
  189.         else {
  190.             for ($key = 0; $key < $len; $key++) {
  191.             if (!vec($other, $key, $otherbits)) {
  192.                 vec($swatch, $key, $bits) = 1;
  193.             }
  194.             }
  195.         }
  196.         }
  197.         elsif ($char eq '-') {
  198.         if ($bits == 1 and $otherbits == 1) {
  199.             $swatch &= ~$other;
  200.         }
  201.         else {
  202.             for ($key = 0; $key < $len; $key++) {
  203.             if (vec($other, $key, $otherbits)) {
  204.                 vec($swatch, $key, $bits) = 0;
  205.             }
  206.             }
  207.         }
  208.         }
  209.     }
  210.     }
  211.     if ($DEBUG) {
  212.     print STDERR "CELLS ";
  213.     for ($key = 0; $key < $len; $key++) {
  214.         print STDERR vec($swatch, $key, $bits), " ";
  215.     }
  216.     print STDERR "\n";
  217.     }
  218.     $swatch;
  219. }
  220.  
  221. 1;
  222.