/* pp_ctl.c
*
- * Copyright (c) 1991-2000, Larry Wall
+ * Copyright (c) 1991-2001, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
PP(pp_wantarray)
{
- djSP;
+ dSP;
I32 cxix;
EXTEND(SP, 1);
PP(pp_regcomp)
{
- djSP;
+ dSP;
register PMOP *pm = (PMOP*)cLOGOP->op_other;
register char *t;
SV *tmpstr;
pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
if (DO_UTF8(tmpstr))
- pm->op_pmdynflags |= PMdf_UTF8;
+ pm->op_pmdynflags |= PMdf_DYN_UTF8;
+ else {
+ pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
+ if (pm->op_pmdynflags & PMdf_UTF8)
+ t = (char*)bytes_to_utf8((U8*)t, &len);
+ }
pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
- PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
+ if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
+ Safefree(t);
+ PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
inside tie/overload accessors. */
}
}
PP(pp_substcont)
{
- djSP;
+ dSP;
register PMOP *pm = (PMOP*) cLOGOP->op_other;
register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
register SV *dstr = cx->sb_dstr;
register char *m = cx->sb_m;
char *orig = cx->sb_orig;
register REGEXP *rx = cx->sb_rx;
-
+
rxres_restore(&cx->sb_rxres, rx);
if (cx->sb_iters++) {
: (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
{
SV *targ = cx->sb_targ;
- sv_catpvn(dstr, s, cx->sb_strend - s);
+ sv_catpvn(dstr, s, cx->sb_strend - s);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
(void)SvOOK_off(targ);
SvPVX(targ) = SvPVX(dstr);
SvCUR_set(targ, SvCUR(dstr));
SvLEN_set(targ, SvLEN(dstr));
+ if (DO_UTF8(dstr))
+ SvUTF8_on(targ);
SvPVX(dstr) = 0;
sv_free(dstr);
TAINT_IF(cx->sb_rxtainted & 1);
PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
- (void)SvPOK_only(targ);
+ (void)SvPOK_only_UTF8(targ);
TAINT_IF(cx->sb_rxtainted);
SvSETMAGIC(targ);
SvTAINT(targ);
cx->sb_strend = s + (cx->sb_strend - m);
}
cx->sb_m = m = rx->startp[0] + orig;
- sv_catpvn(dstr, s, m-s);
+ if (m > s)
+ sv_catpvn(dstr, s, m-s);
cx->sb_s = rx->endp[0] + orig;
{ /* Update the pos() information. */
SV *sv = cx->sb_targ;
MAGIC *mg;
I32 i;
if (SvTYPE(sv) < SVt_PVMG)
- SvUPGRADE(sv, SVt_PVMG);
+ (void)SvUPGRADE(sv, SVt_PVMG);
if (!(mg = mg_find(sv, 'g'))) {
sv_magic(sv, Nullsv, 'g', Nullch, 0);
mg = mg_find(sv, 'g');
PP(pp_formline)
{
- djSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
register SV *tmpForm = *++MARK;
register U16 *fpc;
register char *t;
s = item;
if (item_is_utf) {
while (arg--) {
- if (*s & 0x80) {
+ if (UTF8_IS_CONTINUED(*s)) {
switch (UTF8SKIP(s)) {
case 7: *t++ = *s++;
case 6: *t++ = *s++;
PP(pp_grepstart)
{
- djSP;
+ dSP;
SV *src;
if (PL_stack_base + *PL_markstack_ptr == SP) {
PP(pp_mapwhile)
{
- djSP;
+ dSP;
I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
I32 count;
I32 shift;
PP(pp_sort)
{
- djSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
register SV **up;
SV **myorigmark = ORIGMARK;
register I32 max;
PP(pp_flip)
{
- djSP;
+ dSP;
if (GIMME == G_ARRAY) {
RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
PP(pp_flop)
{
- djSP;
+ dSP;
if (GIMME == G_ARRAY) {
dPOPPOPssrl;
STATIC I32
S_dopoptolabel(pTHX_ char *label)
{
- dTHR;
register I32 i;
register PERL_CONTEXT *cx;
I32
Perl_block_gimme(pTHX)
{
- dTHR;
I32 cxix;
cxix = dopoptosub(cxstack_ix);
}
}
+I32
+Perl_is_lvalue_sub(pTHX)
+{
+ I32 cxix;
+
+ cxix = dopoptosub(cxstack_ix);
+ assert(cxix >= 0); /* We should only be called from inside subs */
+
+ if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
+ return cxstack[cxix].blk_sub.lval;
+ else
+ return 0;
+}
+
STATIC I32
S_dopoptosub(pTHX_ I32 startingblock)
{
- dTHR;
return dopoptosub_at(cxstack, startingblock);
}
STATIC I32
S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
{
- dTHR;
I32 i;
register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
STATIC I32
S_dopoptoeval(pTHX_ I32 startingblock)
{
- dTHR;
I32 i;
register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
STATIC I32
S_dopoptoloop(pTHX_ I32 startingblock)
{
- dTHR;
I32 i;
register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
void
Perl_dounwind(pTHX_ I32 cxix)
{
- dTHR;
register PERL_CONTEXT *cx;
I32 optype;
STATIC void
S_free_closures(pTHX)
{
- dTHR;
SV **svp = AvARRAY(PL_comppad_name);
I32 ix;
for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
}
}
}
- else
+ else {
sv_setpvn(ERRSV, message, msglen);
+ if (PL_hints & HINT_UTF8)
+ SvUTF8_on(ERRSV);
+ else
+ SvUTF8_off(ERRSV);
+ }
}
else
message = SvPVx(ERRSV, msglen);
PP(pp_xor)
{
- djSP; dPOPTOPssrl;
+ dSP; dPOPTOPssrl;
if (SvTRUE(left) != SvTRUE(right))
RETSETYES;
else
PP(pp_andassign)
{
- djSP;
+ dSP;
if (!SvTRUE(TOPs))
RETURN;
else
PP(pp_orassign)
{
- djSP;
+ dSP;
if (SvTRUE(TOPs))
RETURN;
else
PP(pp_caller)
{
- djSP;
+ dSP;
register I32 cxix = dopoptosub(cxstack_ix);
register PERL_CONTEXT *cx;
register PERL_CONTEXT *ccstack = cxstack;
PP(pp_reset)
{
- djSP;
+ dSP;
char *tmps;
STRLEN n_a;
if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
{
- djSP;
+ dSP;
register CV *cv;
register PERL_CONTEXT *cx;
I32 gimme = G_ARRAY;
PP(pp_enteriter)
{
- djSP; dMARK;
+ dSP; dMARK;
register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
SV **svp;
#ifdef USE_THREADS
if (PL_op->op_flags & OPf_SPECIAL) {
- dTHR;
svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
SAVEGENERICSV(*svp);
*svp = NEWSV(0,0);
else
#endif /* USE_THREADS */
if (PL_op->op_targ) {
+#ifndef USE_ITHREADS
svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
SAVESPTR(*svp);
-#ifdef USE_ITHREADS
+#else
+ SAVEPADSV(PL_op->op_targ);
iterdata = (void*)PL_op->op_targ;
cxtype |= CXp_PADVAR;
#endif
PP(pp_enterloop)
{
- djSP;
+ dSP;
register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
PP(pp_leaveloop)
{
- djSP;
+ dSP;
register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
PP(pp_return)
{
- djSP; dMARK;
+ dSP; dMARK;
I32 cxix;
register PERL_CONTEXT *cx;
bool popsub2 = FALSE;
PP(pp_last)
{
- djSP;
+ dSP;
I32 cxix;
register PERL_CONTEXT *cx;
I32 pop2 = 0;
}
*ops = 0;
if (o->op_flags & OPf_KIDS) {
- dTHR;
/* First try all the kids at this level, since that's likeliest. */
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
PP(pp_goto)
{
- djSP;
+ dSP;
OP *retop = 0;
I32 ix;
register PERL_CONTEXT *cx;
PP(pp_exit)
{
- djSP;
+ dSP;
I32 anum;
if (MAXARG < 1)
#ifdef NOTYET
PP(pp_nswitch)
{
- djSP;
+ dSP;
NV value = SvNVx(GvSV(cCOP->cop_gv));
register I32 match = I_32(value);
PP(pp_cswitch)
{
- djSP;
+ dSP;
register I32 match;
if (PL_multiline)
STATIC OP *
S_docatch(pTHX_ OP *o)
{
- dTHR;
int ret;
OP *oldop = PL_op;
volatile PERL_SI *cursi = PL_curstackinfo;
#else
SAVEVPTR(PL_op);
#endif
- PL_hints = 0;
+ PL_hints &= HINT_UTF8;
PL_op = &dummy;
PL_op->op_type = OP_ENTEREVAL;
PP(pp_require)
{
- djSP;
+ dSP;
register PERL_CONTEXT *cx;
SV *sv;
char *name;
/* prepare to compile file */
+#ifdef MACOS_TRADITIONAL
if (PERL_FILE_IS_ABSOLUTE(name)
- || (*name == '.' && (name[1] == '/' ||
- (name[1] == '.' && name[2] == '/'))))
+ || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
{
tryname = name;
tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
-#ifdef MACOS_TRADITIONAL
/* We consider paths of the form :a:b ambiguous and interpret them first
as global then as local
*/
- if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
+ if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
goto trylocal;
}
else
trylocal: {
#else
+ if (PERL_FILE_IS_ABSOLUTE(name)
+ || (*name == '.' && (name[1] == '/' ||
+ (name[1] == '.' && name[2] == '/'))))
+ {
+ tryname = name;
+ tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
}
else {
#endif
PUSHs(dirsv);
PUSHs(sv);
PUTBACK;
- count = call_sv(loader, G_ARRAY);
+ if (sv_isobject(loader))
+ count = call_method("INC", G_ARRAY);
+ else
+ count = call_sv(loader, G_ARRAY);
SPAGAIN;
if (count > 0) {
PP(pp_entereval)
{
- djSP;
+ dSP;
register PERL_CONTEXT *cx;
dPOPss;
I32 gimme = GIMME_V, was = PL_sub_generation;
PP(pp_leaveeval)
{
- djSP;
+ dSP;
register SV **mark;
SV **newsp;
PMOP *newpm;
PP(pp_entertry)
{
- djSP;
+ dSP;
register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
PP(pp_leavetry)
{
- djSP;
+ dSP;
register SV **mark;
SV **newsp;
PMOP *newpm;
static I32
sortcv(pTHXo_ SV *a, SV *b)
{
- dTHR;
I32 oldsaveix = PL_savestack_ix;
I32 oldscopeix = PL_scopestack_ix;
I32 result;
static I32
sortcv_stacked(pTHXo_ SV *a, SV *b)
{
- dTHR;
I32 oldsaveix = PL_savestack_ix;
I32 oldscopeix = PL_scopestack_ix;
I32 result;
}
if (filter_sub && len >= 0) {
- djSP;
+ dSP;
int count;
ENTER;
projects / p5sagit/p5-mst-13.2.git / blobdiff