X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=90c12219f2e8ee9d82e622272608538a5f6fb980;hb=8c99d73ee7ce90de2561496f683f3850d1269e1d;hp=6fa9c10eac9d44999d412578882f09c0513c42f3;hpb=2841d78411ddadd05a6fbe13e0be06f765fad3fb;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index 6fa9c10..90c1221 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -304,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]; @@ -356,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 @@ -517,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); @@ -552,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; @@ -683,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); @@ -704,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; @@ -793,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", @@ -812,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); @@ -1081,7 +1094,7 @@ PP(pp_getc) 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)); @@ -1305,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; @@ -1575,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; @@ -1601,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"); @@ -1621,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"); @@ -1638,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); } } @@ -1654,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: @@ -1813,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) { @@ -3074,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' && @@ -3455,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)); } @@ -3476,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)); } @@ -3612,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 */ } @@ -4029,7 +4075,6 @@ PP(pp_gmtime) EXTEND(SP, 9); EXTEND_MORTAL(9); if (GIMME != G_ARRAY) { - dTARGET; SV *tsv; if (!tmbuf) RETPUSHUNDEF; @@ -4987,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) {