X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/0453d815b8a74697ff1e5451c27aba2fe537b8e0..c00206c8463e3564bde598f9aa9e8be52b3f27e3:/mg.c diff --git a/mg.c b/mg.c index cc40a29..4274a20 100644 --- a/mg.c +++ b/mg.c @@ -27,11 +27,8 @@ # endif #endif -#ifdef PERL_OBJECT -# define VTBL this->*vtbl -#else -# define VTBL *vtbl -#endif +static void restore_magic(pTHXo_ void *p); +static void unwind_handler_stack(pTHXo_ void *p); /* * Use the "DESTRUCTOR" scope cleanup to reinstate magic. @@ -51,7 +48,7 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv) MGS* mgs; assert(SvMAGICAL(sv)); - SAVEDESTRUCTOR(S_restore_magic, (void*)mgs_ix); + SAVEDESTRUCTOR_X(restore_magic, (void*)mgs_ix); mgs = SSPTR(mgs_ix, MGS*); mgs->mgs_sv = sv; @@ -63,48 +60,6 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv) SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; } -STATIC void -S_restore_magic(pTHX_ void *p) -{ - dTHR; - MGS* mgs = SSPTR((I32)p, MGS*); - SV* sv = mgs->mgs_sv; - - if (!sv) - return; - - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) - { - if (mgs->mgs_flags) - SvFLAGS(sv) |= mgs->mgs_flags; - else - mg_magical(sv); - if (SvGMAGICAL(sv)) - SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); - } - - mgs->mgs_sv = NULL; /* mark the MGS structure as restored */ - - /* If we're still on top of the stack, pop us off. (That condition - * will be satisfied if restore_magic was called explicitly, but *not* - * if it's being called via leave_scope.) - * The reason for doing this is that otherwise, things like sv_2cv() - * may leave alloc gunk on the savestack, and some code - * (e.g. sighandler) doesn't expect that... - */ - if (PL_savestack_ix == mgs->mgs_ss_ix) - { - I32 popval = SSPOPINT; - assert(popval == SAVEt_DESTRUCTOR); - PL_savestack_ix -= 2; - popval = SSPOPINT; - assert(popval == SAVEt_ALLOC); - popval = SSPOPINT; - PL_savestack_ix -= popval; - } - -} - void Perl_mg_magical(pTHX_ SV *sv) { @@ -112,11 +67,11 @@ Perl_mg_magical(pTHX_ SV *sv) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; if (vtbl) { - if ((vtbl->svt_get != NULL) && !(mg->mg_flags & MGf_GSKIP)) + if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) SvGMAGICAL_on(sv); if (vtbl->svt_set) SvSMAGICAL_on(sv); - if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || (vtbl->svt_clear != NULL)) + if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear) SvRMAGICAL_on(sv); } } @@ -137,8 +92,8 @@ Perl_mg_get(pTHX_ SV *sv) mgp = &SvMAGIC(sv); while ((mg = *mgp) != 0) { MGVTBL* vtbl = mg->mg_virtual; - if (!(mg->mg_flags & MGf_GSKIP) && vtbl && (vtbl->svt_get != NULL)) { - (VTBL->svt_get)(aTHX_ sv, mg); + if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { + CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg); /* Ignore this magic if it's been deleted */ if ((mg == (mgp_valid ? *mgp : SvMAGIC(sv))) && (mg->mg_flags & MGf_GSKIP)) @@ -153,7 +108,7 @@ Perl_mg_get(pTHX_ SV *sv) mgp = &SvMAGIC(sv); /* Re-establish pointer after sv_upgrade */ } - restore_magic((void*)mgs_ix); + restore_magic(aTHXo_ (void*)mgs_ix); return 0; } @@ -175,11 +130,11 @@ Perl_mg_set(pTHX_ SV *sv) mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ (SSPTR(mgs_ix, MGS*))->mgs_flags = 0; } - if (vtbl && (vtbl->svt_set != NULL)) - (VTBL->svt_set)(aTHX_ sv, mg); + if (vtbl && vtbl->svt_set) + CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg); } - restore_magic((void*)mgs_ix); + restore_magic(aTHXo_ (void*)mgs_ix); return 0; } @@ -192,14 +147,14 @@ Perl_mg_length(pTHX_ SV *sv) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; - if (vtbl && (vtbl->svt_len != NULL)) { + if (vtbl && vtbl->svt_len) { I32 mgs_ix; mgs_ix = SSNEW(sizeof(MGS)); save_magic(mgs_ix, sv); /* omit MGf_GSKIP -- not changed here */ - len = (VTBL->svt_len)(aTHX_ sv, mg); - restore_magic((void*)mgs_ix); + len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg); + restore_magic(aTHXo_ (void*)mgs_ix); return len; } } @@ -216,14 +171,14 @@ Perl_mg_size(pTHX_ SV *sv) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; - if (vtbl && (vtbl->svt_len != NULL)) { + if (vtbl && vtbl->svt_len) { I32 mgs_ix; mgs_ix = SSNEW(sizeof(MGS)); save_magic(mgs_ix, sv); /* omit MGf_GSKIP -- not changed here */ - len = (VTBL->svt_len)(aTHX_ sv, mg); - restore_magic((void*)mgs_ix); + len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg); + restore_magic(aTHXo_ (void*)mgs_ix); return len; } } @@ -254,11 +209,11 @@ Perl_mg_clear(pTHX_ SV *sv) MGVTBL* vtbl = mg->mg_virtual; /* omit GSKIP -- never set here */ - if (vtbl && (vtbl->svt_clear != NULL)) - (VTBL->svt_clear)(aTHX_ sv, mg); + if (vtbl && vtbl->svt_clear) + CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg); } - restore_magic((void*)mgs_ix); + restore_magic(aTHXo_ (void*)mgs_ix); return 0; } @@ -297,8 +252,8 @@ Perl_mg_free(pTHX_ SV *sv) for (mg = SvMAGIC(sv); mg; mg = moremagic) { MGVTBL* vtbl = mg->mg_virtual; moremagic = mg->mg_moremagic; - if (vtbl && (vtbl->svt_free != NULL)) - (VTBL->svt_free)(aTHX_ sv, mg); + if (vtbl && vtbl->svt_free) + CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); if (mg->mg_ptr && mg->mg_type != 'g') if (mg->mg_len >= 0) Safefree(mg->mg_ptr); @@ -445,27 +400,25 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\001': /* ^A */ sv_setsv(sv, PL_bodytarget); break; - case '\002': /* ^B */ - if (PL_curcop->cop_warnings == WARN_NONE || - PL_curcop->cop_warnings == WARN_STD) - { - sv_setpvn(sv, WARN_NONEstring, WARNsize) ; - } - else if (PL_curcop->cop_warnings == WARN_ALL) { - sv_setpvn(sv, WARN_ALLstring, WARNsize) ; - } - else { - sv_setsv(sv, PL_curcop->cop_warnings); - } - break; case '\003': /* ^C */ sv_setiv(sv, (IV)PL_minus_c); break; case '\004': /* ^D */ sv_setiv(sv, (IV)(PL_debug & 32767)); +#if defined(YYDEBUG) && defined(DEBUGGING) + PL_yydebug = (PL_debug & 1); +#endif break; case '\005': /* ^E */ +#ifdef MACOS_TRADITIONAL + { + char msg[256]; + + sv_setnv(sv,(double)gLastMacOSErr); + sv_setpv(sv, gLastMacOSErr ? GetSysErrText(gLastMacOSErr, msg) : ""); + } +#else #ifdef VMS { # include @@ -511,6 +464,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #endif #endif #endif +#endif SvNOK_on(sv); /* what a wonderful hack! */ break; case '\006': /* ^F */ @@ -549,8 +503,22 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setiv(sv, (IV)PL_basetime); #endif break; - case '\027': /* ^W */ - sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE)); + case '\027': /* ^W & $^Warnings*/ + if (*(mg->mg_ptr+1) == '\0') + sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE)); + else if (strEQ(mg->mg_ptr, "\027arnings")) { + if (PL_compiling.cop_warnings == WARN_NONE || + PL_compiling.cop_warnings == WARN_STD) + { + sv_setpvn(sv, WARN_NONEstring, WARNsize) ; + } + else if (PL_compiling.cop_warnings == WARN_ALL) { + sv_setpvn(sv, WARN_ALLstring, WARNsize) ; + } + else { + sv_setsv(sv, PL_compiling.cop_warnings); + } + } break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': @@ -682,7 +650,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) int saveerrno = errno; sv_setnv(sv, (NV)errno); #ifdef OS2 - if (errno == errno_isOS2) sv_setpv(sv, os2error(Perl_rc)); + if (errno == errno_isOS2 || errno == errno_isOS2_set) + sv_setpv(sv, os2error(Perl_rc)); else #endif sv_setpv(sv, errno ? Strerror(errno) : ""); @@ -699,26 +668,32 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; case '(': sv_setiv(sv, (IV)PL_gid); - Perl_sv_setpvf(aTHX_ sv, "%Vd", (IV)PL_gid); +#ifdef HAS_GETGROUPS + Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid); +#endif goto add_groups; case ')': sv_setiv(sv, (IV)PL_egid); - Perl_sv_setpvf(aTHX_ sv, "%Vd", (IV)PL_egid); +#ifdef HAS_GETGROUPS + Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid); +#endif add_groups: #ifdef HAS_GETGROUPS { Groups_t gary[NGROUPS]; i = getgroups(NGROUPS,gary); while (--i >= 0) - Perl_sv_catpvf(aTHX_ sv, " %Vd", (IV)gary[i]); + Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]); } #endif SvIOK_on(sv); /* what a wonderful hack! */ break; case '*': break; +#ifndef MACOS_TRADITIONAL case '0': break; +#endif #ifdef USE_THREADS case '@': sv_setsv(sv, thr->errsv); @@ -850,7 +825,10 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) #if defined(VMS) Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); #else -# ifdef WIN32 +# ifdef PERL_IMPLICIT_SYS + PerlEnv_clearenv(); +# else +# ifdef WIN32 char *envv = GetEnvironmentStrings(); char *cur = envv; STRLEN len; @@ -866,8 +844,13 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) cur += len+1; } FreeEnvironmentStrings(envv); -# else -# ifndef PERL_USE_SAFE_PUTENV +# else +# ifdef CYGWIN + I32 i; + for (i = 0; environ[i]; i++) + safesysfree(environ[i]); +# else +# ifndef PERL_USE_SAFE_PUTENV I32 i; if (environ == PL_origenviron) @@ -875,11 +858,13 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) else for (i = 0; environ[i]; i++) safesysfree(environ[i]); -# endif /* PERL_USE_SAFE_PUTENV */ +# endif /* PERL_USE_SAFE_PUTENV */ +# endif /* CYGWIN */ environ[0] = Nullch; -# endif /* WIN32 */ +# endif /* WIN32 */ +# endif /* PERL_IMPLICIT_SYS */ #endif /* VMS */ return 0; } @@ -943,8 +928,6 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) svp = &PL_diehook; else if (strEQ(s,"__WARN__")) svp = &PL_warnhook; - else if (strEQ(s,"__PARSE__")) - svp = &PL_parsehook; else Perl_croak(aTHX_ "No such hook: %s", s); i = 0; @@ -1165,7 +1148,7 @@ int Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) { dSP; - char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY"; + const char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY"; ENTER; SAVETMPS; @@ -1206,7 +1189,7 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) i = SvTRUE(sv); svp = av_fetch(GvAV(gv), atoi(MgPV(mg,n_a)), FALSE); - if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp))) + if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) o->op_private = i; else if (ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ WARN_INTERNAL, "Can't break at that line\n"); @@ -1255,7 +1238,7 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) SV* lsv = LvTARG(sv); SSize_t pos; STRLEN len; - STRLEN ulen; + STRLEN ulen = 0; dTHR; mg = 0; @@ -1280,8 +1263,6 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) ulen = sv_len_utf8(lsv); if (ulen) len = ulen; - else - ulen = 0; } if (pos < 0) { @@ -1394,65 +1375,13 @@ int Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg) { SV *lsv = LvTARG(sv); - unsigned char *s; - unsigned long retnum; - STRLEN lsvlen; - I32 len; - I32 offset; - I32 size; if (!lsv) { SvOK_off(sv); return 0; } - s = (unsigned char *) SvPV(lsv, lsvlen); - offset = LvTARGOFF(sv); - size = LvTARGLEN(sv); - len = (offset + size + 7) / 8; - - /* Copied from pp_vec() */ - if (len > lsvlen) { - if (size <= 8) - retnum = 0; - else { - offset >>= 3; - if (size == 16) { - if (offset >= lsvlen) - retnum = 0; - else - retnum = (unsigned long) s[offset] << 8; - } - else if (size == 32) { - if (offset >= lsvlen) - retnum = 0; - else if (offset + 1 >= lsvlen) - retnum = (unsigned long) s[offset] << 24; - else if (offset + 2 >= lsvlen) - retnum = ((unsigned long) s[offset] << 24) + - ((unsigned long) s[offset + 1] << 16); - else - retnum = ((unsigned long) s[offset] << 24) + - ((unsigned long) s[offset + 1] << 16) + - (s[offset + 2] << 8); - } - } - } - else if (size < 8) - retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1); - else { - offset >>= 3; - if (size == 8) - retnum = s[offset]; - else if (size == 16) - retnum = ((unsigned long) s[offset] << 8) + s[offset+1]; - else if (size == 32) - retnum = ((unsigned long) s[offset] << 24) + - ((unsigned long) s[offset + 1] << 16) + - (s[offset + 2] << 8) + s[offset+3]; - } - - sv_setuv(sv, (UV)retnum); + sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv))); return 0; } @@ -1650,25 +1579,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) case '\001': /* ^A */ sv_setsv(PL_bodytarget, sv); break; - case '\002': /* ^B */ - if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { - if (memEQ(SvPVX(sv), WARN_ALLstring, WARNsize)) { - PL_compiling.cop_warnings = WARN_ALL; - PL_dowarn |= G_WARN_ONCE ; - } - else if (memEQ(SvPVX(sv), WARN_NONEstring, WARNsize)) - PL_compiling.cop_warnings = WARN_NONE; - else { - if (specialWARN(PL_compiling.cop_warnings)) - PL_compiling.cop_warnings = newSVsv(sv) ; - else - sv_setsv(PL_compiling.cop_warnings, sv); - if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) - PL_dowarn |= G_WARN_ONCE ; - } - } - break; - case '\003': /* ^C */ PL_minus_c = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); break; @@ -1678,15 +1588,19 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) DEBUG_x(dump_all()); break; case '\005': /* ^E */ -#ifdef VMS - set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); +#ifdef MACOS_TRADITIONAL + gLastMacOSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); #else -# ifdef WIN32 - SetLastError( SvIV(sv) ); +# ifdef VMS + set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); # else -# ifndef OS2 +# ifdef WIN32 + SetLastError( SvIV(sv) ); +# else +# ifndef OS2 /* will anyone ever use this? */ SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4); +# endif # endif # endif #endif @@ -1715,6 +1629,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '\020': /* ^P */ PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); + if (PL_perldb && !PL_DBsingle) + init_debugger(); break; case '\024': /* ^T */ #ifdef BIG_TIME @@ -1723,17 +1639,37 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); #endif break; - case '\027': /* ^W */ - if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { - i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); - PL_dowarn = (PL_dowarn & ~G_WARN_ON) + case '\027': /* ^W & $^Warnings */ + if (*(mg->mg_ptr+1) == '\0') { + if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { + i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); + PL_dowarn = (PL_dowarn & ~G_WARN_ON) | (i ? G_WARN_ON : G_WARN_OFF) ; + } + } + else if (strEQ(mg->mg_ptr, "\027arnings")) { + if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { + if (memEQ(SvPVX(sv), WARN_ALLstring, WARNsize)) { + PL_compiling.cop_warnings = WARN_ALL; + PL_dowarn |= G_WARN_ONCE ; + } + else if (memEQ(SvPVX(sv), WARN_NONEstring, WARNsize)) + PL_compiling.cop_warnings = WARN_NONE; + else { + if (specialWARN(PL_compiling.cop_warnings)) + PL_compiling.cop_warnings = newSVsv(sv) ; + else + sv_setsv(PL_compiling.cop_warnings, sv); + if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) + PL_dowarn |= G_WARN_ONCE ; + } + } } break; case '.': if (PL_localizing) { if (PL_localizing == 1) - save_sptr((SV**)&PL_last_in_gv); + SAVESPTR(PL_last_in_gv); } else if (SvOK(sv) && GvIO(PL_last_in_gv)) IoLINES(GvIOp(PL_last_in_gv)) = (long)SvIV(sv); @@ -1787,8 +1723,10 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) case '\\': if (PL_ors) Safefree(PL_ors); - if (SvOK(sv) || SvGMAGICAL(sv)) - PL_ors = savepv(SvPV(sv,PL_orslen)); + if (SvOK(sv) || SvGMAGICAL(sv)) { + s = SvPV(sv,PL_orslen); + PL_ors = savepvn(s,PL_orslen); + } else { PL_ors = Nullch; PL_orslen = 0; @@ -1844,13 +1782,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (PL_uid == PL_euid) /* special case $< = $> */ (void)PerlProc_setuid(PL_uid); else { - PL_uid = (I32)PerlProc_getuid(); + PL_uid = PerlProc_getuid(); Perl_croak(aTHX_ "setruid() not implemented"); } #endif #endif #endif - PL_uid = (I32)PerlProc_getuid(); + PL_uid = PerlProc_getuid(); PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case '>': @@ -1871,13 +1809,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (PL_euid == PL_uid) /* special case $> = $< */ PerlProc_setuid(PL_euid); else { - PL_euid = (I32)PerlProc_geteuid(); + PL_euid = PerlProc_geteuid(); Perl_croak(aTHX_ "seteuid() not implemented"); } #endif #endif #endif - PL_euid = (I32)PerlProc_geteuid(); + PL_euid = PerlProc_geteuid(); PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case '(': @@ -1898,13 +1836,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (PL_gid == PL_egid) /* special case $( = $) */ (void)PerlProc_setgid(PL_gid); else { - PL_gid = (I32)PerlProc_getgid(); + PL_gid = PerlProc_getgid(); Perl_croak(aTHX_ "setrgid() not implemented"); } #endif #endif #endif - PL_gid = (I32)PerlProc_getgid(); + PL_gid = PerlProc_getgid(); PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case ')': @@ -1915,7 +1853,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) while (isSPACE(*p)) ++p; - PL_egid = I_V(atol(p)); + PL_egid = Atol(p); for (i = 0; i < NGROUPS; ++i) { while (*p && !isSPACE(*p)) ++p; @@ -1923,7 +1861,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) ++p; if (!*p) break; - gary[i] = I_V(atol(p)); + gary[i] = Atol(p); } if (i) (void)setgroups(i, gary); @@ -1947,18 +1885,19 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (PL_egid == PL_gid) /* special case $) = $( */ (void)PerlProc_setgid(PL_egid); else { - PL_egid = (I32)PerlProc_getegid(); + PL_egid = PerlProc_getegid(); Perl_croak(aTHX_ "setegid() not implemented"); } #endif #endif #endif - PL_egid = (I32)PerlProc_getegid(); + PL_egid = PerlProc_getegid(); PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case ':': PL_chopset = SvPV_force(sv,len); break; +#ifndef MACOS_TRADITIONAL case '0': if (!PL_origalen) { s = PL_origargv[0]; @@ -2016,6 +1955,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_origargv[i] = Nullch; } break; +#endif #ifdef USE_THREADS case '@': sv_setsv(thr->errsv, sv); @@ -2030,8 +1970,9 @@ int Perl_magic_mutexfree(pTHX_ SV *sv, MAGIC *mg) { dTHR; - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: magic_mutexfree 0x%lx\n", - (unsigned long)thr, (unsigned long)sv);) + DEBUG_S(PerlIO_printf(Perl_debug_log, + "0x%"UVxf": magic_mutexfree 0x%"UVxf"\n", + PTR2UV(thr), PTR2UV(sv));) if (MgOWNER(mg)) Perl_croak(aTHX_ "panic: magic_mutexfree"); MUTEX_DESTROY(MgMUTEXP(mg)); @@ -2061,19 +2002,6 @@ Perl_whichsig(pTHX_ char *sig) static SV* sig_sv; -STATIC void -S_unwind_handler_stack(pTHX_ void *p) -{ - dTHR; - U32 flags = *(U32*)p; - - if (flags & 1) - PL_savestack_ix -= 5; /* Unprotect save in progress. */ - /* cxstack_ix-- Not needed, die already unwound it. */ - if (flags & 64) - SvREFCNT_dec(sig_sv); -} - Signal_t Perl_sighandler(int sig) { @@ -2106,7 +2034,7 @@ Perl_sighandler(int sig) if (flags & 1) { PL_savestack_ix += 5; /* Protect save in progress. */ o_save_i = PL_savestack_ix; - SAVEDESTRUCTOR(S_unwind_handler_stack, (void*)&flags); + SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags); } if (flags & 4) PL_markstack_ptr++; /* Protect mark. */ @@ -2167,3 +2095,61 @@ cleanup: } +#ifdef PERL_OBJECT +#include "XSUB.h" +#endif + +static void +restore_magic(pTHXo_ void *p) +{ + dTHR; + MGS* mgs = SSPTR((I32)p, MGS*); + SV* sv = mgs->mgs_sv; + + if (!sv) + return; + + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) + { + if (mgs->mgs_flags) + SvFLAGS(sv) |= mgs->mgs_flags; + else + mg_magical(sv); + if (SvGMAGICAL(sv)) + SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); + } + + mgs->mgs_sv = NULL; /* mark the MGS structure as restored */ + + /* If we're still on top of the stack, pop us off. (That condition + * will be satisfied if restore_magic was called explicitly, but *not* + * if it's being called via leave_scope.) + * The reason for doing this is that otherwise, things like sv_2cv() + * may leave alloc gunk on the savestack, and some code + * (e.g. sighandler) doesn't expect that... + */ + if (PL_savestack_ix == mgs->mgs_ss_ix) + { + I32 popval = SSPOPINT; + assert(popval == SAVEt_DESTRUCTOR_X); + PL_savestack_ix -= 2; + popval = SSPOPINT; + assert(popval == SAVEt_ALLOC); + popval = SSPOPINT; + PL_savestack_ix -= popval; + } + +} + +static void +unwind_handler_stack(pTHXo_ void *p) +{ + dTHR; + U32 flags = *(U32*)p; + + if (flags & 1) + PL_savestack_ix -= 5; /* Unprotect save in progress. */ + /* cxstack_ix-- Not needed, die already unwound it. */ + if (flags & 64) + SvREFCNT_dec(sig_sv); +}