cause the SV's buffer to get stolen (and maybe other stuff).
So restore it.
*/
- sv_2mortal(SvREFCNT_inc_simple(sv));
+ sv_2mortal(SvREFCNT_inc_simple_NN(sv));
if (!was_temp) {
SvTEMP_off(sv);
}
if (DO_UTF8(sv)) {
const U8 *s = (U8*)SvPV_const(sv, len);
- len = Perl_utf8_length(aTHX_ s, s + len);
+ len = utf8_length(s, s + len);
}
else
(void)SvPV_const(sv, len);
}
else {
const char type = mg->mg_type;
- if (isUPPER(type)) {
+ if (isUPPER(type) && type != PERL_MAGIC_uvar) {
sv_magic(nsv,
(type == PERL_MAGIC_tied)
? SvTIED_obj(sv, mg)
if (PL_curpm) {
register const REGEXP * const rx = PM_GETRE(PL_curpm);
if (rx) {
- return mg->mg_obj
- ? rx->nparens /* @+ */
- : rx->lastparen; /* @- */
+ if (mg->mg_obj) { /* @+ */
+ /* return the number possible */
+ return rx->nparens;
+ } else { /* @- */
+ I32 paren = rx->lastparen;
+
+ /* return the last filled */
+ while ( paren >= 0 &&
+ rx->startp[paren] == -1 || rx->endp[paren] == -1)
+ paren--;
+ return (U32)paren;
+ }
}
}
if (i > 0 && RX_MATCH_UTF8(rx)) {
const char * const b = rx->subbeg;
if (b)
- i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
+ i = utf8_length((U8*)b, (U8*)(b+i));
}
sv_setiv(sv, i);
SvTAINTED_off(sv);
}
else if (strEQ(remaining, "PEN")) {
- if (!PL_compiling.cop_io)
+ if (!(CopHINTS_get(&PL_compiling) & HINT_LEXICAL_IO))
sv_setsv(sv, &PL_sv_undef);
else {
- sv_setsv(sv, PL_compiling.cop_io);
+ sv_setsv(sv,
+ Perl_refcounted_he_fetch(aTHX_
+ PL_compiling.cop_hints_hash,
+ 0, "open", 4, 0, 0));
}
}
break;
else if (PL_compiling.cop_warnings == pWARN_ALL) {
/* Get the bit mask for $warnings::Bits{all}, because
* it could have been extended by warnings::register */
- SV **bits_all;
HV * const bits=get_hv("warnings::Bits", FALSE);
- if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
- sv_setsv(sv, *bits_all);
+ if (bits) {
+ SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
+ if (bits_all)
+ sv_setsv(sv, *bits_all);
}
else {
sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
}
}
else {
- sv_setsv(sv, PL_compiling.cop_warnings);
+ sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
+ *PL_compiling.cop_warnings);
}
SvPOK_only(sv);
}
i = t1 - s1;
s = rx->subbeg + s1;
assert(rx->subbeg);
+ assert(rx->sublen >= s1);
getrx:
if (i >= 0) {
TAINT_NOT;
sv_setpvn(sv, s, i);
PL_tainted = oldtainted;
- if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
+ if ( (rx->reganch & ROPT_CANY_SEEN)
+ ? (RX_MATCH_UTF8(rx)
+ && (!i || is_utf8_string((U8*)s, i)))
+ : (RX_MATCH_UTF8(rx)) )
+ {
SvUTF8_on(sv);
+ }
else
SvUTF8_off(sv);
if (PL_tainting) {
case '/':
break;
case '[':
- WITH_THR(sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop)));
+ sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
break;
case '|':
if (GvIOp(PL_defoutgv))
Stat_t sbuf;
int i = 0, j = 0;
- strncpy(eltbuf, s, 255);
- eltbuf[255] = 0;
+ my_strlcpy(eltbuf, s, sizeof(eltbuf));
elt = eltbuf;
do { /* DCL$PATH may be a search list */
while (1) { /* as may dev portion of any element */
char tmpbuf[256];
Stat_t st;
I32 i;
+#ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
+ const char path_sep = '|';
+#else
+ const char path_sep = ':';
+#endif
s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
- s, strend, ':', &i);
+ s, strend, path_sep, &i);
s++;
- if (i >= sizeof tmpbuf /* too long -- assume the worst */
- || *tmpbuf != '/'
+ if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
+#ifdef VMS
+ || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
+#else
+ || *tmpbuf != '/' /* no starting slash -- assume relative path */
+#endif
|| (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
MgTAINTEDDIR_on(mg);
return 0;
restore_sigmask(pTHX_ SV *save_sv)
{
const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
- (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
+ (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
}
#endif
int
if(PL_psig_ptr[i])
sv_setsv(sv,PL_psig_ptr[i]);
else {
- Sighandler_t sigstate;
- sigstate = rsignal_state(i);
+ Sighandler_t sigstate = rsignal_state(i);
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
- if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
+ if (PL_sig_handlers_initted && PL_sig_ignoring[i])
+ sigstate = SIG_IGN;
#endif
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
- if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
+ if (PL_sig_handlers_initted && PL_sig_defaulting[i])
+ sigstate = SIG_DFL;
#endif
/* cache state so we don't fetch it again */
if(sigstate == (Sighandler_t) SIG_IGN)
sv_setpv(sv,"IGNORE");
else
sv_setsv(sv,&PL_sv_undef);
- PL_psig_ptr[i] = SvREFCNT_inc_simple(sv);
+ PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
SvTEMP_off(sv);
}
}
SV** svp = NULL;
if (strEQ(s,"__DIE__"))
svp = &PL_diehook;
- else if (strEQ(s,"__WARN__"))
+ else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
svp = &PL_warnhook;
- else
- Perl_croak(aTHX_ "No such hook: %s", s);
if (svp && *svp) {
- SV * const to_dec = *svp;
+ SV *const to_dec = *svp;
*svp = NULL;
- SvREFCNT_dec(to_dec);
+ SvREFCNT_dec(to_dec);
}
}
else {
exit(1);
#endif
#endif
- if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+ if (
+#ifdef SIGILL
+ sig == SIGILL ||
+#endif
+#ifdef SIGBUS
+ sig == SIGBUS ||
+#endif
+#ifdef SIGSEGV
+ sig == SIGSEGV ||
+#endif
+ (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
/* Call the perl level handler now--
* with risk we may be in malloc() etc. */
(*PL_sighandlerp)(sig);
Perl_croak(aTHX_ "No such hook: %s", s);
i = 0;
if (*svp) {
- to_dec = *svp;
+ if (*svp != PERL_WARNHOOK_FATAL)
+ to_dec = *svp;
*svp = NULL;
}
}
#endif
SvREFCNT_dec(PL_psig_name[i]);
to_dec = PL_psig_ptr[i];
- PL_psig_ptr[i] = SvREFCNT_inc_simple(sv);
+ PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(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 (i)
(void)rsignal(i, PL_csighandlerp);
else
- *svp = SvREFCNT_inc_simple(sv);
+ *svp = SvREFCNT_inc_simple_NN(sv);
}
#ifdef HAS_SIGPROCMASK
if(i)
}
int
-Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
+Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
{
return magic_methpack(sv,mg,"EXISTS");
}
Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
{
dVAR; dSP;
- SV *retval = &PL_sv_undef;
+ SV *retval;
SV * const tied = SvTIED_obj((SV*)hv, mg);
HV * const pkg = SvSTASH((SV*)SvRV(tied));
if (call_method("SCALAR", G_SCALAR))
retval = *PL_stack_sp--;
+ else
+ retval = &PL_sv_undef;
POPSTACK;
LEAVE;
return retval;
{
dVAR;
STRLEN len;
- const char *tmps = SvPV_const(sv, len);
+ const char * const tmps = SvPV_const(sv, len);
SV * const lsv = LvTARG(sv);
I32 lvoff = LvTARGOFF(sv);
I32 lvlen = LvTARGLEN(sv);
SvUTF8_on(lsv);
}
else if (lsv && SvUTF8(lsv)) {
+ const char *utf8;
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);
+ utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
+ sv_insert(lsv, lvoff, lvlen, utf8, len);
+ Safefree(utf8);
}
else {
sv_insert(lsv, lvoff, lvlen, tmps, len);
if ((I32)LvTARGOFF(sv) <= AvFILL(av))
targ = AvARRAY(av)[LvTARGOFF(sv)];
}
- if (targ && targ != &PL_sv_undef) {
+ if (targ && (targ != &PL_sv_undef)) {
/* somebody else defined it for us */
SvREFCNT_dec(LvTARG(sv));
LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
}
}
else if (strEQ(mg->mg_ptr, "\017PEN")) {
- if (!PL_compiling.cop_io)
- PL_compiling.cop_io = newSVsv(sv);
- else
- sv_setsv(PL_compiling.cop_io,sv);
+ PL_compiling.cop_hints |= HINT_LEXICAL_IO;
+ PL_hints |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO;
+ PL_compiling.cop_hints_hash
+ = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
+ sv_2mortal(newSVpvs("open")), sv);
}
break;
case '\020': /* ^P */
accumulate |= ptr[i] ;
any_fatals |= (ptr[i] & 0xAA) ;
}
- if (!accumulate)
- PL_compiling.cop_warnings = pWARN_NONE;
- else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
+ if (!accumulate) {
+ if (!specialWARN(PL_compiling.cop_warnings))
+ PerlMemShared_free(PL_compiling.cop_warnings);
+ PL_compiling.cop_warnings = pWARN_NONE;
+ }
+ /* Yuck. I can't see how to abstract this: */
+ else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
+ WARN_ALL) && !any_fatals) {
+ if (!specialWARN(PL_compiling.cop_warnings))
+ PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = pWARN_ALL;
PL_dowarn |= G_WARN_ONCE ;
}
else {
- if (specialWARN(PL_compiling.cop_warnings))
- PL_compiling.cop_warnings = newSVsv(sv) ;
- else
- sv_setsv(PL_compiling.cop_warnings, sv);
+ STRLEN len;
+ const char *const p = SvPV_const(sv, len);
+
+ PL_compiling.cop_warnings
+ = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
+ p, len);
+
if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
PL_dowarn |= G_WARN_ONCE ;
}
}
if (i)
(void)setgroups(i, gary);
- if (gary)
- Safefree(gary);
+ Safefree(gary);
}
#else /* HAS_SETGROUPS */
PL_egid = SvIV(sv);
#endif
EXTEND(SP, 2);
PUSHs((SV*)rv);
- PUSHs(newSVpv((void*)sip, sizeof(*sip)));
+ PUSHs(newSVpv((char *)sip, sizeof(*sip)));
}
va_end(args);
/* downgrade public flags to private,
and discard any other private flags */
- U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
- if (public) {
- SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
- SvFLAGS(sv) |= ( public << PRIVSHIFT );
+ const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
+ if (pubflags) {
+ SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
+ SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
}
}
}
=for apidoc magic_sethint
Triggered by a store to %^H, records the key/value pair to
-C<PL_compiling.cop_hints>. It is assumed that hints aren't storing anything
-that would need a deep copy. Maybe we should warn if we find a reference.
+C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
+anything that would need a deep copy. Maybe we should warn if we find a
+reference.
=cut
*/
Doing this here saves a lot of doing it manually in perl code (and
forgetting to do it, and consequent subtle errors. */
PL_hints |= HINT_LOCALIZE_HH;
- PL_compiling.cop_hints
- = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
- (SV *)mg->mg_ptr, newSVsv(sv));
+ PL_compiling.cop_hints_hash
+ = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
+ (SV *)mg->mg_ptr, sv);
return 0;
}
/*
=for apidoc magic_sethint
-Triggered by a delete from %^H, records the key to C<PL_compiling.cop_hints>.
+Triggered by a delete from %^H, records the key to
+C<PL_compiling.cop_hints_hash>.
=cut
*/
Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+ PERL_UNUSED_ARG(sv);
+
assert(mg->mg_len == HEf_SVKEY);
+ PERL_UNUSED_ARG(sv);
+
PL_hints |= HINT_LOCALIZE_HH;
- PL_compiling.cop_hints
- = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
+ PL_compiling.cop_hints_hash
+ = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
(SV *)mg->mg_ptr, &PL_sv_placeholder);
return 0;
}
https://perl5.git.perl.org / perl5.git / blobdiff