X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=e849e33c6834f205b61c8f4ffd77a8de7d025cf0;hb=8e52752b5f49a78716f0f99e5101dfe233b32cb0;hp=21d03351ef4d4b511e27eeaa69e591e82e0af110;hpb=6520202708b2a849ca8538ed88e0f75376c3b2d7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 21d0335..e849e33 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -26,10 +26,21 @@ #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) +static I32 sortcv(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 -#define CALLOP this->*PL_op +static I32 sv_cmp_static(pTHXo_ SV *a, SV *b); +static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b); #else -#define CALLOP *PL_op +#define sv_cmp_static Perl_sv_cmp +#define sv_cmp_locale_static Perl_sv_cmp_locale #endif PP(pp_wantarray) @@ -212,12 +223,12 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) *rsp = (void*)p; } - *p++ = (UV)(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch); + *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch); RX_MATCH_COPIED_off(rx); *p++ = rx->nparens; - *p++ = (UV)rx->subbeg; + *p++ = PTR2UV(rx->subbeg); *p++ = (UV)rx->sublen; for (i = 0; i <= rx->nparens; ++i) { *p++ = (UV)rx->startp[i]; @@ -238,7 +249,7 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) rx->nparens = *p++; - rx->subbeg = (char*)(*p++); + rx->subbeg = INT2PTR(char*,*p++); rx->sublen = (I32)(*p++); for (i = 0; i <= rx->nparens; ++i) { rx->startp[i] = (I32)(*p++); @@ -252,7 +263,7 @@ Perl_rxres_free(pTHX_ void **rsp) UV *p = (UV*)*rsp; if (p) { - Safefree((char*)(*p)); + Safefree(INT2PTR(char*,*p)); Safefree(p); *rsp = Null(void*); } @@ -571,10 +582,10 @@ PP(pp_formline) RESTORE_NUMERIC_LOCAL(); #if defined(USE_LONG_DOUBLE) if (arg & 256) { - sprintf(t, "%#*.*Lf", + sprintf(t, "%#*.*" PERL_PRIfldbl, (int) fieldsize, (int) arg & 255, value); } else { - sprintf(t, "%*.0Lf", (int) fieldsize, value); + sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value); } #else if (arg & 256) { @@ -755,120 +766,6 @@ PP(pp_mapwhile) } } -STATIC I32 -S_sv_ncmp(pTHX_ SV *a, SV *b) -{ - NV nv1 = SvNV(a); - NV nv2 = SvNV(b); - return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0; -} - -STATIC I32 -S_sv_i_ncmp(pTHX_ 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 -S_amagic_ncmp(pTHX_ 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(a, b); -} - -STATIC I32 -S_amagic_i_ncmp(pTHX_ 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(a, b); -} - -STATIC I32 -S_amagic_cmp(pTHX_ 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 -S_amagic_cmp_locale(pTHX_ 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); -} - PP(pp_sort) { djSP; dMARK; dORIGMARK; @@ -974,7 +871,7 @@ PP(pp_sort) (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */ } PL_sortcxix = cxstack_ix; - qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(S_sortcv)); + qsortsv((myorigmark+1), max, sortcv); POPBLOCK(cx,PL_curpm); PL_stack_sp = newsp; @@ -988,19 +885,13 @@ PP(pp_sort) qsortsv(ORIGMARK+1, max, (PL_op->op_private & OPpSORT_NUMERIC) ? ( (PL_op->op_private & OPpSORT_INTEGER) - ? ( overloading - ? FUNC_NAME_TO_PTR(S_amagic_i_ncmp) - : FUNC_NAME_TO_PTR(S_sv_i_ncmp)) - : ( overloading - ? FUNC_NAME_TO_PTR(S_amagic_ncmp) - : FUNC_NAME_TO_PTR(S_sv_ncmp))) + ? ( overloading ? amagic_i_ncmp : sv_i_ncmp) + : ( overloading ? amagic_ncmp : sv_ncmp)) : ( (PL_op->op_private & OPpLOCALE) ? ( overloading - ? FUNC_NAME_TO_PTR(S_amagic_cmp_locale) - : FUNC_NAME_TO_PTR(Perl_sv_cmp_locale)) - : ( overloading - ? FUNC_NAME_TO_PTR(S_amagic_cmp) - : FUNC_NAME_TO_PTR(Perl_sv_cmp) ))); + ? 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; @@ -1022,11 +913,11 @@ PP(pp_sort) PP(pp_range) { if (GIMME == G_ARRAY) - return cCONDOP->op_true; + return NORMAL; if (SvTRUEx(PAD_SV(PL_op->op_targ))) - return cCONDOP->op_false; + return cLOGOP->op_other; else - return cCONDOP->op_true; + return NORMAL; } PP(pp_flip) @@ -1034,7 +925,7 @@ PP(pp_flip) djSP; if (GIMME == G_ARRAY) { - RETURNOP(((CONDOP*)cUNOP->op_first)->op_false); + RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); } else { dTOPss; @@ -1052,7 +943,7 @@ PP(pp_flip) else { sv_setiv(targ, 0); SP--; - RETURNOP(((CONDOP*)cUNOP->op_first)->op_false); + RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); } } sv_setpv(TARG, ""); @@ -1080,7 +971,7 @@ PP(pp_flop) (looks_like_number(left) && *SvPVX(left) != '0') ) { if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX) - Perl_croak(aTHX_ "Range iterator outside integer range"); + DIE(aTHX_ "Range iterator outside integer range"); i = SvIV(left); max = SvIV(right); if (max >= i) { @@ -1356,6 +1247,18 @@ S_free_closures(pTHX) } } +void +Perl_qerror(pTHX_ SV *err) +{ + if (PL_in_eval) + sv_catsv(ERRSV, err); + else if (PL_errors) + sv_catsv(PL_errors, err); + else + Perl_warn(aTHX_ "%_", err); + ++PL_error_count; +} + OP * Perl_die_where(pTHX_ char *message, STRLEN msglen) { @@ -1397,7 +1300,9 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) else message = SvPVx(ERRSV, msglen); - while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) { + while ((cxix = dopoptoeval(cxstack_ix)) < 0 + && PL_curstackinfo->si_prev) + { dounwind(-1); POPSTACK; } @@ -1424,7 +1329,8 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) if (optype == OP_REQUIRE) { char* msg = SvPVx(ERRSV, n_a); - DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require"); + DIE(aTHX_ "%sCompilation failed in require", + *msg ? msg : "Unknown error\n"); } return pop_return(); } @@ -1567,9 +1473,12 @@ PP(pp_caller) PUSHs(&PL_sv_yes); } } - else if (CxTYPE(cx) == CXt_SUB && - cx->blk_sub.hasargs && - PL_curcop->cop_stash == PL_debstash) + else { + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); + } + if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs + && PL_curcop->cop_stash == PL_debstash) { AV *ary = cx->blk_sub.argarray; int off = AvARRAY(ary) - AvALLOC(ary); @@ -1595,30 +1504,6 @@ PP(pp_caller) RETURN; } -STATIC I32 -S_sortcv(pTHX_ SV *a, SV *b) -{ - dTHR; - 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; -} - PP(pp_reset) { djSP; @@ -1731,7 +1616,7 @@ PP(pp_enteriter) (looks_like_number(sv) && *SvPVX(sv) != '0')) { if (SvNV(sv) < IV_MIN || SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX) - Perl_croak(aTHX_ "Range iterator outside integer range"); + DIE(aTHX_ "Range iterator outside integer range"); cx->blk_loop.iterix = SvIV(sv); cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary); } @@ -2102,7 +1987,6 @@ PP(pp_goto) SV** mark; I32 items = 0; I32 oldsave; - int arg_was_real = 0; retry: if (!CvROOT(cv) && !CvXSUB(cv)) { @@ -2134,8 +2018,8 @@ PP(pp_goto) if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) DIE(aTHX_ "Can't goto subroutine from an eval-string"); mark = PL_stack_sp; - if (CxTYPE(cx) == CXt_SUB && - cx->blk_sub.hasargs) { /* put @_ back onto stack */ + if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { + /* put @_ back onto stack */ AV* av = cx->blk_sub.argarray; items = AvFILLp(av) + 1; @@ -2147,11 +2031,14 @@ PP(pp_goto) SvREFCNT_dec(GvAV(PL_defgv)); GvAV(PL_defgv) = cx->blk_sub.savearray; #endif /* USE_THREADS */ + /* abandon @_ if it got reified */ if (AvREAL(av)) { - arg_was_real = 1; - AvREAL_off(av); /* so av_clear() won't clobber elts */ + (void)sv_2mortal((SV*)av); /* delay until return */ + av = newAV(); + av_extend(av, items-1); + AvFLAGS(av) = AVf_REIFY; + PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av); } - av_clear(av); } else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ AV* av; @@ -2309,11 +2196,7 @@ PP(pp_goto) } Copy(mark,AvARRAY(av),items,SV*); AvFILLp(av) = items - 1; - /* preserve @_ nature */ - if (arg_was_real) { - AvREIFY_off(av); - AvREAL_on(av); - } + assert(!AvREAL(av)); while (items--) { if (*mark) SvTEMP_off(*mark); @@ -2329,7 +2212,7 @@ PP(pp_goto) CV *gotocv; if (PERLDB_SUB_NN) { - SvIVX(sv) = (IV)cv; /* Already upgraded, saved */ + SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */ } else { save_item(sv); gv_efullname3(sv, CvGV(cv), Nullch); @@ -2428,7 +2311,7 @@ PP(pp_goto) if (PL_op->op_type == OP_ENTERITER) DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop", label); - (CALLOP->op_ppaddr)(aTHX); + CALL_FPTR(PL_op->op_ppaddr)(aTHX); } PL_op = oldop; } @@ -2555,7 +2438,7 @@ S_docatch(pTHX_ OP *o) #endif PL_op = o; redo_body: - CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_docatch_body)); + CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_docatch_body)); switch (ret) { case 0: break; @@ -2757,13 +2640,16 @@ S_doeval(pTHX_ int gimme, OP** startop) LEAVE; if (optype == OP_REQUIRE) { char* msg = SvPVx(ERRSV, n_a); - DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require"); - } else if (startop) { + DIE(aTHX_ "%sCompilation failed in require", + *msg ? msg : "Unknown error\n"); + } + else if (startop) { char* msg = SvPVx(ERRSV, n_a); POPBLOCK(cx,PL_curpm); POPEVAL(cx); - Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n")); + Perl_croak(aTHX_ "%sCompilation failed in regexp", + (*msg ? msg : "Unknown error\n")); } SvREFCNT_dec(PL_rs); PL_rs = SvREFCNT_inc(PL_nrs); @@ -2865,6 +2751,10 @@ PP(pp_require) I32 gimme = G_SCALAR; PerlIO *tryrsfp = 0; STRLEN n_a; + int filter_has_file = 0; + GV *filter_child_proc = 0; + SV *filter_state = 0; + SV *filter_sub = 0; sv = POPs; if (SvNIOKp(sv) && !SvPOKp(sv)) { @@ -2913,23 +2803,131 @@ PP(pp_require) { namesv = NEWSV(806, 0); for (i = 0; i <= AvFILL(ar); i++) { - char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a); + SV *dirsv = *av_fetch(ar, i, TRUE); + + if (SvROK(dirsv)) { + int count; + SV *loader = dirsv; + + if (SvTYPE(SvRV(loader)) == SVt_PVAV) { + loader = *av_fetch((AV *)SvRV(loader), 0, TRUE); + } + + Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%lx/%s", + SvANY(loader), name); + tryname = SvPVX(namesv); + tryrsfp = 0; + + ENTER; + SAVETMPS; + EXTEND(SP, 2); + + PUSHMARK(SP); + PUSHs(dirsv); + PUSHs(sv); + PUTBACK; + count = call_sv(loader, G_ARRAY); + SPAGAIN; + + if (count > 0) { + int i = 0; + SV *arg; + + SP -= count - 1; + arg = SP[i++]; + + if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) { + arg = SvRV(arg); + } + + if (SvTYPE(arg) == SVt_PVGV) { + IO *io = GvIO((GV *)arg); + + ++filter_has_file; + + if (io) { + tryrsfp = IoIFP(io); + if (IoTYPE(io) == '|') { + /* reading from a child process doesn't + nest -- when returning from reading + the inner module, the outer one is + unreadable (closed?) I've tried to + save the gv to manage the lifespan of + the pipe, but this didn't help. XXX */ + filter_child_proc = (GV *)arg; + (void)SvREFCNT_inc(filter_child_proc); + } + else { + if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { + PerlIO_close(IoOFP(io)); + } + IoIFP(io) = Nullfp; + IoOFP(io) = Nullfp; + } + } + + if (i < count) { + arg = SP[i++]; + } + } + + if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) { + filter_sub = arg; + (void)SvREFCNT_inc(filter_sub); + + if (i < count) { + filter_state = SP[i]; + (void)SvREFCNT_inc(filter_state); + } + + if (tryrsfp == 0) { + tryrsfp = PerlIO_open("/dev/null", + PERL_SCRIPT_MODE); + } + } + } + + PUTBACK; + FREETMPS; + LEAVE; + + if (tryrsfp) { + break; + } + + filter_has_file = 0; + if (filter_child_proc) { + SvREFCNT_dec(filter_child_proc); + filter_child_proc = 0; + } + if (filter_state) { + SvREFCNT_dec(filter_state); + filter_state = 0; + } + if (filter_sub) { + SvREFCNT_dec(filter_sub); + filter_sub = 0; + } + } + else { + char *dir = SvPVx(dirsv, n_a); #ifdef VMS - char *unixdir; - if ((unixdir = tounixpath(dir, Nullch)) == Nullch) - continue; - sv_setpv(namesv, unixdir); - sv_catpv(namesv, unixname); + char *unixdir; + if ((unixdir = tounixpath(dir, Nullch)) == Nullch) + continue; + sv_setpv(namesv, unixdir); + sv_catpv(namesv, unixname); #else - Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); + Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); #endif - TAINT_PROPER("require"); - tryname = SvPVX(namesv); - tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE); - if (tryrsfp) { - if (tryname[0] == '.' && tryname[1] == '/') - tryname += 2; - break; + TAINT_PROPER("require"); + tryname = SvPVX(namesv); + tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE); + if (tryrsfp) { + if (tryname[0] == '.' && tryname[1] == '/') + tryname += 2; + break; + } } } } @@ -2984,11 +2982,22 @@ PP(pp_require) SAVEHINTS(); PL_hints = 0; SAVEPPTR(PL_compiling.cop_warnings); - PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL - : WARN_NONE); - - /* switch to eval mode */ + if (PL_dowarn & G_WARN_ALL_ON) + PL_compiling.cop_warnings = WARN_ALL ; + else if (PL_dowarn & G_WARN_ALL_OFF) + PL_compiling.cop_warnings = WARN_NONE ; + else + PL_compiling.cop_warnings = WARN_STD ; + + if (filter_sub || filter_child_proc) { + SV *datasv = filter_add(run_user_filter, Nullsv); + IoLINES(datasv) = filter_has_file; + IoFMT_GV(datasv) = (GV *)filter_child_proc; + IoTOP_GV(datasv) = (GV *)filter_state; + IoBOTTOM_GV(datasv) = (GV *)filter_sub; + } + /* switch to eval mode */ push_return(PL_op->op_next); PUSHBLOCK(cx, CXt_EVAL, SP); PUSHEVAL(cx, name, PL_compiling.cop_filegv); @@ -3048,8 +3057,7 @@ PP(pp_entereval) SAVEHINTS(); PL_hints = PL_op->op_targ; SAVEPPTR(PL_compiling.cop_warnings); - if (PL_compiling.cop_warnings != WARN_ALL - && PL_compiling.cop_warnings != WARN_NONE){ + if (!specialWARN(PL_compiling.cop_warnings)) { PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; SAVEFREESV(PL_compiling.cop_warnings) ; } @@ -3500,13 +3508,8 @@ struct partition_stack_entry { /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2 */ -#ifdef PERL_OBJECT #define qsort_cmp(elt1, elt2) \ - ((this->*compare)(array[elt1], array[elt2])) -#else -#define qsort_cmp(elt1, elt2) \ - ((*compare)(aTHX_ array[elt1], array[elt2])) -#endif + ((*compare)(aTHXo_ array[elt1], array[elt2])) #ifdef QSORT_ORDER_GUESS #define QSORT_NOTICE_SWAP swapped++; @@ -4077,3 +4080,237 @@ S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare) /* Believe it or not, the array is sorted at this point! */ } + + +#ifdef PERL_OBJECT +#define NO_XSLOCKS +#undef this +#define this pPerl +#include "XSUB.h" +#endif + + +static I32 +sortcv(pTHXo_ SV *a, SV *b) +{ + dTHR; + 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 +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) +{ + SV *datasv = FILTER_DATA(idx); + int filter_has_file = IoLINES(datasv); + GV *filter_child_proc = (GV *)IoFMT_GV(datasv); + SV *filter_state = (SV *)IoTOP_GV(datasv); + SV *filter_sub = (SV *)IoBOTTOM_GV(datasv); + int len = 0; + + /* I was having segfault trouble under Linux 2.2.5 after a + parse error occured. (Had to hack around it with a test + for PL_error_count == 0.) Solaris doesn't segfault -- + not sure where the trouble is yet. XXX */ + + if (filter_has_file) { + len = FILTER_READ(idx+1, buf_sv, maxlen); + } + + if (filter_sub && len >= 0) { + djSP; + int count; + + ENTER; + SAVE_DEFSV; + SAVETMPS; + EXTEND(SP, 2); + + DEFSV = buf_sv; + PUSHMARK(SP); + PUSHs(sv_2mortal(newSViv(maxlen))); + if (filter_state) { + PUSHs(filter_state); + } + PUTBACK; + count = call_sv(filter_sub, G_SCALAR); + SPAGAIN; + + if (count > 0) { + SV *out = POPs; + if (SvOK(out)) { + len = SvIV(out); + } + } + + PUTBACK; + FREETMPS; + LEAVE; + } + + if (len <= 0) { + IoLINES(datasv) = 0; + if (filter_child_proc) { + SvREFCNT_dec(filter_child_proc); + IoFMT_GV(datasv) = Nullgv; + } + if (filter_state) { + SvREFCNT_dec(filter_state); + IoTOP_GV(datasv) = Nullgv; + } + if (filter_sub) { + SvREFCNT_dec(filter_sub); + IoBOTTOM_GV(datasv) = Nullgv; + } + filter_del(run_user_filter); + } + + 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 */