"Magic" is special data attached to SV structures in order to give them
"magical" properties. When any Perl code tries to read from, or assign to,
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
+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).
Magic is implemented as a linked list of MAGIC structures attached to the
-SV. Each MAGIC struct holds the type of the magic, a pointer to an array
+SV. Each MAGIC struct holds the type of the magic, a pointer to an array
of functions that implement the get(), set(), length() etc functions,
-plus space for some flags and pointers. For example, a tied variable has
+plus space for some flags and pointers. For example, a tied variable has
a MAGIC structure that contains a pointer to the object associated with the
tie.
=for apidoc mg_get
Do magic before a value is retrieved from the SV. The type of SV must
-be >= SVt_PVMG. See C<sv_magic>.
+be >= SVt_PVMG. See C<sv_magic>.
=cut
*/
=for apidoc mg_localize
Copy some of the magic from an existing SV to new localized version of that
-SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
+SV. Container magic (eg %ENV, $1, tie)
+gets copied, value magic doesn't (eg
taint, pos).
If setmagic is false then no set magic will be called on the new (empty) SV.
}
sv_setuv(sv, i);
+ return 0;
}
}
}
+ sv_setsv(sv, NULL);
return 0;
}
}
}
+STATIC void
+S_fixup_errno_string(pTHX_ SV* sv)
+{
+ /* Do what is necessary to fixup the non-empty string in 'sv' for return to
+ * Perl space. */
+
+ PERL_ARGS_ASSERT_FIXUP_ERRNO_STRING;
+
+ assert(SvOK(sv));
+
+ 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
+ * case we should turn on that flag. This didn't use to happen, and to
+ * avoid any possible backward compatibility issues, we don't turn on
+ * the flag unless we have to. So the flag stays off for an entirely
+ * ASCII string. We assume that if the string looks like UTF-8, it
+ * really is UTF-8: "text in any other encoding that uses bytes with
+ * the high bit set is extremely unlikely to pass a UTF-8 validity
+ * test" (http://en.wikipedia.org/wiki/Charset_detection). There is a
+ * potential that we will get it wrong however, especially on short
+ * error message text. (If it turns out to be necessary, we could also
+ * keep track if the current LC_MESSAGES locale is UTF-8) */
+ if (! IN_BYTES /* respect 'use bytes' */
+ && ! is_ascii_string((U8*) SvPVX_const(sv), SvCUR(sv))
+ && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv)))
+ {
+ SvUTF8_on(sv);
+ }
+ }
+#endif
+}
+
#ifdef VMS
#include <descrip.h>
#include <starlet.h>
const char *s = NULL;
REGEXP *rx;
const char * const remaining = mg->mg_ptr + 1;
- const char nextchar = *remaining;
+ char nextchar;
PERL_ARGS_ASSERT_MAGIC_GET;
+ if (!mg->mg_ptr) {
+ paren = mg->mg_len;
+ if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
+ do_numbuf_fetch:
+ CALLREG_NUMBUF_FETCH(rx,paren,sv);
+ } else {
+ sv_setsv(sv,&PL_sv_undef);
+ }
+ return 0;
+ }
+
+ nextchar = *remaining;
switch (*mg->mg_ptr) {
case '\001': /* ^A */
if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
break;
case '\005': /* ^E */
- if (nextchar == '\0') {
-#if defined(VMS)
- {
- char msg[255];
- $DESCRIPTOR(msgdsc,msg);
- sv_setnv(sv,(NV) vaxc$errno);
- if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
- sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
- else
- sv_setpvs(sv,"");
- }
+ if (nextchar != '\0') {
+ if (strEQ(remaining, "NCODING"))
+ sv_setsv(sv, PL_encoding);
+ break;
+ }
+
+#if defined(VMS) || defined(OS2) || defined(WIN32)
+# if defined(VMS)
+ {
+ char msg[255];
+ $DESCRIPTOR(msgdsc,msg);
+ sv_setnv(sv,(NV) vaxc$errno);
+ if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
+ sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
+ else
+ sv_setpvs(sv,"");
+ }
#elif defined(OS2)
- if (!(_emx_env & 0x200)) { /* Under DOS */
- sv_setnv(sv, (NV)errno);
- sv_setpv(sv, errno ? Strerror(errno) : "");
- } else {
- if (errno != errno_isOS2) {
- const int tmp = _syserrno();
- if (tmp) /* 2nd call to _syserrno() makes it 0 */
- Perl_rc = tmp;
- }
- sv_setnv(sv, (NV)Perl_rc);
- sv_setpv(sv, os2error(Perl_rc));
- }
-#elif defined(WIN32)
- {
- const DWORD dwErr = GetLastError();
- sv_setnv(sv, (NV)dwErr);
- if (dwErr) {
- PerlProc_GetOSError(sv, dwErr);
- }
- else
- sv_setpvs(sv, "");
- SetLastError(dwErr);
- }
+ if (!(_emx_env & 0x200)) { /* Under DOS */
+ sv_setnv(sv, (NV)errno);
+ sv_setpv(sv, errno ? Strerror(errno) : "");
+ } else {
+ if (errno != errno_isOS2) {
+ const int tmp = _syserrno();
+ if (tmp) /* 2nd call to _syserrno() makes it 0 */
+ Perl_rc = tmp;
+ }
+ sv_setnv(sv, (NV)Perl_rc);
+ sv_setpv(sv, os2error(Perl_rc));
+ }
+ if (SvOK(sv) && strNE(SvPVX(sv), "")) {
+ fixup_errno_string(sv);
+ }
+# elif defined(WIN32)
+ {
+ const DWORD dwErr = GetLastError();
+ sv_setnv(sv, (NV)dwErr);
+ if (dwErr) {
+ PerlProc_GetOSError(sv, dwErr);
+ fixup_errno_string(sv);
+ }
+ else
+ sv_setpvs(sv, "");
+ SetLastError(dwErr);
+ }
+# else
+# error Missing code for platform
+# endif
+ SvRTRIM(sv);
+ SvNOK_on(sv); /* what a wonderful hack! */
+ break;
+#endif /* End of platforms with special handling for $^E; others just fall
+ through to $! */
+
+ case '!':
+ {
+ dSAVE_ERRNO;
+#ifdef VMS
+ sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
#else
- {
- dSAVE_ERRNO;
- sv_setnv(sv, (NV)errno);
- sv_setpv(sv, errno ? Strerror(errno) : "");
- RESTORE_ERRNO;
- }
-#endif
- SvRTRIM(sv);
- SvNOK_on(sv); /* what a wonderful hack! */
- }
- else if (strEQ(remaining, "NCODING"))
- sv_setsv(sv, PL_encoding);
- break;
+ sv_setnv(sv, (NV)errno);
+#endif
+#ifdef OS2
+ if (errno == errno_isOS2 || errno == errno_isOS2_set)
+ sv_setpv(sv, os2error(Perl_rc));
+ else
+#endif
+ if (! errno) {
+ sv_setpvs(sv, "");
+ }
+ else {
+
+ /* Strerror can return NULL on some platforms, which will
+ * result in 'sv' not being considered SvOK. The SvNOK_on()
+ * below will cause just the number part to be valid */
+ sv_setpv(sv, Strerror(errno));
+ if (SvOK(sv)) {
+ fixup_errno_string(sv);
+ }
+ }
+ RESTORE_ERRNO;
+ }
+
+ SvRTRIM(sv);
+ SvNOK_on(sv); /* what a wonderful hack! */
+ break;
+
case '\006': /* ^F */
sv_setiv(sv, (IV)PL_maxsysfd);
break;
}
break;
case '\020':
- if (nextchar == '\0') { /* ^P */
- sv_setiv(sv, (IV)PL_perldb);
- } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
-
- paren = RX_BUFF_IDX_CARET_PREMATCH;
- goto do_numbuf_fetch;
- } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
- paren = RX_BUFF_IDX_CARET_POSTMATCH;
- goto do_numbuf_fetch;
- }
+ sv_setiv(sv, (IV)PL_perldb);
break;
case '\023': /* ^S */
- if (nextchar == '\0') {
+ {
if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
SvOK_off(sv);
else if (PL_in_eval)
}
}
break;
- case '\015': /* $^MATCH */
- if (strEQ(remaining, "ATCH")) {
- paren = RX_BUFF_IDX_CARET_FULLMATCH;
- goto do_numbuf_fetch;
- }
-
- case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9': case '&':
- /*
- * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
- * XXX Does the new way break anything?
- */
- paren = atoi(mg->mg_ptr); /* $& is in [0] */
- do_numbuf_fetch:
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- CALLREG_NUMBUF_FETCH(rx,paren,sv);
- break;
- }
- sv_setsv(sv,&PL_sv_undef);
- break;
case '+':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
paren = RX_LASTPAREN(rx);
}
sv_setsv(sv,&PL_sv_undef);
break;
- case '`':
- paren = RX_BUFF_IDX_PREMATCH;
- goto do_numbuf_fetch;
- case '\'':
- paren = RX_BUFF_IDX_POSTMATCH;
- goto do_numbuf_fetch;
case '.':
if (GvIO(PL_last_in_gv)) {
sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
/* else a value has been assigned manually, so do nothing */
}
break;
-
- case '!':
- {
- dSAVE_ERRNO;
-#ifdef VMS
- sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
-#else
- sv_setnv(sv, (NV)errno);
-#endif
-#ifdef OS2
- if (errno == errno_isOS2 || errno == errno_isOS2_set)
- sv_setpv(sv, os2error(Perl_rc));
- else
-#endif
- if (! errno) {
- sv_setpvs(sv, "");
- }
- else {
-
- /* Strerror can return NULL on some platforms, which will result in
- * 'sv' not being considered SvOK. The SvNOK_on() below will cause
- * just the number part to be valid */
- sv_setpv(sv, Strerror(errno));
-
- /* In some locales the error string may come back as UTF-8, in
- * which case we should turn on that flag. This didn't use to
- * happen, and to avoid any possible backward compatibility issues,
- * we don't turn on the flag unless we have to. So the flag stays
- * off for an entirely ASCII string. We assume that if the string
- * looks like UTF-8, it really is UTF-8: "text in any other
- * encoding that uses bytes with the high bit set is extremely
- * unlikely to pass a UTF-8 validity test"
- * (http://en.wikipedia.org/wiki/Charset_detection). There is a
- * potential that we will get it wrong however, especially on short
- * error message text. (If it turns out to be necessary, we could
- * also keep track if the current LC_MESSAGES locale is UTF-8) */
- if (SvOK(sv) /* It could be that Strerror returned invalid */
- && ! is_ascii_string((U8*) SvPVX_const(sv), SvCUR(sv))
- && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv)))
- {
- SvUTF8_on(sv);
- }
- }
- RESTORE_ERRNO;
- }
-
- SvRTRIM(sv);
- SvNOK_on(sv); /* what a wonderful hack! */
- break;
case '<':
sv_setuid(sv, PerlProc_getuid());
break;
#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;
Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- GV * const gv = PL_DBline;
- const I32 i = SvTRUE(sv);
- SV ** const svp = av_fetch(GvAV(gv),
- atoi(MgPV_nolen_const(mg)), FALSE);
+ SV **svp;
PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
+ /* The magic ptr/len for the debugger's hash should always be an SV. */
+ if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
+ Perl_croak(aTHX_ "panic: magic_setdbline len=%"IVdf", ptr='%s'",
+ (IV)mg->mg_len, mg->mg_ptr);
+ }
+
+ /* Use sv_2iv instead of SvIV() as the former generates smaller code, and
+ setting/clearing debugger breakpoints is not a hot path. */
+ svp = av_fetch(MUTABLE_AV(mg->mg_obj),
+ sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE);
+
if (svp && SvIOKp(*svp)) {
OP * const o = INT2PTR(OP*,SvIVX(*svp));
if (o) {
Slab_to_rw(OpSLAB(o));
#endif
/* set or clear breakpoint in the relevant control op */
- if (i)
+ if (SvTRUE(sv))
o->op_flags |= OPf_SPECIAL;
else
o->op_flags &= ~OPf_SPECIAL;
sv_setuv(sv, i);
return 0;
}
- SvOK_off(sv);
+ sv_setsv(sv,NULL);
return 0;
}
else if (LvSTARGOFF(sv) >= 0) {
AV *const av = MUTABLE_AV(LvTARG(sv));
if (LvSTARGOFF(sv) <= AvFILL(av))
+ {
+ if (SvRMAGICAL(av)) {
+ SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0);
+ targ = svp ? *svp : NULL;
+ }
+ else
targ = AvARRAY(av)[LvSTARGOFF(sv)];
+ }
}
if (targ && (targ != &PL_sv_undef)) {
/* somebody else defined it for us */
LvTARG(sv) = NULL; /* array can't be extended */
else {
SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
- if (!svp || (value = *svp) == &PL_sv_undef)
+ if (!svp || !(value = *svp))
Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
}
}
const char *s;
I32 paren;
const REGEXP * rx;
- const char * const remaining = mg->mg_ptr + 1;
I32 i;
STRLEN len;
MAGIC *tmg;
PERL_ARGS_ASSERT_MAGIC_SET;
- switch (*mg->mg_ptr) {
- case '\015': /* $^MATCH */
- if (strEQ(remaining, "ATCH"))
- goto do_match;
- case '`': /* ${^PREMATCH} caught below */
- do_prematch:
- paren = RX_BUFF_IDX_PREMATCH;
- goto setparen;
- case '\'': /* ${^POSTMATCH} caught below */
- do_postmatch:
- paren = RX_BUFF_IDX_POSTMATCH;
- goto setparen;
- case '&':
- do_match:
- paren = RX_BUFF_IDX_FULLMATCH;
- goto setparen;
- case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- paren = atoi(mg->mg_ptr);
- setparen:
+ if (!mg->mg_ptr) {
+ paren = mg->mg_len;
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- setparen_got_rx:
+ setparen_got_rx:
CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
} else {
/* Croak with a READONLY error when a numbered match var is
* set without a previous pattern match. Unless it's C<local $1>
*/
- croakparen:
+ croakparen:
if (!PL_localizing) {
Perl_croak_no_modify();
}
}
- break;
+ return 0;
+ }
+
+ switch (*mg->mg_ptr) {
case '\001': /* ^A */
if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
else SvOK_off(PL_bodytarget);
}
break;
case '\020': /* ^P */
- if (*remaining == '\0') { /* ^P */
PL_perldb = SvIV(sv);
if (PL_perldb && !PL_DBsingle)
init_debugger();
- break;
- } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
- goto do_prematch;
- } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
- goto do_postmatch;
- }
break;
case '\024': /* ^T */
#ifdef BIG_TIME
}
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);
#else
# define PERL_VMS_BANG 0
#endif
+#if defined(WIN32) && ! defined(UNDER_CE)
+ SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
+ (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
+#else
SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
(SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
+#endif
}
break;
case '<':
{
+ /* 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
- (void)setruid(new_uid);
+ PERL_UNUSED_RESULT(setruid(new_uid));
#else
#ifdef HAS_SETREUID
- (void)setreuid(new_uid, (Uid_t)-1);
+ PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
#else
#ifdef HAS_SETRESUID
- (void)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)
- (void)PerlProc_setuid(0);
+ PERL_UNUSED_RESULT(PerlProc_setuid(0));
#endif
- (void)PerlProc_setuid(new_uid);
+ PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
} else {
Perl_croak(aTHX_ "setruid() not implemented");
}
}
case '>':
{
+ /* 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
- (void)seteuid(new_euid);
+ PERL_UNUSED_RESULT(seteuid(new_euid));
#else
#ifdef HAS_SETREUID
- (void)setreuid((Uid_t)-1, new_euid);
+ PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
#else
#ifdef HAS_SETRESUID
- (void)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 $> = $< */
- PerlProc_setuid(new_euid);
+ PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
else {
Perl_croak(aTHX_ "seteuid() not implemented");
}
}
case '(':
{
+ /* 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
- (void)setrgid(new_gid);
+ PERL_UNUSED_RESULT(setrgid(new_gid));
#else
#ifdef HAS_SETREGID
- (void)setregid(new_gid, (Gid_t)-1);
+ PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
#else
#ifdef HAS_SETRESGID
- (void)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 $( = $) */
- (void)PerlProc_setgid(new_gid);
+ PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
else {
Perl_croak(aTHX_ "setrgid() not implemented");
}
}
case ')':
{
+ /* XXX $) currently silently ignores failures */
Gid_t new_egid;
#ifdef HAS_SETGROUPS
{
gary[i] = (Groups_t)Atol(p);
}
if (i)
- (void)setgroups(i, gary);
+ PERL_UNUSED_RESULT(setgroups(i, gary));
Safefree(gary);
}
#else /* HAS_SETGROUPS */
break; /* don't do magic till later */
}
#ifdef HAS_SETEGID
- (void)setegid(new_egid);
+ PERL_UNUSED_RESULT(setegid(new_egid));
#else
#ifdef HAS_SETREGID
- (void)setregid((Gid_t)-1, new_egid);
+ PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
#else
#ifdef HAS_SETRESGID
- (void)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 $) = $( */
- (void)PerlProc_setgid(new_egid);
+ PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
else {
Perl_croak(aTHX_ "setegid() not implemented");
}
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