/
locale.c
5520 lines (4534 loc) · 207 KB
/
locale.c
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
/* locale.c
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
* 2002, 2003, 2005, 2006, 2007, 2008 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
*/
/*
* A Elbereth Gilthoniel,
* silivren penna míriel
* o menel aglar elenath!
* Na-chaered palan-díriel
* o galadhremmin ennorath,
* Fanuilos, le linnathon
* nef aear, si nef aearon!
*
* [p.238 of _The Lord of the Rings_, II/i: "Many Meetings"]
*/
/* utility functions for handling locale-specific stuff like what
* character represents the decimal point.
*
* All C programs have an underlying locale. Perl code generally doesn't pay
* any attention to it except within the scope of a 'use locale'. For most
* categories, it accomplishes this by just using different operations if it is
* in such scope than if not. However, various libc functions called by Perl
* are affected by the LC_NUMERIC category, so there are macros in perl.h that
* are used to toggle between the current locale and the C locale depending on
* the desired behavior of those functions at the moment. And, LC_MESSAGES is
* switched to the C locale for outputting the message unless within the scope
* of 'use locale'.
*
* This code now has multi-thread-safe locale handling on systems that support
* that. This is completely transparent to most XS code. On earlier systems,
* it would be possible to emulate thread-safe locales, but this likely would
* involve a lot of locale switching, and would require XS code changes.
* Macros could be written so that the code wouldn't have to know which type of
* system is being used.
*
* Table-driven code is used for simplicity and clarity, as many operations
* differ only in which category is being worked on. However the system
* categories need not be small contiguous integers, so do not lend themselves
* to table lookup. Instead we have created our own equivalent values which
* are all small contiguous non-negative integers, and translation functions
* between the two sets. For category 'LC_foo', the name of our index is
* LC_foo_INDEX_. Various parallel tables, indexed by these, are used.
*
* Many of the macros and functions in this file have one of the suffixes '_c',
* '_r', or '_i'. khw found these useful in remembering what type of locale
* category to use as their parameter. '_r' takes an int category number as
* passed to setlocale(), like LC_ALL, LC_CTYPE, etc. The 'r' indicates that
* the value isn't known until runtime. '_c' also indicates such a category
* number, but its value is known at compile time. These are both converted
* into unsigned indexes into various tables of category information, where the
* real work is generally done. The tables are generated at compile-time based
* on platform characteristics and Configure options. They hide from the code
* many of the vagaries of the different locale implementations out there. You
* may have already guessed that '_i' indicates the parameter is such an
* unsigned index. Converting from '_r' to '_i' requires run-time lookup.
* '_c' is used to get cpp to do this at compile time. To avoid the runtime
* expense, the code is structured to use '_r' at the API level, and once
* converted, everything possible is done using the table indexes.
*
* On unthreaded perls, most operations expand out to just the basic
* setlocale() calls. The same is true on threaded perls on modern Windows
* systems where the same API, after set up, is used for thread-safe locale
* handling. On other systems, there is a completely different API, specified
* in POSIX 2008, to do thread-safe locales. On these systems, our
* emulate_setlocale_i() function is used to hide the different API from the
* outside. This makes it completely transparent to most XS code.
*
* A huge complicating factor is that the LC_NUMERIC category is normally held
* in the C locale, except during those relatively rare times when it needs to
* be in the underlying locale. There is a bunch of code to accomplish this,
* and to allow easy switches from one state to the other.
*
* z/OS (os390) is an outlier. Locales really don't work under threads when
* either the radix character isn't a dot, or attempts are made to change
* locales after the first thread is created. The reason is that IBM has made
* it thread-safe by refusing to change locales (returning failure if
* attempted) any time after an application has called pthread_create() to
* create another thread. The expectation is that an application will set up
* its locale information before the first fork, and be stable thereafter. But
* perl toggles LC_NUMERIC if the locale's radix character isn't a dot, as do
* the other toggles, which are less common.
*/
/* If the environment says to, we can output debugging information during
* initialization. This is done before option parsing, and before any thread
* creation, so can be a file-level static. (Must come before #including
* perl.h) */
#ifdef DEBUGGING
static int debug_initialization = 0;
# define DEBUG_INITIALIZATION_set(v) (debug_initialization = v)
# define DEBUG_LOCALE_INITIALIZATION_ debug_initialization
#else
# define debug_initialization 0
# define DEBUG_INITIALIZATION_set(v)
#endif
#include "EXTERN.h"
#define PERL_IN_LOCALE_C
#include "perl_langinfo.h"
#include "perl.h"
#include "reentr.h"
#ifdef I_WCHAR
# include <wchar.h>
#endif
#ifdef I_WCTYPE
# include <wctype.h>
#endif
/* Returns the Unix errno portion; ignoring any others. This is a macro here
* instead of putting it into perl.h, because unclear to khw what should be
* done generally. */
#define GET_ERRNO saved_errno
/* strlen() of a literal string constant. We might want this more general,
* but using it in just this file for now. A problem with more generality is
* the compiler warnings about comparing unlike signs */
#define STRLENs(s) (sizeof("" s "") - 1)
/* Is the C string input 'name' "C" or "POSIX"? If so, and 'name' is the
* return of setlocale(), then this is extremely likely to be the C or POSIX
* locale. However, the output of setlocale() is documented to be opaque, but
* the odds are extremely small that it would return these two strings for some
* other locale. Note that VMS in these two locales includes many non-ASCII
* characters as controls and punctuation (below are hex bytes):
* cntrl: 84-97 9B-9F
* punct: A1-A3 A5 A7-AB B0-B3 B5-B7 B9-BD BF-CF D1-DD DF-EF F1-FD
* Oddly, none there are listed as alphas, though some represent alphabetics
* http://www.nntp.perl.org/group/perl.perl5.porters/2013/02/msg198753.html */
#define isNAME_C_OR_POSIX(name) \
( (name) != NULL \
&& (( *(name) == 'C' && (*(name + 1)) == '\0') \
|| strEQ((name), "POSIX")))
#ifdef USE_LOCALE
/* This code keeps a LRU cache of the UTF-8ness of the locales it has so-far
* looked up. This is in the form of a C string: */
# define UTF8NESS_SEP "\v"
# define UTF8NESS_PREFIX "\f"
/* So, the string looks like:
*
* \vC\a0\vPOSIX\a0\vam_ET\a0\vaf_ZA.utf8\a1\ven_US.UTF-8\a1\0
*
* where the digit 0 after the \a indicates that the locale starting just
* after the preceding \v is not UTF-8, and the digit 1 mean it is. */
STATIC_ASSERT_DECL(STRLENs(UTF8NESS_SEP) == 1);
STATIC_ASSERT_DECL(STRLENs(UTF8NESS_PREFIX) == 1);
# define C_and_POSIX_utf8ness UTF8NESS_SEP "C" UTF8NESS_PREFIX "0" \
UTF8NESS_SEP "POSIX" UTF8NESS_PREFIX "0"
/* The cache is initialized to C_and_POSIX_utf8ness at start up. These are
* kept there always. The remining portion of the cache is LRU, with the
* oldest looked-up locale at the tail end */
# ifdef DEBUGGING
# define setlocale_debug_string_c(category, locale, result) \
setlocale_debug_string_i(category##_INDEX_, locale, result)
# define setlocale_debug_string_r(category, locale, result) \
setlocale_debug_string_i(get_category_index(category, locale), \
locale, result)
# endif
/* Two parallel arrays indexed by our mapping of category numbers into small
* non-negative indexes; first the locale categories Perl uses on this system,
* used to do the inverse mapping. The second array is their names. These
* arrays are in mostly arbitrary order. */
STATIC const int categories[] = {
# ifdef USE_LOCALE_NUMERIC
LC_NUMERIC,
# endif
# ifdef USE_LOCALE_CTYPE
LC_CTYPE,
# endif
# ifdef USE_LOCALE_COLLATE
LC_COLLATE,
# endif
# ifdef USE_LOCALE_TIME
LC_TIME,
# endif
# ifdef USE_LOCALE_MESSAGES
LC_MESSAGES,
# endif
# ifdef USE_LOCALE_MONETARY
LC_MONETARY,
# endif
# ifdef USE_LOCALE_ADDRESS
LC_ADDRESS,
# endif
# ifdef USE_LOCALE_IDENTIFICATION
LC_IDENTIFICATION,
# endif
# ifdef USE_LOCALE_MEASUREMENT
LC_MEASUREMENT,
# endif
# ifdef USE_LOCALE_PAPER
LC_PAPER,
# endif
# ifdef USE_LOCALE_TELEPHONE
LC_TELEPHONE,
# endif
# ifdef USE_LOCALE_SYNTAX
LC_SYNTAX,
# endif
# ifdef USE_LOCALE_TOD
LC_TOD,
# endif
# ifdef LC_ALL
LC_ALL,
# endif
/* Placeholder as a precaution if code fails to check the return of
* get_category_index(), which returns this element to indicate an error */
-1
};
/* The top-most real element is LC_ALL */
STATIC const char * const category_names[] = {
# ifdef USE_LOCALE_NUMERIC
"LC_NUMERIC",
# endif
# ifdef USE_LOCALE_CTYPE
"LC_CTYPE",
# endif
# ifdef USE_LOCALE_COLLATE
"LC_COLLATE",
# endif
# ifdef USE_LOCALE_TIME
"LC_TIME",
# endif
# ifdef USE_LOCALE_MESSAGES
"LC_MESSAGES",
# endif
# ifdef USE_LOCALE_MONETARY
"LC_MONETARY",
# endif
# ifdef USE_LOCALE_ADDRESS
"LC_ADDRESS",
# endif
# ifdef USE_LOCALE_IDENTIFICATION
"LC_IDENTIFICATION",
# endif
# ifdef USE_LOCALE_MEASUREMENT
"LC_MEASUREMENT",
# endif
# ifdef USE_LOCALE_PAPER
"LC_PAPER",
# endif
# ifdef USE_LOCALE_TELEPHONE
"LC_TELEPHONE",
# endif
# ifdef USE_LOCALE_SYNTAX
"LC_SYNTAX",
# endif
# ifdef USE_LOCALE_TOD
"LC_TOD",
# endif
# ifdef LC_ALL
"LC_ALL",
# endif
/* Placeholder as a precaution if code fails to check the return of
* get_category_index(), which returns this element to indicate an error */
NULL
};
# ifdef LC_ALL
/* On systems with LC_ALL, it is kept in the highest index position. (-2
* to account for the final unused placeholder element.) */
# define NOMINAL_LC_ALL_INDEX (C_ARRAY_LENGTH(categories) - 2)
# else
/* On systems without LC_ALL, we pretend it is there, one beyond the real
* top element, hence in the unused placeholder element. */
# define NOMINAL_LC_ALL_INDEX (C_ARRAY_LENGTH(categories) - 1)
# endif
/* Pretending there is an LC_ALL element just above allows us to avoid most
* special cases. Most loops through these arrays in the code below are
* written like 'for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++)'. They will work
* on either type of system. But the code must be written to not access the
* element at 'LC_ALL_INDEX_' except on platforms that have it. This can be
* checked for at compile time by using the #define LC_ALL_INDEX_ which is only
* defined if we do have LC_ALL. */
STATIC unsigned int
S_get_category_index(const int category, const char * locale)
{
/* Given a category, return the equivalent internal index we generally use
* instead.
*
* 'locale' is for use in any generated diagnostics, and may be NULL
*
* Some sort of hash could be used instead of this loop, but the number of
* elements is so far at most 12 */
unsigned int i;
const char * conditional_warn_text = "; can't set it to ";
PERL_ARGS_ASSERT_GET_CATEGORY_INDEX;
# ifdef LC_ALL
for (i = 0; i <= LC_ALL_INDEX_; i++)
# else
for (i = 0; i < NOMINAL_LC_ALL_INDEX; i++)
# endif
{
if (category == categories[i]) {
dTHX_DEBUGGING;
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"%s:%d: index of category %d (%s) is %d\n",
__FILE__, __LINE__, category, category_names[i], i));
return i;
}
}
/* Here, we don't know about this category, so can't handle it. */
if (! locale) {
locale = "";
conditional_warn_text = "";
}
/* diag_listed_as: Unknown locale category %d; can't set it to %s */
Perl_warner_nocontext(packWARN(WARN_LOCALE),
"Unknown locale category %d%s%s",
category, conditional_warn_text, locale);
# ifdef EINVAL
SETERRNO(EINVAL, LIB_INVARG);
# endif
/* Return an out-of-bounds value */
return NOMINAL_LC_ALL_INDEX + 1;
}
STATIC const char *
S_category_name(const int category)
{
unsigned int index;
index = get_category_index(category, NULL);
if (index <= NOMINAL_LC_ALL_INDEX) {
return category_names[index];
}
return Perl_form_nocontext("%d (unknown)", category);
}
#endif /* ifdef USE_LOCALE */
/* porcelain_setlocale() presents a consistent POSIX-compliant interface to
* setlocale(). Windows requres a customized base-level setlocale() */
#ifdef WIN32
# define porcelain_setlocale(cat, locale) win32_setlocale(cat, locale)
#else
# define porcelain_setlocale(cat, locale) \
((const char *) setlocale(cat, locale))
#endif
/* In contrast, the do_setlocale() macros are our added layers upon the base
* setlocale. These are used to present a uniform API to the rest of the code
* in this file in spite of the disparate underlying implementations. */
#ifndef USE_POSIX_2008_LOCALE
/* For non-threaded perls (which we are not to use the POSIX 2008 API on), or a
* thread-safe Windows one in which threading is invisible to us, the added
* layer just calls the base-level functions. See the introductory comments in
* this file for the meaning of the suffixes '_c', '_r', '_i'. */
# define do_setlocale_c(cat, locale) porcelain_setlocale(cat, locale)
# define do_setlocale_i(i, locale) do_setlocale_c(categories[i], locale)
# define do_setlocale_r(cat, locale) do_setlocale_c(cat, locale)
# define querylocale_c(cat) porcelain_setlocale(cat, NULL)
# define querylocale_r(cat) querylocale_c(cat)
# define querylocale_i(i) querylocale_c(categories[i])
# define FIX_GLIBC_LC_MESSAGES_BUG(i)
#else /* Below uses POSIX 2008 */
/* Here, there is a completely different API to get thread-safe locales. We
* emulate the setlocale() API with our own function(s). setlocale categories,
* like LC_NUMERIC, are not valid here for the POSIX 2008 API. Instead, there
* are equivalents, like LC_NUMERIC_MASK, which we use instead, converting to
* by using get_category_index() followed by table lookup. */
# define do_setlocale_i(i, locale) emulate_setlocale_i(i, locale)
# define do_setlocale_c(cat, locale) \
do_setlocale_i(cat##_INDEX_, locale)
# define do_setlocale_r(cat, locale) \
do_setlocale_i(get_category_index(cat, locale), locale)
# define querylocale_i(i) my_querylocale_i(i)
# define querylocale_c(cat) querylocale_i(cat##_INDEX_)
# define querylocale_r(cat) querylocale_i(get_category_index(cat,NULL))
# ifndef HAS_QUERYLOCALE
# define USE_PL_CURLOCALES
# endif
# if ! defined(__GLIBC__) || ! defined(USE_LOCALE_MESSAGES)
# define FIX_GLIBC_LC_MESSAGES_BUG(i)
# else /* Invalidate glibc cache of loaded translations, see [perl #134264] */
# include <libintl.h>
# define FIX_GLIBC_LC_MESSAGES_BUG(i) \
STMT_START { \
if ((i) == LC_MESSAGES_INDEX_) { \
textdomain(textdomain(NULL)); \
} \
} STMT_END
# endif
/* A third array, parallel to the ones above to map from category to its
* equivalent mask */
STATIC const int category_masks[] = {
# ifdef USE_LOCALE_NUMERIC
LC_NUMERIC_MASK,
# endif
# ifdef USE_LOCALE_CTYPE
LC_CTYPE_MASK,
# endif
# ifdef USE_LOCALE_COLLATE
LC_COLLATE_MASK,
# endif
# ifdef USE_LOCALE_TIME
LC_TIME_MASK,
# endif
# ifdef USE_LOCALE_MESSAGES
LC_MESSAGES_MASK,
# endif
# ifdef USE_LOCALE_MONETARY
LC_MONETARY_MASK,
# endif
# ifdef USE_LOCALE_ADDRESS
LC_ADDRESS_MASK,
# endif
# ifdef USE_LOCALE_IDENTIFICATION
LC_IDENTIFICATION_MASK,
# endif
# ifdef USE_LOCALE_MEASUREMENT
LC_MEASUREMENT_MASK,
# endif
# ifdef USE_LOCALE_PAPER
LC_PAPER_MASK,
# endif
# ifdef USE_LOCALE_TELEPHONE
LC_TELEPHONE_MASK,
# endif
# ifdef USE_LOCALE_SYNTAX
LC_SYNTAX_MASK,
# endif
# ifdef USE_LOCALE_TOD
LC_TOD_MASK,
# endif
/* LC_ALL can't be turned off by a Configure
* option, and in Posix 2008, should always be
* here, so compile it in unconditionally.
* This could catch some glitches at compile
* time */
LC_ALL_MASK,
/* Placeholder as a precaution if code fails to check the return of
* get_category_index(), which returns this element to indicate an error */
0
};
# define my_querylocale_c(cat) my_querylocale_i(cat##_INDEX_)
STATIC const char *
S_my_querylocale_i(pTHX_ const unsigned int index)
{
/* This function returns the name of the locale category given by the input
* index into our parallel tables of them.
*
* POSIX 2008, for some sick reason, chose not to provide a method to find
* the category name of a locale, discarding a basic linguistic tenet that
* for any object, people will create a name for it. Some vendors have
* created a querylocale() function to do just that. This function is a
* lot simpler to implement on systems that have this. Otherwise, we have
* to keep track of what the locale has been set to, so that we can return
* its name so as to emulate setlocale(). It's also possible for C code in
* some library to change the locale without us knowing it, though as of
* September 2017, there are no occurrences in CPAN of uselocale(). Some
* libraries do use setlocale(), but that changes the global locale, and
* threads using per-thread locales will just ignore those changes. */
int category;
const locale_t cur_obj = uselocale((locale_t) 0);
PERL_ARGS_ASSERT_MY_QUERYLOCALE_I;
assert(index <= NOMINAL_LC_ALL_INDEX);
category = categories[index];
DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s:%d: my_querylocale_i %p\n",
__FILE__, __LINE__, cur_obj));
if (cur_obj == LC_GLOBAL_LOCALE) {
return porcelain_setlocale(category, NULL);
}
# ifdef HAS_QUERYLOCALE
return (char *) querylocale(category_masks[index], cur_obj);
# else
/* If this assert fails, adjust the size of curlocales in intrpvar.h */
STATIC_ASSERT_STMT(C_ARRAY_LENGTH(PL_curlocales) > LC_ALL_INDEX_);
# if defined(_NL_LOCALE_NAME) \
&& defined(DEBUGGING) \
/* On systems that accept any locale name, the real underlying \
* locale is often returned by this internal function, so we \
* can't use it */ \
&& ! defined(SETLOCALE_ACCEPTS_ANY_LOCALE_NAME)
{
/* Internal glibc for querylocale(), but doesn't handle empty-string
* ("") locale properly; who knows what other glitches. Check for it
* now, under debug. */
char * temp_name = nl_langinfo_l(_NL_LOCALE_NAME(category),
uselocale((locale_t) 0));
/*
PerlIO_printf(Perl_debug_log, "%s:%d: temp_name=%s\n",
__FILE__, __LINE__, temp_name ? temp_name : "NULL");
PerlIO_printf(Perl_debug_log, "%s:%d: index=%d\n",
__FILE__, __LINE__, index);
PerlIO_printf(Perl_debug_log, "%s:%d: PL_curlocales[index]=%s\n",
__FILE__, __LINE__, PL_curlocales[index]);
*/
if (temp_name && PL_curlocales[index] && strNE(temp_name, "")) {
if ( strNE(PL_curlocales[index], temp_name)
&& ! ( isNAME_C_OR_POSIX(temp_name)
&& isNAME_C_OR_POSIX(PL_curlocales[index]))) {
# ifdef USE_C_BACKTRACE
dump_c_backtrace(Perl_debug_log, 20, 1);
# endif
Perl_croak(aTHX_ "panic: Mismatch between what Perl thinks %s is"
" (%s) and what internal glibc thinks"
" (%s)\n", category_names[index],
PL_curlocales[index], temp_name);
}
return temp_name;
}
}
# endif
/* Without querylocale(), we have to use our record-keeping we've done. */
if (category != LC_ALL) {
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"%s:%d: my_querylocale_i returning %s\n",
__FILE__, __LINE__, PL_curlocales[index]));
return PL_curlocales[index];
}
else { /* For LC_ALL */
unsigned int i;
Size_t names_len = 0;
char * all_string;
bool are_all_categories_the_same_locale = TRUE;
/* If we have a valid LC_ALL value, just return it */
if (PL_curlocales[LC_ALL_INDEX_]) {
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"%s:%d: my_querylocale_i returning %s\n",
__FILE__, __LINE__, PL_curlocales[LC_ALL_INDEX_]));
return PL_curlocales[LC_ALL_INDEX_];
}
/* Otherwise, we need to construct a string of name=value pairs.
* We use the glibc syntax, like
* LC_NUMERIC=C;LC_TIME=en_US.UTF-8;...
* First calculate the needed size. Along the way, check if all
* the locale names are the same */
for (i = 0; i < LC_ALL_INDEX_; i++) {
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"%s:%d: my_querylocale_i i=%d, name=%s, locale=%s\n",
__FILE__, __LINE__, i, category_names[i],
PL_curlocales[i]));
names_len += strlen(category_names[i])
+ 1 /* '=' */
+ strlen(PL_curlocales[i])
+ 1; /* ';' */
if (i > 0 && strNE(PL_curlocales[i], PL_curlocales[i-1])) {
are_all_categories_the_same_locale = FALSE;
}
}
/* If they are the same, we don't actually have to construct the
* string; we just make the entry in LC_ALL_INDEX_ valid, and be that
* single name */
if (are_all_categories_the_same_locale) {
PL_curlocales[LC_ALL_INDEX_] = savepv(PL_curlocales[0]);
return PL_curlocales[LC_ALL_INDEX_];
}
names_len++; /* Trailing '\0' */
SAVEFREEPV(Newx(all_string, names_len, char));
*all_string = '\0';
/* Then fill in the string */
for (i = 0; i < LC_ALL_INDEX_; i++) {
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"%s:%d: my_querylocale_i i=%d, name=%s, locale=%s\n",
__FILE__, __LINE__, i, category_names[i],
PL_curlocales[i]));
my_strlcat(all_string, category_names[i], names_len);
my_strlcat(all_string, "=", names_len);
my_strlcat(all_string, PL_curlocales[i], names_len);
my_strlcat(all_string, ";", names_len);
}
DEBUG_L(PerlIO_printf(Perl_debug_log,
"%s:%d: my_querylocale_i returning %s\n",
__FILE__, __LINE__, all_string));
return all_string;
}
# endif
}
STATIC const char *
S_emulate_setlocale_i(pTHX_ const unsigned int index, const char * locale)
{
/* This function effectively performs a setlocale() on just the current
* thread; thus it is thread-safe. It does this by using the POSIX 2008
* locale functions to emulate the behavior of setlocale(). Similar to
* regular setlocale(), the return from this function points to memory that
* can be overwritten by other system calls, so needs to be copied
* immediately if you need to retain it. The difference here is that
* system calls besides another setlocale() can overwrite it.
*
* By doing this, most locale-sensitive functions become thread-safe. The
* exceptions are mostly those that return a pointer to static memory.
*
* This function takes our internal index of the 'category' setlocale is
* called with, and the 'locale' to set the category to. It uses the
* index to find the category mask that the POSIX 2008 functions use. */
int mask;
int category;
locale_t old_obj;
locale_t new_obj;
PERL_ARGS_ASSERT_EMULATE_SETLOCALE_I;
assert(index <= NOMINAL_LC_ALL_INDEX);
mask = category_masks[index];
category = categories[index];
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"%s:%d: emulate_setlocale_i input=%d (%s), mask=0x%x, \"%s\", %d\n",
__FILE__, __LINE__, category, category_name(category), mask,
locale, index));
/* If just querying what the existing locale is ... */
if (locale == NULL) {
return my_querylocale_i(index);
}
# ifndef HAS_QUERYLOCALE
if (strEQ(locale, "")) {
/* For non-querylocale() systems, we do the setting of "" ourselves to
* be sure that we really know what's going on. We follow the Linux
* documented behavior (but if that differs from the actual behavior,
* this won't work exactly as the OS implements). We go out and
* examine the environment based on our understanding of how the system
* works, and use that to figure things out.
*
* Another option would be to toggle to the global locale, and do a
* straight setlocale(LC_ALL, ""). But that could cause races with any
* other thread that has also switched. That's probably a rare event,
* and we could have a global boolean that indicates if any thread has
* switched, but we'd still need the following backup code anyway. The
* only real reason to make the switch is because some alien library
* that can't be changed, like GTk, is doing its own setlocales, */
const char * const lc_all = PerlEnv_getenv("LC_ALL");
/* Use any "LC_ALL" environment variable, as it overrides everything
* else. */
if (lc_all && strNE(lc_all, "")) {
locale = lc_all;
}
else {
/* Otherwise, we need to dig deeper. Unless overridden, the
* default is the LANG environment variable; if it doesn't exist,
* then "C" */
const char * default_name;
default_name = PerlEnv_getenv("LANG");
if (! default_name || strEQ(default_name, "")) {
default_name = "C";
}
if (category != LC_ALL) {
const char * const name = PerlEnv_getenv(category_names[index]);
/* Here we are setting a single category. Assume will have the
* default name */
locale = default_name;
/* But then look for an overriding environment variable */
if (name && strNE(name, "")) {
locale = name;
}
}
else {
bool did_override = FALSE;
unsigned int i;
/* Here, we are getting LC_ALL. Any categories that don't have
* a corresponding environment variable set should be set to
* LANG, or to "C" if there is no LANG. If no individual
* categories differ from this, we can just set LC_ALL. This
* is buggy on systems that have extra categories that we don't
* know about. If there is an environment variable that sets
* that category, we won't know to look for it, and so our use
* of LANG or "C" improperly overrides it. On the other hand,
* if we don't do what is done here, and there is no
* environment variable, the category's locale should be set to
* LANG or "C". So there is no good solution. khw thinks the
* best is to look at systems to see what categories they have,
* and include them, and then to assume that we know the
* complete set */
for (i = 0; i < LC_ALL_INDEX_; i++) {
const char * const env_override
= PerlEnv_getenv(category_names[i]);
const char * this_locale = ( env_override
&& strNE(env_override, ""))
? env_override
: default_name;
if (! emulate_setlocale_i(i, this_locale))
{
return NULL;
}
if (strNE(this_locale, default_name)) {
did_override = TRUE;
}
}
/* If all the categories are the same, we can set LC_ALL to
* that */
if (! did_override) {
locale = default_name;
}
else {
/* Here, LC_ALL is no longer valid, as some individual
* categories don't match it. We call ourselves
* recursively, as that will execute the code that
* generates the proper locale string for this situation.
* We don't do the remainder of this function, as that is
* to update our records, and we've just done that for the
* individual categories in the loop above, and doing so
* would cause LC_ALL to be done as well */
return querylocale_c(LC_ALL);
}
}
}
} /* End of this being setlocale(LC_foo, "") */
else if (strchr(locale, ';')) {
/* LC_ALL may actually incude a conglomeration of various categories.
* Without querylocale, this code uses the glibc (as of this writing)
* syntax for representing that, but that is not a stable API, and
* other platforms do it differently, so we have to handle all cases
* ourselves */
unsigned int i;
const char * s = locale;
const char * e = locale + strlen(locale);
const char * p = s;
const char * category_end;
const char * name_start;
const char * name_end;
/* If the string that gives what to set doesn't include all categories,
* the omitted ones get set to "C". To get this behavior, first set
* all the individual categories to "C", and override the furnished
* ones below */
for (i = 0; i < LC_ALL_INDEX_; i++) {
if (! emulate_setlocale_i(i, "C")) {
return NULL;
}
}
while (s < e) {
/* Parse through the category */
while (isWORDCHAR(*p)) {
p++;
}
category_end = p;
if (*p++ != '=') {
Perl_croak(aTHX_
"panic: %s: %d: Unexpected character in locale name '%02X",
__FILE__, __LINE__, *(p-1));
}
/* Parse through the locale name */
name_start = p;
while (p < e && *p != ';') {
if (! isGRAPH(*p)) {
Perl_croak(aTHX_
"panic: %s: %d: Unexpected character in locale name '%02X",
__FILE__, __LINE__, *(p-1));
}
p++;
}
name_end = p;
/* Space past the semi-colon */
if (p < e) {
p++;
}
/* Find the index of the category name in our lists */
for (i = 0; i < LC_ALL_INDEX_; i++) {
char * individ_locale;
/* Keep going if this isn't the index. The strnNE() avoids a
* Perl_form(), but would fail if ever a category name could be
* a substring of another one, like if there were a
* "LC_TIME_DATE" */
if strnNE(s, category_names[i], category_end - s) {
continue;
}
/* If this index is for the single category we're changing, we
* have found the locale to set it to. */
if (category == categories[i]) {
locale = Perl_form(aTHX_ "%.*s",
(int) (name_end - name_start),
name_start);
goto ready_to_set;
}
assert(category == LC_ALL);
individ_locale = Perl_form(aTHX_ "%.*s",
(int) (name_end - name_start), name_start);
if (! emulate_setlocale_i(i, individ_locale))
{
return NULL;
}
}
s = p;
}
/* Here we have set all the individual categories by recursive calls.
* These collectively should have fixed up LC_ALL, so can just query
* what that now is */
assert(category == LC_ALL);
return querylocale_c(LC_ALL);
} /* End of this being setlocale(LC_ALL,
"LC_CTYPE=foo;LC_NUMERIC=bar;...") */
ready_to_set: ;
/* Here at the end of having to deal with the absence of querylocale().
* Some cases have already been fully handled by recursive calls to this
* function. But at this point, we haven't dealt with those, but are now
* prepared to, knowing what the locale name to set this category to is.
* This would have come for free if this system had had querylocale() */
# endif /* end of ! querylocale */
assert(PL_C_locale_obj);
/* Switching locales generally entails freeing the current one's space (at
* the C library's discretion), hence we can't be using that locale at the
* time of the switch (this wasn't obvious to khw from the man pages). So
* switch to a known locale object that we don't otherwise mess with; the
* function returns the locale object in effect prior to the switch. */
old_obj = uselocale(PL_C_locale_obj);
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"%s:%d: emulate_setlocale_i was using %p\n",
__FILE__, __LINE__, old_obj));
if (! old_obj) {
dSAVE_ERRNO;
DEBUG_L(PerlIO_printf(Perl_debug_log,
"%s:%d: emulate_setlocale_i switching to C"
" failed: %d\n", __FILE__, __LINE__, GET_ERRNO));
RESTORE_ERRNO;
return NULL;
}
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"%s:%d: emulate_setlocale_i now using %p\n",
__FILE__, __LINE__, PL_C_locale_obj));
/* If this call is to switch LC_ALL to the 'C' locale, it already exists,
* and in fact, we already have switched to it (in preparation for what
* normally is to come). But since we're already there, continue to use
* it instead of trying to create a new locale */
if (mask == LC_ALL_MASK && isNAME_C_OR_POSIX(locale)) {
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"%s:%d: will stay in C object\n",
__FILE__, __LINE__));
new_obj = PL_C_locale_obj;
/* We already had switched to the C locale in preparation for freeing
* 'old_obj' */
if (old_obj != LC_GLOBAL_LOCALE && old_obj != PL_C_locale_obj) {
freelocale(old_obj);
}
}
else {
/* If we weren't in a thread safe locale, set so that newlocale() below
* which uses 'old_obj', uses an empty one. Same for our reserved C
* object. The latter is defensive coding, so that, even if there is
* some bug, we will never end up trying to modify either of these, as
* newlocale() just below would otherwise do. */
if (old_obj == LC_GLOBAL_LOCALE || old_obj == PL_C_locale_obj) {
old_obj = (locale_t) 0;
}
/* Ready to create a new locale by modification of the exising one */
new_obj = newlocale(mask, locale, old_obj);
if (! new_obj) {
dSAVE_ERRNO;
DEBUG_L(PerlIO_printf(Perl_debug_log,
"%s:%d: emulate_setlocale_i creating new object"
" failed: %d\n", __FILE__, __LINE__, GET_ERRNO));
if (! uselocale(old_obj)) {
DEBUG_L(PerlIO_printf(Perl_debug_log,
"%s:%d: switching back failed: %d\n",
__FILE__, __LINE__, GET_ERRNO));
}
RESTORE_ERRNO;
return NULL;
}
DEBUG_Lv(STMT_START {
PerlIO_printf(Perl_debug_log,
"%s:%d: emulate_setlocale_i created %p",
__FILE__, __LINE__, new_obj);
if (old_obj) PerlIO_printf(Perl_debug_log,
"; should have freed %p", old_obj);