void
Perl_av_reify(pTHX_ AV *av)
{
SSize_t key;
PERL_ARGS_ASSERT_AV_REIFY;
assert(SvTYPE(av) == SVt_PVAV);
if (AvREAL(av))
return;
#ifdef DEBUGGING
if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
#endif
key = AvMAX(av) + 1;
while (key > AvFILLp(av) + 1)
AvARRAY(av)[--key] = NULL;
while (key) {
SV * const sv = AvARRAY(av)[--key];
if (sv != &PL_sv_undef)
SvREFCNT_inc_simple_void(sv);
}
key = AvARRAY(av) - AvALLOC(av);
while (key)
AvALLOC(av)[--key] = NULL;
AvREIFY_off(av);
AvREAL_on(av);
}
STATIC char
S_grok_bslash_c(pTHX_ const char source, const bool utf8, const bool output_warning)
{
U8 result;
if (utf8) {
/* Trying to deprecate non-ASCII usages. This construct has never
* worked for a utf8 variant. So, even though are accepting non-ASCII
* Latin1 in 5.14, no need to make them work under utf8 */
if (! isASCII(source)) {
Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
}
}
result = toCTRL(source);
if (! isASCII(source)) {
Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Character following \"\\c\" must be ASCII");
}
else if (! isCNTRL(result) && output_warning) {
if (source == '{') {
Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"\"\\c{\" is deprecated and is more clearly written as \";\"");
}
else {
U8 clearer[3];
U8 i = 0;
if (! isALNUM(result)) {
clearer[i++] = '\\';
}
clearer[i++] = result;
clearer[i++] = '\0';
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
"\"\\c%c\" is more clearly written simply as \"%s\"",
source,
clearer);
}
}
return result;
}
void
Perl_taint_proper(pTHX_ const char *f, const char *const s)
{
#if defined(HAS_SETEUID) && defined(DEBUGGING)
PERL_ARGS_ASSERT_TAINT_PROPER;
{
const Uid_t uid = PerlProc_getuid();
const Uid_t euid = PerlProc_geteuid();
#if Uid_t_sign == 1 /* uid_t is unsigned. */
DEBUG_u(PerlIO_printf(Perl_debug_log,
"%s %d %"UVuf" %"UVuf"\n",
s, TAINT_get, (UV)uid, (UV)euid));
#else /* uid_t is signed (Uid_t_sign == -1), or don't know. */
DEBUG_u(PerlIO_printf(Perl_debug_log,
"%s %d %"IVdf" %"IVdf"\n",
s, TAINT_get, (IV)uid, (IV)euid));
#endif
}
#endif
if (TAINT_get) {
const char *ug;
if (!f)
f = PL_no_security;
if (PerlProc_getuid() != PerlProc_geteuid())
ug = " while running setuid";
else if (PerlProc_getgid() != PerlProc_getegid())
ug = " while running setgid";
else if (TAINT_WARN_get)
ug = " while running with -t switch";
else
ug = " while running with -T switch";
/* XXX because taint_proper adds extra format args, we can't
* get the caller to check properly; o we just silence the warning
* and hope the callers aren't naughty */
GCC_DIAG_IGNORE(-Wformat-nonliteral);
if (PL_unsafe || TAINT_WARN_get) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_TAINT), f, s, ug);
}
else {
Perl_croak(aTHX_ f, s, ug);
}
GCC_DIAG_RESTORE;
}
}
void
Perl_taint_proper(pTHX_ const char *f, const char *const s)
{
#if defined(HAS_SETEUID) && defined(DEBUGGING)
dVAR;
PERL_ARGS_ASSERT_TAINT_PROPER;
# if Uid_t_size == 1
{
const UV uid = PerlProc_getuid();
const UV euid = PerlProc_geteuid();
DEBUG_u(PerlIO_printf(Perl_debug_log,
"%s %d %"UVuf" %"UVuf"\n",
s, PL_tainted, uid, euid));
}
# else
{
const IV uid = PerlProc_getuid();
const IV euid = PerlProc_geteuid();
DEBUG_u(PerlIO_printf(Perl_debug_log,
"%s %d %"IVdf" %"IVdf"\n",
s, PL_tainted, uid, euid));
}
# endif
#endif
if (PL_tainted) {
const char *ug;
if (!f)
f = PL_no_security;
if (PerlProc_getuid() != PerlProc_geteuid())
ug = " while running setuid";
else if (PerlProc_getgid() != PerlProc_getegid())
ug = " while running setgid";
else if (PL_taint_warn)
ug = " while running with -t switch";
else
ug = " while running with -T switch";
if (PL_unsafe || PL_taint_warn) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_TAINT), f, s, ug);
}
else {
Perl_croak(aTHX_ f, s, ug);
}
}
}
IV
PerlIOWin32_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
IV code = PerlIOBase_pushed(aTHX_ f,mode,arg,tab);
if (*PerlIONext(f))
{
PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
s->fd = PerlIO_fileno(PerlIONext(f));
}
PerlIOBase(f)->flags |= PERLIO_F_OPEN;
Perl_ck_warner_d(aTHX_
packWARN(WARN_EXPERIMENTAL__WIN32_PERLIO),
"PerlIO layer ':win32' is experimental");
return code;
}