static I32 dopoptoloop _((I32 startingblock));
static I32 dopoptosub _((I32 startingblock));
static void save_lines _((AV *array, SV *sv));
-static int sortcmp _((const void *, const void *));
static int sortcv _((const void *, const void *));
+static int sortcmp _((const void *, const void *));
+static int sortcmp_locale _((const void *, const void *));
static I32 sortcxix;
bool gotsome;
STRLEN len;
- if (!SvCOMPILED(form)) {
+ if (!SvMAGICAL(form) || !SvCOMPILED(form)) {
SvREADONLY_off(form);
doparseform(form);
}
case FF_END: name = "END"; break;
}
if (arg >= 0)
- fprintf(stderr, "%-16s%ld\n", name, (long) arg);
+ PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
else
- fprintf(stderr, "%-16s\n", name);
+ PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
} )
switch (*fpc++) {
case FF_LINEMARK:
}
gotsome = TRUE;
value = SvNV(sv);
+ /* Formats aren't yet marked for locales, so assume "yes". */
+ SET_NUMERIC_LOCAL();
if (arg & 256) {
sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
} else {
if (!(cv && CvROOT(cv))) {
if (gv) {
SV *tmpstr = sv_newmortal();
- gv_efullname(tmpstr, gv);
+ gv_efullname3(tmpstr, gv, Nullch);
if (cv && CvXSUB(cv))
DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
DIE("Undefined sort subroutine \"%s\" called",
SAVETMPS;
SAVESPTR(op);
- oldstack = stack;
+ oldstack = curstack;
if (!sortstack) {
sortstack = newAV();
AvREAL_off(sortstack);
av_extend(sortstack, 32);
}
- SWITCHSTACK(stack, sortstack);
+ SWITCHSTACK(curstack, sortstack);
if (sortstash != stash) {
firstgv = gv_fetchpv("a", TRUE, SVt_PV);
secondgv = gv_fetchpv("b", TRUE, SVt_PV);
else {
if (max > 1) {
MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
- qsort((char*)(ORIGMARK+1), max, sizeof(SV*), sortcmp);
+ qsort((char*)(ORIGMARK+1), max, sizeof(SV*),
+ (op->op_private & OPpLOCALE) ? sortcmp_locale : sortcmp);
}
}
stack_sp = ORIGMARK + max;
I32 max;
if (SvNIOKp(left) || !SvPOKp(left) ||
- (looks_like_number(left) && *SvPVX(left) != '0') ) {
+ (looks_like_number(left) && *SvPVX(left) != '0') )
+ {
i = SvIV(left);
max = SvIV(right);
- if (max > i)
+ if (max >= i) {
+ EXTEND_MORTAL(max - i + 1);
EXTEND(SP, max - i + 1);
+ }
while (i <= max) {
- sv = sv_mortalcopy(&sv_no);
- sv_setiv(sv,i++);
+ sv = sv_2mortal(newSViv(i++));
PUSHs(sv);
}
}
switch (cx->cx_type) {
case CXt_SUBST:
if (dowarn)
- warn("Exiting substitition via %s", op_name[op->op_type]);
+ warn("Exiting substitution via %s", op_name[op->op_type]);
break;
case CXt_SUB:
if (dowarn)
while (cxstack_ix > cxix) {
cx = &cxstack[cxstack_ix--];
- DEBUG_l(fprintf(stderr, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1,
+ DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1,
block_type[cx->cx_type]));
/* Note: we don't need to restore the base context info till the end. */
switch (cx->cx_type) {
}
}
-#ifdef I_STDARG
-OP *
-die(char* pat, ...)
-#else
-/*VARARGS0*/
-OP *
-die(pat, va_alist)
- char *pat;
- va_dcl
-#endif
-{
- va_list args;
- char *message;
- int oldrunlevel = runlevel;
- int was_in_eval = in_eval;
- HV *stash;
- GV *gv;
- CV *cv;
-
-#ifdef I_STDARG
- va_start(args, pat);
-#else
- va_start(args);
-#endif
- message = mess(pat, &args);
- va_end(args);
- if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
- dSP;
-
- PUSHMARK(sp);
- EXTEND(sp, 1);
- PUSHs(sv_2mortal(newSVpv(message,0)));
- PUTBACK;
- perl_call_sv((SV*)cv, G_DISCARD);
- }
- restartop = die_where(message);
- if ((!restartop && was_in_eval) || oldrunlevel > 1)
- longjmp(top_env, 3);
- return restartop;
-}
-
OP *
die_where(message)
char *message;
POPBLOCK(cx,curpm);
if (cx->cx_type != CXt_EVAL) {
- fprintf(stderr, "panic: die %s", message);
+ PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
my_exit(1);
}
POPEVAL(cx);
return pop_return();
}
}
- fputs(message, stderr);
- (void)fflush(stderr);
- if (e_fp) {
-#ifdef DOSISH
- fclose(e_fp);
-#endif
+ PerlIO_printf(PerlIO_stderr(), "%s",message);
+ PerlIO_flush(PerlIO_stderr());
+ if (e_tmpname) {
+ if (e_fp) {
+ PerlIO_close(e_fp);
+ e_fp = Nullfp;
+ }
(void)UNLINK(e_tmpname);
+ Safefree(e_tmpname);
+ e_tmpname = Nullch;
}
statusvalue = SHIFTSTATUS(statusvalue);
#ifdef VMS
RETURN;
if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */
sv = NEWSV(49, 0);
- gv_efullname(sv, CvGV(cxstack[cxix].blk_sub.cv));
+ gv_efullname3(sv, CvGV(cxstack[cxix].blk_sub.cv), Nullch);
PUSHs(sv_2mortal(sv));
PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
}
GV* tmpgv;
dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
SVt_PVAV)));
- SvMULTI_on(tmpgv);
+ GvMULTI_on(tmpgv);
AvREAL_off(dbargs); /* XXX Should be REIFY */
}
GvSV(secondgv) = *str2;
stack_sp = stack_base;
op = sortcop;
- run();
+ runops();
if (stack_sp != stack_base + 1)
croak("Sort subroutine didn't return single value");
if (!SvNIOKp(*stack_sp))
const void *a;
const void *b;
{
- register SV *str1 = *(SV **) a;
- register SV *str2 = *(SV **) b;
- I32 retval;
-
- if (!SvPOKp(str1)) {
- if (!SvPOKp(str2))
- return 0;
- else
- return -1;
- }
- if (!SvPOKp(str2))
- return 1;
+ return sv_cmp(*(SV **)a, *(SV **)b);
+}
- if (SvCUR(str1) < SvCUR(str2)) {
- /*SUPPRESS 560*/
- if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str1)))
- return retval;
- else
- return -1;
- }
- /*SUPPRESS 560*/
- else if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str2)))
- return retval;
- else if (SvCUR(str1) == SvCUR(str2))
- return 0;
- else
- return 1;
+static int
+sortcmp_locale(a, b)
+const void *a;
+const void *b;
+{
+ return sv_cmp_locale(*(SV **)a, *(SV **)b);
}
PP(pp_reset)
SAVETMPS;
SAVEI32(debug);
- SAVESPTR(stack_sp);
+ SAVESTACK_POS();
debug = 0;
hasargs = 0;
sp = stack_sp;
cx->blk_loop.iterix = -1;
}
else {
- cx->blk_loop.iterary = stack;
- AvFILL(stack) = sp - stack_base;
+ cx->blk_loop.iterary = curstack;
+ AvFILL(curstack) = sp - stack_base;
cx->blk_loop.iterix = MARK - stack_base;
}
PMOP *newpm;
I32 optype = 0;
- if (stack == sortstack) {
+ if (curstack == sortstack) {
if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) < sortcxix) {
if (cxstack_ix > sortcxix)
dounwind(sortcxix);
- AvARRAY(stack)[1] = *SP;
+ AvARRAY(curstack)[1] = *SP;
stack_sp = stack_base + 1;
return 0;
}
if (!CvROOT(cv) && !CvXSUB(cv)) {
if (CvGV(cv)) {
SV *tmpstr = sv_newmortal();
- gv_efullname(tmpstr, CvGV(cv));
+ gv_efullname3(tmpstr, CvGV(cv), Nullch);
DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
}
DIE("Goto undefined subroutine");
AV* av = cx->blk_sub.argarray;
items = AvFILL(av) + 1;
- Copy(AvARRAY(av), ++stack_sp, items, SV*);
+ stack_sp++;
+ EXTEND(stack_sp, items); /* @_ could have been extended. */
+ Copy(AvARRAY(av), stack_sp, items, SV*);
stack_sp += items;
GvAV(defgv) = cx->blk_sub.savearray;
AvREAL_off(av);
sp = stack_base + items;
}
else {
+ stack_sp--; /* There is no cv arg. */
(void)(*CvXSUB(cv))(cv);
}
LEAVE;
for ( ;ix > 0; ix--) {
if (svp[ix] != &sv_undef) {
char *name = SvPVX(svp[ix]);
- if (SvFLAGS(svp[ix]) & SVf_FAKE) {
- /* outer lexical? */
+ if ((SvFLAGS(svp[ix]) & SVf_FAKE)
+ || *name == '&')
+ {
+ /* outer lexical or anon code */
av_store(newpad, ix,
SvREFCNT_inc(oldpad[ix]) );
}
mark++;
}
}
+ if (perldb && curstash != debstash) {
+ /* &xsub is not copying @_ */
+ SV *sv = GvSV(DBsub);
+ save_item(sv);
+ gv_efullname3(sv, CvGV(cv), Nullch);
+ /* We do not care about using sv to call CV,
+ * just for info. */
+ }
RETURNOP(CvSTART(cv));
}
}
}
if (do_dump) {
+#ifdef VMS
+ if (!retop) retop = main_start;
+#endif
restartop = retop;
do_undump = TRUE;
do_undump = FALSE;
}
- if (stack == signalstack) {
+ if (curstack == signalstack) {
restartop = retop;
- longjmp(top_env, 3);
+ Siglongjmp(top_env, 3);
}
RETURNOP(retop);
dSP;
OP *saveop = op;
HV *newstash;
+ CV *caller;
AV* comppadlist;
in_eval = 1;
+ PUSHMARK(SP);
+
/* set up a scratch pad */
- SAVEINT(padix);
+ SAVEI32(padix);
SAVESPTR(curpad);
SAVESPTR(comppad);
SAVESPTR(comppad_name);
- SAVEINT(comppad_name_fill);
- SAVEINT(min_intro_pending);
- SAVEINT(max_intro_pending);
+ SAVEI32(comppad_name_fill);
+ SAVEI32(min_intro_pending);
+ SAVEI32(max_intro_pending);
+ caller = compcv;
SAVESPTR(compcv);
compcv = (CV*)NEWSV(1104,0);
sv_upgrade((SV *)compcv, SVt_PVCV);
+ CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
comppad = newAV();
comppad_name = newAV();
curcop->cop_arybase = 0;
SvREFCNT_dec(rs);
rs = newSVpv("\n", 1);
- sv_setpv(GvSV(errgv),"");
+ if (saveop->op_flags & OPf_SPECIAL)
+ in_eval |= 4;
+ else
+ sv_setpv(GvSV(errgv),"");
if (yyparse() || error_count || !eval_root) {
SV **newsp;
I32 gimme;
op_free(eval_root);
eval_root = Nullop;
}
+ SP = stack_base + POPMARK; /* pop original mark */
POPBLOCK(cx,curpm);
POPEVAL(cx);
pop_return();
DEBUG_x(dump_eval());
+ /* Register with debugger: */
+
+ if (perldb && saveop->op_type == OP_REQUIRE) {
+ CV *cv = perl_get_cv("DB::postponed", FALSE);
+
+ if (cv) {
+ dSP;
+ PUSHMARK(sp);
+ XPUSHs((SV*)compiling.cop_filegv);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+ }
+ }
+
/* compiled okay, so do it */
+ SP = stack_base + POPMARK; /* pop original mark */
RETURNOP(eval_start);
}
char *tmpname;
SV** svp;
I32 gimme = G_SCALAR;
- FILE *tryrsfp = 0;
+ PerlIO *tryrsfp = 0;
sv = POPs;
if (SvNIOKp(sv) && !SvPOKp(sv)) {
- if (atof(patchlevel) + 0.000999 < SvNV(sv))
- DIE("Perl %3.3f required--this is only version %s, stopped",
- SvNV(sv),patchlevel);
+ SET_NUMERIC_STANDARD();
+ if (atof(patchlevel) + 0.00000999 < SvNV(sv))
+ DIE("Perl %s required--this is only version %s, stopped",
+ SvPV(sv,na),patchlevel);
RETPUSHYES;
}
name = SvPV(sv, na);
|| (tmpname[0] && tmpname[1] == ':')
#endif
#ifdef VMS
- || (strchr(tmpname,':') || ((*tmpname == '[' || *tmpname == '<') &&
- (tmpname[1] == '-' || tmpname[1] == ']' || tmpname[1] == '>')))
+ || (strchr(tmpname,':') || ((*tmpname == '[' || *tmpname == '<') &&
+ (isALNUM(tmpname[1]) || strchr("$-_]>",tmpname[1]))))
#endif
)
{
- tryrsfp = fopen(tmpname,"r");
+ tryrsfp = PerlIO_open(tmpname,"r");
}
else {
AV *ar = GvAVn(incgv);
I32 i;
-
- for (i = 0; i <= AvFILL(ar); i++) {
#ifdef VMS
+ char unixified[256];
+ if (tounixspec_ts(tmpname,unixified) != NULL)
+ for (i = 0; i <= AvFILL(ar); i++) {
if (tounixpath_ts(SvPVx(*av_fetch(ar, i, TRUE), na),buf) == NULL)
continue;
- strcat(buf,name);
+ strcat(buf,unixified);
#else
+ for (i = 0; i <= AvFILL(ar); i++) {
(void)sprintf(buf, "%s/%s",
SvPVx(*av_fetch(ar, i, TRUE), na), name);
#endif
- tryrsfp = fopen(buf, "r");
+ tryrsfp = PerlIO_open(buf, "r");
if (tryrsfp) {
char *s = buf;
dSP;
register CONTEXT *cx;
dPOPss;
- I32 gimme = GIMME;
- char tmpbuf[32];
+ I32 gimme = GIMME, was = sub_generation;
+ char tmpbuf[32], *safestr;
STRLEN len;
+ OP *ret;
if (!SvPV(sv,len) || !len)
RETPUSHUNDEF;
sprintf(tmpbuf, "_<(eval %d)", ++evalseq);
compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
compiling.cop_line = 1;
- SAVEDELETE(defstash, savepv(tmpbuf), strlen(tmpbuf));
+ /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
+ deleting the eval's FILEGV from the stash before gv_check() runs
+ (i.e. before run-time proper). To work around the coredump that
+ ensues, we always turn GvMULTI_on for any globals that were
+ introduced within evals. See force_ident(). GSAR 96-10-12 */
+ safestr = savepv(tmpbuf);
+ SAVEDELETE(defstash, safestr, strlen(safestr));
SAVEI32(hints);
hints = op->op_targ;
if (perldb && curstash != debstash)
save_lines(GvAV(compiling.cop_filegv), linestr);
PUTBACK;
- return doeval(gimme);
+ ret = doeval(gimme);
+ if (perldb && was != sub_generation) { /* Some subs defined here. */
+ strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
+ }
+ return ret;
}
PP(pp_leaveeval)
I32 gimme;
register CONTEXT *cx;
OP *retop;
+ U8 save_flags = op -> op_flags;
I32 optype;
POPBLOCK(cx,newpm);
}
else {
for (mark = newsp + 1; mark <= SP; mark++)
- if (!(SvFLAGS(TOPs) & SVs_TEMP))
+ if (!(SvFLAGS(*mark) & SVs_TEMP))
*mark = sv_mortalcopy(*mark);
/* in case LEAVE wipes old return values */
}
curpm = newpm; /* Don't pop $1 et al till now */
- if (optype != OP_ENTEREVAL) {
+ if (optype == OP_REQUIRE &&
+ !(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) {
char *name = cx->blk_eval.old_name;
- if (!(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) {
- /* Unassume the success we assumed earlier. */
- (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
-
- if (optype == OP_REQUIRE)
- retop = die("%s did not return a true value", name);
- }
+ /* Unassume the success we assumed earlier. */
+ (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
+ retop = die("%s did not return a true value", name);
}
lex_end();
LEAVE;
- sv_setpv(GvSV(errgv),"");
+ if (!(save_flags & OPf_SPECIAL))
+ sv_setpv(GvSV(errgv),"");
RETURNOP(retop);
}
}
else {
for (mark = newsp + 1; mark <= SP; mark++)
- if (!(SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)))
+ if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP)))
*mark = sv_mortalcopy(*mark);
/* in case LEAVE wipes old return values */
}
register I32 arg;
bool ischop;
- New(804, fops, (send - s)*3+2, U16); /* Almost certainly too long... */
+ if (len == 0)
+ croak("Null picture in formline");
+
+ New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
fpc = fops;
if (s < send) {
skipspaces++;
arg -= skipspaces;
if (arg) {
- if (postspace) {
+ if (postspace)
*fpc++ = FF_SPACE;
- postspace = FALSE;
- }
*fpc++ = FF_LITERAL;
*fpc++ = arg;
}
+ postspace = FALSE;
if (s <= send)
skipspaces--;
if (skipspaces) {
}
Copy(fops, s, arg, U16);
Safefree(fops);
+ sv_magic(sv, Nullsv, 'f', Nullch, 0);
SvCOMPILED_on(sv);
}
projects / p5sagit/p5-mst-13.2.git / blobdiff