X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/25da442874cf6136cfd7e0a24430b1ec13c17197..055972dc609b4a79791de1e554064be888603159:/mg.c diff --git a/mg.c b/mg.c index 116a369..d86e22d 100644 --- a/mg.c +++ b/mg.c @@ -1,6 +1,7 @@ /* mg.c * - * Copyright (c) 1991-2002, Larry Wall + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -33,6 +34,8 @@ # include #endif +Signal_t Perl_csighandler(int sig); + /* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */ #if !defined(HAS_SIGACTION) && defined(VMS) # define FAKE_PERSISTENT_SIGNAL_HANDLERS @@ -45,6 +48,14 @@ static void restore_magic(pTHX_ void *p); static void unwind_handler_stack(pTHX_ void *p); +#ifdef __Lynx__ +/* Missing protos on LynxOS */ +void setruid(uid_t id); +void seteuid(uid_t id); +void setrgid(uid_t id); +void setegid(uid_t id); +#endif + /* * Use the "DESTRUCTOR" scope cleanup to reinstate magic. */ @@ -131,6 +142,16 @@ Perl_mg_get(pTHX_ SV *sv) if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg); + + /* guard against sv having been freed */ + if (SvTYPE(sv) == SVTYPEMASK) { + Perl_croak(aTHX_ "Tied variable freed while still in use"); + } + /* guard against magic having been deleted - eg FETCH calling + * untie */ + if (!SvMAGIC(sv)) + break; + /* Don't restore the flags for this entry if it was deleted. */ if (mg->mg_flags & MGf_GSKIP) (SSPTR(mgs_ix, MGS *))->mgs_flags = 0; @@ -363,7 +384,7 @@ Perl_mg_free(pTHX_ SV *sv) if (vtbl && vtbl->svt_free) CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { - if (mg->mg_len > 0) + if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8) Safefree(mg->mg_ptr); else if (mg->mg_len == HEf_SVKEY) SvREFCNT_dec((SV*)mg->mg_ptr); @@ -376,10 +397,7 @@ Perl_mg_free(pTHX_ SV *sv) return 0; } - -#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include -#endif U32 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) @@ -534,7 +552,7 @@ int Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { register I32 paren; - register char *s; + register char *s = NULL; register I32 i; register REGEXP *rx; @@ -548,9 +566,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\004': /* ^D */ sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK)); -#if defined(YYDEBUG) && defined(DEBUGGING) - PL_yydebug = DEBUG_p_TEST; -#endif break; case '\005': /* ^E */ if (*(mg->mg_ptr+1) == '\0') { @@ -602,8 +617,12 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) SetLastError(dwErr); } #else - sv_setnv(sv, (NV)errno); - sv_setpv(sv, errno ? Strerror(errno) : ""); + { + int saveerrno = errno; + sv_setnv(sv, (NV)errno); + sv_setpv(sv, errno ? Strerror(errno) : ""); + errno = saveerrno; + } #endif #endif #endif @@ -626,8 +645,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setsv(sv, &PL_sv_undef); break; case '\017': /* ^O & ^OPEN */ - if (*(mg->mg_ptr+1) == '\0') + if (*(mg->mg_ptr+1) == '\0') { sv_setpv(sv, PL_osname); + SvTAINTED_off(sv); + } else if (strEQ(mg->mg_ptr, "\017PEN")) { if (!PL_compiling.cop_io) sv_setsv(sv, &PL_sv_undef); @@ -676,7 +697,16 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setpvn(sv, WARN_NONEstring, WARNsize) ; } else if (PL_compiling.cop_warnings == pWARN_ALL) { - sv_setpvn(sv, WARN_ALLstring, WARNsize) ; + /* Get the bit mask for $warnings::Bits{all}, because + * it could have been extended by warnings::register */ + SV **bits_all; + HV *bits=get_hv("warnings::Bits", FALSE); + if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) { + sv_setsv(sv, *bits_all); + } + else { + sv_setpvn(sv, WARN_ALLstring, WARNsize) ; + } } else { sv_setsv(sv, PL_compiling.cop_warnings); @@ -783,7 +813,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } break; case '^': - s = IoTOP_NAME(GvIOp(PL_defoutgv)); + if (GvIOp(PL_defoutgv)) + s = IoTOP_NAME(GvIOp(PL_defoutgv)); if (s) sv_setpv(sv,s); else { @@ -792,20 +823,24 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } break; case '~': - s = IoFMT_NAME(GvIOp(PL_defoutgv)); + if (GvIOp(PL_defoutgv)) + s = IoFMT_NAME(GvIOp(PL_defoutgv)); if (!s) s = GvENAME(PL_defoutgv); sv_setpv(sv,s); break; #ifndef lint case '=': - sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv))); + if (GvIOp(PL_defoutgv)) + sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv))); break; case '-': - sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv))); + if (GvIOp(PL_defoutgv)) + sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv))); break; case '%': - sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); + if (GvIOp(PL_defoutgv)) + sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); break; #endif case ':': @@ -816,7 +851,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase)); break; case '|': - sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); + if (GvIOp(PL_defoutgv)) + sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); break; case ',': break; @@ -874,8 +910,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #endif (void)SvIOK_on(sv); /* what a wonderful hack! */ break; - case '*': - break; #ifndef MACOS_TRADITIONAL case '0': break; @@ -1002,6 +1036,7 @@ Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) { +#ifndef PERL_MICRO #if defined(VMS) || defined(EPOC) Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); #else @@ -1028,7 +1063,8 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) } # endif /* USE_ENVIRON_ARRAY */ # endif /* PERL_IMPLICIT_SYS || WIN32 */ -#endif /* VMS || EPC */ +#endif /* VMS || EPOC */ +#endif /* !PERL_MICRO */ return 0; } @@ -1043,6 +1079,14 @@ static int sig_defaulting[SIG_SIZE]; #endif #ifndef PERL_MICRO +#ifdef HAS_SIGPROCMASK +static void +restore_sigmask(pTHX_ SV *save_sv) +{ + sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv ); + (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0); +} +#endif int Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) { @@ -1050,7 +1094,7 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) STRLEN n_a; /* Are we fetching a signal entry? */ i = whichsig(MgPV(mg,n_a)); - if (i) { + if (i > 0) { if(PL_psig_ptr[i]) sv_setsv(sv,PL_psig_ptr[i]); else { @@ -1076,19 +1120,67 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) { - I32 i; + /* XXX Some of this code was copied from Perl_magic_setsig. A little + * refactoring might be in order. + */ + register char *s; STRLEN n_a; - /* Are we clearing a signal entry? */ - i = whichsig(MgPV(mg,n_a)); - if (i) { - if(PL_psig_ptr[i]) { - SvREFCNT_dec(PL_psig_ptr[i]); - PL_psig_ptr[i]=0; - } - if(PL_psig_name[i]) { - SvREFCNT_dec(PL_psig_name[i]); - PL_psig_name[i]=0; - } + SV* to_dec; + s = MgPV(mg,n_a); + if (*s == '_') { + SV** svp; + if (strEQ(s,"__DIE__")) + svp = &PL_diehook; + else if (strEQ(s,"__WARN__")) + svp = &PL_warnhook; + else + Perl_croak(aTHX_ "No such hook: %s", s); + if (*svp) { + to_dec = *svp; + *svp = 0; + SvREFCNT_dec(to_dec); + } + } + else { + I32 i; + /* Are we clearing a signal entry? */ + i = whichsig(s); + if (i > 0) { +#ifdef HAS_SIGPROCMASK + sigset_t set, save; + SV* save_sv; + /* Avoid having the signal arrive at a bad time, if possible. */ + sigemptyset(&set); + sigaddset(&set,i); + sigprocmask(SIG_BLOCK, &set, &save); + ENTER; + save_sv = newSVpv((char *)(&save), sizeof(sigset_t)); + SAVEFREESV(save_sv); + SAVEDESTRUCTOR_X(restore_sigmask, save_sv); +#endif + PERL_ASYNC_CHECK(); +#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) + if (!sig_handlers_initted) Perl_csighandler_init(); +#endif +#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS + sig_defaulting[i] = 1; + (void)rsignal(i, PL_csighandlerp); +#else + (void)rsignal(i, SIG_DFL); +#endif + if(PL_psig_name[i]) { + SvREFCNT_dec(PL_psig_name[i]); + PL_psig_name[i]=0; + } + if(PL_psig_ptr[i]) { + to_dec=PL_psig_ptr[i]; + PL_psig_ptr[i]=0; + LEAVE; + SvREFCNT_dec(to_dec); + } + else + LEAVE; + } } return 0; } @@ -1111,7 +1203,7 @@ Perl_csighandler(int sig) dTHX; #endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS - (void) rsignal(sig, &Perl_csighandler); + (void) rsignal(sig, PL_csighandlerp); if (sig_ignoring[sig]) return; #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS @@ -1141,7 +1233,7 @@ Perl_csighandler_init(void) #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS dTHX; sig_defaulting[sig] = 1; - (void) rsignal(sig, &Perl_csighandler); + (void) rsignal(sig, PL_csighandlerp); #endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS sig_ignoring[sig] = 0; @@ -1158,21 +1250,6 @@ Perl_despatch_signals(pTHX) PL_sig_pending = 0; for (sig = 1; sig < SIG_SIZE; sig++) { if (PL_psig_pend[sig]) { -#define PERL_BLOCK_SIGNALS -#if defined(HAS_SIGPROCMASK) && defined(PERL_BLOCK_SIGNALS) - /* From sigaction(2) (FreeBSD man page): - * | Signal routines normally execute with the signal that - * | caused their invocation blocked, but other signals may - * | yet occur. - * Emulate this behavior. - */ -# define PERL_BLOCKSIG_ADD(set,sig) \ - sigset_t set; sigemptyset(&(set)); sigaddset(&(set), sig) -# define PERL_BLOCKSIG_BLOCK(set) \ - sigprocmask(SIG_BLOCK, &(set), NULL) -# define PERL_BLOCKSIG_UNBLOCK(set) \ - sigprocmask(SIG_UNBLOCK, &(set), NULL) -#endif /* HAS_SIGPROCMASK && PERL_BLOCK_SIGNALS */ PERL_BLOCKSIG_ADD(set, sig); PL_psig_pend[sig] = 0; PERL_BLOCKSIG_BLOCK(set); @@ -1188,7 +1265,16 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) register char *s; I32 i; SV** svp = 0; + /* Need to be careful with SvREFCNT_dec(), because that can have side + * effects (due to closures). We must make sure that the new disposition + * is in place before it is called. + */ + SV* to_dec = 0; STRLEN len; +#ifdef HAS_SIGPROCMASK + sigset_t set, save; + SV* save_sv; +#endif s = MgPV(mg,len); if (*s == '_') { @@ -1200,17 +1286,28 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "No such hook: %s", s); i = 0; if (*svp) { - SvREFCNT_dec(*svp); + to_dec = *svp; *svp = 0; } } else { i = whichsig(s); /* ...no, a brick */ - if (!i) { + if (i < 0) { if (ckWARN(WARN_SIGNAL)) Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s); return 0; } +#ifdef HAS_SIGPROCMASK + /* Avoid having the signal arrive at a bad time, if possible. */ + sigemptyset(&set); + sigaddset(&set,i); + sigprocmask(SIG_BLOCK, &set, &save); + ENTER; + save_sv = newSVpv((char *)(&save), sizeof(sigset_t)); + SAVEFREESV(save_sv); + SAVEDESTRUCTOR_X(restore_sigmask, save_sv); +#endif + PERL_ASYNC_CHECK(); #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) if (!sig_handlers_initted) Perl_csighandler_init(); #endif @@ -1218,20 +1315,26 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) sig_ignoring[i] = 0; #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS - sig_defaulting[i] = 0; + sig_defaulting[i] = 0; #endif SvREFCNT_dec(PL_psig_name[i]); - SvREFCNT_dec(PL_psig_ptr[i]); + to_dec = PL_psig_ptr[i]; PL_psig_ptr[i] = SvREFCNT_inc(sv); SvTEMP_off(sv); /* Make sure it doesn't go away on us */ PL_psig_name[i] = newSVpvn(s, len); SvREADONLY_on(PL_psig_name[i]); } if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) { - if (i) - (void)rsignal(i, &Perl_csighandler); + if (i) { + (void)rsignal(i, PL_csighandlerp); +#ifdef HAS_SIGPROCMASK + LEAVE; +#endif + } else *svp = SvREFCNT_inc(sv); + if(to_dec) + SvREFCNT_dec(to_dec); return 0; } s = SvPV_force(sv,len); @@ -1239,25 +1342,22 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) if (i) { #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS sig_ignoring[i] = 1; - (void)rsignal(i, &Perl_csighandler); + (void)rsignal(i, PL_csighandlerp); #else (void)rsignal(i, SIG_IGN); #endif - } else - *svp = 0; + } } else if (strEQ(s,"DEFAULT") || !*s) { if (i) #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS { sig_defaulting[i] = 1; - (void)rsignal(i, &Perl_csighandler); + (void)rsignal(i, PL_csighandlerp); } #else (void)rsignal(i, SIG_DFL); #endif - else - *svp = 0; } else { /* @@ -1268,10 +1368,16 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) if (!strchr(s,':') && !strchr(s,'\'')) sv_insert(sv, 0, 0, "main::", 6); if (i) - (void)rsignal(i, &Perl_csighandler); + (void)rsignal(i, PL_csighandlerp); else *svp = SvREFCNT_inc(sv); } +#ifdef HAS_SIGPROCMASK + if(i) + LEAVE; +#endif + if(to_dec) + SvREFCNT_dec(to_dec); return 0; } #endif /* !PERL_MICRO */ @@ -1371,9 +1477,9 @@ S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth) int Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) { - magic_methpack(sv,mg,"FETCH"); if (mg->mg_ptr) mg->mg_flags |= MGf_GSKIP; + magic_methpack(sv,mg,"FETCH"); return 0; } @@ -1428,6 +1534,7 @@ Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg) call_method("CLEAR", G_SCALAR|G_DISCARD); POPSTACK; LEAVE; + return 0; } @@ -1462,6 +1569,41 @@ Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg) return magic_methpack(sv,mg,"EXISTS"); } +SV * +Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) +{ + dSP; + SV *retval = &PL_sv_undef; + SV *tied = SvTIED_obj((SV*)hv, mg); + HV *pkg = SvSTASH((SV*)SvRV(tied)); + + if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) { + SV *key; + if (HvEITER(hv)) + /* we are in an iteration so the hash cannot be empty */ + return &PL_sv_yes; + /* no xhv_eiter so now use FIRSTKEY */ + key = sv_newmortal(); + magic_nextpack((SV*)hv, mg, key); + HvEITER(hv) = NULL; /* need to reset iterator */ + return SvOK(key) ? &PL_sv_yes : &PL_sv_no; + } + + /* there is a SCALAR method that we can call */ + ENTER; + PUSHSTACKi(PERLSI_MAGIC); + PUSHMARK(SP); + EXTEND(SP, 1); + PUSHs(tied); + PUTBACK; + + if (call_method("SCALAR", G_SCALAR)) + retval = *PL_stack_sp--; + POPSTACK; + LEAVE; + return retval; +} + int Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) { @@ -1638,16 +1780,21 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) sv_utf8_upgrade(lsv); sv_pos_u2b(lsv, &lvoff, &lvlen); sv_insert(lsv, lvoff, lvlen, tmps, len); + LvTARGLEN(sv) = sv_len_utf8(sv); SvUTF8_on(lsv); } else if (lsv && SvUTF8(lsv)) { sv_pos_u2b(lsv, &lvoff, &lvlen); + LvTARGLEN(sv) = len; tmps = (char*)bytes_to_utf8((U8*)tmps, &len); sv_insert(lsv, lvoff, lvlen, tmps, len); Safefree(tmps); } - else - sv_insert(lsv, lvoff, lvlen, tmps, len); + else { + sv_insert(lsv, lvoff, lvlen, tmps, len); + LvTARGLEN(sv) = len; + } + return 0; } @@ -1784,17 +1931,18 @@ Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) SV **svp = AvARRAY(av); I32 i = AvFILLp(av); while (i >= 0) { - if (svp[i] && svp[i] != &PL_sv_undef) { + if (svp[i]) { if (!SvWEAKREF(svp[i])) Perl_croak(aTHX_ "panic: magic_killbackrefs"); /* XXX Should we check that it hasn't changed? */ SvRV(svp[i]) = 0; (void)SvOK_off(svp[i]); SvWEAKREF_off(svp[i]); - svp[i] = &PL_sv_undef; + svp[i] = Nullsv; } i--; } + SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */ return 0; } @@ -1833,6 +1981,13 @@ Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg) } int +Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) +{ + sv_unmagic(sv, PERL_MAGIC_qr); + return 0; +} + +int Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg) { regexp *re = (regexp *)mg->mg_obj; @@ -1882,8 +2037,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '\004': /* ^D */ - PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG; +#ifdef DEBUGGING + s = SvPV_nolen(sv); + PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG; DEBUG_x(dump_all()); +#else + PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG; +#endif break; case '\005': /* ^E */ if (*(mg->mg_ptr+1) == '\0') { @@ -1933,12 +2093,14 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '\017': /* ^O */ if (*(mg->mg_ptr+1) == '\0') { - if (PL_osname) + if (PL_osname) { Safefree(PL_osname); - if (SvOK(sv)) - PL_osname = savepv(SvPV(sv,len)); - else PL_osname = Nullch; + } + if (SvOK(sv)) { + TAINT_PROPER("assigning to $^O"); + PL_osname = savepv(SvPV(sv,len)); + } } else if (strEQ(mg->mg_ptr, "\017PEN")) { if (!PL_compiling.cop_io) @@ -1949,7 +2111,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) + if ((PERLDB_SUB || PERLDB_LINE || PERLDB_SUBLINE || PERLDB_ASSERTION) + && !PL_DBsingle) init_debugger(); break; case '\024': /* ^T */ @@ -2048,10 +2211,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } } break; - case '*': - i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); - PL_multiline = (i != 0); - break; case '/': SvREFCNT_dec(PL_rs); PL_rs = newSVsv(sv); @@ -2125,9 +2284,14 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #ifdef HAS_SETRESUID (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1); #else - if (PL_uid == PL_euid) /* special case $< = $> */ + if (PL_uid == PL_euid) { /* special case $< = $> */ +#ifdef PERL_DARWIN + /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */ + if (PL_uid != 0 && PerlProc_getuid() == 0) + (void)PerlProc_setuid(0); +#endif (void)PerlProc_setuid(PL_uid); - else { + } else { PL_uid = PerlProc_getuid(); Perl_croak(aTHX_ "setruid() not implemented"); } @@ -2278,61 +2442,28 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) pstat(PSTAT_SETCMD, un, len, 0, 0); } #endif - if (!PL_origalen) { - s = PL_origargv[0]; - s += strlen(s); - /* See if all the arguments are contiguous in memory */ - for (i = 1; i < PL_origargc; i++) { - if (PL_origargv[i] == s + 1 -#ifdef OS2 - || PL_origargv[i] == s + 2 -#endif - ) - { - ++s; - s += strlen(s); /* this one is ok too */ - } - else - break; - } - /* can grab env area too? */ - if (PL_origenviron -#ifdef USE_ITHREADS - && PL_curinterp == aTHX -#endif - && (PL_origenviron[0] == s + 1)) - { - my_setenv("NoNe SuCh", Nullch); - /* force copy of environment */ - for (i = 0; PL_origenviron[i]; i++) - if (PL_origenviron[i] == s + 1) { - ++s; - s += strlen(s); - } - else - break; - } - PL_origalen = s - PL_origargv[0]; - } + /* PL_origalen is set in perl_parse(). */ s = SvPV_force(sv,len); - i = len; - if (i >= (I32)PL_origalen) { - i = PL_origalen; - /* don't allow system to limit $0 seen by script */ - /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */ - Copy(s, PL_origargv[0], i, char); - s = PL_origargv[0]+i; - *s = '\0'; + if (len >= (STRLEN)PL_origalen-1) { + /* Longer than original, will be truncated. We assume that + * PL_origalen bytes are available. */ + Copy(s, PL_origargv[0], PL_origalen-1, char); } else { - Copy(s, PL_origargv[0], i, char); - s = PL_origargv[0]+i; - *s++ = '\0'; - while (++i < (I32)PL_origalen) - *s++ = '\0'; - for (i = 1; i < PL_origargc; i++) - PL_origargv[i] = Nullch; - } + /* Shorter than original, will be padded. */ + Copy(s, PL_origargv[0], len, char); + PL_origargv[0][len] = 0; + memset(PL_origargv[0] + len + 1, + /* Is the space counterintuitive? Yes. + * (You were expecting \0?) + * Does it work? Seems to. (In Linux 2.4.20 at least.) + * --jhi */ + (int)' ', + PL_origalen - len - 1); + } + PL_origargv[0][PL_origalen-1] = 0; + for (i = 1; i < PL_origargc; i++) + PL_origargv[i] = 0; UNLOCK_DOLLARZERO_MUTEX; break; #endif @@ -2345,7 +2476,7 @@ Perl_whichsig(pTHX_ char *sig) { register char **sigv; - for (sigv = PL_sig_name+1; *sigv; sigv++) + for (sigv = PL_sig_name; *sigv; sigv++) if (strEQ(sig,*sigv)) return PL_sig_num[sigv - PL_sig_name]; #ifdef SIGCLD @@ -2356,7 +2487,7 @@ Perl_whichsig(pTHX_ char *sig) if (strEQ(sig,"CLD")) return SIGCHLD; #endif - return 0; + return -1; } #if !defined(PERL_IMPLICIT_CONTEXT) @@ -2457,7 +2588,7 @@ Perl_sighandler(int sig) #else /* Not clear if this will work */ (void)rsignal(sig, SIG_IGN); - (void)rsignal(sig, &Perl_csighandler); + (void)rsignal(sig, PL_csighandlerp); #endif #endif /* !PERL_MICRO */ Perl_die(aTHX_ Nullformat); @@ -2492,6 +2623,13 @@ restore_magic(pTHX_ void *p) if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { +#ifdef PERL_COPY_ON_WRITE + /* While magic was saved (and off) sv_setsv may well have seen + this SV as a prime candidate for COW. */ + if (SvIsCOW(sv)) + sv_force_normal(sv); +#endif + if (mgs->mgs_flags) SvFLAGS(sv) |= mgs->mgs_flags; else