X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=90c12219f2e8ee9d82e622272608538a5f6fb980;hb=8c99d73ee7ce90de2561496f683f3850d1269e1d;hp=d5c54269458d6c7679b2e4dca251e08aa699f333;hpb=13b3f78704810709000ac835e0f07862c2b103e2;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_sys.c b/pp_sys.c
index d5c5426..90c1221 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -118,20 +118,6 @@ extern int h_errno;
 #   define vfork fork
 #endif
 
-/* Put this after #includes because <unistd.h> defines _XOPEN_*.
- * Sock_size_t is defined identically in doio.c. */
-#ifndef Sock_size_t
-#  ifdef HAS_SOCKLEN_T
-#      define Sock_size_t socklen_t
-#  else
-#      if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
-#          define Sock_size_t Size_t
-#      else
-#          define Sock_size_t int
-#      endif
-#  endif
-#endif
-
 #ifdef HAS_CHSIZE
 # ifdef my_chsize  /* Probably #defined to Perl_my_chsize in embed.h */
 #   undef my_chsize
@@ -318,9 +304,14 @@ PP(pp_backtick)
     STRLEN n_a;
     char *tmps = POPpx;
     I32 gimme = GIMME_V;
+    char *mode = "r";
 
     TAINT_PROPER("``");
-    fp = PerlProc_popen(tmps, "r");
+    if (PL_op->op_private & OPpOPEN_IN_RAW)
+	mode = "rb";
+    else if (PL_op->op_private & OPpOPEN_IN_CRLF)
+	mode = "rt";
+    fp = PerlProc_popen(tmps, mode);
     if (fp) {
 	if (gimme == G_VOID) {
 	    char tmpbuf[256];
@@ -370,6 +361,10 @@ PP(pp_glob)
     OP *result;
     tryAMAGICunTARGET(iter, -1);
 
+    /* Note that we only ever get here if File::Glob fails to load
+     * without at the same time croaking, for some reason, or if
+     * perl was built with PERL_EXTERNAL_GLOB */
+
     ENTER;
 
 #ifndef VMS
@@ -531,7 +526,7 @@ PP(pp_open)
     if (GvIOp(gv))
 	IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
 
-    if (mg = SvTIED_mg((SV*)gv, 'q')) {
+    if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
 	PUSHMARK(SP);
 	XPUSHs(SvTIED_obj((SV*)gv, mg));
 	XPUSHs(sv);
@@ -566,7 +561,7 @@ PP(pp_close)
     else
 	gv = (GV*)POPs;
 
-    if (mg = SvTIED_mg((SV*)gv, 'q')) {
+    if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
 	PUSHMARK(SP);
 	XPUSHs(SvTIED_obj((SV*)gv, mg));
 	PUTBACK;
@@ -697,15 +692,20 @@ PP(pp_binmode)
     IO *io;
     PerlIO *fp;
     MAGIC *mg;
+    SV *discp = Nullsv;
 
     if (MAXARG < 1)
 	RETPUSHUNDEF;
+    if (MAXARG > 1)
+	discp = POPs;
 
     gv = (GV*)POPs; 
 
     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
 	PUSHMARK(SP);
 	XPUSHs(SvTIED_obj((SV*)gv, mg));
+	if (discp)
+	    XPUSHs(discp);
 	PUTBACK;
 	ENTER;
 	call_method("BINMODE", G_SCALAR);
@@ -718,13 +718,12 @@ PP(pp_binmode)
     if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
 	RETPUSHUNDEF;
 
-    if (do_binmode(fp,IoTYPE(io),TRUE)) 
+    if (do_binmode(fp,IoTYPE(io),mode_from_discipline(discp))) 
 	RETPUSHYES;
     else
 	RETPUSHUNDEF;
 }
 
-
 PP(pp_tie)
 {
     djSP;
@@ -807,7 +806,7 @@ PP(pp_untie)
 
     if (ckWARN(WARN_UNTIE)) {
         MAGIC * mg ;
-        if (mg = SvTIED_mg(sv, how)) {
+        if ((mg = SvTIED_mg(sv, how))) {
             if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)  
 		Perl_warner(aTHX_ WARN_UNTIE,
 		    "untie attempted while %"UVuf" inner references still exist",
@@ -826,7 +825,7 @@ PP(pp_tied)
     char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
     MAGIC *mg;
 
-    if (mg = SvTIED_mg(sv, how)) {
+    if ((mg = SvTIED_mg(sv, how))) {
 	SV *osv = SvTIED_obj(sv, mg);
 	if (osv == mg->mg_obj)
 	    osv = sv_mortalcopy(osv);
@@ -942,7 +941,7 @@ PP(pp_sselect)
     /* If SELECT_MIN_BITS is greater than one we most probably will want
      * to align the sizes with SELECT_MIN_BITS/8 because for example
      * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
-     * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
+     * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
      * on (sets/tests/clears bits) is 32 bits.  */
     growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
 #  else
@@ -1090,12 +1089,12 @@ PP(pp_getc)
     GV *gv;
     MAGIC *mg;
 
-    if (MAXARG <= 0)
+    if (MAXARG == 0)
 	gv = PL_stdingv;
     else
 	gv = (GV*)POPs;
 
-    if (mg = SvTIED_mg((SV*)gv, 'q')) {
+    if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
 	I32 gimme = GIMME_V;
 	PUSHMARK(SP);
 	XPUSHs(SvTIED_obj((SV*)gv, mg));
@@ -1319,7 +1318,7 @@ PP(pp_prtf)
     else
 	gv = PL_defoutgv;
 
-    if (mg = SvTIED_mg((SV*)gv, 'q')) {
+    if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
 	if (MARK == ORIGMARK) {
 	    MEXTEND(SP, 1);
 	    ++MARK;
@@ -1589,10 +1588,11 @@ PP(pp_send)
     djSP; dMARK; dORIGMARK; dTARGET;
     GV *gv;
     IO *io;
-    Off_t offset;
     SV *bufsv;
     char *buffer;
-    Off_t length;
+    Size_t length;
+    SSize_t retval;
+    IV offset;
     STRLEN blen;
     MAGIC *mg;
 
@@ -1615,17 +1615,17 @@ PP(pp_send)
 	goto say_undef;
     bufsv = *++MARK;
     buffer = SvPV(bufsv, blen);
-#if Off_t_SIZE > IVSIZE
+#if Size_t_size > IVSIZE
     length = SvNVx(*++MARK);
 #else
     length = SvIVx(*++MARK);
 #endif
-    if (length < 0)
+    if ((Size_t)length < 0)
 	DIE(aTHX_ "Negative length");
     SETERRNO(0,0);
     io = GvIO(gv);
     if (!io || !IoIFP(io)) {
-	length = -1;
+	retval = -1;
 	if (ckWARN(WARN_CLOSED)) {
 	    if (PL_op->op_type == OP_SYSWRITE)
 		report_closed_fh(gv, io, "syswrite", "filehandle");
@@ -1635,11 +1635,7 @@ PP(pp_send)
     }
     else if (PL_op->op_type == OP_SYSWRITE) {
 	if (MARK < SP) {
-#if Off_t_SIZE > IVSIZE
-	    offset = SvNVx(*++MARK);
-#else
 	    offset = SvIVx(*++MARK);
-#endif
 	    if (offset < 0) {
 		if (-offset > blen)
 		    DIE(aTHX_ "Offset outside string");
@@ -1652,14 +1648,14 @@ PP(pp_send)
 	    length = blen - offset;
 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
 	if (IoTYPE(io) == 's') {
-	    length = PerlSock_send(PerlIO_fileno(IoIFP(io)),
+	    retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
 				   buffer+offset, length, 0);
 	}
 	else
 #endif
 	{
 	    /* See the note at doio.c:do_print about filesize limits. --jhi */
-	    length = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
+	    retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
 				   buffer+offset, length);
 	}
     }
@@ -1668,20 +1664,24 @@ PP(pp_send)
 	char *sockbuf;
 	STRLEN mlen;
 	sockbuf = SvPVx(*++MARK, mlen);
-	length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
-				(struct sockaddr *)sockbuf, mlen);
+	retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
+				 length, (struct sockaddr *)sockbuf, mlen);
     }
     else
-	length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
+	retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
 
 #else
     else
 	DIE(aTHX_ PL_no_sock_func, "send");
 #endif
-    if (length < 0)
+    if (retval < 0)
 	goto say_undef;
     SP = ORIGMARK;
-    PUSHi(length);
+#if Size_t_size > IVSIZE
+    PUSHn(retval);
+#else
+    PUSHi(retval);
+#endif
     RETURN;
 
   say_undef:
@@ -1700,7 +1700,7 @@ PP(pp_eof)
     GV *gv;
     MAGIC *mg;
 
-    if (MAXARG <= 0) {
+    if (MAXARG == 0) {
 	if (PL_op->op_flags & OPf_SPECIAL) {	/* eof() */
 	    IO *io;
 	    gv = PL_last_in_gv = PL_argvgv;
@@ -1744,7 +1744,7 @@ PP(pp_tell)
     GV *gv;     
     MAGIC *mg;
 
-    if (MAXARG <= 0)
+    if (MAXARG == 0)
 	gv = PL_last_in_gv;
     else
 	gv = PL_last_in_gv = (GV*)POPs;
@@ -1827,11 +1827,24 @@ PP(pp_sysseek)
 PP(pp_truncate)
 {
     djSP;
-    Off_t len = (Off_t)POPn;
+    /* There seems to be no consensus on the length type of truncate()
+     * and ftruncate(), both off_t and size_t have supporters. In
+     * general one would think that when using large files, off_t is
+     * at least as wide as size_t, so using an off_t should be okay. */
+    /* XXX Configure probe for the length type of *truncate() needed XXX */
+    Off_t len;
     int result = 1;
     GV *tmpgv;
     STRLEN n_a;
 
+#if Size_t_size > IVSIZE
+    len = (Off_t)POPn;
+#else
+    len = (Off_t)POPi;
+#endif
+    /* Checking for length < 0 is problematic as the type might or
+     * might not be signed: if it is not, clever compilers will moan. */ 
+    /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
     SETERRNO(0,0);
 #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
     if (PL_op->op_flags & OPf_SPECIAL) {
@@ -1979,7 +1992,7 @@ PP(pp_flock)
 
 #ifdef FLOCK
     argtype = POPi;
-    if (MAXARG <= 0)
+    if (MAXARG == 0)
 	gv = PL_last_in_gv;
     else
 	gv = (GV*)POPs;
@@ -3088,9 +3101,26 @@ PP(pp_fttext)
 #else
 	else if (*s & 128) {
 #ifdef USE_LOCALE
-	    if (!(PL_op->op_private & OPpLOCALE) || !isALPHA_LC(*s))
-#endif
-		odd++;
+	    if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s))
+		continue;
+#endif
+	    /* utf8 characters don't count as odd */
+	    if (*s & 0x40) {
+		int ulen = UTF8SKIP(s);
+		if (ulen < len - i) {
+		    int j;
+		    for (j = 1; j < ulen; j++) {
+			if ((s[j] & 0xc0) != 0x80)
+			    goto not_utf8;
+		    }
+		    --ulen;	/* loop does extra increment */
+		    s += ulen;
+		    i += ulen;
+		    continue;
+		}
+	    }
+	  not_utf8:
+	    odd++;
 	}
 	else if (*s < 32 &&
 	  *s != '\n' && *s != '\r' && *s != '\b' &&
@@ -3469,14 +3499,15 @@ PP(pp_readdir)
 
     if (GIMME == G_ARRAY) {
 	/*SUPPRESS 560*/
-	while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
+	while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
 #ifdef DIRNAMLEN
 	    sv = newSVpvn(dp->d_name, dp->d_namlen);
 #else
 	    sv = newSVpv(dp->d_name, 0);
 #endif
 #ifndef INCOMPLETE_TAINTS
-  	    SvTAINTED_on(sv);
+	    if (!(IoFLAGS(io) & IOf_UNTAINT))
+		SvTAINTED_on(sv);
 #endif
 	    XPUSHs(sv_2mortal(sv));
 	}
@@ -3490,7 +3521,8 @@ PP(pp_readdir)
 	sv = newSVpv(dp->d_name, 0);
 #endif
 #ifndef INCOMPLETE_TAINTS
-	SvTAINTED_on(sv);
+	if (!(IoFLAGS(io) & IOf_UNTAINT))
+	    SvTAINTED_on(sv);
 #endif
 	XPUSHs(sv_2mortal(sv));
     }
@@ -3626,7 +3658,7 @@ PP(pp_fork)
 	RETSETUNDEF;
     if (!childpid) {
 	/*SUPPRESS 560*/
-	if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
+	if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
 	    sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
 	hv_clear(PL_pidstatus);	/* no kids, so don't wait for 'em */
     }
@@ -4043,7 +4075,6 @@ PP(pp_gmtime)
     EXTEND(SP, 9);
     EXTEND_MORTAL(9);
     if (GIMME != G_ARRAY) {
-	dTARGET;
 	SV *tsv;
 	if (!tmbuf)
 	    RETPUSHUNDEF;
@@ -4728,7 +4759,7 @@ PP(pp_gpwuid)
 PP(pp_gpwent)
 {
     djSP;
-#if defined(HAS_PASSWD) && defined(HAS_GETPWENT)
+#ifdef HAS_PASSWD
     I32 which = PL_op->op_type;
     register SV *sv;
     struct passwd *pwent;
@@ -4742,7 +4773,11 @@ PP(pp_gpwent)
     else if (which == OP_GPWUID)
 	pwent = getpwuid(POPi);
     else
+#ifdef HAS_GETPWENT
 	pwent = (struct passwd *)getpwent();
+#else
+	DIE(aTHX_ PL_no_func, "getpwent");
+#endif
 
 #ifdef HAS_GETSPNAM
     if (which == OP_GPWNAM) {
@@ -4894,7 +4929,7 @@ PP(pp_ggrgid)
 PP(pp_ggrent)
 {
     djSP;
-#if defined(HAS_GROUP) && defined(HAS_GETGRENT)
+#ifdef HAS_GROUP
     I32 which = PL_op->op_type;
     register char **elem;
     register SV *sv;
@@ -4906,7 +4941,11 @@ PP(pp_ggrent)
     else if (which == OP_GGRGID)
 	grent = (struct group *)getgrgid(POPi);
     else
+#ifdef HAS_GETGRENT
 	grent = (struct group *)getgrent();
+#else
+        DIE(aTHX_ PL_no_func, "getgrent");
+#endif
 
     EXTEND(SP, 4);
     if (GIMME != G_ARRAY) {
@@ -4993,7 +5032,6 @@ PP(pp_syscall)
     unsigned long a[20];
     register I32 i = 0;
     I32 retval = -1;
-    MAGIC *mg;
     STRLEN n_a;
 
     if (PL_tainting) {