X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/097ee67dff1c60f201bc09435bc6eaeeafcd8123..6b7c0e6edcea00cbbde34f695354b0ec1ee0e05b:/mg.c diff --git a/mg.c b/mg.c index 30253bc..96d268b 100644 --- a/mg.c +++ b/mg.c @@ -1,6 +1,6 @@ /* mg.c * - * Copyright (c) 1991-1999, Larry Wall + * Copyright (c) 1991-2000, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -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,47 +60,13 @@ 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 */ +/* +=for apidoc mg_magical - /* 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; - } +Turns on the magical status of an SV. See C. -} +=cut +*/ void Perl_mg_magical(pTHX_ SV *sv) @@ -112,16 +75,24 @@ 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); } } } +/* +=for apidoc mg_get + +Do magic after a value is retrieved from the SV. See C. + +=cut +*/ + int Perl_mg_get(pTHX_ SV *sv) { @@ -137,8 +108,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,10 +124,18 @@ 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; } +/* +=for apidoc mg_set + +Do magic after a value is assigned to the SV. See C. + +=cut +*/ + int Perl_mg_set(pTHX_ SV *sv) { @@ -175,14 +154,22 @@ 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; } +/* +=for apidoc mg_length + +Report on the SV's length. See C. + +=cut +*/ + U32 Perl_mg_length(pTHX_ SV *sv) { @@ -192,14 +179,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 +203,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; } } @@ -241,6 +228,14 @@ Perl_mg_size(pTHX_ SV *sv) return 0; } +/* +=for apidoc mg_clear + +Clear something magical that the SV represents. See C. + +=cut +*/ + int Perl_mg_clear(pTHX_ SV *sv) { @@ -254,14 +249,22 @@ 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; } +/* +=for apidoc mg_find + +Finds the magic pointer for type matching the SV. See C. + +=cut +*/ + MAGIC* Perl_mg_find(pTHX_ SV *sv, int type) { @@ -273,6 +276,14 @@ Perl_mg_find(pTHX_ SV *sv, int type) return 0; } +/* +=for apidoc mg_copy + +Copies the magic from one SV to another. See C. + +=cut +*/ + int Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) { @@ -289,6 +300,14 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) return count; } +/* +=for apidoc mg_free + +Free any magic storage used by the SV. See C. + +=cut +*/ + int Perl_mg_free(pTHX_ SV *sv) { @@ -297,8 +316,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); @@ -320,10 +339,7 @@ U32 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) { dTHR; - register char *s; - register I32 i; register REGEXP *rx; - char *t; if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { if (mg->mg_obj) /* @+ */ @@ -368,10 +384,8 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) { dTHR; register I32 paren; - register char *s; register I32 i; register REGEXP *rx; - char *t; switch (*mg->mg_ptr) { case '1': case '2': case '3': case '4': @@ -431,33 +445,6 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) return 0; } -#if 0 -static char * -printW(SV *sv) -{ -#if 1 - return "" ; - -#else - int i ; - static char buffer[50] ; - char buf1[20] ; - char * p ; - - - sprintf(buffer, "Buffer %d, Length = %d - ", sv, SvCUR(sv)) ; - p = SvPVX(sv) ; - for (i = 0; i < SvCUR(sv) ; ++ i) { - sprintf (buf1, " %x [%x]", (p+i), *(p+i)) ; - strcat(buffer, buf1) ; - } - - return buffer ; - -#endif -} -#endif - int Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { @@ -466,39 +453,37 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) register char *s; register I32 i; register REGEXP *rx; - char *t; switch (*mg->mg_ptr) { case '\001': /* ^A */ sv_setsv(sv, PL_bodytarget); break; - case '\002': /* ^B */ - /* printf("magic_get $^B: ") ; */ - if (PL_curcop->cop_warnings == WARN_NONE) - /* printf("WARN_NONE\n"), */ - sv_setpvn(sv, WARN_NONEstring, WARNsize) ; - else if (PL_curcop->cop_warnings == WARN_ALL) - /* printf("WARN_ALL\n"), */ - sv_setpvn(sv, WARN_ALLstring, WARNsize) ; - else - /* printf("some %s\n", printW(PL_curcop->cop_warnings)), */ - 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 # include char msg[255]; $DESCRIPTOR(msgdsc,msg); - sv_setnv(sv,(double) vaxc$errno); + 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 @@ -507,7 +492,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #else #ifdef OS2 if (!(_emx_env & 0x200)) { /* Under DOS */ - sv_setnv(sv, (double)errno); + sv_setnv(sv, (NV)errno); sv_setpv(sv, errno ? Strerror(errno) : ""); } else { if (errno != errno_isOS2) { @@ -515,36 +500,29 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (tmp) /* 2nd call to _syserrno() makes it 0 */ Perl_rc = tmp; } - sv_setnv(sv, (double)Perl_rc); + sv_setnv(sv, (NV)Perl_rc); sv_setpv(sv, os2error(Perl_rc)); } #else #ifdef WIN32 { DWORD dwErr = GetLastError(); - sv_setnv(sv, (double)dwErr); + sv_setnv(sv, (NV)dwErr); if (dwErr) { -#ifdef PERL_OBJECT - char *sMsg; - DWORD dwLen; - PerlProc_GetSysMsg(sMsg, dwLen, dwErr); - sv_setpvn(sv, sMsg, dwLen); - PerlProc_FreeBuf(sMsg); -#else - win32_str_os_error(aTHX_ sv, dwErr); -#endif + PerlProc_GetOSError(sv, dwErr); } else sv_setpv(sv, ""); SetLastError(dwErr); } #else - sv_setnv(sv, (double)errno); + sv_setnv(sv, (NV)errno); sv_setpv(sv, errno ? Strerror(errno) : ""); #endif #endif #endif +#endif SvNOK_on(sv); /* what a wonderful hack! */ break; case '\006': /* ^F */ @@ -569,7 +547,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { dTHR; if (PL_lex_state != LEX_NOTPARSING) - SvOK_off(sv); + (void)SvOK_off(sv); else if (PL_in_eval) sv_setiv(sv, 1); else @@ -583,8 +561,24 @@ 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) == G_WARN_ON)); + case '\027': /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */ + if (*(mg->mg_ptr+1) == '\0') + sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE)); + else if (strEQ(mg->mg_ptr, "\027ARNING_BITS")) { + 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); + } + } + else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS")) + sv_setiv(sv, (IV)PL_widesyscalls); break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': @@ -611,6 +605,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) PL_tainted = FALSE; } sv_setpvn(sv, s, i); + if ((PL_curpm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) + SvUTF8_on(sv); + else + SvUTF8_off(sv); if (PL_tainting) PL_tainted = (was_tainted || RX_MATCH_TAINTED(rx)); break; @@ -709,14 +707,15 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; case '!': #ifdef VMS - sv_setnv(sv, (double)((errno == EVMSERR) ? vaxc$errno : errno)); + sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno)); sv_setpv(sv, errno ? Strerror(errno) : ""); #else { int saveerrno = errno; - sv_setnv(sv, (double)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) : ""); @@ -733,26 +732,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! */ + (void)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); @@ -868,7 +873,7 @@ Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) STRLEN n_a; magic_clear_all_env(sv,mg); hv_iterinit((HV*)sv); - while (entry = hv_iternext((HV*)sv)) { + while ((entry = hv_iternext((HV*)sv))) { I32 keylen; my_setenv(hv_iterkey(entry, &keylen), SvPV(hv_iterval((HV*)sv, entry), n_a)); @@ -884,7 +889,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; @@ -900,8 +908,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) @@ -909,11 +922,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; } @@ -977,8 +992,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; @@ -990,7 +1003,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) else { i = whichsig(s); /* ...no, a brick */ if (!i) { - if (ckWARN(WARN_SIGNAL) || strEQ(s,"ALARM")) + if (ckWARN(WARN_SIGNAL)) Perl_warner(aTHX_ WARN_SIGNAL, "No such signal: SIG%s", s); return 0; } @@ -1066,7 +1079,7 @@ Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) i = HvKEYS(hv); else { /*SUPPRESS 560*/ - while (entry = hv_iternext(hv)) { + while ((entry = hv_iternext(hv))) { i++; } } @@ -1199,7 +1212,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; @@ -1240,10 +1253,10 @@ 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 - Perl_warn(aTHX_ "Can't break at that line\n"); + else if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Can't break at that line\n"); return 0; } @@ -1273,7 +1286,7 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) if (mg && mg->mg_len >= 0) { dTHR; I32 i = mg->mg_len; - if (IN_UTF8) + if (DO_UTF8(lsv)) sv_pos_b2u(lsv, &i); sv_setiv(sv, i + PL_curcop->cop_arybase); return 0; @@ -1289,7 +1302,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; @@ -1310,12 +1323,10 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) pos = SvIV(sv) - PL_curcop->cop_arybase; - if (IN_UTF8) { + if (DO_UTF8(lsv)) { ulen = sv_len_utf8(lsv); if (ulen) len = ulen; - else - ulen = 0; } if (pos < 0) { @@ -1403,7 +1414,7 @@ Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) { dTHR; TAINT_IF((mg->mg_len & 1) || - (mg->mg_len & 2) && mg->mg_obj == sv); /* kludge */ + ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */ return 0; } @@ -1428,65 +1439,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); + (void)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; } @@ -1605,7 +1564,7 @@ Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "panic: magic_killbackrefs"); /* XXX Should we check that it hasn't changed? */ SvRV(svp[i]) = 0; - SvOK_off(svp[i]); + (void)SvOK_off(svp[i]); SvWEAKREF_off(svp[i]); svp[i] = &PL_sv_undef; } @@ -1684,22 +1643,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; - else if (memEQ(SvPVX(sv), WARN_NONEstring, WARNsize)) - PL_compiling.cop_warnings = WARN_NONE; - else { - if (PL_compiling.cop_warnings != WARN_NONE && - PL_compiling.cop_warnings != WARN_ALL) - sv_setsv(PL_compiling.cop_warnings, sv); - else - PL_compiling.cop_warnings = newSVsv(sv) ; - } - } - break; - case '\003': /* ^C */ PL_minus_c = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); break; @@ -1709,15 +1652,21 @@ 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 +# ifdef VMS + set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); +# else +# ifdef WIN32 SetLastError( SvIV(sv) ); -#else +# else +# ifndef OS2 /* will anyone ever use this? */ SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4); -#endif +# endif +# endif +# endif #endif break; case '\006': /* ^F */ @@ -1744,6 +1693,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 @@ -1752,16 +1703,44 @@ 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 = (i ? G_WARN_ON : G_WARN_OFF) ; + case '\027': /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */ + 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, "\027ARNING_BITS")) { + if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { + if (!SvPOK(sv) && PL_localizing) { + sv_setpvn(sv, WARN_NONEstring, WARNsize); + PL_compiling.cop_warnings = WARN_NONE; + break; + } + 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 ; + } + } + } + else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS")) + PL_widesyscalls = SvTRUE(sv); 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); @@ -1815,8 +1794,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; @@ -1872,13 +1853,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 '>': @@ -1899,13 +1880,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 '(': @@ -1926,13 +1907,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 ')': @@ -1943,7 +1924,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; @@ -1951,7 +1932,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); @@ -1975,18 +1956,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]; @@ -2044,6 +2026,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_origargv[i] = Nullch; } break; +#endif #ifdef USE_THREADS case '@': sv_setsv(thr->errsv, sv); @@ -2058,8 +2041,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)); @@ -2089,19 +2073,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) { @@ -2113,7 +2084,7 @@ Perl_sighandler(int sig) CV *cv = Nullcv; OP *myop = PL_op; U32 flags = 0; - I32 o_save_i = PL_savestack_ix, type; + I32 o_save_i = PL_savestack_ix; XPV *tXpv = PL_Xpv; if (PL_savestack_ix + 15 <= PL_savestack_max) @@ -2134,7 +2105,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. */ @@ -2195,3 +2166,61 @@ cleanup: } +#ifdef PERL_OBJECT +#include "XSUB.h" +#endif + +static void +restore_magic(pTHXo_ void *p) +{ + dTHR; + MGS* mgs = SSPTR(PTR2IV(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); +}