#endif
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-Signal_t Perl_csighandler(int sig, ...);
+Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
#else
Signal_t Perl_csighandler(int sig);
#endif
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
+ SvMAGIC_set(sv, moremagic);
}
SvMAGIC_set(sv, NULL);
return 0;
dVAR;
register I32 paren;
register I32 i;
- register const REGEXP *rx;
- I32 s1, t1;
+ register const REGEXP * rx;
+ const char * const remaining = mg->mg_ptr + 1;
switch (*mg->mg_ptr) {
+ case '\020':
+ if (*remaining == '\0') { /* ^P */
+ break;
+ } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
+ goto do_prematch;
+ } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
+ goto do_postmatch;
+ }
+ break;
+ case '\015': /* $^MATCH */
+ if (strEQ(remaining, "ATCH")) {
+ goto do_match;
+ } else {
+ break;
+ }
+ case '`':
+ do_prematch:
+ paren = RX_BUFF_IDX_PREMATCH;
+ goto maybegetparen;
+ case '\'':
+ do_postmatch:
+ paren = RX_BUFF_IDX_POSTMATCH;
+ goto maybegetparen;
+ case '&':
+ do_match:
+ paren = RX_BUFF_IDX_FULLMATCH;
+ goto maybegetparen;
case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9': case '&':
+ case '5': case '6': case '7': case '8': case '9':
+ paren = atoi(mg->mg_ptr);
+ maybegetparen:
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
+ getparen:
+ i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
- paren = atoi(mg->mg_ptr); /* $& is in [0] */
- getparen:
- if (paren <= (I32)rx->nparens &&
- (s1 = rx->offs[paren].start) != -1 &&
- (t1 = rx->offs[paren].end) != -1)
- {
- i = t1 - s1;
- getlen:
- if (i > 0 && RX_MATCH_UTF8(rx)) {
- const char * const s = rx->subbeg + s1;
- const U8 *ep;
- STRLEN el;
-
- i = t1 - s1;
- if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
- i = el;
- }
if (i < 0)
Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
return i;
- }
- else {
+ } else {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
- }
- }
- else {
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
+ return 0;
}
- return 0;
case '+':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
paren = rx->lastparen;
goto getparen;
}
return 0;
- case '`':
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if (rx->offs[0].start != -1) {
- i = rx->offs[0].start;
- if (i > 0) {
- s1 = 0;
- t1 = i;
- goto getlen;
- }
- }
- }
- return 0;
- case '\'':
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if (rx->offs[0].end != -1) {
- i = rx->sublen - rx->offs[0].end;
- if (i > 0) {
- s1 = rx->offs[0].end;
- t1 = rx->sublen;
- goto getlen;
- }
- }
- }
- return 0;
}
magic_get(sv,mg);
if (!SvPOK(sv) && SvNIOK(sv)) {
sv_setiv(sv, (IV)PL_hints);
break;
case '\011': /* ^I */ /* NOT \t in EBCDIC */
- if (PL_inplace)
- sv_setpv(sv, PL_inplace);
- else
- sv_setsv(sv, &PL_sv_undef);
+ sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
break;
case '\017': /* ^O & ^OPEN */
if (nextchar == '\0') {
break;
case '\023': /* ^S */
if (nextchar == '\0') {
- if (PL_lex_state != LEX_NOTPARSING)
+ if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
SvOK_off(sv);
else if (PL_in_eval)
sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
* XXX Does the new way break anything?
*/
paren = atoi(mg->mg_ptr); /* $& is in [0] */
- CALLREG_NUMBUF(rx,paren,sv);
+ CALLREG_NUMBUF_FETCH(rx,paren,sv);
break;
}
sv_setsv(sv,&PL_sv_undef);
case '+':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
if (rx->lastparen) {
- CALLREG_NUMBUF(rx,rx->lastparen,sv);
+ CALLREG_NUMBUF_FETCH(rx,rx->lastparen,sv);
break;
}
}
case '\016': /* ^N */
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
if (rx->lastcloseparen) {
- CALLREG_NUMBUF(rx,rx->lastcloseparen,sv);
+ CALLREG_NUMBUF_FETCH(rx,rx->lastcloseparen,sv);
break;
}
case '`':
do_prematch_fetch:
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- CALLREG_NUMBUF(rx,-2,sv);
+ CALLREG_NUMBUF_FETCH(rx,-2,sv);
break;
}
sv_setsv(sv,&PL_sv_undef);
case '\'':
do_postmatch_fetch:
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- CALLREG_NUMBUF(rx,-1,sv);
+ CALLREG_NUMBUF_FETCH(rx,-1,sv);
break;
}
sv_setsv(sv,&PL_sv_undef);
sv_setpv(sv,s);
else {
sv_setpv(sv,GvENAME(PL_defoutgv));
- sv_catpv(sv,"_TOP");
+ sv_catpvs(sv,"_TOP");
}
break;
case '~':
sigaddset(&set,i);
sigprocmask(SIG_BLOCK, &set, &save);
ENTER;
- save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
+ save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
SAVEFREESV(save_sv);
SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
#endif
Signal_t
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-Perl_csighandler(int sig, ...)
+Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
#else
Perl_csighandler(int sig)
#endif
#else
dTHX;
#endif
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+#endif
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
(void) rsignal(sig, PL_csighandlerp);
if (PL_sig_ignoring[sig]) return;
exit(1);
#endif
#endif
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+#endif
if (
#ifdef SIGILL
sig == SIGILL ||
(PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
/* Call the perl level handler now--
* with risk we may be in malloc() etc. */
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+ (*PL_sighandlerp)(sig, NULL, NULL);
+#else
(*PL_sighandlerp)(sig);
+#endif
else
S_raise_signal(aTHX_ sig);
}
PERL_BLOCKSIG_ADD(set, sig);
PL_psig_pend[sig] = 0;
PERL_BLOCKSIG_BLOCK(set);
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+ (*PL_sighandlerp)(sig, NULL, NULL);
+#else
(*PL_sighandlerp)(sig);
+#endif
PERL_BLOCKSIG_UNBLOCK(set);
}
}
sigaddset(&set,i);
sigprocmask(SIG_BLOCK, &set, &save);
ENTER;
- save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
+ save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
SAVEFREESV(save_sv);
SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
#endif
/* Bail out if destruction is going on */
if(PL_dirty) return 0;
+ /* Skip _isaelem because _isa will handle it shortly */
+ if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
+ return 0;
+
+ /* XXX Once it's possible, we need to
+ detect that our @ISA is aliased in
+ other stashes, and act on the stashes
+ of all of the aliases */
+
/* The first case occurs via setisa,
the second via setisa_elem, which
calls this same magic */
: (GV*)SvMAGIC(mg->mg_obj)->mg_obj
);
- if(PL_delaymagic)
- PL_delayedisa = stash;
- else
- mro_isa_changed_in(stash);
+ mro_isa_changed_in(stash);
return 0;
}
}
int
-Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
-{
- GV* gv;
- PERL_UNUSED_ARG(mg);
-
- Perl_croak(aTHX_ "Perl_magic_setglob is dead code?");
-
- if (!SvOK(sv))
- return 0;
- if (isGV_with_GP(sv)) {
- /* We're actually already a typeglob, so don't need the stuff below.
- */
- return 0;
- }
- gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
- if (sv == (SV*)gv)
- return 0;
- if (GvGP(sv))
- gp_free((GV*)sv);
- GvGP(sv) = gp_ref(GvGP(gv));
- return 0;
-}
-
-int
Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
{
STRLEN len;
{
dVAR;
register const char *s;
+ register I32 paren;
+ register const REGEXP * rx;
+ const char * const remaining = mg->mg_ptr + 1;
I32 i;
STRLEN len;
+
switch (*mg->mg_ptr) {
+ case '\015': /* $^MATCH */
+ if (strEQ(remaining, "ATCH"))
+ goto do_match;
+ case '`': /* ${^PREMATCH} caught below */
+ do_prematch:
+ paren = RX_BUFF_IDX_PREMATCH;
+ goto setparen;
+ case '\'': /* ${^POSTMATCH} caught below */
+ do_postmatch:
+ paren = RX_BUFF_IDX_POSTMATCH;
+ goto setparen;
+ case '&':
+ do_match:
+ paren = RX_BUFF_IDX_FULLMATCH;
+ goto setparen;
+ case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ paren = atoi(mg->mg_ptr);
+ setparen:
+ if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
+ CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
+ break;
+ } else {
+ /* Croak with a READONLY error when a numbered match var is
+ * set without a previous pattern match. Unless it's C<local $1>
+ */
+ if (!PL_localizing) {
+ Perl_croak(aTHX_ PL_no_modify);
+ }
+ }
case '\001': /* ^A */
sv_setsv(PL_bodytarget, sv);
break;
}
break;
case '\020': /* ^P */
- PL_perldb = SvIV(sv);
- if (PL_perldb && !PL_DBsingle)
- init_debugger();
- break;
+ if (*remaining == '\0') { /* ^P */
+ PL_perldb = SvIV(sv);
+ if (PL_perldb && !PL_DBsingle)
+ init_debugger();
+ break;
+ } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
+ goto do_prematch;
+ } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
+ goto do_postmatch;
+ }
case '\024': /* ^T */
#ifdef BIG_TIME
PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
Signal_t
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-Perl_sighandler(int sig, ...)
+Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
#else
Perl_sighandler(int sig)
#endif
struct sigaction oact;
if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
- siginfo_t *sip;
- va_list args;
-
- va_start(args, sig);
- sip = (siginfo_t*)va_arg(args, siginfo_t*);
if (sip) {
HV *sih = newHV();
SV *rv = newRV_noinc((SV*)sih);
/* The siginfo fields signo, code, errno, pid, uid,
* addr, status, and band are defined by POSIX/SUSv3. */
- hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
- hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
+ (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
+ (void)hv_stores(sih, "code", newSViv(sip->si_code));
#if 0 /* XXX TODO: Configure scan for the existence of these, but even that does not help if the SA_SIGINFO is not implemented according to the spec. */
- hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
- hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
- hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
- hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
- hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
- hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
+ hv_stores(sih, "errno", newSViv(sip->si_errno));
+ hv_stores(sih, "status", newSViv(sip->si_status));
+ hv_stores(sih, "uid", newSViv(sip->si_uid));
+ hv_stores(sih, "pid", newSViv(sip->si_pid));
+ hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
+ hv_stores(sih, "band", newSViv(sip->si_band));
#endif
EXTEND(SP, 2);
PUSHs((SV*)rv);
- PUSHs(newSVpv((char *)sip, sizeof(*sip)));
+ PUSHs(newSVpvn((char *)sip, sizeof(*sip)));
}
- va_end(args);
}
}
#endif
Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- assert(mg->mg_len == HEf_SVKEY);
+ SV *key = (mg->mg_len == HEf_SVKEY) ? (SV *)mg->mg_ptr
+ : sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len));
/* mg->mg_obj isn't being used. If needed, it would be possible to store
an alternative leaf in there, with PL_compiling.cop_hints being used if
forgetting to do it, and consequent subtle errors. */
PL_hints |= HINT_LOCALIZE_HH;
PL_compiling.cop_hints_hash
- = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
- (SV *)mg->mg_ptr, sv);
+ = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
return 0;
}
https://perl5.git.perl.org / perl5.git / blobdiff