#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
-static I32 sortcv(pTHXo_ SV *a, SV *b);
-static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
-static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
-static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
-static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
-static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
-static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b);
-static I32 amagic_cmp(pTHXo_ SV *a, SV *b);
-static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b);
-static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen);
-
-#ifdef PERL_OBJECT
-static I32 sv_cmp_static(pTHXo_ SV *a, SV *b);
-static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b);
-#else
-#define sv_cmp_static Perl_sv_cmp
-#define sv_cmp_locale_static Perl_sv_cmp_locale
-#endif
+static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
PP(pp_wantarray)
{
SV *tmpstr;
STRLEN len;
MAGIC *mg = Null(MAGIC*);
+
+ tmpstr = POPs;
-Change 10771 by jhi@alpha on 2001/06/21 12:10:29
-
- Subject: [PATCH] Make /o work under i?threads
- From: Richard Soderberg <rs@crystalflame.net>
- Date: Thu, 21 Jun 2001 05:21:43 -0700 (PDT)
- Message-ID: <Pine.LNX.4.21.0106210518210.2479-100000@oregonnet.com>
-
-Affected files ...
-
- ... //depot/perl/pp_ctl.c#267 edit
-
-Differences ...
-
- ==== //depot/perl/pp_ctl.c#267 (text) ====
-Index: perl/pp_ctl.c
---- perl/pp_ctl.c.~1~ Sun Jun 24 22:31:38 2001
-+++ perl/pp_ctl.c Sun Jun 24 22:31:38 2001
-@@ -88,6 +88,13 @@
- MAGIC *mg = Null(MAGIC*);
-
- tmpstr = POPs;
-
- /* prevent recompiling under /o and ithreads. */
-#if defined(USE_ITHREADS) || defined(USE_THREADS)
- if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
- RETURN;
+ /* prevent recompiling under /o and ithreads. */
+#if defined(USE_ITHREADS) || defined(USE_5005THREADS)
+ if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
+ RETURN;
#endif
- tmpstr = POPs;
if (SvROK(tmpstr)) {
SV *sv = SvRV(tmpstr);
if(SvMAGICAL(sv))
pm = PL_curpm;
else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
pm->op_pmflags |= PMf_WHITE;
+ else
+ pm->op_pmflags &= ~PMf_WHITE;
/* XXX runtime compiled output needs to move to the pad */
if (pm->op_pmflags & PMf_KEEP) {
pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
-#if !defined(USE_ITHREADS) && !defined(USE_THREADS)
+#if !defined(USE_ITHREADS) && !defined(USE_5005THREADS)
/* XXX can't change the optree at runtime either */
cLOGOP->op_first->op_next = PL_op->op_next;
#endif
rxres_restore(&cx->sb_rxres, rx);
if (cx->sb_iters++) {
+ I32 saviters = cx->sb_iters;
if (cx->sb_iters > cx->sb_maxiters)
DIE(aTHX_ "Substitution loop");
POPSUBST(cx);
RETURNOP(pm->op_next);
}
+ cx->sb_iters = saviters;
}
if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
m = s;
ENTER; /* enter outer scope */
SAVETMPS;
- /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
+ /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
SAVESPTR(DEFSV);
ENTER; /* enter inner scope */
SAVEVPTR(PL_curpm);
}
}
-PP(pp_sort)
-{
- dSP; dMARK; dORIGMARK;
- register SV **up;
- SV **myorigmark = ORIGMARK;
- register I32 max;
- HV *stash;
- GV *gv;
- CV *cv = 0;
- I32 gimme = GIMME;
- OP* nextop = PL_op->op_next;
- I32 overloading = 0;
- bool hasargs = FALSE;
- I32 is_xsub = 0;
-
- if (gimme != G_ARRAY) {
- SP = MARK;
- RETPUSHUNDEF;
- }
-
- ENTER;
- SAVEVPTR(PL_sortcop);
- if (PL_op->op_flags & OPf_STACKED) {
- if (PL_op->op_flags & OPf_SPECIAL) {
- OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
- kid = kUNOP->op_first; /* pass rv2gv */
- kid = kUNOP->op_first; /* pass leave */
- PL_sortcop = kid->op_next;
- stash = CopSTASH(PL_curcop);
- }
- else {
- cv = sv_2cv(*++MARK, &stash, &gv, 0);
- if (cv && SvPOK(cv)) {
- STRLEN n_a;
- char *proto = SvPV((SV*)cv, n_a);
- if (proto && strEQ(proto, "$$")) {
- hasargs = TRUE;
- }
- }
- if (!(cv && CvROOT(cv))) {
- if (cv && CvXSUB(cv)) {
- is_xsub = 1;
- }
- else if (gv) {
- SV *tmpstr = sv_newmortal();
- gv_efullname3(tmpstr, gv, Nullch);
- DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
- SvPVX(tmpstr));
- }
- else {
- DIE(aTHX_ "Undefined subroutine in sort");
- }
- }
-
- if (is_xsub)
- PL_sortcop = (OP*)cv;
- else {
- PL_sortcop = CvSTART(cv);
- SAVEVPTR(CvROOT(cv)->op_ppaddr);
- CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
-
- SAVEVPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
- }
- }
- }
- else {
- PL_sortcop = Nullop;
- stash = CopSTASH(PL_curcop);
- }
-
- up = myorigmark + 1;
- while (MARK < SP) { /* This may or may not shift down one here. */
- /*SUPPRESS 560*/
- if ((*up = *++MARK)) { /* Weed out nulls. */
- SvTEMP_off(*up);
- if (!PL_sortcop && !SvPOK(*up)) {
- STRLEN n_a;
- if (SvAMAGIC(*up))
- overloading = 1;
- else
- (void)sv_2pv(*up, &n_a);
- }
- up++;
- }
- }
- max = --up - myorigmark;
- if (PL_sortcop) {
- if (max > 1) {
- PERL_CONTEXT *cx;
- SV** newsp;
- bool oldcatch = CATCH_GET;
-
- SAVETMPS;
- SAVEOP();
-
- CATCH_SET(TRUE);
- PUSHSTACKi(PERLSI_SORT);
- if (!hasargs && !is_xsub) {
- if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
- SAVESPTR(PL_firstgv);
- SAVESPTR(PL_secondgv);
- PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
- PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
- PL_sortstash = stash;
- }
-#ifdef USE_THREADS
- sv_lock((SV *)PL_firstgv);
- sv_lock((SV *)PL_secondgv);
-#endif
- SAVESPTR(GvSV(PL_firstgv));
- SAVESPTR(GvSV(PL_secondgv));
- }
-
- PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
- if (!(PL_op->op_flags & OPf_SPECIAL)) {
- cx->cx_type = CXt_SUB;
- cx->blk_gimme = G_SCALAR;
- PUSHSUB(cx);
- if (!CvDEPTH(cv))
- (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
- }
- PL_sortcxix = cxstack_ix;
-
- if (hasargs && !is_xsub) {
- /* This is mostly copied from pp_entersub */
- AV *av = (AV*)PL_curpad[0];
-
-#ifndef USE_THREADS
- cx->blk_sub.savearray = GvAV(PL_defgv);
- GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
-#endif /* USE_THREADS */
- cx->blk_sub.oldcurpad = PL_curpad;
- cx->blk_sub.argarray = av;
- }
- qsortsv((myorigmark+1), max,
- is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
-
- POPBLOCK(cx,PL_curpm);
- PL_stack_sp = newsp;
- POPSTACK;
- CATCH_SET(oldcatch);
- }
- }
- else {
- if (max > 1) {
- MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
- qsortsv(ORIGMARK+1, max,
- (PL_op->op_private & OPpSORT_NUMERIC)
- ? ( (PL_op->op_private & OPpSORT_INTEGER)
- ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
- : ( overloading ? amagic_ncmp : sv_ncmp))
- : ( IN_LOCALE_RUNTIME
- ? ( overloading
- ? amagic_cmp_locale
- : sv_cmp_locale_static)
- : ( overloading ? amagic_cmp : sv_cmp_static)));
- if (PL_op->op_private & OPpSORT_REVERSE) {
- SV **p = ORIGMARK+1;
- SV **q = ORIGMARK+max;
- while (p < q) {
- SV *tmp = *p;
- *p++ = *q;
- *q-- = tmp;
- }
- }
- }
- }
- LEAVE;
- PL_stack_sp = ORIGMARK + max;
- return nextop;
-}
-
/* Range stuff. */
PP(pp_range)
case CXt_SUBST:
if (ckWARN(WARN_EXITING))
Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
- PL_op_name[PL_op->op_type]);
+ OP_NAME(PL_op));
break;
case CXt_SUB:
if (ckWARN(WARN_EXITING))
Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
- PL_op_name[PL_op->op_type]);
+ OP_NAME(PL_op));
break;
case CXt_FORMAT:
if (ckWARN(WARN_EXITING))
Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
- PL_op_name[PL_op->op_type]);
+ OP_NAME(PL_op));
break;
case CXt_EVAL:
if (ckWARN(WARN_EXITING))
Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
- PL_op_name[PL_op->op_type]);
+ OP_NAME(PL_op));
break;
case CXt_NULL:
if (ckWARN(WARN_EXITING))
Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
- PL_op_name[PL_op->op_type]);
+ OP_NAME(PL_op));
return -1;
case CXt_LOOP:
if (!cx->blk_loop.label ||
case CXt_SUBST:
if (ckWARN(WARN_EXITING))
Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
- PL_op_name[PL_op->op_type]);
+ OP_NAME(PL_op));
break;
case CXt_SUB:
if (ckWARN(WARN_EXITING))
Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
- PL_op_name[PL_op->op_type]);
+ OP_NAME(PL_op));
break;
case CXt_FORMAT:
if (ckWARN(WARN_EXITING))
Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
- PL_op_name[PL_op->op_type]);
+ OP_NAME(PL_op));
break;
case CXt_EVAL:
if (ckWARN(WARN_EXITING))
Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
- PL_op_name[PL_op->op_type]);
+ OP_NAME(PL_op));
break;
case CXt_NULL:
if (ckWARN(WARN_EXITING))
Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
- PL_op_name[PL_op->op_type]);
+ OP_NAME(PL_op));
return -1;
case CXt_LOOP:
DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
#endif
PerlIO *serr = Perl_error_log;
- PerlIO_write(serr, message, msglen);
+ PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
(void)PerlIO_flush(serr);
#ifdef USE_SFIO
errno = e;
if (MAXARG)
count = POPi;
- EXTEND(SP, 10);
+
for (;;) {
/* we may be in a higher stacklevel, so dig down deeper */
while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
cxix = dopoptosub_at(ccstack, top_si->si_cxix);
}
if (cxix < 0) {
- if (GIMME != G_ARRAY)
+ if (GIMME != G_ARRAY) {
+ EXTEND(SP, 1);
RETPUSHUNDEF;
+ }
RETURN;
}
if (PL_DBsub && cxix >= 0 &&
stashname = CopSTASHPV(cx->blk_oldcop);
if (GIMME != G_ARRAY) {
+ EXTEND(SP, 1);
if (!stashname)
PUSHs(&PL_sv_undef);
else {
RETURN;
}
+ EXTEND(SP, 10);
+
if (!stashname)
PUSHs(&PL_sv_undef);
else
ENTER;
SAVETMPS;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
if (PL_op->op_flags & OPf_SPECIAL) {
svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
SAVEGENERICSV(*svp);
*svp = NEWSV(0,0);
}
else
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
if (PL_op->op_targ) {
#ifndef USE_ITHREADS
svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
SAVESPTR(*svp);
#else
SAVEPADSV(PL_op->op_targ);
- iterdata = (void*)PL_op->op_targ;
+ iterdata = INT2PTR(void*, PL_op->op_targ);
cxtype |= CXp_PADVAR;
#endif
}
STATIC OP *
S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
{
- OP *kid;
+ OP *kid = Nullop;
OP **ops = opstack;
static char too_deep[] = "Target of goto is too deeply nested";
EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
Copy(AvARRAY(av), PL_stack_sp, items, SV*);
PL_stack_sp += items;
-#ifndef USE_THREADS
+#ifndef USE_5005THREADS
SvREFCNT_dec(GvAV(PL_defgv));
GvAV(PL_defgv) = cx->blk_sub.savearray;
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
/* abandon @_ if it got reified */
if (AvREAL(av)) {
(void)sv_2mortal((SV*)av); /* delay until return */
}
else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
AV* av;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
av = (AV*)PL_curpad[0];
#else
av = GvAV(PL_defgv);
PL_stack_sp--; /* There is no cv arg. */
/* Push a mark for the start of arglist */
PUSHMARK(mark);
- (void)(*CvXSUB(cv))(aTHXo_ cv);
+ (void)(*CvXSUB(cv))(aTHX_ cv);
/* Pop the current context like a decent sub should */
POPBLOCK(cx, PL_curpm);
/* Do _not_ use PUTBACK, keep the XSUB's return stack! */
svp = AvARRAY(padlist);
}
}
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
if (!cx->blk_sub.hasargs) {
AV* av = (AV*)PL_curpad[0];
PUTBACK ;
}
}
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
SAVEVPTR(PL_curpad);
PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
-#ifndef USE_THREADS
+#ifndef USE_5005THREADS
if (cx->blk_sub.hasargs)
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
{
AV* av = (AV*)PL_curpad[0];
SV** ary;
-#ifndef USE_THREADS
+#ifndef USE_5005THREADS
cx->blk_sub.savearray = GvAV(PL_defgv);
GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
cx->blk_sub.oldcurpad = PL_curpad;
cx->blk_sub.argarray = av;
++mark;
#ifdef VMS
if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
anum = 0;
+ VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
#endif
}
PL_exit_flags |= PERL_EXIT_EXPECTED;
return rop;
}
-/* With USE_THREADS, eval_owner must be held on entry to doeval */
+/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
STATIC OP *
S_doeval(pTHX_ int gimme, OP** startop)
{
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
CvOWNER(PL_compcv) = 0;
New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(PL_compcv));
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
PL_comppad = newAV();
av_push(PL_comppad, Nullsv);
PL_comppad_name_fill = 0;
PL_min_intro_pending = 0;
PL_padix = 0;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
PL_curpad[0] = (SV*)newAV();
SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
comppadlist = newAV();
AvREAL_off(comppadlist);
PL_error_count = 0;
PL_curcop = &PL_compiling;
PL_curcop->cop_arybase = 0;
- SvREFCNT_dec(PL_rs);
- PL_rs = newSVpvn("\n", 1);
if (saveop && saveop->op_flags & OPf_SPECIAL)
PL_in_eval |= EVAL_KEEPERR;
else
Perl_croak(aTHX_ "%sCompilation failed in regexp",
(*msg ? msg : "Unknown error\n"));
}
- SvREFCNT_dec(PL_rs);
- PL_rs = SvREFCNT_inc(PL_nrs);
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
MUTEX_LOCK(&PL_eval_mutex);
PL_eval_owner = 0;
COND_SIGNAL(&PL_eval_cond);
MUTEX_UNLOCK(&PL_eval_mutex);
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
RETPUSHUNDEF;
}
- SvREFCNT_dec(PL_rs);
- PL_rs = SvREFCNT_inc(PL_nrs);
CopLINE_set(&PL_compiling, 0);
if (startop) {
*startop = PL_eval_root;
SP = PL_stack_base + POPMARK; /* pop original mark */
PL_op = saveop; /* The caller may need it. */
PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
MUTEX_LOCK(&PL_eval_mutex);
PL_eval_owner = 0;
COND_SIGNAL(&PL_eval_cond);
MUTEX_UNLOCK(&PL_eval_mutex);
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
RETURNOP(PL_eval_start);
}
GV *filter_child_proc = 0;
SV *filter_state = 0;
SV *filter_sub = 0;
+ SV *hook_sv = 0;
+ SV *encoding;
+ OP *op;
sv = POPs;
if (SvNIOKp(sv)) {
"v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
PERL_VERSION, PERL_SUBVERSION);
}
+ if (ckWARN(WARN_PORTABLE))
+ Perl_warner(aTHX_ WARN_PORTABLE,
+ "v-string in use/require non-portable");
RETPUSHYES;
}
else if (!SvPOKp(sv)) { /* require 5.005_03 */
if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
"this is only v%d.%d.%d, stopped"
- " (did you mean v%"UVuf".%"UVuf".0?)",
+ " (did you mean v%"UVuf".%03"UVuf"?)",
rev, ver, sver, PERL_REVISION, PERL_VERSION,
PERL_SUBVERSION, rev, ver/100);
}
int count;
SV *loader = dirsv;
- if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
+ if (SvTYPE(SvRV(loader)) == SVt_PVAV
+ && !sv_isobject(loader))
+ {
loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
}
Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
- PTR2UV(SvANY(loader)), name);
+ PTR2UV(SvRV(dirsv)), name);
tryname = SvPVX(namesv);
tryrsfp = 0;
LEAVE;
if (tryrsfp) {
+ hook_sv = dirsv;
break;
}
SETERRNO(0, SS$_NORMAL);
/* Assume success here to prevent recursive requirement. */
- (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
- newSVpv(CopFILE(&PL_compiling), 0), 0 );
+ len = strlen(name);
+ /* Check whether a hook in @INC has already filled %INC */
+ if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
+ (void)hv_store(GvHVn(PL_incgv), name, len,
+ (hook_sv ? SvREFCNT_inc(hook_sv)
+ : newSVpv(CopFILE(&PL_compiling), 0)),
+ 0 );
+ }
ENTER;
SAVETMPS;
PL_compiling.cop_warnings = pWARN_ALL ;
else if (PL_dowarn & G_WARN_ALL_OFF)
PL_compiling.cop_warnings = pWARN_NONE ;
+ else if (PL_taint_warn)
+ PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
else
PL_compiling.cop_warnings = pWARN_STD ;
SAVESPTR(PL_compiling.cop_io);
CopLINE_set(&PL_compiling, 0);
PUTBACK;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
MUTEX_LOCK(&PL_eval_mutex);
if (PL_eval_owner && PL_eval_owner != thr)
while (PL_eval_owner)
COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
PL_eval_owner = thr;
MUTEX_UNLOCK(&PL_eval_mutex);
-#endif /* USE_THREADS */
- return DOCATCH(doeval(gimme, NULL));
+#endif /* USE_5005THREADS */
+
+ /* Store and reset encoding. */
+ encoding = PL_encoding;
+ PL_encoding = Nullsv;
+
+ op = DOCATCH(doeval(gimme, NULL));
+
+ /* Restore encoding. */
+ PL_encoding = encoding;
+
+ return op;
}
PP(pp_dofile)
if (PERLDB_LINE && PL_curstash != PL_debstash)
save_lines(CopFILEAV(&PL_compiling), PL_linestr);
PUTBACK;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
MUTEX_LOCK(&PL_eval_mutex);
if (PL_eval_owner && PL_eval_owner != thr)
while (PL_eval_owner)
COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
PL_eval_owner = thr;
MUTEX_UNLOCK(&PL_eval_mutex);
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
ret = doeval(gimme, NULL);
if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
&& ret != PL_op->op_next) { /* Successive compilation. */
SvCOMPILED_on(sv);
}
-/*
- * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
- *
- * The original code was written in conjunction with BSD Computer Software
- * Research Group at University of California, Berkeley.
- *
- * See also: "Optimistic Merge Sort" (SODA '92)
- *
- * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
- *
- * The code can be distributed under the same terms as Perl itself.
- *
- */
-
-#ifdef TESTHARNESS
-#include <sys/types.h>
-typedef void SV;
-#define pTHXo_
-#define pTHX_
-#define STATIC
-#define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
-#define Safefree(VAR) free(VAR)
-typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
-#endif /* TESTHARNESS */
-
-typedef char * aptr; /* pointer for arithmetic on sizes */
-typedef SV * gptr; /* pointers in our lists */
-
-/* Binary merge internal sort, with a few special mods
-** for the special perl environment it now finds itself in.
-**
-** Things that were once options have been hotwired
-** to values suitable for this use. In particular, we'll always
-** initialize looking for natural runs, we'll always produce stable
-** output, and we'll always do Peter McIlroy's binary merge.
-*/
-
-/* Pointer types for arithmetic and storage and convenience casts */
-
-#define APTR(P) ((aptr)(P))
-#define GPTP(P) ((gptr *)(P))
-#define GPPP(P) ((gptr **)(P))
-
-
-/* byte offset from pointer P to (larger) pointer Q */
-#define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
-
-#define PSIZE sizeof(gptr)
-
-/* If PSIZE is power of 2, make PSHIFT that power, if that helps */
-
-#ifdef PSHIFT
-#define PNELEM(P, Q) (BYTEOFF(P,Q) >> (PSHIFT))
-#define PNBYTE(N) ((N) << (PSHIFT))
-#define PINDEX(P, N) (GPTP(APTR(P) + PNBYTE(N)))
-#else
-/* Leave optimization to compiler */
-#define PNELEM(P, Q) (GPTP(Q) - GPTP(P))
-#define PNBYTE(N) ((N) * (PSIZE))
-#define PINDEX(P, N) (GPTP(P) + (N))
-#endif
-
-/* Pointer into other corresponding to pointer into this */
-#define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
-
-#define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
-
-
-/* Runs are identified by a pointer in the auxilliary list.
-** The pointer is at the start of the list,
-** and it points to the start of the next list.
-** NEXT is used as an lvalue, too.
-*/
-
-#define NEXT(P) (*GPPP(P))
-
-
-/* PTHRESH is the minimum number of pairs with the same sense to justify
-** checking for a run and extending it. Note that PTHRESH counts PAIRS,
-** not just elements, so PTHRESH == 8 means a run of 16.
-*/
-
-#define PTHRESH (8)
-
-/* RTHRESH is the number of elements in a run that must compare low
-** to the low element from the opposing run before we justify
-** doing a binary rampup instead of single stepping.
-** In random input, N in a row low should only happen with
-** probability 2^(1-N), so we can risk that we are dealing
-** with orderly input without paying much when we aren't.
-*/
-
-#define RTHRESH (6)
-
-
-/*
-** Overview of algorithm and variables.
-** The array of elements at list1 will be organized into runs of length 2,
-** or runs of length >= 2 * PTHRESH. We only try to form long runs when
-** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
-**
-** Unless otherwise specified, pair pointers address the first of two elements.
-**
-** b and b+1 are a pair that compare with sense ``sense''.
-** b is the ``bottom'' of adjacent pairs that might form a longer run.
-**
-** p2 parallels b in the list2 array, where runs are defined by
-** a pointer chain.
-**
-** t represents the ``top'' of the adjacent pairs that might extend
-** the run beginning at b. Usually, t addresses a pair
-** that compares with opposite sense from (b,b+1).
-** However, it may also address a singleton element at the end of list1,
-** or it may be equal to ``last'', the first element beyond list1.
-**
-** r addresses the Nth pair following b. If this would be beyond t,
-** we back it off to t. Only when r is less than t do we consider the
-** run long enough to consider checking.
-**
-** q addresses a pair such that the pairs at b through q already form a run.
-** Often, q will equal b, indicating we only are sure of the pair itself.
-** However, a search on the previous cycle may have revealed a longer run,
-** so q may be greater than b.
-**
-** p is used to work back from a candidate r, trying to reach q,
-** which would mean b through r would be a run. If we discover such a run,
-** we start q at r and try to push it further towards t.
-** If b through r is NOT a run, we detect the wrong order at (p-1,p).
-** In any event, after the check (if any), we have two main cases.
-**
-** 1) Short run. b <= q < p <= r <= t.
-** b through q is a run (perhaps trivial)
-** q through p are uninteresting pairs
-** p through r is a run
-**
-** 2) Long run. b < r <= q < t.
-** b through q is a run (of length >= 2 * PTHRESH)
-**
-** Note that degenerate cases are not only possible, but likely.
-** For example, if the pair following b compares with opposite sense,
-** then b == q < p == r == t.
-*/
-
-
-static void
-dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
-{
- int sense;
- register gptr *b, *p, *q, *t, *p2;
- register gptr c, *last, *r;
- gptr *savep;
-
- b = list1;
- last = PINDEX(b, nmemb);
- sense = (cmp(aTHX_ *b, *(b+1)) > 0);
- for (p2 = list2; b < last; ) {
- /* We just started, or just reversed sense.
- ** Set t at end of pairs with the prevailing sense.
- */
- for (p = b+2, t = p; ++p < last; t = ++p) {
- if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
- }
- q = b;
- /* Having laid out the playing field, look for long runs */
- do {
- p = r = b + (2 * PTHRESH);
- if (r >= t) p = r = t; /* too short to care about */
- else {
- while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
- ((p -= 2) > q));
- if (p <= q) {
- /* b through r is a (long) run.
- ** Extend it as far as possible.
- */
- p = q = r;
- while (((p += 2) < t) &&
- ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
- r = p = q + 2; /* no simple pairs, no after-run */
- }
- }
- if (q > b) { /* run of greater than 2 at b */
- savep = p;
- p = q += 2;
- /* pick up singleton, if possible */
- if ((p == t) &&
- ((t + 1) == last) &&
- ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
- savep = r = p = q = last;
- p2 = NEXT(p2) = p2 + (p - b);
- if (sense) while (b < --p) {
- c = *b;
- *b++ = *p;
- *p = c;
- }
- p = savep;
- }
- while (q < p) { /* simple pairs */
- p2 = NEXT(p2) = p2 + 2;
- if (sense) {
- c = *q++;
- *(q-1) = *q;
- *q++ = c;
- } else q += 2;
- }
- if (((b = p) == t) && ((t+1) == last)) {
- NEXT(p2) = p2 + 1;
- b++;
- }
- q = r;
- } while (b < t);
- sense = !sense;
- }
- return;
-}
-
-
-/* Overview of bmerge variables:
-**
-** list1 and list2 address the main and auxiliary arrays.
-** They swap identities after each merge pass.
-** Base points to the original list1, so we can tell if
-** the pointers ended up where they belonged (or must be copied).
-**
-** When we are merging two lists, f1 and f2 are the next elements
-** on the respective lists. l1 and l2 mark the end of the lists.
-** tp2 is the current location in the merged list.
-**
-** p1 records where f1 started.
-** After the merge, a new descriptor is built there.
-**
-** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
-** It is used to identify and delimit the runs.
-**
-** In the heat of determining where q, the greater of the f1/f2 elements,
-** belongs in the other list, b, t and p, represent bottom, top and probe
-** locations, respectively, in the other list.
-** They make convenient temporary pointers in other places.
-*/
-
-STATIC void
-S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
-{
- int i, run;
- int sense;
- register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
- gptr *aux, *list2, *p2, *last;
- gptr *base = list1;
- gptr *p1;
-
- if (nmemb <= 1) return; /* sorted trivially */
- New(799,list2,nmemb,gptr); /* allocate auxilliary array */
- aux = list2;
- dynprep(aTHX_ list1, list2, nmemb, cmp);
- last = PINDEX(list2, nmemb);
- while (NEXT(list2) != last) {
- /* More than one run remains. Do some merging to reduce runs. */
- l2 = p1 = list1;
- for (tp2 = p2 = list2; p2 != last;) {
- /* The new first run begins where the old second list ended.
- ** Use the p2 ``parallel'' pointer to identify the end of the run.
- */
- f1 = l2;
- t = NEXT(p2);
- f2 = l1 = POTHER(t, list2, list1);
- if (t != last) t = NEXT(t);
- l2 = POTHER(t, list2, list1);
- p2 = t;
- while (f1 < l1 && f2 < l2) {
- /* If head 1 is larger than head 2, find ALL the elements
- ** in list 2 strictly less than head1, write them all,
- ** then head 1. Then compare the new heads, and repeat,
- ** until one or both lists are exhausted.
- **
- ** In all comparisons (after establishing
- ** which head to merge) the item to merge
- ** (at pointer q) is the first operand of
- ** the comparison. When we want to know
- ** if ``q is strictly less than the other'',
- ** we can't just do
- ** cmp(q, other) < 0
- ** because stability demands that we treat equality
- ** as high when q comes from l2, and as low when
- ** q was from l1. So we ask the question by doing
- ** cmp(q, other) <= sense
- ** and make sense == 0 when equality should look low,
- ** and -1 when equality should look high.
- */
-
-
- if (cmp(aTHX_ *f1, *f2) <= 0) {
- q = f2; b = f1; t = l1;
- sense = -1;
- } else {
- q = f1; b = f2; t = l2;
- sense = 0;
- }
-
-
- /* ramp up
- **
- ** Leave t at something strictly
- ** greater than q (or at the end of the list),
- ** and b at something strictly less than q.
- */
- for (i = 1, run = 0 ;;) {
- if ((p = PINDEX(b, i)) >= t) {
- /* off the end */
- if (((p = PINDEX(t, -1)) > b) &&
- (cmp(aTHX_ *q, *p) <= sense))
- t = p;
- else b = p;
- break;
- } else if (cmp(aTHX_ *q, *p) <= sense) {
- t = p;
- break;
- } else b = p;
- if (++run >= RTHRESH) i += i;
- }
-
-
- /* q is known to follow b and must be inserted before t.
- ** Increment b, so the range of possibilities is [b,t).
- ** Round binary split down, to favor early appearance.
- ** Adjust b and t until q belongs just before t.
- */
-
- b++;
- while (b < t) {
- p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
- if (cmp(aTHX_ *q, *p) <= sense) {
- t = p;
- } else b = p + 1;
- }
-
-
- /* Copy all the strictly low elements */
-
- if (q == f1) {
- FROMTOUPTO(f2, tp2, t);
- *tp2++ = *f1++;
- } else {
- FROMTOUPTO(f1, tp2, t);
- *tp2++ = *f2++;
- }
- }
-
-
- /* Run out remaining list */
- if (f1 == l1) {
- if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
- } else FROMTOUPTO(f1, tp2, l1);
- p1 = NEXT(p1) = POTHER(tp2, list2, list1);
- }
- t = list1;
- list1 = list2;
- list2 = t;
- last = PINDEX(list2, nmemb);
- }
- if (base == list2) {
- last = PINDEX(list1, nmemb);
- FROMTOUPTO(list1, list2, last);
- }
- Safefree(aux);
- return;
-}
-
-
-#ifdef PERL_OBJECT
-#undef this
-#define this pPerl
-#include "XSUB.h"
-#endif
-
-
-static I32
-sortcv(pTHXo_ SV *a, SV *b)
-{
- I32 oldsaveix = PL_savestack_ix;
- I32 oldscopeix = PL_scopestack_ix;
- I32 result;
- GvSV(PL_firstgv) = a;
- GvSV(PL_secondgv) = b;
- PL_stack_sp = PL_stack_base;
- PL_op = PL_sortcop;
- CALLRUNOPS(aTHX);
- if (PL_stack_sp != PL_stack_base + 1)
- Perl_croak(aTHX_ "Sort subroutine didn't return single value");
- if (!SvNIOKp(*PL_stack_sp))
- Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
- result = SvIV(*PL_stack_sp);
- while (PL_scopestack_ix > oldscopeix) {
- LEAVE;
- }
- leave_scope(oldsaveix);
- return result;
-}
-
-static I32
-sortcv_stacked(pTHXo_ SV *a, SV *b)
-{
- I32 oldsaveix = PL_savestack_ix;
- I32 oldscopeix = PL_scopestack_ix;
- I32 result;
- AV *av;
-
-#ifdef USE_THREADS
- av = (AV*)PL_curpad[0];
-#else
- av = GvAV(PL_defgv);
-#endif
-
- if (AvMAX(av) < 1) {
- SV** ary = AvALLOC(av);
- if (AvARRAY(av) != ary) {
- AvMAX(av) += AvARRAY(av) - AvALLOC(av);
- SvPVX(av) = (char*)ary;
- }
- if (AvMAX(av) < 1) {
- AvMAX(av) = 1;
- Renew(ary,2,SV*);
- SvPVX(av) = (char*)ary;
- }
- }
- AvFILLp(av) = 1;
-
- AvARRAY(av)[0] = a;
- AvARRAY(av)[1] = b;
- PL_stack_sp = PL_stack_base;
- PL_op = PL_sortcop;
- CALLRUNOPS(aTHX);
- if (PL_stack_sp != PL_stack_base + 1)
- Perl_croak(aTHX_ "Sort subroutine didn't return single value");
- if (!SvNIOKp(*PL_stack_sp))
- Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
- result = SvIV(*PL_stack_sp);
- while (PL_scopestack_ix > oldscopeix) {
- LEAVE;
- }
- leave_scope(oldsaveix);
- return result;
-}
-
-static I32
-sortcv_xsub(pTHXo_ SV *a, SV *b)
-{
- dSP;
- I32 oldsaveix = PL_savestack_ix;
- I32 oldscopeix = PL_scopestack_ix;
- I32 result;
- CV *cv=(CV*)PL_sortcop;
-
- SP = PL_stack_base;
- PUSHMARK(SP);
- EXTEND(SP, 2);
- *++SP = a;
- *++SP = b;
- PUTBACK;
- (void)(*CvXSUB(cv))(aTHXo_ cv);
- if (PL_stack_sp != PL_stack_base + 1)
- Perl_croak(aTHX_ "Sort subroutine didn't return single value");
- if (!SvNIOKp(*PL_stack_sp))
- Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
- result = SvIV(*PL_stack_sp);
- while (PL_scopestack_ix > oldscopeix) {
- LEAVE;
- }
- leave_scope(oldsaveix);
- return result;
-}
-
-
-static I32
-sv_ncmp(pTHXo_ SV *a, SV *b)
-{
- NV nv1 = SvNV(a);
- NV nv2 = SvNV(b);
- return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
-}
-
static I32
-sv_i_ncmp(pTHXo_ SV *a, SV *b)
-{
- IV iv1 = SvIV(a);
- IV iv2 = SvIV(b);
- return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
-}
-#define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
- *svp = Nullsv; \
- if (PL_amagic_generation) { \
- if (SvAMAGIC(left)||SvAMAGIC(right))\
- *svp = amagic_call(left, \
- right, \
- CAT2(meth,_amg), \
- 0); \
- } \
- } STMT_END
-
-static I32
-amagic_ncmp(pTHXo_ register SV *a, register SV *b)
-{
- SV *tmpsv;
- tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
- if (tmpsv) {
- NV d;
-
- if (SvIOK(tmpsv)) {
- I32 i = SvIVX(tmpsv);
- if (i > 0)
- return 1;
- return i? -1 : 0;
- }
- d = SvNV(tmpsv);
- if (d > 0)
- return 1;
- return d? -1 : 0;
- }
- return sv_ncmp(aTHXo_ a, b);
-}
-
-static I32
-amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
-{
- SV *tmpsv;
- tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
- if (tmpsv) {
- NV d;
-
- if (SvIOK(tmpsv)) {
- I32 i = SvIVX(tmpsv);
- if (i > 0)
- return 1;
- return i? -1 : 0;
- }
- d = SvNV(tmpsv);
- if (d > 0)
- return 1;
- return d? -1 : 0;
- }
- return sv_i_ncmp(aTHXo_ a, b);
-}
-
-static I32
-amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
-{
- SV *tmpsv;
- tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
- if (tmpsv) {
- NV d;
-
- if (SvIOK(tmpsv)) {
- I32 i = SvIVX(tmpsv);
- if (i > 0)
- return 1;
- return i? -1 : 0;
- }
- d = SvNV(tmpsv);
- if (d > 0)
- return 1;
- return d? -1 : 0;
- }
- return sv_cmp(str1, str2);
-}
-
-static I32
-amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
-{
- SV *tmpsv;
- tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
- if (tmpsv) {
- NV d;
-
- if (SvIOK(tmpsv)) {
- I32 i = SvIVX(tmpsv);
- if (i > 0)
- return 1;
- return i? -1 : 0;
- }
- d = SvNV(tmpsv);
- if (d > 0)
- return 1;
- return d? -1 : 0;
- }
- return sv_cmp_locale(str1, str2);
-}
-
-static I32
-run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
+run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
{
SV *datasv = FILTER_DATA(idx);
int filter_has_file = IoLINES(datasv);
return len;
}
-#ifdef PERL_OBJECT
-
-static I32
-sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
-{
- return sv_cmp_locale(str1, str2);
-}
-
-static I32
-sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
-{
- return sv_cmp(str1, str2);
-}
-
-#endif /* PERL_OBJECT */
https://perl5.git.perl.org / perl5.git / blobdiff