void
Perl_boot_core_xsutils(pTHX)
{
SV* xsfile = newSVpv_share(__FILE__, 0);
/* static internal builtins */
boot_strict(aTHX_ xsfile);
boot_attributes(aTHX_ xsfile);
#if 0
boot_Carp(aTHX_ xsfile);
/* static_xs: not with miniperl */
newXS("Exporter::boot_Exporter", boot_Exporter, file);
newXS("XSLoader::boot_XSLoader", boot_XSLoader, file);
boot_Exporter(aTHX_ xsfile);
boot_XSLoader(aTHX_ xsfile);
/* shared xs: if as generated external modules only, without .pm */
newXS("warnings::bootstrap", XS_warnings_bootstrap, file);
newXS("Config::bootstrap", XS_Config_bootstrap, file);
newXS("unicode::bootstrap", XS_unicode_bootstrap, file);
xs_incset(aTHX_ STR_WITH_LEN("warnings.pm"), xsfile);
xs_incset(aTHX_ STR_WITH_LEN("Config.pm"), xsfile);
xs_incset(aTHX_ STR_WITH_LEN("utf8_heavy.pl"), xsfile);
#endif
#ifdef USE_CPERL
boot_coretypes(aTHX_ xsfile);
boot_core_cperl(aTHX);
#endif
}
static void
op_names_init(pTHX)
{
int i;
STRLEN len;
char **op_names;
char *bitmap;
dMY_CXT;
op_named_bits = newHV();
op_names = get_op_names();
for(i=0; i < PL_maxo; ++i) {
SV * const sv = newSViv(i);
SvREADONLY_on(sv);
(void) hv_store(op_named_bits, op_names[i], strlen(op_names[i]), sv, 0);
}
put_op_bitspec(aTHX_ STR_WITH_LEN(":none"), sv_2mortal(new_opset(aTHX_ Nullsv)));
opset_all = new_opset(aTHX_ Nullsv);
bitmap = SvPV(opset_all, len);
memset(bitmap, 0xFF, len-1); /* deal with last byte specially, see below */
/* Take care to set the right number of bits in the last byte */
bitmap[len-1] = (PL_maxo & 0x07) ? ~(0xFF << (PL_maxo & 0x07)) : 0xFF;
put_op_bitspec(aTHX_ STR_WITH_LEN(":all"), opset_all); /* don't mortalise */
}
static void
boot_strict(pTHX_ SV *xsfile)
{
Perl_set_version(aTHX_ STR_WITH_LEN("strict::VERSION"), STR_WITH_LEN("1.10c"), 1.10);
newXS("strict::bits", XS_strict_bits, file);
newXS("strict::import", XS_strict_import, file);
newXS("strict::unimport", XS_strict_unimport, file);
xs_incset(aTHX_ STR_WITH_LEN("strict.pm"), xsfile);
}
static void
boot_attributes(pTHX_ SV *xsfile)
{
Perl_set_version(aTHX_ STR_WITH_LEN("attributes::VERSION"), STR_WITH_LEN("1.10c"), 1.10);
newXS("attributes::bootstrap", XS_attributes_bootstrap,file);
newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
newXSproto("attributes::reftype", XS_attributes_reftype, file, "$");
/*newXS("attributes::import", XS_attributes_import, file);*/
newXSproto("attributes::get", XS_attributes_get, file, "$");
/*xs_incset(aTHX_ STR_WITH_LEN("attributes.pm"), xsfile); not yet fully converted */
}
/* initialize our core types */
static void
boot_coretypes(pTHX_ SV *xsfile)
{
AV *isa; HV *stash;
DEF_CORETYPE_1("Int");
DEF_CORETYPE_1("Num");
DEF_CORETYPE_1("Str");
DEF_CORETYPE("UInt");
TYPE_EXTENDS_1("UInt", "Int");
/* native types */
DEF_CORETYPE_1("int");
DEF_CORETYPE_1("num");
DEF_CORETYPE_1("str");
DEF_CORETYPE("uint");
TYPE_EXTENDS_1("uint", "int");
#if 0
/* Extended versions, needed only for user types, not core types */
DEF_CORETYPE_1("Undef");
/* Note: (:Int?) is taken for an optional argument (:Int|:Void),
and :?Int for (:Int|:Undef) */
DEF_CORETYPE("?Int"); /* type alias for (:Int|:Undef) */
TYPE_EXTENDS_2("?Int", "Int", "Undef");
DEF_CORETYPE("?Num");
TYPE_EXTENDS_2("?Num", "Num", "Undef");
DEF_CORETYPE("?Str");
TYPE_EXTENDS_2("?Str", "Str", "Undef");
DEF_CORETYPE_1("Bool");
DEF_CORETYPE_1("Numeric");
DEF_CORETYPE_1("Scalar");
DEF_CORETYPE_1("Ref");
DEF_CORETYPE_1("Sub"); /* Callable */
DEF_CORETYPE_1("Array");
DEF_CORETYPE_1("Hash");
DEF_CORETYPE_1("List");
DEF_CORETYPE_1("Any");
DEF_CORETYPE_1("Void"); /* needed */
#endif
Perl_set_version(aTHX_ STR_WITH_LEN("coretypes::VERSION"), STR_WITH_LEN("0.02c"), 0.02);
xs_incset(aTHX_ STR_WITH_LEN("coretypes.pm"), xsfile);
}
/*
* Unlocks the flash memory for programming.
*/
error_t flash_unlock() {
if (FLASH_CR & FLASH_LOCK) {
FLASH_KEYR = FLASH_KEY1;
FLASH_KEYR = FLASH_KEY2;
// Check if unlock was successful.
if (FLASH_CR & FLASH_LOCK) {
error(ER_BUG, STR_WITH_LEN("Flash unlocking failed"), EA_PANIC);
}
}
return E_SUCCESS;
}
MVMObject * MVM_proc_getenvhash(MVMThreadContext *tc) {
MVMInstance * const instance = tc->instance;
MVMObject * env_hash;
#ifdef _WIN32
const MVMuint16 acp = GetACP(); /* We should get ACP at runtime. */
#endif
MVMuint32 pos = 0;
MVMString *needle = MVM_string_ascii_decode(tc, instance->VMString, STR_WITH_LEN("="));
char *env;
MVM_gc_root_temp_push(tc, (MVMCollectable **)&needle);
env_hash = MVM_repr_alloc_init(tc, MVM_hll_current(tc)->slurpy_hash_type);
MVM_gc_root_temp_push(tc, (MVMCollectable **)&env_hash);
while ((env = environ[pos++]) != NULL) {
#ifndef _WIN32
MVMString *str = MVM_string_utf8_c8_decode(tc, instance->VMString, env, strlen(env));
#else
char * const _env = ANSIToUTF8(acp, env);
MVMString *str = MVM_string_utf8_c8_decode(tc, instance->VMString, _env, strlen(_env));
#endif
MVMuint32 index = MVM_string_index(tc, str, needle, 0);
MVMString *key, *val;
MVMObject *box;
#ifdef _WIN32
MVM_free(_env);
#endif
MVM_gc_root_temp_push(tc, (MVMCollectable **)&str);
key = MVM_string_substring(tc, str, 0, index);
MVM_gc_root_temp_push(tc, (MVMCollectable **)&key);
val = MVM_string_substring(tc, str, index + 1, -1);
box = MVM_repr_box_str(tc, MVM_hll_current(tc)->str_box_type, val);
MVM_repr_bind_key_o(tc, env_hash, key, box);
MVM_gc_root_temp_pop_n(tc, 2);
}
MVM_gc_root_temp_pop_n(tc, 2);
return env_hash;
}
/*
* Erases a page in flash. base_addr must point to the beginning of
* the page.
*/
error_t flash_erase_page(void *base_addr) {
#ifdef TRACE_FLASH
debug_string("Erasing flash page at ");
debug_hex(base_addr, 8);
debug_string(CRLF);
#endif
while(FLASH_SR & FLASH_BSY);
if (FLASH_CR & FLASH_LOCK)
error(ER_BUG, STR_WITH_LEN("Flash is locked"), EA_PANIC);
FLASH_CR |= FLASH_PER;
FLASH_AR = (uint32_t) base_addr;
FLASH_CR |= FLASH_STRT;
error_t error = flash_check_error();
FLASH_CR &= ~FLASH_PER;
if (error) return error;
// Verify
uint16_t *start = (uint16_t*) base_addr;
for (uint16_t *i = start;
i < start + FLASH_PAGE_SIZE/sizeof(uint16_t);
i++) {
if (*i != 0xffff) {
#ifdef TRACE_FLASH
debug_string("Verification failed at ");
debug_hex(i, 8);
debug_string(" with ");
debug_hex(*i, 8);
debug_string(CRLF);
#endif
return E_FLASH_WRITE;
}
}
return E_SUCCESS;
}
// This function reads the various JavaBin datatypes and returns a Perl SV.
// Different datatypes are jumped to view a lookup in an array of computed gotos.
//
// The first group (undef to enum) use the entire tag for the index of the type.
//
// The second are matched by taking the tag byte, shifting it by 5 so to only read
// the first 3 bits of the tag byte, giving it a range or 0-7 inclusive.
//
// To store both in one array the second group have 18 added to them. See DISPATCH.
//
// The remaining 5 bits can then be used to store the size of the datatype, e.g. how
// many chars in a string, this therefore has a range of 0-31, if the size exceeds or
// matches this then an additional vint is added.
//
// The overview of the tag byte is therefore TTTSSSSS with T and S being type and size.
static SV* read_sv(pTHX) {
void* dispatch[] = {
&&read_undef,
&&read_bool,
&&read_bool,
&&read_byte,
&&read_short,
&&read_double,
&&read_int,
&&read_long,
&&read_float,
&&read_date,
&&read_map,
&&read_solr_doc,
&&read_solr_doc_list,
&&read_byte_array,
&&read_iterator,
NULL,
NULL,
NULL,
&&read_enum,
&&read_string,
&&read_small_int,
&&read_small_long,
&&read_array,
&&read_map,
&&read_map,
};
in++;
goto *dispatch[in[-1] >> 5 ? (in[-1] >> 5) + 18 : in[-1]];
read_undef:
return &PL_sv_undef;
read_bool: {
SV *rv = newSV_type(SVt_IV), *sv = in[-1] == 1 ? bool_true : bool_false;
SvREFCNT(sv)++;
SvROK_on(rv);
SvRV_set(rv, sv);
return rv;
}
read_byte:
return newSViv((int8_t) *in++);
read_short: {
const int16_t s = in[0] << 8 | in[1];
in += 2;
return newSViv(s);
}
read_double: {
// For perls with double length NVs this conversion is simple.
// Read 8 bytes, cast to double, return. For long double perls
// more magic is used, see read_float for more details.
const int_double u = { (uint64_t) in[0] << 56 |
(uint64_t) in[1] << 48 |
(uint64_t) in[2] << 40 |
(uint64_t) in[3] << 32 |
(uint64_t) in[4] << 24 |
(uint64_t) in[5] << 16 |
(uint64_t) in[6] << 8 |
(uint64_t) in[7] };
in += 8;
#ifdef USE_LONG_DOUBLE
char *str = alloca(snprintf(NULL, 0, "%.14f", u.d));
sprintf(str, "%.14f", u.d);
return newSVnv(strtold(str, NULL));
#else
return newSVnv(u.d);
#endif
}
read_int: {
const int32_t i = in[0] << 24 | in[1] << 16 | in[2] << 8 | in[3];
in += 4;
return newSViv(i);
}
read_long: {
const int64_t l = (uint64_t) in[0] << 56 |
(uint64_t) in[1] << 48 |
(uint64_t) in[2] << 40 |
(uint64_t) in[3] << 32 |
(uint64_t) in[4] << 24 |
(uint64_t) in[5] << 16 |
(uint64_t) in[6] << 8 |
(uint64_t) in[7];
in += 8;
return newSViv(l);
}
read_float: {
// JavaBin has a 4byte float format, NVs in perl are double or long double,
// therefore a little magic is required. Read the 4 bytes into an int in the
// correct endian order. Re-read these bits as a float, stringify this float,
// then finally numify the string into a double or long double.
const int_float u = { in[0] << 24 | in[1] << 16 | in[2] << 8 | in[3] };
in += 4;
char *str = alloca(snprintf(NULL, 0, "%f", u.f));
sprintf(str, "%f", u.f);
#ifdef USE_LONG_DOUBLE
return newSVnv(strtold(str, NULL));
#else
return newSVnv(strtod(str, NULL));
#endif
}
read_date: {
const int64_t date_ms = (uint64_t) in[0] << 56 |
(uint64_t) in[1] << 48 |
(uint64_t) in[2] << 40 |
(uint64_t) in[3] << 32 |
(uint64_t) in[4] << 24 |
(uint64_t) in[5] << 16 |
(uint64_t) in[6] << 8 |
(uint64_t) in[7];
in += 8;
const time_t date = date_ms / 1000;
const struct tm *t = gmtime(&date);
char date_str[25];
sprintf(date_str, "%u-%02u-%02uT%02u:%02u:%02u.%03uZ", t->tm_year + 1900,
t->tm_mon + 1,
t->tm_mday,
t->tm_hour,
t->tm_min,
t->tm_sec,
(uint32_t) (date_ms % 1000));
return newSVpvn(date_str, 24);
}
read_solr_doc:
in++; // Assume a solr doc is a map.
read_map: {
HV *hv = (HV*)newSV_type(SVt_PVHV);
uint32_t len = in[-1] >> 5 ? READ_LEN : read_v_int();
while (len--) {
cached_key key;
in++;
const uint32_t i = READ_LEN;
if (i)
key = cached_keys[i];
else {
in++;
cached_keys[++cache_pos] = key = (cached_key){ (char*)in, 0, READ_LEN };
uint8_t *key_str = in;
in += key.len;
// Set the UTF8 flag if we hit a high byte.
while (key_str != in) {
if (*key_str++ & 128) {
key.flags = HVhek_UTF8;
break;
}
}
}
hv_common(hv, NULL, key.key, key.len, key.flags, HV_FETCH_ISSTORE, read_sv(aTHX), 0);
}
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV_set(rv, (SV*)hv);
return rv;
}
read_solr_doc_list: {
HV *hv = (HV*)newSV_type(SVt_PVHV);
// Assume values are in an array, skip tag & read_sv.
in++;
hv_set(hv, "numFound", read_sv(aTHX), numFound);
hv_set(hv, "start", read_sv(aTHX), start);
hv_set(hv, "maxScore", read_sv(aTHX), maxScore);
hv_set(hv, "docs", read_sv(aTHX), docs);
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV_set(rv, (SV*)hv);
return rv;
}
read_byte_array: {
AV *av = (AV*)newSV_type(SVt_PVAV);
SSize_t len = read_v_int();
SV **ary = safemalloc(len * sizeof(SV*));
AvALLOC(av) = AvARRAY(av) = ary;
AvFILLp(av) = AvMAX(av) = len - 1;
while (len--)
*ary++ = newSViv((int8_t) *in++);
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV_set(rv, (SV*)av);
return rv;
}
read_iterator: {
AV *av = (AV*)newSV_type(SVt_PVAV);
uint32_t len = 0;
while (*in != 15)
av_store(av, len++, read_sv(aTHX));
in++;
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV_set(rv, (SV*)av);
return rv;
}
read_enum: {
SV *sv = read_sv(aTHX); // small_int if +ve, int otherwise.
sv_upgrade(sv, SVt_PVMG);
in++;
const STRLEN len = READ_LEN;
char *str = sv_grow(sv, len + 1);
memcpy(str, in, len);
in += len;
str[len] = '\0';
SvCUR(sv) = len;
SvFLAGS(sv) = SVf_IOK | SVp_IOK | SVs_OBJECT | SVf_POK | SVp_POK | SVt_PVMG | SVf_UTF8;
HV *stash = CALL(gv_stashpvn, STR_WITH_LEN("JavaBin::Enum"), 0);
SvREFCNT(stash)++;
SvSTASH_set(sv, stash);
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV_set(rv, sv);
return rv;
}
read_string: {
const STRLEN len = READ_LEN;
SV *sv = newSV_type(SVt_PV);
char *str = SvPVX(sv) = (char*)safemalloc(len);
memcpy(str, in, len);
SvCUR(sv) = SvLEN(sv) = len;
SvFLAGS(sv) |= SVf_POK | SVp_POK | SVf_UTF8;
in += len;
return sv;
}
read_small_int: {
uint32_t result = in[-1] & 15;
if (in[-1] & 16)
result |= read_v_int() << 4;
return newSViv(result);
}
read_small_long: {
uint64_t result = in[-1] & 15;
// Inlined variable-length +ve long code, see read_v_int().
if (in[-1] & 16) {
uint8_t shift = 4;
do result |= (*in++ & 127) << shift;
while (in[-1] & 128 && (shift += 7));
}
return newSViv(result);
}
read_array: {
AV *av = (AV*)newSV_type(SVt_PVAV);
SSize_t len = READ_LEN;
SV **ary = safemalloc(len * sizeof(SV*));
AvALLOC(av) = AvARRAY(av) = ary;
AvFILLp(av) = AvMAX(av) = len - 1;
while (len--)
*ary++ = read_sv(aTHX);
SV *rv = newSV_type(SVt_IV);
SvROK_on(rv);
SvRV(rv) = (SV*)av;
return rv;
}
}
static void grow_out(pTHX_ const STRLEN want) {
const STRLEN len = out_buf - (uint8_t *)SvPVX(out_sv);
// If we want more than we have, realloc the string.
if (len + want >= SvLEN(out_sv)) {
sv_grow(out_sv, len + want);
out_buf = (uint8_t *)SvPVX(out_sv) + len;
}
}
static void write_v_int(uint32_t i) {
while (i & ~127) {
*out_buf++ = (i & 127) | 128;
i >>= 7;
}
*out_buf++ = i;
}
static void write_shifted_tag(uint8_t tag, uint32_t len) {
if (len < 31)
*out_buf++ = tag | len;
else {
*out_buf++ = tag | 31;
write_v_int(len - 31);
}
}
static void write_sv(pTHX_ SV *sv) {
SvGETMAGIC(sv);
if (SvPOKp(sv)) {
const STRLEN len = SvCUR(sv);
grow_out(aTHX_ len + 5);
write_shifted_tag(32, len);
memcpy(out_buf, SvPVX(sv), len);
out_buf += len;
}
else if (SvNOKp(sv)) {
const int_double u = { .d = SvNV(sv) };
grow_out(aTHX_ 9);
*out_buf++ = 5;
*out_buf++ = u.i >> 56;
*out_buf++ = u.i >> 48;
*out_buf++ = u.i >> 40;
*out_buf++ = u.i >> 32;
*out_buf++ = u.i >> 24;
*out_buf++ = u.i >> 16;
*out_buf++ = u.i >> 8;
*out_buf++ = u.i;
}
else if (SvIOKp(sv)) {
MVMint64 MVM_proc_spawn(MVMThreadContext *tc, MVMString *cmd, MVMString *cwd, MVMObject *env) {
MVMint64 result, spawn_result;
uv_process_t process = {0};
uv_process_options_t process_options = {0};
int i;
char * const cmdin = MVM_string_utf8_encode_C_string(tc, cmd);
char * const _cwd = MVM_string_utf8_encode_C_string(tc, cwd);
const MVMuint64 size = MVM_repr_elems(tc, env);
MVMIter * const iter = (MVMIter *)MVM_iter(tc, env);
char **_env = malloc((size + 1) * sizeof(char *));
#ifdef _WIN32
const MVMuint16 acp = GetACP(); /* We should get ACP at runtime. */
char * const _cmd = ANSIToUTF8(acp, getenv("ComSpec"));
char *args[3];
args[0] = "/c";
args[1] = cmdin;
args[2] = NULL;
#else
char * const _cmd = "/bin/sh";
char *args[4];
args[0] = "/bin/sh";
args[1] = "-c";
args[2] = cmdin;
args[3] = NULL;
#endif
MVMROOT(tc, iter, {
MVMString * const equal = MVM_string_ascii_decode(tc, tc->instance->VMString, STR_WITH_LEN("="));
MVMROOT(tc, equal, {
MVMString *env_str;
i = 0;
while(MVM_iter_istrue(tc, iter)) {
MVM_repr_shift_o(tc, (MVMObject *)iter);
env_str = MVM_string_concatenate(tc, MVM_iterkey_s(tc, iter), equal);
env_str = MVM_string_concatenate(tc, env_str, MVM_repr_get_str(tc, MVM_iterval(tc, iter)));
_env[i++] = MVM_string_utf8_encode_C_string(tc, env_str);
}
_env[size] = NULL;
});
});
/*
* 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)
dVAR;
#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 * const language = PerlEnv_getenv("LANGUAGE");
#endif
char * const lc_all = PerlEnv_getenv("LC_ALL");
char * const 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
Safefree(curctype);
if (! (curctype =
setlocale(LC_CTYPE,
(!done && (lang || PerlEnv_getenv("LC_CTYPE")))
? "" : NULL)))
setlocale_failure = TRUE;
else
curctype = savepv(curctype);
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
Safefree(curcoll);
if (! (curcoll =
setlocale(LC_COLLATE,
(!done && (lang || PerlEnv_getenv("LC_COLLATE")))
? "" : NULL)))
setlocale_failure = TRUE;
else
curcoll = savepv(curcoll);
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
Safefree(curnum);
if (! (curnum =
setlocale(LC_NUMERIC,
(!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
? "" : NULL)))
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
Safefree(curctype);
if (! (curctype = setlocale(LC_CTYPE, "")))
setlocale_failure = TRUE;
else
curctype = savepv(curctype);
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
Safefree(curcoll);
if (! (curcoll = setlocale(LC_COLLATE, "")))
setlocale_failure = TRUE;
else
curcoll = savepv(curcoll);
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
Safefree(curnum);
if (! (curnum = setlocale(LC_NUMERIC, "")))
setlocale_failure = TRUE;
else
curnum = savepv(curnum);
#endif /* USE_LOCALE_NUMERIC */
}
if (setlocale_failure) {
char *p;
const 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
Safefree(curctype);
curctype = savepv(setlocale(LC_CTYPE, NULL));
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
Safefree(curcoll);
curcoll = savepv(setlocale(LC_COLLATE, NULL));
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
Safefree(curnum);
curnum = savepv(setlocale(LC_NUMERIC, NULL));
#endif /* USE_LOCALE_NUMERIC */
}
else {
#ifdef USE_LOCALE_CTYPE
new_ctype(curctype);
#endif /* USE_LOCALE_CTYPE */
#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 = (Perl_ibcmp(aTHX_ codeset, STR_WITH_LEN("UTF-8")) == 0 ||
Perl_ibcmp(aTHX_ codeset, STR_WITH_LEN("UTF8") ) == 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 = (Perl_ibcmp(aTHX_ lang, STR_WITH_LEN("UTF-8")) == 0 ||
Perl_ibcmp(aTHX_ lang, STR_WITH_LEN("UTF8") ) == 0);
#ifdef USE_LOCALE_CTYPE
if (curctype)
utf8locale = (Perl_ibcmp(aTHX_ curctype, STR_WITH_LEN("UTF-8")) == 0 ||
Perl_ibcmp(aTHX_ curctype, STR_WITH_LEN("UTF8") ) == 0);
#endif
if (lc_all)
utf8locale = (Perl_ibcmp(aTHX_ lc_all, STR_WITH_LEN("UTF-8")) == 0 ||
Perl_ibcmp(aTHX_ lc_all, STR_WITH_LEN("UTF8") ) == 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). */
{
const char *p = PerlEnv_getenv("PERL_UNICODE");
PL_unicode = p ? parse_unicode_opts(&p) : 0;
if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
PL_utf8cache = -1;
}
#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;
}
MVMObject * MVM_radix(MVMThreadContext *tc, MVMint64 radix, MVMString *str, MVMint64 offset, MVMint64 flag) {
MVMObject *result;
MVMint64 zvalue = 0;
MVMint64 zbase = 1;
MVMint64 chars = MVM_string_graphs(tc, str);
MVMint64 value = zvalue;
MVMint64 base = zbase;
MVMint64 pos = -1;
MVMuint16 neg = 0;
MVMint64 ch;
if (radix > 36) {
MVM_exception_throw_adhoc(tc, "Cannot convert radix of %"PRId64" (max 36)", radix);
}
ch = (offset < chars) ? MVM_string_get_grapheme_at_nocheck(tc, str, offset) : 0;
if ((flag & 0x02) && (ch == '+' || ch == '-')) {
neg = (ch == '-');
offset++;
ch = (offset < chars) ? MVM_string_get_grapheme_at_nocheck(tc, str, offset) : 0;
}
while (offset < chars) {
if (ch >= '0' && ch <= '9') ch = ch - '0'; /* fast-path for ASCII 0..9 */
else if (ch >= 'a' && ch <= 'z') ch = ch - 'a' + 10;
else if (ch >= 'A' && ch <= 'Z') ch = ch - 'A' + 10;
else if (ch >= 0xFF21 && ch <= 0xFF3A) ch = ch - 0xFF21 + 10; /* uppercase fullwidth */
else if (ch >= 0xFF41 && ch <= 0xFF5A) ch = ch - 0xFF41 + 10; /* lowercase fullwidth */
else if (ch > 0 && MVM_unicode_codepoint_has_property_value(tc, ch, MVM_UNICODE_PROPERTY_GENERAL_CATEGORY,
MVM_unicode_cname_to_property_value_code(tc, MVM_UNICODE_PROPERTY_GENERAL_CATEGORY, STR_WITH_LEN("Nd")))) {
/* As of Unicode 6.0.0, we know that Nd category numerals are within
* the range 0..9
*/
/* the string returned for NUMERIC_VALUE contains a floating point
* value, so atoi will stop on the . in the string. This is fine
* though, since we'd have to truncate the float regardless.
*/
ch = atoi(MVM_unicode_codepoint_get_property_cstr(tc, ch, MVM_UNICODE_PROPERTY_NUMERIC_VALUE));
}
else break;
if (ch >= radix) break;
zvalue = zvalue * radix + ch;
zbase = zbase * radix;
offset++; pos = offset;
if (ch != 0 || !(flag & 0x04)) { value=zvalue; base=zbase; }
if (offset >= chars) break;
ch = MVM_string_get_grapheme_at_nocheck(tc, str, offset);
if (ch != '_') continue;
offset++;
if (offset >= chars) break;
ch = MVM_string_get_grapheme_at_nocheck(tc, str, offset);
}
if (neg || flag & 0x01) { value = -value; }
/* initialize the object */
result = MVM_repr_alloc_init(tc, MVM_hll_current(tc)->slurpy_array_type);
MVMROOT(tc, result, {
MVMObject *box_type = MVM_hll_current(tc)->int_box_type;
MVMROOT(tc, box_type, {
MVMObject *boxed = MVM_repr_box_int(tc, box_type, value);
MVM_repr_push_o(tc, result, boxed);
boxed = MVM_repr_box_int(tc, box_type, base);
MVM_repr_push_o(tc, result, boxed);
boxed = MVM_repr_box_int(tc, box_type, pos);
MVM_repr_push_o(tc, result, boxed);
});
});
