/*
* Set up for a new numeric locale.
*/
void
Perl_new_numeric(pTHX_ const char *newnum)
{
#ifdef USE_LOCALE_NUMERIC
dVAR;
if (! newnum) {
Safefree(PL_numeric_name);
PL_numeric_name = NULL;
PL_numeric_standard = TRUE;
PL_numeric_local = TRUE;
return;
}
if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) {
Safefree(PL_numeric_name);
PL_numeric_name = stdize_locale(savepv(newnum));
PL_numeric_standard = ((*newnum == 'C' && newnum[1] == '\0')
|| strEQ(newnum, "POSIX"));
PL_numeric_local = TRUE;
set_numeric_radix();
}
#endif /* USE_LOCALE_NUMERIC */
}
HV*
Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
{
char smallbuf[256];
char *tmpbuf;
HV *stash;
GV *tmpgv;
if (namelen + 3 < sizeof smallbuf)
tmpbuf = smallbuf;
else
New(606, tmpbuf, namelen + 3, char);
Copy(name,tmpbuf,namelen,char);
tmpbuf[namelen++] = ':';
tmpbuf[namelen++] = ':';
tmpbuf[namelen] = '\0';
tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
if (!tmpgv)
return 0;
if (!GvHV(tmpgv))
GvHV(tmpgv) = newHV();
stash = GvHV(tmpgv);
if (!HvNAME(stash))
HvNAME(stash) = savepv(name);
return stash;
}
void run(const std::string& input) {
std::string output;
const char* a = input.c_str();
{
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
//XPUSHs(sv_2mortal(newSVpv(a, 0)));
PUTBACK;
//int count = call_pv("test_method", G_SCALAR);
int count = call_pv("test_method", G_SCALAR | G_NOARGS);
SPAGAIN;
if (count > 0) {
char* ptr = savepv(POPp);
if (ptr) {
output = std::string(ptr);
}
}
FREETMPS;
LEAVE;
}
std::cout << "in: " << input << std::endl;
std::cout << "out: " << output << std::endl;
}
/*
* Set up for a new collation locale.
*/
void
Perl_new_collate(pTHX_ const char *newcoll)
{
#ifdef USE_LOCALE_COLLATE
dVAR;
if (! newcoll) {
if (PL_collation_name) {
++PL_collation_ix;
Safefree(PL_collation_name);
PL_collation_name = NULL;
}
PL_collation_standard = TRUE;
PL_collxfrm_base = 0;
PL_collxfrm_mult = 2;
return;
}
if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
++PL_collation_ix;
Safefree(PL_collation_name);
PL_collation_name = stdize_locale(savepv(newcoll));
PL_collation_standard = ((*newcoll == 'C' && newcoll[1] == '\0')
|| strEQ(newcoll, "POSIX"));
{
/* 2: at most so many chars ('a', 'b'). */
/* 50: surely no system expands a char more. */
#define XFRMBUFSIZE (2 * 50)
char xbuf[XFRMBUFSIZE];
const Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE);
const Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
const SSize_t mult = fb - fa;
if (mult < 1 && !(fa == 0 && fb == 0))
Perl_croak(aTHX_ "panic: strxfrm() gets absurd - a => %"UVuf", ab => %"UVuf,
(UV) fa, (UV) fb);
PL_collxfrm_base = (fa > (Size_t)mult) ? (fa - mult) : 0;
PL_collxfrm_mult = mult;
}
}
#endif /* USE_LOCALE_COLLATE */
}
/*
* Initialize locale awareness.
*/
int
Perl_init_i18nl10n(pTHX_ int printwarn)
{
int ok = 1;
/* returns
* 1 = set ok or not applicable,
* 0 = fallback to C locale,
* -1 = fallback to C locale failed
*/
#if defined(USE_LOCALE)
#ifdef USE_LOCALE_CTYPE
char *curctype = NULL;
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
char *curcoll = NULL;
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
char *curnum = NULL;
#endif /* USE_LOCALE_NUMERIC */
#ifdef __GLIBC__
char *language = PerlEnv_getenv("LANGUAGE");
#endif
char *lc_all = PerlEnv_getenv("LC_ALL");
char *lang = PerlEnv_getenv("LANG");
bool setlocale_failure = FALSE;
#ifdef LOCALE_ENVIRON_REQUIRED
/*
* Ultrix setlocale(..., "") fails if there are no environment
* variables from which to get a locale name.
*/
bool done = FALSE;
#ifdef LC_ALL
if (lang) {
if (setlocale(LC_ALL, ""))
done = TRUE;
else
setlocale_failure = TRUE;
}
if (!setlocale_failure) {
#ifdef USE_LOCALE_CTYPE
if (! (curctype =
setlocale(LC_CTYPE,
(!done && (lang || PerlEnv_getenv("LC_CTYPE")))
? "" : Nullch)))
setlocale_failure = TRUE;
else
curctype = savepv(curctype);
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
if (! (curcoll =
setlocale(LC_COLLATE,
(!done && (lang || PerlEnv_getenv("LC_COLLATE")))
? "" : Nullch)))
setlocale_failure = TRUE;
else
curcoll = savepv(curcoll);
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
if (! (curnum =
setlocale(LC_NUMERIC,
(!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
? "" : Nullch)))
setlocale_failure = TRUE;
else
curnum = savepv(curnum);
#endif /* USE_LOCALE_NUMERIC */
}
#endif /* LC_ALL */
#endif /* !LOCALE_ENVIRON_REQUIRED */
#ifdef LC_ALL
if (! setlocale(LC_ALL, ""))
setlocale_failure = TRUE;
#endif /* LC_ALL */
if (!setlocale_failure) {
#ifdef USE_LOCALE_CTYPE
if (! (curctype = setlocale(LC_CTYPE, "")))
setlocale_failure = TRUE;
else
curctype = savepv(curctype);
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
if (! (curcoll = setlocale(LC_COLLATE, "")))
setlocale_failure = TRUE;
else
curcoll = savepv(curcoll);
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
if (! (curnum = setlocale(LC_NUMERIC, "")))
setlocale_failure = TRUE;
else
curnum = savepv(curnum);
#endif /* USE_LOCALE_NUMERIC */
}
if (setlocale_failure) {
char *p;
bool locwarn = (printwarn > 1 ||
(printwarn &&
(!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
if (locwarn) {
#ifdef LC_ALL
PerlIO_printf(Perl_error_log,
"perl: warning: Setting locale failed.\n");
#else /* !LC_ALL */
PerlIO_printf(Perl_error_log,
"perl: warning: Setting locale failed for the categories:\n\t");
#ifdef USE_LOCALE_CTYPE
if (! curctype)
PerlIO_printf(Perl_error_log, "LC_CTYPE ");
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
if (! curcoll)
PerlIO_printf(Perl_error_log, "LC_COLLATE ");
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
if (! curnum)
PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
#endif /* USE_LOCALE_NUMERIC */
PerlIO_printf(Perl_error_log, "\n");
#endif /* LC_ALL */
PerlIO_printf(Perl_error_log,
"perl: warning: Please check that your locale settings:\n");
#ifdef __GLIBC__
PerlIO_printf(Perl_error_log,
"\tLANGUAGE = %c%s%c,\n",
language ? '"' : '(',
language ? language : "unset",
language ? '"' : ')');
#endif
PerlIO_printf(Perl_error_log,
"\tLC_ALL = %c%s%c,\n",
lc_all ? '"' : '(',
lc_all ? lc_all : "unset",
lc_all ? '"' : ')');
#if defined(USE_ENVIRON_ARRAY)
{
char **e;
for (e = environ; *e; e++) {
if (strnEQ(*e, "LC_", 3)
&& strnNE(*e, "LC_ALL=", 7)
&& (p = strchr(*e, '=')))
PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
(int)(p - *e), *e, p + 1);
}
}
#else
PerlIO_printf(Perl_error_log,
"\t(possibly more locale environment variables)\n");
#endif
PerlIO_printf(Perl_error_log,
"\tLANG = %c%s%c\n",
lang ? '"' : '(',
lang ? lang : "unset",
lang ? '"' : ')');
PerlIO_printf(Perl_error_log,
" are supported and installed on your system.\n");
}
#ifdef LC_ALL
if (setlocale(LC_ALL, "C")) {
if (locwarn)
PerlIO_printf(Perl_error_log,
"perl: warning: Falling back to the standard locale (\"C\").\n");
ok = 0;
}
else {
if (locwarn)
PerlIO_printf(Perl_error_log,
"perl: warning: Failed to fall back to the standard locale (\"C\").\n");
ok = -1;
}
#else /* ! LC_ALL */
if (0
#ifdef USE_LOCALE_CTYPE
|| !(curctype || setlocale(LC_CTYPE, "C"))
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
|| !(curcoll || setlocale(LC_COLLATE, "C"))
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
|| !(curnum || setlocale(LC_NUMERIC, "C"))
#endif /* USE_LOCALE_NUMERIC */
)
{
if (locwarn)
PerlIO_printf(Perl_error_log,
"perl: warning: Cannot fall back to the standard locale (\"C\").\n");
ok = -1;
}
#endif /* ! LC_ALL */
#ifdef USE_LOCALE_CTYPE
curctype = savepv(setlocale(LC_CTYPE, Nullch));
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
curcoll = savepv(setlocale(LC_COLLATE, Nullch));
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
curnum = savepv(setlocale(LC_NUMERIC, Nullch));
#endif /* USE_LOCALE_NUMERIC */
}
else {
#ifdef USE_LOCALE_CTYPE
new_ctype(curctype);
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
new_collate(curcoll);
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
new_numeric(curnum);
#endif /* USE_LOCALE_NUMERIC */
}
#endif /* USE_LOCALE */
#ifdef USE_PERLIO
{
/* Set PL_utf8locale to TRUE if using PerlIO _and_
any of the following are true:
- nl_langinfo(CODESET) contains /^utf-?8/i
- $ENV{LC_ALL} contains /^utf-?8/i
- $ENV{LC_CTYPE} contains /^utf-?8/i
- $ENV{LANG} contains /^utf-?8/i
The LC_ALL, LC_CTYPE, LANG obey the usual override
hierarchy of locale environment variables. (LANGUAGE
affects only LC_MESSAGES only under glibc.) (If present,
it overrides LC_MESSAGES for GNU gettext, and it also
can have more than one locale, separated by spaces,
in case you need to know.)
If PL_utf8locale and PL_unicode (set by -C or by $ENV{PERL_UNICODE})
are true, perl.c:S_parse_body() will turn on the PerlIO :utf8 layer
on STDIN, STDOUT, STDERR, _and_ the default open discipline.
*/
bool utf8locale = FALSE;
char *codeset = NULL;
#if defined(HAS_NL_LANGINFO) && defined(CODESET)
codeset = nl_langinfo(CODESET);
#endif
if (codeset)
utf8locale = (ibcmp(codeset, "UTF-8", 5) == 0 ||
ibcmp(codeset, "UTF8", 4) == 0);
#if defined(USE_LOCALE)
else { /* nl_langinfo(CODESET) is supposed to correctly
* interpret the locale environment variables,
* but just in case it fails, let's do this manually. */
if (lang)
utf8locale = (ibcmp(lang, "UTF-8", 5) == 0 ||
ibcmp(lang, "UTF8", 4) == 0);
#ifdef USE_LOCALE_CTYPE
if (curctype)
utf8locale = (ibcmp(curctype, "UTF-8", 5) == 0 ||
ibcmp(curctype, "UTF8", 4) == 0);
#endif
if (lc_all)
utf8locale = (ibcmp(lc_all, "UTF-8", 5) == 0 ||
ibcmp(lc_all, "UTF8", 4) == 0);
}
#endif /* USE_LOCALE */
if (utf8locale)
PL_utf8locale = TRUE;
}
/* Set PL_unicode to $ENV{PERL_UNICODE} if using PerlIO.
This is an alternative to using the -C command line switch
(the -C if present will override this). */
{
char *p = PerlEnv_getenv("PERL_UNICODE");
PL_unicode = p ? parse_unicode_opts(&p) : 0;
}
#endif
#ifdef USE_LOCALE_CTYPE
Safefree(curctype);
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
Safefree(curcoll);
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
Safefree(curnum);
#endif /* USE_LOCALE_NUMERIC */
return ok;
}
void
my_xsinit(pTHX)
{
dVAR;
static const char file[] = __FILE__;
#ifdef USE_CTRLX
GV *ctrlXgv;
SV *ctrlX;
#endif
#ifdef USE_SUBFILE
if (PL_preprocess)
croak("Can't use -P with pl2exe");
#endif
#ifdef NEED_INIT_WIN32CORE
init_Win32CORE(aTHX);
#endif
#ifdef USE_ZIP
pl2exe_boot_zip(aTHX);
#endif
#ifdef NEED_PREAMBLE
newXS("ExtUtils::PerlToExe::preamble",
XS_ExtUtils_PerlToExe_preamble,
file);
if (!PL_preambleav)
PL_preambleav = newAV();
av_push(PL_preambleav,
newSVpvs("BEGIN { ExtUtils::PerlToExe::preamble() }"));
#endif
#ifdef NEED_TAINT
TAINT;
TAINT_PROPER("appended " TAINT_TYPE);
TAINT_NOT;
#endif
#ifdef USE_CTRLX
ctrlXgv = gv_fetchpvs("\030", GV_NOTQUAL, SVt_PV);
ctrlX = GvSV(ctrlXgv);
/*
* We can't reopen PL_rsfp yet as it hasn't been set (the file is
* open, it's just in an auto variable in S_parse_body). However,
* it's easier to fixup the name here, before gv_fetch_file gets
* called on it.
*/
PL_origfilename = savepv(SvPV_nolen(ctrlX));
CopFILE_free(PL_curcop);
CopFILE_set(PL_curcop, PL_origfilename);
sv_setpv(ctrlX, CTRL_X);
SvTAINTED_on(ctrlX);
#endif
#ifdef USE_ZIP
pl2exe_load_zip(aTHX_ PL_origfilename);
#endif
real_xsinit(aTHX);
}
regexp* hook_regcompp (pTHX_ char* exp, char* xend, PMOP* pm)
{
SV* handler = NULL;
/* fprintf(stderr,"hook_regcompp in %lx\n",(unsigned long)exp); */
/* Check $^H for lexical selection of semantics and implementation */
if(handler == NULL) {
const char hint_key[] = "regcompp";
SV** phandler;
HV* hints;
hints = get_hv("\b",0);
if(hints != NULL) {
phandler = hv_fetch(hints, hint_key, strlen(hint_key), 0);
if(phandler != NULL) {
handler = *phandler;
/* fprintf(stderr,"hook_regcompp lexical...%lx\n",(unsigned long)handler); */
/* call_sv(handler,G_DISCARD|G_EVAL);
fprintf(stderr,"can survive %lx %lx\n",(unsigned long)exp,(unsigned long)handler);
*/
}
}
}
/* Check $re::override::regcompp
for a dynamic selection of implementation */
if(handler == NULL) {
SV* sv;
sv = get_sv("$re::override::regcompp",0);
if(sv != NULL && sv != &PL_sv_undef) {
/* fprintf(stderr,"hook_regcompp dynamic...\n"); */
handler = sv;
}
}
/* If no handlers, then hand off */
if(handler == NULL) {
/* fprintf(stderr,"hook_regcompp punt.\n"); */
return previous_comp_hook(aTHX_ exp,xend,pm);
}
{
dSP;
char *nulpat;
regexp* r;
I32 ret;
I32 api;
nulpat = savepv(""); /*XXX - can be constant? */
r = Perl_pregcomp(aTHX_ nulpat,nulpat,pm);
/*XXX - can free nulpat now? */
/* fprintf(stderr,"exp =%lu\nxend=%lu\n",(unsigned long)exp,(unsigned long)xend);*/
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpvn(exp,xend-exp)));
mXPUSHu((unsigned long)r);
PUTBACK;
HANDLER_CALL:
/* fprintf(stderr,"calling out...\n");*/
ret = call_sv(handler, G_ARRAY);
/* fprintf(stderr,"...back.\n");*/
SPAGAIN;
api = POPi;
if(api == 13) {
SV* pat;
long nparens;
SV* exec_callback_sub;
/* fprintf(stderr,"api 13\n");*/
if(ret != 4) {
fprintf(stderr,"api 13 violation\n"); exit(0);
}
pat = POPs;
nparens = POPl;
exec_callback_sub = POPs;
PUTBACK;
regexp_setup(aTHX_ r,pat,nparens,exec_callback_sub);
} else if(api == 14) {
SV* expr_code;
SV* expr_result;
/* fprintf(stderr,"api 14\n");*/
if(ret != 3) {
fprintf(stderr,"api 14 violation\n"); exit(0);
}
handler = SvREFCNT_inc(POPs); /*XXX needed? */
expr_code = POPs;
PUTBACK;
expr_result = eval_pv(SvPV_nolen(expr_code),0);
SPAGAIN;
XPUSHs(expr_result);
PUTBACK;
goto HANDLER_CALL;
} else {
fprintf(stderr,"api UNKNOWN violation\n"); exit(0);
}
/* fprintf(stderr,"hook_regcompp done.\n"); */
return r;
}
}
