X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=2d29448e778c16d37861e6e338e0aa170a53cce7;hb=4499d6b9d14594604210bc28005c5e4ab2e49947;hp=af6394d913653ba772f9d2527a5183eacf5fc212;hpb=0453d815b8a74697ff1e5451c27aba2fe537b8e0;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_ctl.c b/pp_ctl.c
index af6394d..2d29448 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -32,6 +32,23 @@
 #define CALLOP *PL_op
 #endif
 
+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
+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
+
 PP(pp_wantarray)
 {
     djSP;
@@ -571,10 +588,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 +772,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 +877,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 +891,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;
@@ -1567,9 +1464,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 +1495,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;
@@ -2555,7 +2431,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;
@@ -2865,6 +2741,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 +2793,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;
+		    }
 		}
 	    }
 	}
@@ -2990,9 +2978,16 @@ PP(pp_require)
         PL_compiling.cop_warnings = WARN_NONE ;
     else 
         PL_compiling.cop_warnings = WARN_STD ;
-    
-    /* switch to eval mode */
 
+    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);
@@ -3503,13 +3498,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++;
@@ -4080,3 +4070,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 */