source: trunk/essentials/dev-lang/perl/lib/charnames.pm@ 3368

package charnames;
use strict;
use warnings;
use Carp;
use File::Spec;
our $VERSION = '1.05';

use bytes ();           # for $bytes::hint_bits
$charnames::hint_bits = 0x20000; # HINT_LOCALIZE_HH

my %alias1 = (
                # Icky 3.2 names with parentheses.
                'LINE FEED'             => 'LINE FEED (LF)',
                'FORM FEED'             => 'FORM FEED (FF)',
                'CARRIAGE RETURN'       => 'CARRIAGE RETURN (CR)',
                'NEXT LINE'             => 'NEXT LINE (NEL)',
                # Convenience.
                'LF'                    => 'LINE FEED (LF)',
                'FF'                    => 'FORM FEED (FF)',
                'CR'                    => 'CARRIAGE RETURN (CR)',
                'NEL'                   => 'NEXT LINE (NEL)',
                # More convenience.  For futher convencience,
                # it is suggested some way using using the NamesList
                # aliases is implemented.
                'ZWNJ'                  => 'ZERO WIDTH NON-JOINER',
                'ZWJ'                   => 'ZERO WIDTH JOINER',
                'BOM'                   => 'BYTE ORDER MARK',
            );

my %alias2 = (
                # Pre-3.2 compatibility (only for the first 256 characters).
                'HORIZONTAL TABULATION' => 'CHARACTER TABULATION',
                'VERTICAL TABULATION'   => 'LINE TABULATION',
                'FILE SEPARATOR'        => 'INFORMATION SEPARATOR FOUR',
                'GROUP SEPARATOR'       => 'INFORMATION SEPARATOR THREE',
                'RECORD SEPARATOR'      => 'INFORMATION SEPARATOR TWO',
                'UNIT SEPARATOR'        => 'INFORMATION SEPARATOR ONE',
                'PARTIAL LINE DOWN'     => 'PARTIAL LINE FORWARD',
                'PARTIAL LINE UP'       => 'PARTIAL LINE BACKWARD',
            );

my %alias3 = (
                # User defined aliasses. Even more convenient :)
            );
my $txt;

sub alias (@)
{
  @_ or return %alias3;
  my $alias = ref $_[0] ? $_[0] : { @_ };
  @alias3{keys %$alias} = values %$alias;
} # alias

sub alias_file ($)
{
  my ($arg, $file) = @_;
  if (-f $arg && File::Spec->file_name_is_absolute ($arg)) {
    $file = $arg;
  }
  elsif ($arg =~ m/^\w+$/) {
    $file = "unicore/${arg}_alias.pl";
  }
  else {
    croak "Charnames alias files can only have identifier characters";
  }
  if (my @alias = do $file) {
    @alias == 1 && !defined $alias[0] and
      croak "$file cannot be used as alias file for charnames";
    @alias % 2 and
      croak "$file did not return a (valid) list of alias pairs";
    alias (@alias);
    return (1);
  }
  0;
} # alias_file

# This is not optimized in any way yet
sub charnames
{
  my $name = shift;

  if (exists $alias1{$name}) {
    $name = $alias1{$name};
  }
  elsif (exists $alias2{$name}) {
    require warnings;
    warnings::warnif('deprecated', qq{Unicode character name "$name" is deprecated, use "$alias2{$name}" instead});
    $name = $alias2{$name};
  }
  elsif (exists $alias3{$name}) {
    $name = $alias3{$name};
  }

  my $ord;
  my @off;
  my $fname;

  if ($name eq "BYTE ORDER MARK") {
    $fname = $name;
    $ord = 0xFEFF;
  } else {
    ## Suck in the code/name list as a big string.
    ## Lines look like:
    ##     "0052\t\tLATIN CAPITAL LETTER R\n"
    $txt = do "unicore/Name.pl" unless $txt;

    ## @off will hold the index into the code/name string of the start and
    ## end of the name as we find it.

    ## If :full, look for the name exactly
    if ($^H{charnames_full} and $txt =~ /\t\t\Q$name\E$/m) {
      @off = ($-[0], $+[0]);
    }

    ## If we didn't get above, and :short allowed, look for the short name.
    ## The short name is like "greek:Sigma"
    unless (@off) {
      if ($^H{charnames_short} and $name =~ /^(.+?):(.+)/s) {
        my ($script, $cname) = ($1, $2);
        my $case = $cname =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL";
        if ($txt =~ m/\t\t\U$script\E (?:$case )?LETTER \U\Q$cname\E$/m) {
          @off = ($-[0], $+[0]);
        }
      }
    }

    ## If we still don't have it, check for the name among the loaded
    ## scripts.
    if (not @off) {
      my $case = $name =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL";
      for my $script (@{$^H{charnames_scripts}}) {
        if ($txt =~ m/\t\t$script (?:$case )?LETTER \U\Q$name\E$/m) {
          @off = ($-[0], $+[0]);
          last;
        }
      }
    }

    ## If we don't have it by now, give up.
    unless (@off) {
      carp "Unknown charname '$name'";
      return "\x{FFFD}";
    }

    ##
    ## Now know where in the string the name starts.
    ## The code, in hex, is before that.
    ##
    ## The code can be 4-6 characters long, so we've got to sort of
    ## go look for it, just after the newline that comes before $off[0].
    ##
    ## This would be much easier if unicore/Name.pl had info in
    ## a name/code order, instead of code/name order.
    ##
    ## The +1 after the rindex() is to skip past the newline we're finding,
    ## or, if the rindex() fails, to put us to an offset of zero.
    ##
    my $hexstart = rindex($txt, "\n", $off[0]) + 1;

    ## we know where it starts, so turn into number -
    ## the ordinal for the char.
    $ord = hex substr($txt, $hexstart, $off[0] - $hexstart);
  }

  if ($^H & $bytes::hint_bits) {        # "use bytes" in effect?
    use bytes;
    return chr $ord if $ord <= 255;
    my $hex = sprintf "%04x", $ord;
    if (not defined $fname) {
      $fname = substr $txt, $off[0] + 2, $off[1] - $off[0] - 2;
    }
    croak "Character 0x$hex with name '$fname' is above 0xFF";
  }

  no warnings 'utf8'; # allow even illegal characters
  return pack "U", $ord;
} # charnames

sub import
{
  shift; ## ignore class name

  if (not @_) {
    carp("`use charnames' needs explicit imports list");
  }
  $^H |= $charnames::hint_bits;
  $^H{charnames} = \&charnames ;

  ##