an SV marked as magical, it calls the 'get' or 'set' function associated
with that SV's magic. A get is called prior to reading an SV, in order to
give it a chance to update its internal value (get on $. writes the line
-number of the last read filehandle into to the SV's IV slot), while
+number of the last read filehandle into the SV's IV slot), while
set is called after an SV has been written to, in order to allow it to make
use of its changed value (set on $/ copies the SV's new value to the
PL_rs global variable).
if(strEQ(SvPVX(sv), "")) {
sv_catpv(sv, UNKNOWN_ERRNO_MSG);
}
+#if 0
+ /* This is disabled to get v5.20 out the door. It means that $! behaves as
+ * if in the scope of both 'use locale' and 'use bytes'. This can cause
+ * mixed encodings and double utf8 upgrading, See towards the end of the
+ * thread for [perl #119499] */
else {
/* In some locales the error string may come back as UTF-8, in which
SvUTF8_on(sv);
}
}
+#endif
}
#ifdef VMS
#ifdef HAS_GETGROUPS
{
Groups_t *gary = NULL;
- I32 i, num_groups = getgroups(0, gary);
- Newx(gary, num_groups, Groups_t);
- num_groups = getgroups(num_groups, gary);
- for (i = 0; i < num_groups; i++)
- Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
- Safefree(gary);
+ I32 i;
+ I32 num_groups = getgroups(0, gary);
+ if (num_groups > 0) {
+ Newx(gary, num_groups, Groups_t);
+ num_groups = getgroups(num_groups, gary);
+ for (i = 0; i < num_groups; i++)
+ Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
+ Safefree(gary);
+ }
}
(void)SvIOK_on(sv); /* what a wonderful hack! */
#endif
same function. */
mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
+ assert(mg);
if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
SV **svp = AvARRAY((AV *)mg->mg_obj);
I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
}
break;
case '/':
- SvREFCNT_dec(PL_rs);
- PL_rs = newSVsv(sv);
+ {
+ SV *tmpsv= sv;
+ if (SvROK(sv)) {
+ SV *referent= SvRV(sv);
+ const char *reftype= sv_reftype(referent, 0);
+ /* XXX: dodgy type check: This leaves me feeling dirty, but the alternative
+ * is to copy pretty much the entire sv_reftype() into this routine, or to do
+ * a full string comparison on the return of sv_reftype() both of which
+ * make me feel worse! NOTE, do not modify this comment without reviewing the
+ * corresponding comment in sv_reftype(). - Yves */
+ if (reftype[0] == 'S' || reftype[0] == 'L') {
+ IV val= SvIV(referent);
+ if (val <= 0) {
+ tmpsv= &PL_sv_undef;
+ Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ "Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef",
+ SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero"
+ );
+ }
+ } else {
+ /* diag_listed_as: Setting $/ to %s reference is forbidden */
+ Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
+ *reftype == 'A' ? "n" : "", reftype);
+ }
+ }
+ SvREFCNT_dec(PL_rs);
+ PL_rs = newSVsv(tmpsv);
+ }
break;
case '\\':
SvREFCNT_dec(PL_ors_sv);
break;
case '<':
{
- int rc = 0;
+ /* XXX $< currently silently ignores failures */
const Uid_t new_uid = SvUID(sv);
PL_delaymagic_uid = new_uid;
if (PL_delaymagic) {
break; /* don't do magic till later */
}
#ifdef HAS_SETRUID
- rc = setruid(new_uid);
+ PERL_UNUSED_RESULT(setruid(new_uid));
#else
#ifdef HAS_SETREUID
- rc = setreuid(new_uid, (Uid_t)-1);
+ PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
#else
#ifdef HAS_SETRESUID
- rc = setresuid(new_uid, (Uid_t)-1, (Uid_t)-1);
+ PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
#else
if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
#ifdef PERL_DARWIN
/* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
if (new_uid != 0 && PerlProc_getuid() == 0)
- rc = PerlProc_setuid(0);
+ PERL_UNUSED_RESULT(PerlProc_setuid(0));
#endif
- rc = PerlProc_setuid(new_uid);
+ PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
} else {
Perl_croak(aTHX_ "setruid() not implemented");
}
#endif
#endif
#endif
- /* XXX $< currently silently ignores failures */
- PERL_UNUSED_VAR(rc);
break;
}
case '>':
{
- int rc = 0;
+ /* XXX $> currently silently ignores failures */
const Uid_t new_euid = SvUID(sv);
PL_delaymagic_euid = new_euid;
if (PL_delaymagic) {
break; /* don't do magic till later */
}
#ifdef HAS_SETEUID
- rc = seteuid(new_euid);
+ PERL_UNUSED_RESULT(seteuid(new_euid));
#else
#ifdef HAS_SETREUID
- rc = setreuid((Uid_t)-1, new_euid);
+ PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
#else
#ifdef HAS_SETRESUID
- rc = setresuid((Uid_t)-1, new_euid, (Uid_t)-1);
+ PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
#else
if (new_euid == PerlProc_getuid()) /* special case $> = $< */
- rc = PerlProc_setuid(new_euid);
+ PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
else {
Perl_croak(aTHX_ "seteuid() not implemented");
}
#endif
#endif
#endif
- /* XXX $> currently silently ignores failures */
- PERL_UNUSED_VAR(rc);
break;
}
case '(':
{
- int rc = 0;
+ /* XXX $( currently silently ignores failures */
const Gid_t new_gid = SvGID(sv);
PL_delaymagic_gid = new_gid;
if (PL_delaymagic) {
break; /* don't do magic till later */
}
#ifdef HAS_SETRGID
- rc = setrgid(new_gid);
+ PERL_UNUSED_RESULT(setrgid(new_gid));
#else
#ifdef HAS_SETREGID
- rc = setregid(new_gid, (Gid_t)-1);
+ PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
#else
#ifdef HAS_SETRESGID
- rc = setresgid(new_gid, (Gid_t)-1, (Gid_t) -1);
+ PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
#else
if (new_gid == PerlProc_getegid()) /* special case $( = $) */
- rc = PerlProc_setgid(new_gid);
+ PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
else {
Perl_croak(aTHX_ "setrgid() not implemented");
}
#endif
#endif
#endif
- /* XXX $( currently silently ignores failures */
- PERL_UNUSED_VAR(rc);
break;
}
case ')':
{
- int rc = 0;
+ /* XXX $) currently silently ignores failures */
Gid_t new_egid;
#ifdef HAS_SETGROUPS
{
gary[i] = (Groups_t)Atol(p);
}
if (i)
- rc = setgroups(i, gary);
+ PERL_UNUSED_RESULT(setgroups(i, gary));
Safefree(gary);
}
#else /* HAS_SETGROUPS */
break; /* don't do magic till later */
}
#ifdef HAS_SETEGID
- rc = setegid(new_egid);
+ PERL_UNUSED_RESULT(setegid(new_egid));
#else
#ifdef HAS_SETREGID
- rc = setregid((Gid_t)-1, new_egid);
+ PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
#else
#ifdef HAS_SETRESGID
- rc = setresgid((Gid_t)-1, new_egid, (Gid_t)-1);
+ PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
#else
if (new_egid == PerlProc_getgid()) /* special case $) = $( */
- rc = PerlProc_setgid(new_egid);
+ PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
else {
Perl_croak(aTHX_ "setegid() not implemented");
}
#endif
#endif
#endif
- /* XXX $) currently silently ignores failures */
- PERL_UNUSED_VAR(rc);
break;
}
case ':':
sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
nmg = mg_find(nsv, mg->mg_type);
+ assert(nmg);
if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
nmg->mg_ptr = mg->mg_ptr;
nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
https://perl5.git.perl.org / perl5.git / blobdiff