ext/XS-APItest/t/locale.t

   1 BEGIN {
   2     require '../../t/test.pl';
   3     require '../../t/loc_tools.pl'; # to find locales
   4 }
   5
   6 use XS::APItest;
   7 use Config;
   8
   9 skip_all("locales not available") unless locales_enabled('LC_NUMERIC');
  10
  11 my @locales = eval { find_locales( &LC_NUMERIC ) };
  12 skip_all("no LC_NUMERIC locales available") unless @locales;
  13
  14 my $comma_locale;
  15 for my $locale (@locales) {
  16     use POSIX;
  17     use locale;
  18     setlocale(LC_NUMERIC, $locale) or next;
  19     my $in = 4.2; # avoid any constant folding bugs
  20     my $s = sprintf("%g", $in);
  21     if ($s eq "4,2")  {
  22         $comma_locale = $locale;
  23         last;
  24     }
  25 }
  26
  27
  28 SKIP: {
  29       if ($Config{usequadmath}) {
  30             skip "no gconvert with usequadmath", 2;
  31       }
  32       is(test_Gconvert(4.179, 2), "4.2", "Gconvert doesn't recognize underlying locale outside 'use locale'");
  33       use locale;
  34       is(test_Gconvert(4.179, 2), "4.2", "Gconvert doesn't recognize underlying locale inside 'use locale'");
  35 }
  36
  37 sub check_in_bounds($$$) {
  38     my ($value, $lower, $upper) = @_;
  39
  40     $value >= $lower && $value <= $upper
  41 }
  42
  43 SKIP: {
  44     # This checks that when switching to the global locale, the service that
  45     # Perl provides of transparently dealing with locales that have a non-dot
  46     # radix is turned off, but gets turned on again after a sync_locale();
  47
  48     skip "no locale with a comma radix available", 5 unless $comma_locale;
  49
  50     my $global_locale = switch_to_global_and_setlocale(LC_NUMERIC,
  51                                                        $comma_locale);
  52     # Can't do a compare of $global_locale and $comma_locale because what the
  53     # system returns may be an alias.  ALl we can do is test for
  54     # success/failure
  55     ok($global_locale, "Successfully switched to $comma_locale");
  56     is(newSvNV("4.888"), 4, "dot not recognized in global comma locale for SvNV");
  57
  58     no warnings 'numeric';  # Otherwise get "Argument isn't numeric in
  59                             # subroutine entry"
  60
  61     is(check_in_bounds(newSvNV("4,888"), 4.88, 4.89), 1,
  62        "comma recognized in global comma locale for SvNV");
  63     isnt(sync_locale, 0, "sync_locale() returns that was in the global locale");
  64
  65     is(check_in_bounds(newSvNV("4.888"), 4.88, 4.89), 1,
  66     "dot recognized in perl-controlled comma locale for SvNV");
  67 }
  68
  69 my %correct_C_responses = (
  70         # Entries that are undef could have varying returns
  71                             ABDAY_1 => 'Sun',
  72                             ABDAY_2 => 'Mon',
  73                             ABDAY_3 => 'Tue',
  74                             ABDAY_4 => 'Wed',
  75                             ABDAY_5 => 'Thu',
  76                             ABDAY_6 => 'Fri',
  77                             ABDAY_7 => 'Sat',
  78                             ABMON_1 => 'Jan',
  79                             ABMON_2 => 'Feb',
  80                             ABMON_3 => 'Mar',
  81                             ABMON_4 => 'Apr',
  82                             ABMON_5 => 'May',
  83                             ABMON_6 => 'Jun',
  84                             ABMON_7 => 'Jul',
  85                             ABMON_8 => 'Aug',
  86                             ABMON_9 => 'Sep',
  87                             ABMON_10 => 'Oct',
  88                             ABMON_11 => 'Nov',
  89                             ABMON_12 => 'Dec',
  90                             ALT_DIGITS => undef,
  91                             AM_STR => 'AM',
  92                             CODESET => undef,
  93                             CRNCYSTR => undef,
  94                             DAY_1 => 'Sunday',
  95                             DAY_2 => 'Monday',
  96                             DAY_3 => 'Tuesday',
  97                             DAY_4 => 'Wednesday',
  98                             DAY_5 => 'Thursday',
  99                             DAY_6 => 'Friday',
 100                             DAY_7 => 'Saturday',
 101                             D_FMT => undef,
 102                             D_T_FMT => undef,
 103                             ERA => '',
 104                             ERA_D_FMT => undef,
 105                             ERA_D_T_FMT => undef,
 106                             ERA_T_FMT => undef,
 107                             MON_1 => 'January',
 108                             MON_2 => 'February',
 109                             MON_3 => 'March',
 110                             MON_4 => 'April',
 111                             MON_5 => 'May',
 112                             MON_6 => 'June',
 113                             MON_7 => 'July',
 114                             MON_8 => 'August',
 115                             MON_9 => 'September',
 116                             MON_10 => 'October',
 117                             MON_11 => 'November',
 118                             MON_12 => 'December',
 119                             NOEXPR => undef,
 120                             NOSTR => undef,
 121                             PM_STR => 'PM',
 122                             RADIXCHAR => '.',
 123                             THOUSEP => '',
 124                             T_FMT => undef,
 125                             T_FMT_AMPM => undef,
 126                             YESEXPR => undef,
 127                             YESSTR => undef,
 128                         );
 129
 130 my $hdr = "../../perl_langinfo.h";
 131 open my $fh, "<", $hdr;
 132 $|=1;
 133
 134 SKIP: {
 135     skip "No LC_ALL", 1 unless locales_enabled('LC_ALL');
 136
 137     use POSIX;
 138     setlocale(LC_ALL, "C");
 139     eval "use I18N::Langinfo qw(langinfo RADIXCHAR); langinfo(RADIXCHAR)";
 140     my $has_nl_langinfo = $@ eq "";
 141
 142     skip "Can't open $hdr for reading: $!", 1 unless $fh;
 143
 144     my %items;
 145
 146     # Find all the current items from the header, and their values.
 147     # For non-nl_langinfo systems, those values are arbitrary negative numbers
 148     # set in the header.  Otherwise they are the nl_langinfo approved values,
 149     # which for the moment is the item name.
 150     # The relevant lines look like: #  define YESSTR -54
 151     while (<$fh>) {
 152         chomp;
 153         next unless / - \d+ $ /x;
 154         s/ ^ \# \s* define \s*//x;
 155         m/ (.*) \  (.*) /x;
 156         $items{$1} = ($has_nl_langinfo)
 157                      ? $1       # Yields 'YESSTR'
 158                      : $2;      # Yields -54
 159     }
 160
 161     # Get the translation from item name to numeric value.
 162     I18N::Langinfo->import(keys %items) if $has_nl_langinfo;
 163
 164     foreach my $formal_item (sort keys %items) {
 165       SKIP:
 166         if (exists $correct_C_responses{$formal_item}) {
 167             my $correct = $correct_C_responses{$formal_item};
 168             my $item = eval $items{$formal_item};
 169             skip "This platform apparently doesn't support $formal_item", 1 if $@;
 170             my $result = test_Perl_langinfo($item);
 171             if (defined $correct) {
 172                 is ($result, $correct,
 173                     "Returns expected value" . "('$correct') for $formal_item");
 174             }
 175             elsif (defined $result) {
 176                 pass("Returns a value (in this case '$result') for $formal_item");
 177             }
 178             else {
 179                 fail("Returned undef for $formal_item");
 180             }
 181         }
 182     }
 183 }
 184
 185 done_testing();