"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/locale.pm" (18 Apr 2017, 4855 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 package locale;
    2 
    3 our $VERSION = '1.09';
    4 use Config;
    5 
    6 $Carp::Internal{ (__PACKAGE__) } = 1;
    7 
    8 =head1 NAME
    9 
   10 locale - Perl pragma to use or avoid POSIX locales for built-in operations
   11 
   12 =head1 WARNING
   13 
   14 DO NOT USE this pragma in scripts that have multiple
   15 L<threads|threads> active.  The locale is not local to a single thread.
   16 Another thread may change the locale at any time, which could cause at a
   17 minimum that a given thread is operating in a locale it isn't expecting
   18 to be in.  On some platforms, segfaults can also occur.  The locale
   19 change need not be explicit; some operations cause perl to change the
   20 locale itself.  You are vulnerable simply by having done a C<"use
   21 locale">.
   22 
   23 =head1 SYNOPSIS
   24 
   25     @x = sort @y;      # Native-platform/Unicode code point sort order
   26     {
   27         use locale;
   28         @x = sort @y;  # Locale-defined sort order
   29     }
   30     @x = sort @y;      # Native-platform/Unicode code point sort order
   31                        # again
   32 
   33 =head1 DESCRIPTION
   34 
   35 This pragma tells the compiler to enable (or disable) the use of POSIX
   36 locales for built-in operations (for example, LC_CTYPE for regular
   37 expressions, LC_COLLATE for string comparison, and LC_NUMERIC for number
   38 formatting).  Each "use locale" or "no locale"
   39 affects statements to the end of the enclosing BLOCK.
   40 
   41 See L<perllocale> for more detailed information on how Perl supports
   42 locales.
   43 
   44 On systems that don't have locales, this pragma will cause your operations
   45 to behave as if in the "C" locale; attempts to change the locale will fail.
   46 
   47 =cut
   48 
   49 # A separate bit is used for each of the two forms of the pragma, to save
   50 # having to look at %^H for the normal case of a plain 'use locale' without an
   51 # argument.
   52 
   53 $locale::hint_bits = 0x4;
   54 $locale::partial_hint_bits = 0x10;  # If pragma has an argument
   55 
   56 # The pseudo-category :characters consists of 2 real ones; but it also is
   57 # given its own number, -1, because in the complement form it also has the
   58 # side effect of "use feature 'unicode_strings'"
   59 
   60 sub import {
   61     shift;  # should be 'locale'; not checked
   62 
   63     $^H{locale} = 0 unless defined $^H{locale};
   64     if (! @_) { # If no parameter, use the plain form that changes all categories
   65         $^H |= $locale::hint_bits;
   66 
   67     }
   68     else {
   69         my @categories = ( qw(:ctype :collate :messages
   70                               :numeric :monetary :time) );
   71         for (my $i = 0; $i < @_; $i++) {
   72             my $arg = $_[$i];
   73             $complement = $arg =~ s/ : ( ! | not_ ) /:/x;
   74             if (! grep { $arg eq $_ } @categories, ":characters") {
   75                 require Carp;
   76                 Carp::croak("Unknown parameter '$_[$i]' to 'use locale'");
   77             }
   78 
   79             if ($complement) {
   80                 if ($i != 0 || $i < @_ - 1)  {
   81                     require Carp;
   82                     Carp::croak("Only one argument to 'use locale' allowed"
   83                                 . "if is $complement");
   84                 }
   85 
   86                 if ($arg eq ':characters') {
   87                     push @_, grep { $_ ne ':ctype' && $_ ne ':collate' }
   88                                   @categories;
   89                     # We add 1 to the category number;  This category number
   90                     # is -1
   91                     $^H{locale} |= (1 << 0);
   92                 }
   93                 else {
   94                     push @_, grep { $_ ne $arg } @categories;
   95                 }
   96                 next;
   97             }
   98             elsif ($arg eq ':characters') {
   99                 push @_, ':ctype', ':collate';
  100                 next;
  101             }
  102 
  103             $^H |= $locale::partial_hint_bits;
  104 
  105             # This form of the pragma overrides the other
  106             $^H &= ~$locale::hint_bits;
  107 
  108             $arg =~ s/^://;
  109 
  110             eval { require POSIX; import POSIX 'locale_h'; };
  111 
  112             # Map our names to the ones defined by POSIX
  113             my $LC = "LC_" . uc($arg);
  114 
  115             my $bit = eval "&POSIX::$LC";
  116             if (defined $bit) { # XXX Should we warn that this category isn't
  117                                 # supported on this platform, or make it
  118                                 # always be the C locale?
  119 
  120                 # Verify our assumption.
  121                 if (! ($bit >= 0 && $bit < 31)) {
  122                     require Carp;
  123                     Carp::croak("Cannot have ':$arg' parameter to 'use locale'"
  124                               . " on this platform.  Use the 'perlbug' utility"
  125                               . " to report this problem, or send email to"
  126                               . " 'perlbug\@perl.org'.  $LC=$bit");
  127                 }
  128 
  129                 # 1 is added so that the pseudo-category :characters, which is
  130                 # -1, comes out 0.
  131                 $^H{locale} |= 1 << ($bit + 1);
  132             }
  133         }
  134     }
  135 
  136 }
  137 
  138 sub unimport {
  139     $^H &= ~($locale::hint_bits|$locale::partial_hint_bits);
  140     $^H{locale} = 0;
  141 }
  142 
  143 1;