=provides

__UNDEFINED__
Perl_setlocale
LOCK_NUMERIC_STANDARD
UNLOCK_NUMERIC_STANDARD

=implementation

#if PERL_VERSION_LT(5,27,9)
__UNDEFINED__ LC_NUMERIC_LOCK
__UNDEFINED__ LC_NUMERIC_UNLOCK
#  if PERL_VERSION_LT(5,19,0)
#    undef STORE_LC_NUMERIC_SET_STANDARD
#    undef RESTORE_LC_NUMERIC
#    undef DECLARATION_FOR_LC_NUMERIC_MANIPULATION
#    ifdef USE_LOCALE
__UNDEFINED__ DECLARATION_FOR_LC_NUMERIC_MANIPULATION char *LoC_
__UNDEFINED__ STORE_NUMERIC_SET_STANDARD()            \
	 LoC_ = savepv(setlocale(LC_NUMERIC, NULL));  \
	 SAVEFREEPV(LoC_);                            \
	 setlocale(LC_NUMERIC, "C");
__UNDEFINED__ RESTORE_LC_NUMERIC()                    \
	 setlocale(LC_NUMERIC, LoC_);
#    else
__UNDEFINED__ DECLARATION_FOR_LC_NUMERIC_MANIPULATION
__UNDEFINED__ STORE_LC_NUMERIC_SET_STANDARD()
__UNDEFINED__ RESTORE_LC_NUMERIC()
#    endif
#  endif
#endif

#ifndef LOCK_NUMERIC_STANDARD
#  define LOCK_NUMERIC_STANDARD()
#endif

#ifndef UNLOCK_NUMERIC_STANDARD
#  define UNLOCK_NUMERIC_STANDARD()
#endif

/* The names of these changed in 5.28 */
__UNDEFINED__ LOCK_LC_NUMERIC_STANDARD    LOCK_NUMERIC_STANDARD
__UNDEFINED__ UNLOCK_LC_NUMERIC_STANDARD  UNLOCK_NUMERIC_STANDARD

/* If this doesn't exist, it's not needed, so is void noop */
__UNDEFINED__  switch_to_global_locale()

/* Originally, this didn't return a value, but in perls like that, the value
 * should always be TRUE.  Add a return to Perl_sync_locale() when it's
 * available.  And actually do a sync when its not, if locales are available on
 * this system. */
#ifdef sync_locale
#  if { VERSION < 5.27.9 }
#    if { VERSION >= 5.21.3 }
#      undef sync_locale
#      define sync_locale() (Perl_sync_locale(aTHX), 1)
#    elif defined(sync_locale)  /* These should only be the 5.20 maints*/
#      undef sync_locale        /* Just copy their defn and return 1 */
#      define sync_locale() (new_ctype(setlocale(LC_CTYPE, NULL)),        \
                             new_collate(setlocale(LC_COLLATE, NULL)),    \
                             set_numeric_local(),                         \
                             new_numeric(setlocale(LC_NUMERIC, NULL)),    \
                             1)
#    elif defined(new_ctype) && defined(LC_CTYPE)
#      define sync_locale() (new_ctype(setlocale(LC_CTYPE, NULL)), 1)
#    endif
#  endif
#endif

__UNDEFINED__ sync_locale() 1

/* Warning: Perl_setlocale
 * This function will compile and run in even the earliest perls supported by
 * PPPort, but there were significant locale-related bugs that may prevent its
 * proper operation until v5.22.  The final bugs to be fixed in the releases
 * leading up to that one involved setting and querying the locale for
 * LC_NUMERIC. */

#if { VERSION < 5.27.2 }
#  if { NEED Perl_setlocale }

const char *
Perl_setlocale(const int category, const char * locale)
{
    CV * setlocale;
    dTHX;

#    ifdef D_PPP_usechar

    char * locale_afterwards;
    dSP;

#    else

    SV * locale_afterwards;
    dXSARGS;

#    endif

    load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("POSIX"), NULL);
    setlocale = get_cv("POSIX::setlocale", 0);
    assert(setlocale);

#    if defined(PUSHSTACKi) && defined(PERLSI_REQUIRE) && defined(POPSTACK)

    PUSHSTACKi(PERLSI_REQUIRE);

#    endif

    ENTER ;
    SAVETMPS;

    PUSHMARK(SP) ;
    mXPUSHi(category);
    mXPUSHp(locale, strlen(locale));
    PUTBACK;
    call_sv(MUTABLE_SV(setlocale), G_SCALAR);

    SPAGAIN ;

#    ifdef D_PPP_usechar

    locale_afterwards = POPp;

#    else

    locale_afterwards = POPs;
    SvREFCNT_inc_simple_void_NN(locale_afterwards);

#    endif

    PUTBACK ;
    FREETMPS ;
    LEAVE ;

#    if defined(PUSHSTACKi) && defined(PERLSI_REQUIRE) && defined(POPSTACK)

    POPSTACK;

#    endif
#    ifdef D_PPP_usechar

    return(locale_afterwards);

#    else

    if (! SvPOK(locale_afterwards)) {
        XSRETURN_UNDEF;
    }

    return(savepv(SvPVX_const(locale_afterwards)));

#    endif

}

#  endif
#endif

=xsinit

#define NEED_Perl_setlocale

=xsubs

bool
sync_locale()
        CODE:
            RETVAL = sync_locale();
        OUTPUT:
            RETVAL

char *
Perl_setlocale(locale = 0)
	char *    locale
    PREINIT:
	char *		retval;
    CODE:
        /*const in input not valid in 5.7.0 */
	retval = (char *) Perl_setlocale(LC_ALL, locale);
        if (! retval) {
            XSRETURN_UNDEF;
        }
        RETVAL = retval;
    OUTPUT:
	RETVAL

=tests plan => 2

use Config;

# We don't know for sure that we are in the global locale for testing.  But
# if this is unthreaded, it almost certainly is.  But Configure can be called
# to force POSIX locales on unthreaded systems.  If this becomes a problem
# this check could be beefed up.
if ($Config{usethreads}) {
    ok(1, "ironically we have to skip testing sync_locale under threads");
}
else {
    ok(&Devel::PPPort::sync_locale(), "sync_locale returns TRUE");
}

is(&Devel::PPPort::Perl_setlocale("C"), "C", "setlocale returns 'C' when setting to 'C'");