-
Notifications
You must be signed in to change notification settings - Fork 528
/
locale.c
7908 lines (6563 loc) · 300 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
*
123456789112345678921234567893123456789412345678951234567896123456789712345678981
* strptime
* 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 for the
* translation. 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.
*
* 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
* bool_setlocale_2008_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.
*
* In addition, the setlocale equivalents have versions for the return context,
* 'void' and 'bool', besides the full return value. This can present
* opportunities for avoiding work. We don't have to necessarily create a safe
* copy to return if no return is desired.
*
* There are 3.5 major implementations here; which one chosen depends on what
* the platform has available, and Configuration options.
*
* 1) Raw posix_setlocale(). This implementation is basically the libc
* setlocale(), with possibly minor tweaks. This is used for for startup,
* and always for unthreaded perls, and when the API for safe locale
* threading is identical to the unsafe API (Windows, currently).
*
* This implementation is composed of two layers:
* a) posix_setlocale() implements the libc setlocale(). In most cases,
* it is just an alias for the libc version. But Windows doesn't
* fully conform to the POSIX standard, and this is a layer on top of
* libc to bring it more into conformance. And in Configurations
* where perl is to ignore some locale categories that the libc
* setlocale() knows about, there is a layer to cope with that.
* b) stdized_setlocale() is a layer above a) that fixes some vagaries in
* the return value of the libc setlocale().
*
* 2) An implementation that adds a minimal layer above implementation 1),
* making that implementation uninterruptible and returning a
* per-thread/per-category value.
*
* 3a and 3b) An implementation of POSIX 2008 thread-safe locale handling,
* hiding from the programmer the completely different API for this.
* This automatically makes almost all code thread-safe without need for
* changes. This implementation is chosen on threaded perls when the
* platform supports the POSIX 2008 functions, and when there is no manual
* override to the contrary passed to Configure.
*
* 3a) is when the platform has a documented reliable querylocale() function
* or equivalent that is selected to be used.
* 3b) is when we have to emulate that functionality.
*
* 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.
*
* Associated with each implementation are three sets of macros that translate
* a consistent API into what that implementation needs. Each set consists of
* three macros with the suffixes:
* _c Means the argument is a locale category number known at compile time.
* An example would be LC_TIME. This token is a compile-time constant
* and can be passed to a '_c' macro.
* _r Means the argument is a locale category number whose value might not be
* known until runtime
* _i Means the argument is our internal index of a locale category
*
* The three sets are: ('_X' means one of '_c', '_r', '_i')
* 1) bool_setlocale_X()
* This calls the appropriate setlocale()-equivalent for the
* implementation, with the category and new locale. The input locale is
* not necessarily valid, so the return is true or false depending on
* whether or not the setlocale() succeeded. This is not used for
* querying the locale, so the input locale must not be NULL.
*
* This macro is suitable for toggling the locale back and forth during an
* operation. For example, the names of days and months under LC_TIME are
* strings that are also subject to LC_CTYPE. If the locales of these two
* categories differ, mojibake can result on many platforms. The code
* here will toggle LC_CTYPE into the locale of LC_TIME temporarily to
* avoid this.
*
* Several categories require extra work when their locale is changed.
* LC_CTYPE, for example, requires the calculation of the table of which
* characters fold to which others under /i pattern matching or fc(), as
* folding is not a concept in POSIX. This table isn't needed when the
* LC_CTYPE locale is toggled. To save work that would be discarded, the
* bool_setlocale_X() implementations don't do this extra work. Instead,
* there is a separate function for just this purpose to be done before
* control is transferred back to the external caller. All categories
* that have such requirements have such a function. The
* update_functions[] array contains pointers to them (or NULL for
* categories which don't need a function).
*
* Care must be taken to remember to call the separate function before
* returning to an external caller, and to not use things it updates
* before its call. An alternative approach would be to have
* bool_setlocale_X() always call the update, which would return
* immediately if a flag wasn't set indicating it was time to actually
* perform it.
*
* 2) void_setlocale_X()
* This is like bool_setlocale_X(), but it is used only when it is
* expected that the call must succeed, or something is seriously wrong.
* A panic is issued if it fails. The caller uses this form when it just
* wants to assume things worked.
*
* 3) querylocale_X()
* This returns a string that specifies the current locale for the given
* category given by the input argument. The string is safe from other
* threads zapping it and the caller need not worry about freeing it, but
* it may be mortalized, so must be copied if you need to preserve it
* across calls, or long term.
*
* The underlying C API that this implements uses category numbers, hence the
* code is structured to use '_r' at the API level to convert to indexes, which
* are then used internally with the '_i' forms.
*
* The splitting apart into setting vs querying means that the return value of
* the bool macros is not subject to potential clashes with other threads,
* eliminating any need for the calling code to worry about that and get it
* wrong. Whereas, you do have to think about thread interactions when using a
* query.
*
* There are also a few other macros herein that use this naming convention to
* describe their category parameter.
*/
/* 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) */
#include "config.h"
#ifdef DEBUGGING
static int debug_initialization = 0;
# define DEBUG_INITIALIZATION_set(v) (debug_initialization = v)
# define DEBUG_LOCALE_INITIALIZATION_ debug_initialization
/* C standards seem to say that __LINE__ is merely "an integer constant",
* which means it might be either int, long (with L suffix), or long long
* (or their corresponding unsigned type). So, we have to explicitly cast
* __LINE__ to a particular integer type to pass it reliably to variadic
* functions like (PerlIO_)printf, as below: */
# if defined(USE_ITHREADS) && ! defined(NO_LOCALE_THREADS)
# define DEBUG_PRE_STMTS \
dSAVE_ERRNO; dTHX; PerlIO_printf(Perl_debug_log,"\n%s: %" LINE_Tf ": 0x%p: ",\
__FILE__, (line_t)__LINE__, aTHX);
# else
# define DEBUG_PRE_STMTS \
dSAVE_ERRNO; dTHX; PerlIO_printf(Perl_debug_log, "\n%s: %" LINE_Tf ": ", \
__FILE__, (line_t)__LINE__);
# endif
# define DEBUG_POST_STMTS RESTORE_ERRNO;
#else
# define debug_initialization 0
# define DEBUG_INITIALIZATION_set(v)
# define DEBUG_PRE_STMTS
# define DEBUG_POST_STMTS
#endif
#include "EXTERN.h"
#define PERL_IN_LOCALE_C
#include "perl.h"
#include "reentr.h"
#ifdef I_WCHAR
# include <wchar.h>
#endif
#ifdef I_WCTYPE
# include <wctype.h>
#endif
/* The main errno that gets used is this one, on platforms that support it */
#ifdef EINVAL
# define SET_EINVAL SETERRNO(EINVAL, LIB_INVARG)
#else
# define SET_EINVAL
#endif
/* If we have any of these library functions, we can reliably determine is a
* locale is a UTF-8 one or not. And if we aren't using locales at all, we act
* as if everything is the C locale, so the answer there is always "No, it
* isn't UTF-8"; this too is reliably accurate */
#if defined(HAS_SOME_LANGINFO) || defined(HAS_MBTOWC) || defined(HAS_MBRTOWC) \
|| ! defined(USE_LOCALE)
# define HAS_RELIABLE_UTF8NESS_DETERMINATION
#endif
#ifdef USE_LOCALE
/* Not all categories need be set to the same locale. This macro determines if
* 'name' which represents LC_ALL is uniform or disparate. There are two
* situations: 1) the platform uses unordered name=value pairs; 2) the platform
* uses ordered positional values, with a separator string between them */
# ifdef LC_ALL_SEPARATOR /* positional */
# define is_disparate_LC_ALL(name) cBOOL(instr(name, LC_ALL_SEPARATOR))
# else /* name=value */
/* In the, hopefully never occurring, event that the platform doesn't use
* either mechanism for disparate LC_ALL's, assume the name=value pairs
* form, rather than taking the extreme step of refusing to compile. Many
* programs won't have disparate locales, so will generally work */
# define LC_ALL_SEPARATOR ";"
# define is_disparate_LC_ALL(name) cBOOL( strchr(name, ';') \
&& strchr(name, '='))
# endif
PERL_STATIC_INLINE const char *
S_mortalized_pv_copy(pTHX_ const char * const pv)
{
PERL_ARGS_ASSERT_MORTALIZED_PV_COPY;
/* Copies the input pv, and arranges for it to be freed at an unspecified
* later time. */
if (pv == NULL) {
return NULL;
}
const char * copy = savepv(pv);
SAVEFREEPV(copy);
return copy;
}
#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
/* Default values come from the C locale */
#define C_codeset "ANSI_X3.4-1968" /* Only in some Configurations, and usually
a single instance, so is a #define */
static const char C_decimal_point[] = ".";
static const char C_thousands_sep[] = "";
/* 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")))
#if defined(HAS_NL_LANGINFO_L) || defined(HAS_NL_LANGINFO)
# define HAS_SOME_LANGINFO
#endif
#define my_langinfo_c(item, category, locale, retbufp, retbuf_sizep, utf8ness) \
my_langinfo_i(item, category##_INDEX_, locale, retbufp, \
retbuf_sizep, utf8ness)
#ifdef USE_LOCALE
# ifdef DEBUGGING
# define setlocale_debug_string_i(index, locale, result) \
my_setlocale_debug_string_i(index, locale, result, __LINE__)
# 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, result)
# endif
# define toggle_locale_i(index, locale) \
S_toggle_locale_i(aTHX_ index, locale, __LINE__)
# define toggle_locale_c(cat, locale) toggle_locale_i(cat##_INDEX_, locale)
# define restore_toggled_locale_i(index, locale) \
S_restore_toggled_locale_i(aTHX_ index, locale, __LINE__)
# define restore_toggled_locale_c(cat, locale) \
restore_toggled_locale_i(cat##_INDEX_, locale)
/* On systems without LC_ALL, pretending it exists anyway simplifies things.
* Choose a value for it that is very unlikely to to clash with any actual
* category */
# define FAKE_LC_ALL PERL_INT_MIN
/* Defines for the parallel arrays and other items below. There is a single
* set for every possible locale category on any system. If you add categories
* be AWARE that Configure will need to change to include the new one.
*
* If the category is present on the system, each symbol expands to the
* appropriate value. If not present, the symbol expands to nothing. This
* allows each array to list all symbols, and only the ones relevant to the
* system actually have content. This way of formatting these brings all the
* varying components adjacent, so a glance tells if something is awry.
*
* The #defines of the form 'foo_GET_INDEX_CASE(var)' each expand to a case
* statement that sets 'var' to our internal index that corresponds to the
* category given by 'foo'. These are for use in a switch() statement that
* includes all of them, expanding to do the mapping for all categories on
* the system. */
# ifdef USE_LOCALE_CTYPE
# define LC_CTYPE_ENTRY_ LC_CTYPE,
# define LC_CTYPE_MASK_ LC_CTYPE_MASK,
# define LC_CTYPE_STRING_ "LC_CTYPE",
# define LC_CTYPE_STRLEN_ STRLENs("LC_CTYPE"),
# define LC_CTYPE_GET_INDEX_CASE(var) \
case LC_CTYPE: \
var = LC_CTYPE_INDEX_; break;
# define LC_CTYPE_UPDATE_ S_new_ctype,
# else
# define LC_CTYPE_ENTRY_
# define LC_CTYPE_MASK_
# define LC_CTYPE_STRING_
# define LC_CTYPE_STRLEN_
# define LC_CTYPE_GET_INDEX_CASE(var)
# define LC_CTYPE_UPDATE_
# endif
# ifdef USE_LOCALE_NUMERIC
# define LC_NUMERIC_ENTRY_ LC_NUMERIC,
# define LC_NUMERIC_MASK_ LC_NUMERIC_MASK,
# define LC_NUMERIC_STRING_ "LC_NUMERIC",
# define LC_NUMERIC_STRLEN_ STRLENs("LC_NUMERIC"),
# define LC_NUMERIC_GET_INDEX_CASE(var) case LC_NUMERIC: \
var = LC_NUMERIC_INDEX_; break;
# define LC_NUMERIC_UPDATE_ S_new_numeric,
# else
# define LC_NUMERIC_ENTRY_
# define LC_NUMERIC_MASK_
# define LC_NUMERIC_STRING_
# define LC_NUMERIC_STRLEN_
# define LC_NUMERIC_GET_INDEX_CASE(var)
# define LC_NUMERIC_UPDATE_
# endif
# ifdef USE_LOCALE_COLLATE
# define LC_COLLATE_ENTRY_ LC_COLLATE,
# define LC_COLLATE_MASK_ LC_COLLATE_MASK,
# define LC_COLLATE_STRING_ "LC_COLLATE",
# define LC_COLLATE_STRLEN_ STRLENs("LC_COLLATE"),
# define LC_COLLATE_GET_INDEX_CASE(var) case LC_COLLATE: \
var = LC_COLLATE_INDEX_; break;
# define LC_COLLATE_UPDATE_ S_new_collate,
# else
# define LC_COLLATE_ENTRY_
# define LC_COLLATE_MASK_
# define LC_COLLATE_STRING_
# define LC_COLLATE_STRLEN_
# define LC_COLLATE_GET_INDEX_CASE(var)
# define LC_COLLATE_UPDATE_
# endif
# ifdef USE_LOCALE_TIME
# define LC_TIME_ENTRY_ LC_TIME,
# define LC_TIME_MASK_ LC_TIME_MASK,
# define LC_TIME_STRING_ "LC_TIME",
# define LC_TIME_STRLEN_ STRLENs("LC_TIME"),
# define LC_TIME_GET_INDEX_CASE(var) case LC_TIME: \
var = LC_TIME_INDEX_; break;
# define LC_TIME_UPDATE_ NULL,
# else
# define LC_TIME_ENTRY_
# define LC_TIME_MASK_
# define LC_TIME_STRING_
# define LC_TIME_STRLEN_
# define LC_TIME_UPDATE_
# define LC_TIME_GET_INDEX_CASE(var)
# endif
# ifdef USE_LOCALE_MESSAGES
# define LC_MESSAGES_ENTRY_ LC_MESSAGES,
# define LC_MESSAGES_MASK_ LC_MESSAGES_MASK,
# define LC_MESSAGES_STRING_ "LC_MESSAGES",
# define LC_MESSAGES_STRLEN_ STRLENs("LC_MESSAGES"),
# define LC_MESSAGES_GET_INDEX_CASE(var) \
case LC_MESSAGES: \
var = LC_MESSAGES_INDEX_; break;
# define LC_MESSAGES_UPDATE_ NULL,
# else
# define LC_MESSAGES_ENTRY_
# define LC_MESSAGES_MASK_
# define LC_MESSAGES_STRING_
# define LC_MESSAGES_STRLEN_
# define LC_MESSAGES_GET_INDEX_CASE(var)
# define LC_MESSAGES_UPDATE_
# endif
# ifdef USE_LOCALE_MONETARY
# define LC_MONETARY_ENTRY_ LC_MONETARY,
# define LC_MONETARY_MASK_ LC_MONETARY_MASK,
# define LC_MONETARY_STRING_ "LC_MONETARY",
# define LC_MONETARY_STRLEN_ STRLENs("LC_MONETARY"),
# define LC_MONETARY_GET_INDEX_CASE(var) \
case LC_MONETARY: \
var = LC_MONETARY_INDEX_; break;
# define LC_MONETARY_UPDATE_ NULL,
# else
# define LC_MONETARY_ENTRY_
# define LC_MONETARY_MASK_
# define LC_MONETARY_STRING_
# define LC_MONETARY_STRLEN_
# define LC_MONETARY_GET_INDEX_CASE(var)
# define LC_MONETARY_UPDATE_
# endif
# ifdef USE_LOCALE_ADDRESS
# define LC_ADDRESS_ENTRY_ LC_ADDRESS,
# define LC_ADDRESS_MASK_ LC_ADDRESS_MASK,
# define LC_ADDRESS_STRING_ "LC_ADDRESS",
# define LC_ADDRESS_STRLEN_ STRLENs("LC_ADDRESS"),
# define LC_ADDRESS_GET_INDEX_CASE(var) \
case LC_ADDRESS: \
var = LC_ADDRESS_INDEX_; break;
# define LC_ADDRESS_UPDATE_ NULL,
# else
# define LC_ADDRESS_ENTRY_
# define LC_ADDRESS_MASK_
# define LC_ADDRESS_STRING_
# define LC_ADDRESS_STRLEN_
# define LC_ADDRESS_GET_INDEX_CASE(var)
# define LC_ADDRESS_UPDATE_
# endif
# ifdef USE_LOCALE_IDENTIFICATION
# define LC_IDENTIFICATION_ENTRY_ LC_IDENTIFICATION,
# define LC_IDENTIFICATION_MASK_ LC_IDENTIFICATION_MASK,
# define LC_IDENTIFICATION_STRING_ "LC_IDENTIFICATION",
# define LC_IDENTIFICATION_STRLEN_ STRLENs("LC_IDENTIFICATION"),
# define LC_IDENTIFICATION_GET_INDEX_CASE(var) \
case LC_IDENTIFICATION: \
var = LC_IDENTIFICATION_INDEX_;\
break;
# define LC_IDENTIFICATION_UPDATE_ NULL,
# else
# define LC_IDENTIFICATION_ENTRY_
# define LC_IDENTIFICATION_MASK_
# define LC_IDENTIFICATION_STRING_
# define LC_IDENTIFICATION_STRLEN_
# define LC_IDENTIFICATION_GET_INDEX_CASE(var)
# define LC_IDENTIFICATION_UPDATE_
# endif
# ifdef USE_LOCALE_MEASUREMENT
# define LC_MEASUREMENT_ENTRY_ LC_MEASUREMENT,
# define LC_MEASUREMENT_MASK_ LC_MEASUREMENT_MASK,
# define LC_MEASUREMENT_STRING_ "LC_MEASUREMENT",
# define LC_MEASUREMENT_STRLEN_ STRLENs("LC_MEASUREMENT"),
# define LC_MEASUREMENT_GET_INDEX_CASE(var) \
case LC_MEASUREMENT: \
var = LC_MEASUREMENT_INDEX_; break;
# define LC_MEASUREMENT_UPDATE_ NULL,
# else
# define LC_MEASUREMENT_ENTRY_
# define LC_MEASUREMENT_MASK_
# define LC_MEASUREMENT_STRING_
# define LC_MEASUREMENT_STRLEN_
# define LC_MEASUREMENT_GET_INDEX_CASE(var)
# define LC_MEASUREMENT_UPDATE_
# endif
# ifdef USE_LOCALE_PAPER
# define LC_PAPER_ENTRY_ LC_PAPER,
# define LC_PAPER_MASK_ LC_PAPER_MASK,
# define LC_PAPER_STRING_ "LC_PAPER",
# define LC_PAPER_STRLEN_ STRLENs("LC_PAPER"),
# define LC_PAPER_GET_INDEX_CASE(var) case LC_PAPER: \
var = LC_PAPER_INDEX_; break;
# define LC_PAPER_UPDATE_ NULL,
# else
# define LC_PAPER_ENTRY_
# define LC_PAPER_MASK_
# define LC_PAPER_STRING_
# define LC_PAPER_STRLEN_
# define LC_PAPER_GET_INDEX_CASE(var)
# define LC_PAPER_UPDATE_
# endif
# ifdef USE_LOCALE_TELEPHONE
# define LC_TELEPHONE_ENTRY_ LC_TELEPHONE,
# define LC_TELEPHONE_MASK_ LC_TELEPHONE_MASK,
# define LC_TELEPHONE_STRING_ "LC_TELEPHONE",
# define LC_TELEPHONE_STRLEN_ STRLENs("LC_TELEPHONE"),
# define LC_TELEPHONE_GET_INDEX_CASE(var) \
case LC_TELEPHONE: \
var = LC_TELEPHONE_INDEX_; break;
# define LC_TELEPHONE_UPDATE_ NULL,
# else
# define LC_TELEPHONE_ENTRY_
# define LC_TELEPHONE_MASK_
# define LC_TELEPHONE_STRING_
# define LC_TELEPHONE_STRLEN_
# define LC_TELEPHONE_GET_INDEX_CASE(var)
# define LC_TELEPHONE_UPDATE_
# endif
# ifdef USE_LOCALE_NAME
# define LC_NAME_ENTRY_ LC_NAME,
# define LC_NAME_MASK_ LC_NAME_MASK,
# define LC_NAME_STRING_ "LC_NAME",
# define LC_NAME_STRLEN_ STRLENs("LC_NAME"),
# define LC_NAME_GET_INDEX_CASE(var) case LC_NAME: \
var = LC_NAME_INDEX_; break;
# define LC_NAME_UPDATE_ NULL,
# else
# define LC_NAME_ENTRY_
# define LC_NAME_MASK_
# define LC_NAME_STRING_
# define LC_NAME_STRLEN_
# define LC_NAME_GET_INDEX_CASE(var)
# define LC_NAME_UPDATE_
# endif
# ifdef USE_LOCALE_SYNTAX
# define LC_SYNTAX_ENTRY_ LC_SYNTAX,
# define LC_SYNTAX_MASK_ LC_SYNTAX_MASK,
# define LC_SYNTAX_STRING_ "LC_SYNTAX",
# define LC_SYNTAX_STRLEN_ STRLENs("LC_SYNTAX"),
# define LC_SYNTAX_GET_INDEX_CASE(var) case LC_SYNTAX: \
var = LC_SYNTAX_INDEX_; break;
# define LC_SYNTAX_UPDATE_ NULL,
# else
# define LC_SYNTAX_ENTRY_
# define LC_SYNTAX_MASK_
# define LC_SYNTAX_STRING_
# define LC_SYNTAX_STRLEN_
# define LC_SYNTAX_GET_INDEX_CASE(var)
# define LC_SYNTAX_UPDATE_
# endif
# ifdef USE_LOCALE_TOD
# define LC_TOD_ENTRY_ LC_TOD,
# define LC_TOD_MASK_ LC_TOD_MASK,
# define LC_TOD_STRING_ "LC_TOD",
# define LC_TOD_STRLEN_ STRLENs("LC_TOD"),
# define LC_TOD_GET_INDEX_CASE(var) case LC_TOD: \
var = LC_TOD_INDEX_; break;
# define LC_TOD_UPDATE_ NULL,
# else
# define LC_TOD_ENTRY_
# define LC_TOD_MASK_
# define LC_TOD_STRING_
# define LC_TOD_STRLEN_
# define LC_TOD_GET_INDEX_CASE(var)
# define LC_TOD_UPDATE_
# endif
# ifdef LC_ALL
# define LC_ALL_ENTRY_ LC_ALL,
# define LC_ALL_MASK_ LC_ALL_MASK,
# define LC_ALL_STRING_ "LC_ALL",
# define LC_ALL_STRLEN_ STRLENs("LC_ALL"),
# define LC_ALL_GET_INDEX_CASE(var) case LC_ALL: \
var = LC_ALL_INDEX_; break;
# define LC_ALL_UPDATE_ S_new_LC_ALL,
# else
# define LC_ALL_ENTRY_ FAKE_LC_ALL,
# define LC_ALL_MASK_ 0,
# define LC_ALL_STRING_ "If you see this, it is a bug in" \
" perl; please report it via perlbug"
# define LC_ALL_STRLEN_ (sizeof(LC_ALL_STRING_) - 1),
# define LC_ALL_GET_INDEX_CASE(var)
# define LC_ALL_UPDATE_ NULL,
# endif
/* All category numbers unknown to perl get mapped to this entry. This is
* likely to be a parameter error from the calling program; but it could be
* that this platform has a category we don't know about, in which case it
* needs to be added, using the paradigm of one of the existing categories
*
* Unlikely to clash with a real category */
# define LC_UNKNOWN_ENTRY (FAKE_LC_ALL + 1)
# define LC_UNKNOWN_MASK 0
# define LC_UNKNOWN_STRING "Locale category unknown to Perl; if" \
" you see this, it is a bug in perl;" \
" please report it via perlbug"
# define LC_UNKNOWN_STRLEN (sizeof(LC_UNKNOWN_STRING) - 1)
# define LC_UNKNOWN_UPDATE NULL
/* Several 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. CTYPE is first because when we are
* setting multiple categories, CTYPE needs to match the other(s), and the way
* the code is constructed, if we tried the other first, we might have to set
* CTYPE twice. */
STATIC const int categories[] = {
LC_CTYPE_ENTRY_
LC_NUMERIC_ENTRY_
LC_COLLATE_ENTRY_
LC_TIME_ENTRY_
LC_MESSAGES_ENTRY_
LC_MONETARY_ENTRY_
LC_ADDRESS_ENTRY_
LC_IDENTIFICATION_ENTRY_
LC_MEASUREMENT_ENTRY_
LC_PAPER_ENTRY_
LC_TELEPHONE_ENTRY_
LC_NAME_ENTRY_
LC_SYNTAX_ENTRY_
LC_TOD_ENTRY_
LC_ALL_ENTRY_
LC_UNKNOWN_ENTRY
};
STATIC const char * const category_names[] = {
LC_CTYPE_STRING_
LC_NUMERIC_STRING_
LC_COLLATE_STRING_
LC_TIME_STRING_
LC_MESSAGES_STRING_
LC_MONETARY_STRING_
LC_ADDRESS_STRING_
LC_IDENTIFICATION_STRING_
LC_MEASUREMENT_STRING_
LC_PAPER_STRING_
LC_TELEPHONE_STRING_
LC_NAME_STRING_
LC_SYNTAX_STRING_
LC_TOD_STRING_
LC_ALL_STRING_
LC_UNKNOWN_STRING
};
STATIC const Size_t category_name_lengths[] = {
LC_CTYPE_STRLEN_
LC_NUMERIC_STRLEN_
LC_COLLATE_STRLEN_
LC_TIME_STRLEN_
LC_MESSAGES_STRLEN_
LC_MONETARY_STRLEN_
LC_ADDRESS_STRLEN_
LC_IDENTIFICATION_STRLEN_
LC_MEASUREMENT_STRLEN_
LC_PAPER_STRLEN_
LC_TELEPHONE_STRLEN_
LC_NAME_STRLEN_
LC_SYNTAX_STRLEN_
LC_TOD_STRLEN_
LC_ALL_STRLEN_
LC_UNKNOWN_STRLEN
};
/* A few categories require additional setup when they are changed. This table
* points to the functions that do that setup */
STATIC void (*update_functions[]) (pTHX_ const char *, bool force) = {
LC_CTYPE_UPDATE_
LC_NUMERIC_UPDATE_
LC_COLLATE_UPDATE_
LC_TIME_UPDATE_
LC_MESSAGES_UPDATE_
LC_MONETARY_UPDATE_
LC_ADDRESS_UPDATE_
LC_IDENTIFICATION_UPDATE_
LC_MEASUREMENT_UPDATE_
LC_PAPER_UPDATE_
LC_TELEPHONE_UPDATE_
LC_NAME_UPDATE_
LC_SYNTAX_UPDATE_
LC_TOD_UPDATE_
LC_ALL_UPDATE_
LC_UNKNOWN_UPDATE
};
# if defined(USE_POSIX_2008_LOCALE)
STATIC const int category_masks[] = {
LC_CTYPE_MASK_
LC_NUMERIC_MASK_
LC_COLLATE_MASK_
LC_TIME_MASK_
LC_MESSAGES_MASK_
LC_MONETARY_MASK_
LC_ADDRESS_MASK_
LC_IDENTIFICATION_MASK_
LC_MEASUREMENT_MASK_
LC_PAPER_MASK_
LC_TELEPHONE_MASK_
LC_NAME_MASK_
LC_SYNTAX_MASK_
LC_TOD_MASK_
LC_ALL_MASK_
LC_UNKNOWN_MASK
};
# endif
#endif
#if defined(USE_LOCALE) || defined(DEBUGGING)
STATIC const char *
S_get_displayable_string(pTHX_
const char * const s,
const char * const e,
const bool is_utf8)
{
PERL_ARGS_ASSERT_GET_DISPLAYABLE_STRING;
const char * t = s;
bool prev_was_printable = TRUE;
bool first_time = TRUE;
char * ret;
/* Worst case scenario: All are non-printable so have a blank between each.
* If UTF-8, all are the largest possible code point; otherwise all are a
* single byte. '(2 + 1)' is from each byte takes 2 characters to
* display, and a blank (or NUL for the final one) after it */
Newxz(ret, (e - s) * (2 + 1) * ((is_utf8) ? UVSIZE : 1), char);
SAVEFREEPV(ret);
while (t < e) {
UV cp = (is_utf8)
? utf8_to_uvchr_buf((U8 *) t, e, NULL)
: * (U8 *) t;
if (isPRINT(cp)) {
if (! prev_was_printable) {
my_strlcat(ret, " ", sizeof(ret));
}
/* Escape these to avoid any ambiguity */
if (cp == ' ' || cp == '\\') {
my_strlcat(ret, "\\", sizeof(ret));
}
my_strlcat(ret, Perl_form(aTHX_ "%c", (U8) cp), sizeof(ret));
prev_was_printable = TRUE;
}
else {
if (! first_time) {
my_strlcat(ret, " ", sizeof(ret));
}
my_strlcat(ret, Perl_form(aTHX_ "%02" UVXf, cp), sizeof(ret));
prev_was_printable = FALSE;
}
t += (is_utf8) ? UTF8SKIP(t) : 1;
first_time = FALSE;
}
return ret;
}
#endif
#ifdef USE_LOCALE
# define get_category_index(cat) get_category_index_helper(cat, NULL, \
__LINE__)
STATIC unsigned int
S_get_category_index_helper(pTHX_ const int category, bool * succeeded,
const line_t caller_line)
{
PERL_ARGS_ASSERT_GET_CATEGORY_INDEX_HELPER;
/* Given a category, return the equivalent internal index we generally use
* instead, warn or panic if not found. */
unsigned int i;
/* Each line expands like:
* case LC_CTYPE: i = LC_CTYPE_INDEX_; break;
*/
switch (category) {
LC_CTYPE_GET_INDEX_CASE(i)
LC_NUMERIC_GET_INDEX_CASE(i)
LC_COLLATE_GET_INDEX_CASE(i)
LC_TIME_GET_INDEX_CASE(i)
LC_MESSAGES_GET_INDEX_CASE(i)
LC_MONETARY_GET_INDEX_CASE(i)
LC_ADDRESS_GET_INDEX_CASE(i)
LC_IDENTIFICATION_GET_INDEX_CASE(i)
LC_MEASUREMENT_GET_INDEX_CASE(i)
LC_PAPER_GET_INDEX_CASE(i)
LC_TELEPHONE_GET_INDEX_CASE(i)
LC_NAME_GET_INDEX_CASE(i)
LC_SYNTAX_GET_INDEX_CASE(i)
LC_TOD_GET_INDEX_CASE(i)
LC_ALL_GET_INDEX_CASE(i)
default: goto unknown_locale;
}
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"index of category %d (%s) is %d;"
" called from %" LINE_Tf "\n",
category, category_names[i], i, caller_line));
if (succeeded) {
*succeeded = true;
}
return i;
unknown_locale:
if (succeeded) {
*succeeded = false;
return 0; /* Arbitrary */
}
locale_panic_via_(Perl_form(aTHX_ "Unknown locale category %d", category),
__FILE__, caller_line);
NOT_REACHED; /* NOTREACHED */
}
#endif /* ifdef USE_LOCALE */
void
Perl_force_locale_unlock()
{
#if defined(USE_LOCALE_THREADS)
dTHX;
/* If recursively locked, clear all at once */
if (PL_locale_mutex_depth > 1) {
PL_locale_mutex_depth = 1;
}
if (PL_locale_mutex_depth > 0) {
LOCALE_UNLOCK_;
}
#endif
}
#ifdef USE_POSIX_2008_LOCALE
STATIC locale_t
S_use_curlocale_scratch(pTHX)
{
/* This function is used to hide from the caller the case where the current
* locale_t object in POSIX 2008 is the global one, which is illegal in
* many of the P2008 API calls. This checks for that and, if necessary
* creates a proper P2008 object. Any prior object is deleted, as is any
* remaining object during global destruction. */
locale_t cur = uselocale((locale_t) 0);
if (cur != LC_GLOBAL_LOCALE) {
return cur;
}
if (PL_scratch_locale_obj) {
freelocale(PL_scratch_locale_obj);
}
PL_scratch_locale_obj = duplocale(LC_GLOBAL_LOCALE);
return PL_scratch_locale_obj;
}
#endif
void
Perl_locale_panic(const char * msg,
const line_t immediate_caller_line,
const char * const higher_caller_file,
const line_t higher_caller_line)
{
PERL_ARGS_ASSERT_LOCALE_PANIC;
dTHX;
dSAVE_ERRNO;
force_locale_unlock();
#ifdef USE_C_BACKTRACE
dump_c_backtrace(Perl_debug_log, 20, 1);
#endif
const char * called_by = "";
if ( strNE(__FILE__, higher_caller_file)
|| immediate_caller_line != higher_caller_line)
{
called_by = Perl_form(aTHX_ "\nCalled by %s: %" LINE_Tf "\n",
higher_caller_file, higher_caller_line);
}
RESTORE_ERRNO;
const int extended_errnum = get_extended_os_errno();
const char * errno_text;
if (errno == extended_errnum) {
errno_text = Perl_form(aTHX_ "; errno=%d", errno);
}
else {
errno_text = Perl_form(aTHX_ "; errno=%d, $^E=%d",
errno, extended_errnum);
}
/* diag_listed_as: panic: %s */
Perl_croak(aTHX_ "%s: %" LINE_Tf ": panic: %s%s%s\n",
__FILE__, immediate_caller_line,
msg, errno_text, called_by);
}
/* Macros to report and croak on an unexpected failure to set the locale. The
* via version has more stack trace information */
#define setlocale_failure_panic_i(i, cur, fail, line, higher_line) \
setlocale_failure_panic_via_i(i, cur, fail, __LINE__, line, \
__FILE__, higher_line)
#define setlocale_failure_panic_c(cat, cur, fail, line, higher_line) \
setlocale_failure_panic_i(cat##_INDEX_, cur, fail, line, higher_line)
#if defined(USE_POSIX_2008_LOCALE) && defined(LC_ALL)
STATIC parse_LC_ALL_string_return
S_parse_LC_ALL_string(pTHX_ const char * string,
const char ** output,
const line_t caller_line)
{
/* This function parses the value of the input 'string' which is expected
* to be the representation of an LC_ALL locale, and splits the result into
* the values for the individual component categories, returning those in
* the 'output' array. Each array value will be a savepv() copy that is
* the responsibility of the caller to make sure gets freed
*
* The locale for each category is independent of the other categories.
* Often, they are all the same, but certainly not always. Perl, in fact,
* usually keeps LC_NUMERIC in the C locale, regardless of the underlying
* locale. LC_ALL has to be able to represent the case of when not all
* categories have the same locale. Platforms have differing ways of
* representing this. Internally, this file uses the 'name=value;'
* representation found on some platforms, so this function always looks
* for and parses that.
*
* Often, all categories will have the same locale. In that case, the
* input 'string' likely is a single value, and no splitting is needed.
* In such cases, this function doesn't store anything into 'output', and
* returns 'no_array'.
*
* Otherwise, output[] will be filled with the individual locale names for
* all categories on the system, and the caller needs to arrange for each
* to be freed.
*
* The input 'string' may not be valid. This function looks mainly for
* syntactic errors, and if found, returns 'invalid'. 'output' will not be
* filled in that case, but the input state of it isn't necessarily
* preserved. Turning on -DL debugging will give details as to the error.
*
*/
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"Entering parse_LC_ALL_string; called from %" \
LINE_Tf "\nnew='%s'\n", caller_line, string));
const char separator[] = ";";
const Size_t separator_len = 1;
const bool single_component = (strchr(string, ';') == NULL);
if (single_component) {
return full_array;
}
/* Here the input is multiple components. Parse through them.
*