X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=84fff242781518b9a98c08c626f6bc9b693c4fa8;hb=2aa761807d7eac561ade382b2c66eebffcdf056f;hp=0e9ca198e7894c41f4179ddbc072cd4518db9670;hpb=6520202708b2a849ca8538ed88e0f75376c3b2d7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mg.c b/mg.c index 0e9ca19..84fff24 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; +/* +=for apidoc mg_magical - if (!sv) - return; +Turns on the magical status of an SV. See C. - 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; - } - -} +=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,16 +384,14 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) { dTHR; register I32 paren; - register char *s; register I32 i; register REGEXP *rx; - char *t; + I32 s1, t1; switch (*mg->mg_ptr) { case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { - I32 s1, t1; paren = atoi(mg->mg_ptr); getparen: @@ -386,6 +400,16 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) (t1 = rx->endp[paren]) != -1) { i = t1 - s1; + getlen: + if (i > 0 && (PL_curpm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) { + char *s = rx->subbeg + s1; + char *send = rx->subbeg + t1; + i = 0; + while (s < send) { + s += UTF8SKIP(s); + i++; + } + } if (i >= 0) return i; } @@ -402,8 +426,11 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { if (rx->startp[0] != -1) { i = rx->startp[0]; - if (i >= 0) - return i; + if (i > 0) { + s1 = 0; + t1 = i; + goto getlen; + } } } return 0; @@ -411,8 +438,11 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { if (rx->endp[0] != -1) { i = rx->sublen - rx->endp[0]; - if (i >= 0) - return i; + if (i > 0) { + s1 = rx->endp[0]; + t1 = rx->sublen; + goto getlen; + } } } return 0; @@ -431,33 +461,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,32 +469,30 @@ 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)gMacPerl_OSErr); + sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : ""); + } +#else #ifdef VMS { # include @@ -537,6 +538,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #endif #endif #endif +#endif SvNOK_on(sv); /* what a wonderful hack! */ break; case '\006': /* ^F */ @@ -561,7 +563,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 @@ -575,8 +577,25 @@ 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 == pWARN_NONE || + PL_compiling.cop_warnings == pWARN_STD) + { + sv_setpvn(sv, WARN_NONEstring, WARNsize) ; + } + else if (PL_compiling.cop_warnings == pWARN_ALL) { + sv_setpvn(sv, WARN_ALLstring, WARNsize) ; + } + else { + sv_setsv(sv, PL_compiling.cop_warnings); + } + SvPOK_only(sv); + } + 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 '&': @@ -595,6 +614,9 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { i = t1 - s1; s = rx->subbeg + s1; + if (!rx->subbeg) + break; + getrx: if (i >= 0) { bool was_tainted; @@ -603,6 +625,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; @@ -708,7 +734,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) : ""); @@ -725,26 +752,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); @@ -860,7 +893,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)); @@ -876,7 +909,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; @@ -892,8 +928,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) @@ -901,15 +942,18 @@ 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; } +#ifndef PERL_MICRO int Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) { @@ -969,8 +1013,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; @@ -982,7 +1024,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; } @@ -1028,6 +1070,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) } return 0; } +#endif /* !PERL_MICRO */ int Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) @@ -1058,7 +1101,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++; } } @@ -1191,7 +1234,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; @@ -1232,10 +1275,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; } @@ -1265,7 +1308,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; @@ -1281,7 +1324,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; @@ -1302,12 +1345,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) { @@ -1395,7 +1436,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; } @@ -1420,65 +1461,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; } @@ -1597,7 +1586,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; } @@ -1676,22 +1665,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; @@ -1701,15 +1674,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 + gMacPerl_OSErr = 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 @@ -1738,6 +1715,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 @@ -1746,16 +1725,51 @@ 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 = pWARN_NONE; + break; + } + if (isWARN_on(sv, WARN_ALL) && !isWARNf_on(sv, WARN_ALL)) { + PL_compiling.cop_warnings = pWARN_ALL; + PL_dowarn |= G_WARN_ONCE ; + } + else { + STRLEN len, i; + int accumulate = 0 ; + char * ptr = (char*)SvPV(sv, len) ; + for (i = 0 ; i < len ; ++i) + accumulate += ptr[i] ; + if (!accumulate) + PL_compiling.cop_warnings = pWARN_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); @@ -1809,8 +1823,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; @@ -1866,13 +1882,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 '>': @@ -1893,13 +1909,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 '(': @@ -1920,13 +1936,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 ')': @@ -1937,7 +1953,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; @@ -1945,7 +1961,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); @@ -1969,18 +1985,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]; @@ -2037,7 +2054,11 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) for (i = 1; i < PL_origargc; i++) PL_origargv[i] = Nullch; } +#ifdef HAS_SETPROCTITLE + setproctitle("%s", SvPV_nolen(sv)); +#endif break; +#endif #ifdef USE_THREADS case '@': sv_setsv(thr->errsv, sv); @@ -2052,8 +2073,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)); @@ -2083,23 +2105,14 @@ 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) { +#if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT) + dTHXoa(PL_curinterp); /* fake TLS, because signals don't do TLS */ +#else dTHX; +#endif dSP; GV *gv = Nullgv; HV *st; @@ -2107,8 +2120,12 @@ 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 defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT) + PERL_SET_THX(aTHXo); /* fake TLS, see above */ +#endif if (PL_savestack_ix + 15 <= PL_savestack_max) flags |= 1; @@ -2128,7 +2145,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. */ @@ -2189,3 +2206,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); +}