/* mg.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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.
SvMAGICAL_off(sv);
SvREADONLY_off(sv);
- SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
+ /* No public flags are set, so promote any private flags to public. */
+ SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ }
}
/*
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);
dVAR;
register I32 paren;
register char *s = NULL;
- register I32 i;
register REGEXP *rx;
const char * const remaining = mg->mg_ptr + 1;
const char nextchar = *remaining;
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) ;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- I32 s1, t1;
-
/*
* Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
* XXX Does the new way break anything?
*/
paren = atoi(mg->mg_ptr); /* $& is in [0] */
- getparen:
- if (paren <= (I32)rx->nparens &&
- (s1 = rx->startp[paren]) != -1 &&
- (t1 = rx->endp[paren]) != -1)
- {
- i = t1 - s1;
- s = rx->subbeg + s1;
- assert(rx->subbeg);
-
- getrx:
- if (i >= 0) {
- const int oldtainted = PL_tainted;
- TAINT_NOT;
- sv_setpvn(sv, s, i);
- PL_tainted = oldtainted;
- if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
- if (PL_tainting) {
- if (RX_MATCH_TAINTED(rx)) {
- MAGIC* const mg = SvMAGIC(sv);
- MAGIC* mgt;
- PL_tainted = 1;
- SvMAGIC_set(sv, mg->mg_moremagic);
- SvTAINT(sv);
- if ((mgt = SvMAGIC(sv))) {
- mg->mg_moremagic = mgt;
- SvMAGIC_set(sv, mg);
- }
- } else
- SvTAINTED_off(sv);
- }
- break;
- }
- }
+ reg_numbered_buff_get( paren, rx, sv, 0);
+ break;
}
sv_setsv(sv,&PL_sv_undef);
break;
case '+':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- paren = rx->lastparen;
- if (paren)
- goto getparen;
+ if (rx->lastparen) {
+ reg_numbered_buff_get( rx->lastparen, rx, sv, 0);
+ break;
+ }
}
sv_setsv(sv,&PL_sv_undef);
break;
case '\016': /* ^N */
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- paren = rx->lastcloseparen;
- if (paren)
- goto getparen;
+ if (rx->lastcloseparen) {
+ reg_numbered_buff_get( rx->lastcloseparen, rx, sv, 0);
+ break;
+ }
+
}
sv_setsv(sv,&PL_sv_undef);
break;
case '`':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if ((s = rx->subbeg) && rx->startp[0] != -1) {
- i = rx->startp[0];
- goto getrx;
- }
+ reg_numbered_buff_get( -2, rx, sv, 0);
+ break;
}
sv_setsv(sv,&PL_sv_undef);
break;
case '\'':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if (rx->subbeg && rx->endp[0] != -1) {
- s = rx->subbeg + rx->endp[0];
- i = rx->sublen - rx->endp[0];
- goto getrx;
- }
+ reg_numbered_buff_get( -1, rx, sv, 0);
+ break;
}
sv_setsv(sv,&PL_sv_undef);
break;
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 >= (I32)sizeof tmpbuf /* too long -- assume the worst */
- || *tmpbuf != '/'
+#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
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 {
return 0;
}
+#ifndef SIG_PENDING_DIE_COUNT
+# define SIG_PENDING_DIE_COUNT 120
+#endif
+
static void
S_raise_signal(pTHX_ int sig)
{
/* Set a flag to say this signal is pending */
PL_psig_pend[sig]++;
/* And one to say _a_ signal is pending */
- PL_sig_pending = 1;
+ if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
+ Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
+ (unsigned long)SIG_PENDING_DIE_COUNT);
}
Signal_t
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;
}
}
SvREFCNT_dec(to_dec);
return 0;
}
- s = SvPV_force(sv,len);
+ s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
if (strEQ(s,"IGNORE")) {
if (i) {
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
}
int
-Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
+Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
{
return magic_methpack(sv,mg,"EXISTS");
}
SSize_t pos;
STRLEN len;
STRLEN ulen = 0;
- MAGIC *found;
+ MAGIC* found;
PERL_UNUSED_ARG(mg);
sv_force_normal_flags(lsv, 0);
#endif
found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
- NULL, 0);
+ NULL, 0);
}
else if (!SvOK(sv)) {
found->mg_len = -1;
if (!SvOK(sv))
return 0;
- if (SvFLAGS(sv) & SVp_SCREAM
- && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
+ if (isGV_with_GP(sv)) {
/* We're actually already a typeglob, so don't need the stuff below.
*/
return 0;
if (he)
value = HeVAL(he);
if (!value || value == &PL_sv_undef)
- Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
+ Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
}
else {
AV* const av = (AV*)LvTARG(sv);
{
PERL_UNUSED_ARG(mg);
sv_unmagic(sv, PERL_MAGIC_bm);
+ SvTAIL_off(sv);
SvVALID_off(sv);
return 0;
}
}
}
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;
+ 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 ;
}
}
if (i)
(void)setgroups(i, gary);
- if (gary)
- Safefree(gary);
+ Safefree(gary);
}
#else /* HAS_SETGROUPS */
PL_egid = SvIV(sv);
setproctitle("%s", s);
# endif
}
-#endif
-#if defined(__hpux) && defined(PSTAT_SETCMD)
+#elif defined(__hpux) && defined(PSTAT_SETCMD)
if (PL_origalen != 1) {
union pstun un;
s = SvPV_const(sv, len);
un.pst_command = (char *)s;
pstat(PSTAT_SETCMD, un, len, 0, 0);
}
-#endif
+#else
if (PL_origalen > 1) {
/* PL_origalen is set in perl_parse(). */
s = SvPV_force(sv,len);
}
else {
/* Shorter than original, will be padded. */
+#ifdef PERL_DARWIN
+ /* Special case for Mac OS X: see [perl #38868] */
+ const int pad = 0;
+#else
+ /* Is the space counterintuitive? Yes.
+ * (You were expecting \0?)
+ * Does it work? Seems to. (In Linux 2.4.20 at least.)
+ * --jhi */
+ const int pad = ' ';
+#endif
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);
+ pad, PL_origalen - len - 1);
}
PL_origargv[0][PL_origalen-1] = 0;
for (i = 1; i < PL_origargc; i++)
PL_origargv[i] = 0;
}
+#endif
UNLOCK_DOLLARZERO_MUTEX;
break;
#endif
#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;
}
projects / p5sagit/p5-mst-13.2.git / blobdiff