Add API function Perl_langinfo()

This is designed to generally replace nl_langinfo() in XS code.  It is
thread-safer, hides the quirks of perl's LC_NUMERIC handling, and can be
used on systems lacking nl_langinfo.

Author: khwilliamson

MANIFEST

@@ -4896,6 +4896,7 @@ parser.h			parser object header
 patchlevel.h			The current patch level of perl
 perl.c				main()
 perl.h				Global declarations
+perl_langinfo.h			Perl's version of <langinfo.h>
 perlapi.c			Perl API functions
 perlapi.h			Perl API function declarations
 perldtrace.d			D script for Perl probes

embed.fnc

@@ -1259,6 +1259,11 @@ ApdO	|HV*	|get_hv		|NN const char *name|I32 flags
 ApdO	|CV*	|get_cv		|NN const char* name|I32 flags
 Apd	|CV*	|get_cvn_flags	|NN const char* name|STRLEN len|I32 flags
 EXnpo	|char*	|setlocale	|int category|NULLOK const char* locale
+#if defined(HAS_NL_LANGINFO) && defined(PERL_LANGINFO_H)
+Ando	|const char*|Perl_langinfo|const nl_item item
+#else
+Ando	|const char*|Perl_langinfo|const int item
+#endif
 ApOM	|int	|init_i18nl10n	|int printwarn
 ApOM	|int	|init_i18nl14n	|int printwarn
 p	|char*	|my_strerror	|const int errnum
@@ -2718,15 +2723,20 @@ s	|bool	|isa_lookup	|NN HV *stash|NN const char * const name \
                                         |STRLEN len|U32 flags
 #endif
 
-#if defined(USE_LOCALE) && defined(PERL_IN_LOCALE_C)
+#if defined(PERL_IN_LOCALE_C)
+in	|const char *|save_to_buffer|NN const char * string	\
+				    |NULLOK char **buf		\
+				    |NN Size_t *buf_size	\
+				    |const Size_t offset
+#  if defined(USE_LOCALE)
 s	|char*	|stdize_locale	|NN char* locs
 s	|void	|new_collate	|NULLOK const char* newcoll
 s	|void	|new_ctype	|NN const char* newctype
 s	|void	|set_numeric_radix
-#ifdef WIN32
+#    ifdef WIN32
 s	|char*	|my_setlocale	|int category|NULLOK const char* locale
-#endif
-#   ifdef DEBUGGING
+#    endif
+#    ifdef DEBUGGING
 s	|void	|print_collxfrm_input_and_return		\
 			    |NN const char * const s		\
 			    |NN const char * const e		\
@@ -2738,7 +2748,8 @@ s	|void	|print_bytes_for_locale	|NN const char * const s	\
 snR	|char *	|setlocale_debug_string	|const int category		    \
 					|NULLOK const char* const locale    \
 					|NULLOK const char* const retval
-#   endif
+#    endif
+#  endif
 #endif
 
 #if        defined(USE_LOCALE)		\

embed.h

@@ -1478,6 +1478,13 @@
 #  if defined(DEBUGGING)
 #define get_debug_opts(a,b)	Perl_get_debug_opts(aTHX_ a,b)
 #define set_padlist		Perl_set_padlist
+#    if defined(PERL_IN_LOCALE_C)
+#      if defined(USE_LOCALE)
+#define print_bytes_for_locale(a,b,c)	S_print_bytes_for_locale(aTHX_ a,b,c)
+#define print_collxfrm_input_and_return(a,b,c,d)	S_print_collxfrm_input_and_return(aTHX_ a,b,c,d)
+#define setlocale_debug_string	S_setlocale_debug_string
+#      endif
+#    endif
 #    if defined(PERL_IN_PAD_C)
 #define cv_dump(a,b)		S_cv_dump(aTHX_ a,b)
 #    endif
@@ -1488,11 +1495,6 @@
 #define printbuf(a,b)		S_printbuf(aTHX_ a,b)
 #define tokereport(a,b)		S_tokereport(aTHX_ a,b)
 #    endif
-#    if defined(USE_LOCALE) && defined(PERL_IN_LOCALE_C)
-#define print_bytes_for_locale(a,b,c)	S_print_bytes_for_locale(aTHX_ a,b,c)
-#define print_collxfrm_input_and_return(a,b,c,d)	S_print_collxfrm_input_and_return(aTHX_ a,b,c,d)
-#define setlocale_debug_string	S_setlocale_debug_string
-#    endif
 #  endif
 #  if defined(DEBUG_LEAKING_SCALARS_FORK_DUMP)
 #define dump_sv_child(a)	Perl_dump_sv_child(aTHX_ a)
@@ -1591,6 +1593,18 @@
 #define share_hek_flags(a,b,c,d)	S_share_hek_flags(aTHX_ a,b,c,d)
 #define unshare_hek_or_pvn(a,b,c,d)	S_unshare_hek_or_pvn(aTHX_ a,b,c,d)
 #  endif
+#  if defined(PERL_IN_LOCALE_C)
+#define save_to_buffer		S_save_to_buffer
+#    if defined(USE_LOCALE)
+#define new_collate(a)		S_new_collate(aTHX_ a)
+#define new_ctype(a)		S_new_ctype(aTHX_ a)
+#define set_numeric_radix()	S_set_numeric_radix(aTHX)
+#define stdize_locale(a)	S_stdize_locale(aTHX_ a)
+#      if defined(WIN32)
+#define my_setlocale(a,b)	S_my_setlocale(aTHX_ a,b)
+#      endif
+#    endif
+#  endif
 #  if defined(PERL_IN_LOCALE_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_MATHOMS_C)
 #    if defined(USE_LOCALE_COLLATE)
 #define _mem_collxfrm(a,b,c,d)	Perl__mem_collxfrm(aTHX_ a,b,c,d)
@@ -1882,15 +1896,6 @@
 #define padname_dup(a,b)	Perl_padname_dup(aTHX_ a,b)
 #define padnamelist_dup(a,b)	Perl_padnamelist_dup(aTHX_ a,b)
 #  endif
-#  if defined(USE_LOCALE) && defined(PERL_IN_LOCALE_C)
-#define new_collate(a)		S_new_collate(aTHX_ a)
-#define new_ctype(a)		S_new_ctype(aTHX_ a)
-#define set_numeric_radix()	S_set_numeric_radix(aTHX)
-#define stdize_locale(a)	S_stdize_locale(aTHX_ a)
-#    if defined(WIN32)
-#define my_setlocale(a,b)	S_my_setlocale(aTHX_ a,b)
-#    endif
-#  endif
 #  if defined(USE_LOCALE_COLLATE)
 #define magic_setcollxfrm(a,b)	Perl_magic_setcollxfrm(aTHX_ a,b)
 #ifndef NO_MATHOMS

embedvar.h

@@ -176,6 +176,8 @@
 #define PL_inplace		(vTHX->Iinplace)
 #define PL_isarev		(vTHX->Iisarev)
 #define PL_known_layers		(vTHX->Iknown_layers)
+#define PL_langinfo_buf		(vTHX->Ilanginfo_buf)
+#define PL_langinfo_bufsize	(vTHX->Ilanginfo_bufsize)
 #define PL_last_in_gv		(vTHX->Ilast_in_gv)
 #define PL_last_swash_hv	(vTHX->Ilast_swash_hv)
 #define PL_last_swash_key	(vTHX->Ilast_swash_key)

ext/XS-APItest/APItest.pm

@@ -5,7 +5,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '0.91';
+our $VERSION = '0.92';
 
 require XSLoader;
 

ext/XS-APItest/APItest.xs

@@ -6544,6 +6544,13 @@ test_Gconvert(SV * number, SV * num_digits)
     OUTPUT:
         RETVAL
 
+SV *
+test_Perl_langinfo(SV * item)
+    CODE:
+        RETVAL = newSVpv(Perl_langinfo(SvIV(item)), 0);
+    OUTPUT:
+        RETVAL
+
 MODULE = XS::APItest		PACKAGE = XS::APItest::Backrefs
 
 void

ext/XS-APItest/t/locale.t

@@ -22,9 +22,6 @@ for (@locales) {
     }
 }
 
-skip_all("no non-dot radix locales available") unless $non_dot_locale;
-
-plan tests => 2;
 
 SKIP: {
       if ($Config{usequadmath}) {
@@ -34,3 +31,106 @@ SKIP: {
       use locale;
       is(test_Gconvert(4.179, 2), "4.2", "Gconvert doesn't recognize underlying locale inside 'use locale'");
 }
+
+my %correct_C_responses = (
+        # Commented out entries are ones which there is room for variation
+                            ABDAY_1 => 'Sun',
+                            ABDAY_2 => 'Mon',
+                            ABDAY_3 => 'Tue',
+                            ABDAY_4 => 'Wed',
+                            ABDAY_5 => 'Thu',
+                            ABDAY_6 => 'Fri',
+                            ABDAY_7 => 'Sat',
+                            ABMON_1 => 'Jan',
+                            ABMON_10 => 'Oct',
+                            ABMON_11 => 'Nov',
+                            ABMON_12 => 'Dec',
+                            ABMON_2 => 'Feb',
+                            ABMON_3 => 'Mar',
+                            ABMON_4 => 'Apr',
+                            ABMON_5 => 'May',
+                            ABMON_6 => 'Jun',
+                            ABMON_7 => 'Jul',
+                            ABMON_8 => 'Aug',
+                            ABMON_9 => 'Sep',
+                            ALT_DIGITS => '',
+                            AM_STR => 'AM',
+                            #CODESET => 'ANSI_X3.4-1968',
+                            #CRNCYSTR => '-',
+                            DAY_1 => 'Sunday',
+                            DAY_2 => 'Monday',
+                            DAY_3 => 'Tuesday',
+                            DAY_4 => 'Wednesday',
+                            DAY_5 => 'Thursday',
+                            DAY_6 => 'Friday',
+                            DAY_7 => 'Saturday',
+                            #D_FMT => '%m/%d/%y',
+                            #D_T_FMT => '%a %b %e %H:%M:%S %Y',
+                            ERA => '',
+                            #ERA_D_FMT => '',
+                            #ERA_D_T_FMT => '',
+                            #ERA_T_FMT => '',
+                            MON_1 => 'January',
+                            MON_10 => 'October',
+                            MON_11 => 'November',
+                            MON_12 => 'December',
+                            MON_2 => 'February',
+                            MON_3 => 'March',
+                            MON_4 => 'April',
+                            MON_5 => 'May',
+                            MON_6 => 'June',
+                            MON_7 => 'July',
+                            MON_8 => 'August',
+                            MON_9 => 'September',
+                            #NOEXPR => '^[nN]',
+                            PM_STR => 'PM',
+                            RADIXCHAR => '.',
+                            THOUSEP => '',
+                            #T_FMT => '%H:%M:%S',
+                            #T_FMT_AMPM => '%I:%M:%S %p',
+                            #YESEXPR => '^[yY]',
+                        );
+
+my $hdr = "../../perl_langinfo.h";
+open my $fh, "<", $hdr;
+$|=1;
+
+SKIP: {
+    skip "No LC_ALL", 1 unless find_locales( &LC_ALL );
+
+    use POSIX;
+    setlocale(LC_ALL, "C");
+    eval "use I18N::Langinfo qw(langinfo RADIXCHAR); langinfo(RADIXCHAR)";
+    my $has_nl_langinfo = $@ eq "";
+
+    skip "Can't open $hdr for reading: $!", 1 unless $fh;
+
+    my %items;
+
+    # Find all the current items from the header, and their values.
+    # For non-nl_langinfo systems, those values are arbitrary negative numbers
+    # set in the header.  Otherwise they are the nl_langinfo approved values,
+    # which for the moment is the item name.
+    while (<$fh>) {
+        chomp;
+        next unless / - \d+ $ /x;
+        s/ ^ .* PERL_//x;
+        m/ (.*) \  (.*) /x;
+        $items{$1} = ($has_nl_langinfo)
+                     ? $1
+                     : $2;
+    }
+
+    # Get the translation from item name to numeric value.
+    I18N::Langinfo->import(keys %items) if $has_nl_langinfo;
+
+    foreach my $item (sort keys %items) {
+        my $result = test_Perl_langinfo(eval $items{$item});
+        if (exists $correct_C_responses{$item}) {
+            is ($result, $correct_C_responses{$item},
+                "Returns expected value for $item");
+        }
+    }
+}
+
+done_testing();

intrpvar.h

@@ -588,6 +588,9 @@ PERLVARI(I, collation_standard, bool, TRUE)
 					/* Assume simple collation */
 #endif /* USE_LOCALE_COLLATE */
 
+PERLVARI(I, langinfo_buf, char *, NULL)
+PERLVARI(I, langinfo_bufsize, Size_t, 0)
+
 #ifdef PERL_SAWAMPERSAND
 PERLVAR(I, sawampersand, U8)		/* must save all match strings */
 #endif