lib/locale.pm

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