lib/locale.pm

   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;