# ifndef NGROUPS
# define NGROUPS 32
# endif
+# ifdef I_GRP
+# include <grp.h>
+# endif
#endif
static void restore_magic(pTHXo_ void *p);
/* MGS is typedef'ed to struct magic_state in perl.h */
STATIC void
-S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
+S_save_magic(pTHX_ IV mgs_ix, SV *sv)
{
MGS* mgs;
assert(SvMAGICAL(sv));
- SAVEDESTRUCTOR_X(restore_magic, (void*)mgs_ix);
+ SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*,mgs_ix));
mgs = SSPTR(mgs_ix, MGS*);
mgs->mgs_sv = sv;
SvMAGICAL_off(sv);
SvREADONLY_off(sv);
- SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
}
/*
int
Perl_mg_get(pTHX_ SV *sv)
{
- I32 mgs_ix;
+ IV mgs_ix;
MAGIC* mg;
MAGIC** mgp;
int mgp_valid = 0;
mgp = &SvMAGIC(sv); /* Re-establish pointer after sv_upgrade */
}
- restore_magic(aTHXo_ (void*)mgs_ix);
+ restore_magic(aTHXo_ INT2PTR(void*,mgs_ix));
return 0;
}
int
Perl_mg_set(pTHX_ SV *sv)
{
- I32 mgs_ix;
+ IV mgs_ix;
MAGIC* mg;
MAGIC* nextmg;
CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
}
- restore_magic(aTHXo_ (void*)mgs_ix);
+ restore_magic(aTHXo_ INT2PTR(void*,mgs_ix));
return 0;
}
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
MGVTBL* vtbl = mg->mg_virtual;
if (vtbl && vtbl->svt_len) {
- I32 mgs_ix;
+ IV mgs_ix;
mgs_ix = SSNEW(sizeof(MGS));
save_magic(mgs_ix, sv);
/* omit MGf_GSKIP -- not changed here */
len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
- restore_magic(aTHXo_ (void*)mgs_ix);
+ restore_magic(aTHXo_ INT2PTR(void*,mgs_ix));
return len;
}
}
return len;
}
-I32
+IV
Perl_mg_size(pTHX_ SV *sv)
{
MAGIC* mg;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
MGVTBL* vtbl = mg->mg_virtual;
if (vtbl && vtbl->svt_len) {
- I32 mgs_ix;
+ IV mgs_ix;
mgs_ix = SSNEW(sizeof(MGS));
save_magic(mgs_ix, sv);
/* omit MGf_GSKIP -- not changed here */
len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
- restore_magic(aTHXo_ (void*)mgs_ix);
+ restore_magic(aTHXo_ INT2PTR(void*,mgs_ix));
return len;
}
}
int
Perl_mg_clear(pTHX_ SV *sv)
{
- I32 mgs_ix;
+ IV mgs_ix;
MAGIC* mg;
mgs_ix = SSNEW(sizeof(MGS));
CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
}
- restore_magic(aTHXo_ (void*)mgs_ix);
+ restore_magic(aTHXo_ INT2PTR(void*,mgs_ix));
return 0;
}
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
if (isUPPER(mg->mg_type)) {
sv_magic(nsv,
- mg->mg_type == 'P' ? SvTIED_obj(sv, mg) :
- (mg->mg_type == 'D' && mg->mg_obj) ? sv : mg->mg_obj,
+ mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
+ (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
+ ? sv : mg->mg_obj,
toLOWER(mg->mg_type), key, klen);
count++;
}
moremagic = mg->mg_moremagic;
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
- if (mg->mg_ptr && mg->mg_type != 'g')
+ if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
if (mg->mg_len >= 0)
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
SvREFCNT_dec((SV*)mg->mg_ptr);
+ }
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
return 0;
}
+
#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
#include <signal.h>
#endif
if (i > 0 && DO_UTF8(PL_reg_sv)) {
char *b = rx->subbeg;
- i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
+ if (b)
+ i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
}
- sv_setiv(sv,i);
+
+ sv_setiv(sv, i);
}
}
return 0;
char *s = rx->subbeg + s1;
char *send = rx->subbeg + t1;
- i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
+ i = t1 - s1;
+ if (is_utf8_string((U8*)s, i))
+ i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
}
if (i < 0)
- Perl_croak(aTHX_ "panic: magic_len: %d", i);
+ Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
return i;
}
}
break;
case '\004': /* ^D */
- sv_setiv(sv, (IV)(PL_debug & 32767));
+ sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
#if defined(YYDEBUG) && defined(DEBUGGING)
- PL_yydebug = (PL_debug & 1);
+ PL_yydebug = DEBUG_p_TEST;
#endif
break;
case '\005': /* ^E */
(void)SvOK_off(sv);
else if (PL_in_eval)
sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
+ else
+ sv_setiv(sv, 0);
}
break;
case '\024': /* ^T */
getrx:
if (i >= 0) {
- bool was_tainted;
+ bool was_tainted = FALSE;
if (PL_tainting) {
was_tainted = PL_tainted;
PL_tainted = FALSE;
}
sv_setpvn(sv, s, i);
- if (DO_UTF8(PL_reg_sv))
+ if (PL_reg_sv && DO_UTF8(PL_reg_sv) && is_utf8_string((U8*)s, i))
SvUTF8_on(sv);
else
SvUTF8_off(sv);
case '.':
#ifndef lint
if (GvIO(PL_last_in_gv)) {
- sv_setiv(sv, (IV)IoLINES(GvIO(PL_last_in_gv)));
+ sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
}
#endif
break;
struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
if (uf && uf->uf_val)
- (*uf->uf_val)(uf->uf_index, sv);
+ (*uf->uf_val)(aTHX_ uf->uf_index, sv);
return 0;
}
return 0;
}
+void
+Perl_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;
+}
+
+Signal_t
+Perl_csighandler(int sig)
+{
+#ifdef PERL_OLD_SIGNALS
+ /* Call the perl level handler now with risk we may be in malloc() etc. */
+ (*PL_sighandlerp)(sig);
+#else
+ dTHX;
+ Perl_raise_signal(aTHX_ sig);
+#endif
+}
+
+void
+Perl_despatch_signals(pTHX)
+{
+ int sig;
+ PL_sig_pending = 0;
+ for (sig = 1; sig < SIG_SIZE; sig++) {
+ if (PL_psig_pend[sig]) {
+ PL_psig_pend[sig] = 0;
+ (*PL_sighandlerp)(sig);
+ }
+ }
+}
+
int
Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
{
register char *s;
I32 i;
- SV** svp;
+ SV** svp = 0;
STRLEN len;
s = MgPV(mg,len);
}
if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
if (i)
- (void)rsignal(i, PL_sighandlerp);
+ (void)rsignal(i, &Perl_csighandler);
else
*svp = SvREFCNT_inc(sv);
return 0;
if (!strchr(s,':') && !strchr(s,'\''))
sv_insert(sv, 0, 0, "main::", 6);
if (i)
- (void)rsignal(i, PL_sighandlerp);
+ (void)rsignal(i, &Perl_csighandler);
else
*svp = SvREFCNT_inc(sv);
}
if (hv) {
(void) hv_iterinit(hv);
- if (! SvTIED_mg((SV*)hv, 'P'))
+ if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
i = HvKEYS(hv);
else {
/*SUPPRESS 560*/
else if (mg->mg_len == HEf_SVKEY)
PUSHs((SV*)mg->mg_ptr);
}
- else if (mg->mg_type == 'p') {
+ else if (mg->mg_type == PERL_MAGIC_tiedelem) {
PUSHs(sv_2mortal(newSViv(mg->mg_len)));
}
}
SV* lsv = LvTARG(sv);
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
- mg = mg_find(lsv, 'g');
+ mg = mg_find(lsv, PERL_MAGIC_regex_global);
if (mg && mg->mg_len >= 0) {
I32 i = mg->mg_len;
if (DO_UTF8(lsv))
mg = 0;
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
- mg = mg_find(lsv, 'g');
+ mg = mg_find(lsv, PERL_MAGIC_regex_global);
if (!mg) {
if (!SvOK(sv))
return 0;
- sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
- mg = mg_find(lsv, 'g');
+ sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
+ mg = mg_find(lsv, PERL_MAGIC_regex_global);
}
else if (!SvOK(sv)) {
mg->mg_len = -1;
I32 offs = LvTARGOFF(sv);
I32 rem = LvTARGLEN(sv);
+ if (SvUTF8(lsv))
+ sv_pos_u2b(lsv, &offs, &rem);
if (offs > len)
offs = len;
if (rem + offs > len)
rem = len - offs;
sv_setpvn(sv, tmps + offs, (STRLEN)rem);
- if (DO_UTF8(lsv))
+ if (SvUTF8(lsv))
SvUTF8_on(sv);
return 0;
}
Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
{
STRLEN len;
- char *tmps = SvPV(sv,len);
+ char *tmps = SvPV(sv, len);
+ SV *lsv = LvTARG(sv);
+ I32 lvoff = LvTARGOFF(sv);
+ I32 lvlen = LvTARGLEN(sv);
+
if (DO_UTF8(sv)) {
- sv_utf8_upgrade(LvTARG(sv));
- sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
- SvUTF8_on(LvTARG(sv));
+ sv_utf8_upgrade(lsv);
+ sv_pos_u2b(lsv, &lvoff, &lvlen);
+ sv_insert(lsv, lvoff, lvlen, tmps, len);
+ SvUTF8_on(lsv);
+ }
+ else if (SvUTF8(lsv)) {
+ sv_pos_u2b(lsv, &lvoff, &lvlen);
+ tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
+ sv_insert(lsv, lvoff, lvlen, tmps, len);
+ Safefree(tmps);
}
else
- sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
+ sv_insert(lsv, lvoff, lvlen, tmps, len);
return 0;
}
MAGIC *mg;
SV *value = Nullsv;
- if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y')))
+ if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
return;
if (mg->mg_obj) {
SV *ahv = LvTARG(sv);
int
Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
{
- sv_unmagic(sv, 'B');
+ sv_unmagic(sv, PERL_MAGIC_bm);
SvVALID_off(sv);
return 0;
}
int
Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
{
- sv_unmagic(sv, 'f');
+ sv_unmagic(sv, PERL_MAGIC_fm);
SvCOMPILED_off(sv);
return 0;
}
struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
if (uf && uf->uf_set)
- (*uf->uf_set)(uf->uf_index, sv);
+ (*uf->uf_set)(aTHX_ uf->uf_index, sv);
return 0;
}
break;
case '\004': /* ^D */
- PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
+ PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
DEBUG_x(dump_all());
break;
case '\005': /* ^E */
dSP;
GV *gv = Nullgv;
HV *st;
- SV *sv, *tSv = PL_Sv;
+ SV *sv = Nullsv, *tSv = PL_Sv;
CV *cv = Nullcv;
OP *myop = PL_op;
U32 flags = 0;
PUSHs(sv);
PUTBACK;
- call_sv((SV*)cv, G_DISCARD);
+ call_sv((SV*)cv, G_DISCARD|G_EVAL);
POPSTACK;
+ if (SvTRUE(ERRSV)) {
+#ifndef PERL_MICRO
+#ifdef HAS_SIGPROCMASK
+ /* Handler "died", for example to get out of a restart-able read().
+ * Before we re-do that on its behalf re-enable the signal which was
+ * blocked by the system when we entered.
+ */
+ sigset_t set;
+ sigemptyset(&set);
+ sigaddset(&set,sig);
+ sigprocmask(SIG_UNBLOCK, &set, NULL);
+#else
+ /* Not clear if this will work */
+ (void)rsignal(sig, SIG_IGN);
+ (void)rsignal(sig, &Perl_csighandler);
+#endif
+#endif /* !PERL_MICRO */
+ Perl_die(aTHX_ Nullch);
+ }
cleanup:
if (flags & 1)
PL_savestack_ix -= 8; /* Unprotect save in progress. */