lib/charnames.pm

   1 package charnames;
   2
   3 our $VERSION = '1.00';
   4
   5 use bytes ();           # for $bytes::hint_bits
   6 use warnings();
   7 $charnames::hint_bits = 0x20000;
   8
   9 my $txt;
  10
  11 # This is not optimized in any way yet
  12 sub charnames {
  13   $name = shift;
  14   $txt = do "unicode/Name.pl" unless $txt;
  15   my @off;
  16   if ($^H{charnames_full} and $txt =~ /\t\t$name$/m) {
  17     @off = ($-[0], $+[0]);
  18   }
  19   unless (@off) {
  20     if ($^H{charnames_short} and $name =~ /^(.*?):(.*)/s) {
  21       my ($script, $cname) = ($1,$2);
  22       my $case = ( $cname =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL");
  23       if ($txt =~ m/\t\t\U$script\E (?:$case )?LETTER \U$cname$/m) {
  24         @off = ($-[0], $+[0]);
  25       }
  26     }
  27   }
  28   unless (@off) {
  29     my $case = ( $name =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL");
  30     for ( @{$^H{charnames_scripts}} ) {
  31       (@off = ($-[0], $+[0])), last
  32         if $txt =~ m/\t\t$_ (?:$case )?LETTER \U$name$/m;
  33     }
  34   }
  35   die "Unknown charname '$name'" unless @off;
  36
  37   my $hexlen = 4; # Unicode guarantees 4-, 5-, or 6-digit format
  38   $hexlen++ while
  39       $hexlen < 6 && substr($txt, $off[0] - $hexlen - 1, 1) =~ /[0-9a-f]/;
  40   my $ord = hex substr $txt, $off[0] - $hexlen, $hexlen;
  41   if ($^H & $bytes::hint_bits) {        # "use bytes" in effect?
  42     use bytes;
  43     return chr $ord if $ord <= 255;
  44     my $hex = sprintf '%X=0%o', $ord, $ord;
  45     my $fname = substr $txt, $off[0] + 2, $off[1] - $off[0] - 2;
  46     die "Character 0x$hex with name '$fname' is above 0xFF";
  47   }
  48   return chr $ord;
  49 }
  50
  51 sub import {
  52   shift;
  53   die "`use charnames' needs explicit imports list" unless @_;
  54   $^H |= $charnames::hint_bits;
  55   $^H{charnames} = \&charnames ;
  56   my %h;
  57   @h{@_} = (1) x @_;
  58   $^H{charnames_full} = delete $h{':full'};
  59   $^H{charnames_short} = delete $h{':short'};
  60   $^H{charnames_scripts} = [map uc, keys %h];
  61   if (warnings::enabled('utf8') && @{$^H{charnames_scripts}}) {
  62         $txt = do "unicode/Name.pl" unless $txt;
  63     for (@{$^H{charnames_scripts}}) {
  64         warnings::warn('utf8',  "No such script: '$_'") unless
  65             $txt =~ m/\t\t$_ (?:CAPITAL |SMALL )?LETTER /;
  66         }
  67   }
  68 }
  69
  70
  71 1;
  72 __END__
  73
  74 =head1 NAME
  75
  76 charnames - define character names for C<\N{named}> string literal escape.
  77
  78 =head1 SYNOPSIS
  79
  80   use charnames ':full';
  81   print "\N{GREEK SMALL LETTER SIGMA} is called sigma.\n";
  82
  83   use charnames ':short';
  84   print "\N{greek:Sigma} is an upper-case sigma.\n";
  85
  86   use charnames qw(cyrillic greek);
  87   print "\N{sigma} is Greek sigma, and \N{be} is Cyrillic b.\n";
  88
  89   use charnames ...; # either :full or :short will do
  90   print "This is Unicode code point \N{U+263A}\n"; # explicit code point
  91
  92 =head1 DESCRIPTION
  93
  94 Pragma C<use charnames> supports arguments C<:full>, C<:short> and
  95 script names.  If C<:full> is present, for expansion of
  96 C<\N{CHARNAME}}> string C<CHARNAME> is first looked in the list of
  97 standard Unicode names of chars.  If C<:short> is present, and
  98 C<CHARNAME> has the form C<SCRIPT:CNAME>, then C<CNAME> is looked up
  99 as a letter in script C<SCRIPT>.  If pragma C<use charnames> is used
 100 with script name arguments, then for C<\N{CHARNAME}}> the name
 101 C<CHARNAME> is looked up as a letter in the given scripts (in the
 102 specified order).
 103
 104 For lookup of C<CHARNAME> inside a given script C<SCRIPTNAME>
 105 this pragma looks for the names
 106
 107   SCRIPTNAME CAPITAL LETTER CHARNAME
 108   SCRIPTNAME SMALL LETTER CHARNAME
 109   SCRIPTNAME LETTER CHARNAME
 110
 111 in the table of standard Unicode names.  If C<CHARNAME> is lowercase,
 112 then the C<CAPITAL> variant is ignored, otherwise the C<SMALL> variant is
 113 ignored.
 114
 115 =head1 CUSTOM TRANSLATORS
 116
 117 The mechanism of translation of C<\N{...}> escapes is general and not
 118 hardwired into F<charnames.pm>.  A module can install custom
 119 translations (inside the scope which C<use>s the module) with the
 120 following magic incantation:
 121
 122     use charnames ();           # for $charnames::hint_bits
 123     sub import {
 124         shift;
 125         $^H |= $charnames::hint_bits;
 126         $^H{charnames} = \&translator;
 127     }
 128
 129 Here translator() is a subroutine which takes C<CHARNAME> as an
 130 argument, and returns text to insert into the string instead of the
 131 C<\N{CHARNAME}> escape.  Since the text to insert should be different
 132 in C<bytes> mode and out of it, the function should check the current
 133 state of C<bytes>-flag as in:
 134
 135     use bytes ();                       # for $bytes::hint_bits
 136     sub translator {
 137         if ($^H & $bytes::hint_bits) {
 138             return bytes_translator(@_);
 139         }
 140         else {
 141             return utf8_translator(@_);
 142         }
 143     }
 144
 145 =head1 BUGS
 146
 147 Since evaluation of the translation function happens in a middle of
 148 compilation (of a string literal), the translation function should not
 149 do any C<eval>s or C<require>s.  This restriction should be lifted in
 150 a future version of Perl.
 151
 152 =cut