1package locale; 2 3use strict; 4use warnings; 5 6our $VERSION = '1.12'; 7use Config; 8 9$Carp::Internal{ (__PACKAGE__) } = 1; 10 11=head1 NAME 12 13locale - Perl pragma to use or avoid POSIX locales for built-in operations 14 15=head1 SYNOPSIS 16 17 my @x1 = sort @y; # Native-platform/Unicode code point sort order 18 { 19 use locale; 20 my @x2 = sort @y; # Locale-defined sort order 21 } 22 my @x3 = sort @y; # Native-platform/Unicode code point sort order 23 # again 24 25 # Parameters to the pragma are to work around deficiencies in locale 26 # handling that have since been fixed, and hence these are likely no 27 # longer useful 28 use locale qw(:ctype :collate); # Only use the locale for character 29 # classification (\w, \d, etc.), and 30 # for string comparison operations 31 # like '$a le $b' and sorting. 32 use locale ':not_characters'; # Use the locale for everything but 33 # character classification and string 34 # comparison operations 35 36 use locale ':!numeric'; # Use the locale for everything but 37 # numeric-related operations 38 use locale ':not_numeric'; # Same 39 40 no locale; # Turn off locale handling for the remainder of 41 # the scope. 42 43=head1 DESCRIPTION 44 45This pragma tells the compiler to enable (or disable) the use of POSIX 46locales for built-in operations (for example, C<LC_CTYPE> for regular 47expressions, C<LC_COLLATE> for string comparison, and C<LC_NUMERIC> for number 48formatting). Each C<use locale> or C<no locale> 49affects statements to the end of the enclosing BLOCK. 50 51The pragma is documented as part of L<perllocale>. 52 53=cut 54 55# A separate bit is used for each of the two forms of the pragma, to save 56# having to look at %^H for the normal case of a plain 'use locale' without an 57# argument. 58 59$locale::hint_bits = 0x4; 60$locale::partial_hint_bits = 0x10; # If pragma has an argument 61 62# The pseudo-category :characters consists of 2 real ones; but it also is 63# given its own number, -1, because in the complement form it also has the 64# side effect of "use feature 'unicode_strings'" 65 66sub import { 67 shift; # should be 'locale'; not checked 68 69 $^H{locale} = 0 unless defined $^H{locale}; 70 if (! @_) { # If no parameter, use the plain form that changes all categories 71 $^H |= $locale::hint_bits; 72 73 } 74 else { 75 my @categories = ( qw(:ctype :collate :messages 76 :numeric :monetary :time) ); 77 for (my $i = 0; $i < @_; $i++) { 78 my $arg = $_[$i]; 79 my $complement = $arg =~ s/ : ( ! | not_ ) /:/x; 80 if (! grep { $arg eq $_ } @categories, ":characters") { 81 require Carp; 82 Carp::croak("Unknown parameter '$_[$i]' to 'use locale'"); 83 } 84 85 if ($complement) { 86 if ($i != 0 || $i < @_ - 1) { 87 require Carp; 88 Carp::croak("Only one argument to 'use locale' allowed" 89 . "if is $complement"); 90 } 91 92 if ($arg eq ':characters') { 93 push @_, grep { $_ ne ':ctype' && $_ ne ':collate' } 94 @categories; 95 # We add 1 to the category number; This category number 96 # is -1 97 $^H{locale} |= (1 << 0); 98 } 99 else { 100 push @_, grep { $_ ne $arg } @categories; 101 } 102 next; 103 } 104 elsif ($arg eq ':characters') { 105 push @_, ':ctype', ':collate'; 106 next; 107 } 108 109 $^H |= $locale::partial_hint_bits; 110 111 # This form of the pragma overrides the other 112 $^H &= ~$locale::hint_bits; 113 114 $arg =~ s/^://; 115 116 eval { require POSIX; POSIX->import('locale_h'); }; 117 118 # Map our names to the ones defined by POSIX 119 my $LC = "LC_" . uc($arg); 120 121 my $bit = eval "&POSIX::$LC"; 122 if (defined $bit) { # XXX Should we warn that this category isn't 123 # supported on this platform, or make it 124 # always be the C locale? 125 126 # Verify our assumption. 127 if (! ($bit >= 0 && $bit < 31)) { 128 require Carp; 129 Carp::croak("Cannot have ':$arg' parameter to 'use locale'" 130 . " on this platform. Use the 'perlbug' utility" 131 . " to report this problem, or send email to" 132 . " 'perlbug\@perl.org'. $LC=$bit"); 133 } 134 135 # 1 is added so that the pseudo-category :characters, which is 136 # -1, comes out 0. 137 $^H{locale} |= 1 << ($bit + 1); 138 } 139 } 140 } 141 142} 143 144sub unimport { 145 $^H &= ~($locale::hint_bits | $locale::partial_hint_bits); 146 $^H{locale} = 0; 147} 148 1491; 150