X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f4a7049d1e66956838433895a259b4fb84d25493..866c78d1cf6feeffe34601c244c137d8b30ec2e4:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index 5c9bfea..6aa8645 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -1,7 +1,7 @@ /* pp_sys.c * - * Copyright (C) 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, + * 2004, 2005, 2006, 2007 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -297,22 +297,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) return res; } -# define PERL_EFF_ACCESS(p,f) (emulate_eaccess((p), (f))) -#endif - -#if !defined(PERL_EFF_ACCESS) -/* With it or without it: anyway you get a warning: either that - it is unused, or it is declared static and never defined. - */ -STATIC int -S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) -{ - PERL_UNUSED_ARG(path); - PERL_UNUSED_ARG(mode); - Perl_croak(aTHX_ "switching effective uid is not implemented"); - /*NOTREACHED*/ - return -1; -} +# define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f))) #endif PP(pp_backtick) @@ -330,14 +315,14 @@ PP(pp_backtick) mode = "rt"; fp = PerlProc_popen(tmps, mode); if (fp) { - const char * const type = PL_curcop->cop_io ? SvPV_nolen_const(PL_curcop->cop_io) : NULL; + const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL); if (type && *type) PerlIO_apply_layers(aTHX_ fp,mode,type); if (gimme == G_VOID) { char tmpbuf[256]; while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0) - ; + NOOP; } else if (gimme == G_SCALAR) { ENTER; @@ -345,7 +330,7 @@ PP(pp_backtick) PL_rs = &PL_sv_undef; sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */ while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL) - ; + NOOP; LEAVE; XPUSHs(TARG); SvTAINTED_on(TARG); @@ -437,6 +422,7 @@ PP(pp_warn) else if (SP == MARK) { tmpsv = &PL_sv_no; EXTEND(SP, 1); + SP = MARK + 1; } else { tmpsv = TOPs; @@ -453,7 +439,7 @@ PP(pp_warn) if (!tmps || !len) tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong")); - Perl_warn(aTHX_ "%"SVf, tmpsv); + Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv)); RETSETYES; } @@ -477,7 +463,7 @@ PP(pp_die) } else { tmpsv = TOPs; - tmps = SvROK(tmpsv) ? NULL : SvPV_const(tmpsv, len); + tmps = SvROK(tmpsv) ? (const char *)NULL : SvPV_const(tmpsv, len); } if (!tmps || !len) { SV * const error = ERRSV; @@ -517,7 +503,7 @@ PP(pp_die) if (!tmps || !len) tmpsv = sv_2mortal(newSVpvs("Died")); - DIE(aTHX_ "%"SVf, tmpsv); + DIE(aTHX_ "%"SVf, SVfARG(tmpsv)); } /* I/O. */ @@ -537,11 +523,16 @@ PP(pp_open) if (!isGV(gv)) DIE(aTHX_ PL_no_usym, "filehandle"); - if ((io = GvIOp(gv))) + + if ((io = GvIOp(gv))) { + MAGIC *mg; IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; - if (io) { - MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar); + if (IoDIRP(io) && ckWARN2(WARN_IO, WARN_DEPRECATED)) + Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), + "Opening dirhandle %s also as a file", GvENAME(gv)); + + mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar); if (mg) { /* Method's args are same as ours ... */ /* ... except handle is replaced by the object */ @@ -578,21 +569,23 @@ PP(pp_open) PP(pp_close) { dVAR; dSP; - IO *io; - MAGIC *mg; GV * const gv = (MAXARG == 0) ? PL_defoutgv : (GV*)POPs; - if (gv && (io = GvIO(gv)) - && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) - { - PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)io, mg)); - PUTBACK; - ENTER; - call_method("CLOSE", G_SCALAR); - LEAVE; - SPAGAIN; - RETURN; + if (gv) { + IO * const io = GvIO(gv); + if (io) { + MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar); + if (mg) { + PUSHMARK(SP); + XPUSHs(SvTIED_obj((SV*)io, mg)); + PUTBACK; + ENTER; + call_method("CLOSE", G_SCALAR); + LEAVE; + SPAGAIN; + RETURN; + } + } } EXTEND(SP, 1); PUSHs(boolSV(do_close(gv, TRUE))); @@ -635,10 +628,14 @@ PP(pp_pipe_op) IoTYPE(wstio) = IoTYPE_WRONLY; if (!IoIFP(rstio) || !IoOFP(wstio)) { - if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio)); - else PerlLIO_close(fd[0]); - if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio)); - else PerlLIO_close(fd[1]); + if (IoIFP(rstio)) + PerlIO_close(IoIFP(rstio)); + else + PerlLIO_close(fd[0]); + if (IoOFP(wstio)) + PerlIO_close(IoOFP(wstio)); + else + PerlLIO_close(fd[1]); goto badexit; } #if defined(HAS_FCNTL) && defined(F_SETFD) @@ -701,8 +698,12 @@ PP(pp_umask) Mode_t anum; if (MAXARG < 1) { - anum = PerlLIO_umask(0); - (void)PerlLIO_umask(anum); + anum = PerlLIO_umask(022); + /* setting it to 022 between the two calls to umask avoids + * to have a window where the umask is set to 0 -- meaning + * that another thread could create world-writeable files. */ + if (anum != 022) + (void)PerlLIO_umask(anum); } else anum = PerlLIO_umask(POPi); @@ -725,7 +726,6 @@ PP(pp_binmode) GV *gv; IO *io; PerlIO *fp; - MAGIC *mg; SV *discp = NULL; if (MAXARG < 1) @@ -736,19 +736,20 @@ PP(pp_binmode) gv = (GV*)POPs; - if (gv && (io = GvIO(gv)) - && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) - { - PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)io, mg)); - if (discp) - XPUSHs(discp); - PUTBACK; - ENTER; - call_method("BINMODE", G_SCALAR); - LEAVE; - SPAGAIN; - RETURN; + if (gv && (io = GvIO(gv))) { + MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar); + if (mg) { + PUSHMARK(SP); + XPUSHs(SvTIED_obj((SV*)io, mg)); + if (discp) + XPUSHs(discp); + PUTBACK; + ENTER; + call_method("BINMODE", G_SCALAR); + LEAVE; + SPAGAIN; + RETURN; + } } EXTEND(SP, 1); @@ -760,22 +761,23 @@ PP(pp_binmode) } PUTBACK; - if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp), - (discp) ? SvPV_nolen_const(discp) : NULL)) { - if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { - if (!PerlIO_binmode(aTHX_ IoOFP(io),IoTYPE(io), - mode_from_discipline(discp), - (discp) ? SvPV_nolen_const(discp) : NULL)) { - SPAGAIN; - RETPUSHUNDEF; - } + { + const int mode = mode_from_discipline(discp); + const char *const d = (discp ? SvPV_nolen_const(discp) : NULL); + if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) { + if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { + if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) { + SPAGAIN; + RETPUSHUNDEF; + } + } + SPAGAIN; + RETPUSHYES; + } + else { + SPAGAIN; + RETPUSHUNDEF; } - SPAGAIN; - RETPUSHYES; - } - else { - SPAGAIN; - RETPUSHUNDEF; } } @@ -833,10 +835,10 @@ PP(pp_tie) /* Not clear why we don't call call_method here too. * perhaps to get different error message ? */ - stash = gv_stashsv(*MARK, FALSE); + stash = gv_stashsv(*MARK, 0); if (!stash || !(gv = gv_fetchmethod(stash, methname))) { DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"", - methname, *MARK); + methname, SVfARG(*MARK)); } ENTER; PUSHSTACKi(PERLSI_MAGIC); @@ -935,7 +937,7 @@ PP(pp_dbmopen) HV * const hv = (HV*)POPs; SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File")); - stash = gv_stashsv(sv, FALSE); + stash = gv_stashsv(sv, 0); if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) { PUTBACK; require_pv("AnyDBM_File.pm"); @@ -1157,7 +1159,7 @@ PP(pp_select) { dVAR; dSP; dTARGET; HV *hv; - GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL; + GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL; GV * egv = GvEGV(PL_defoutgv); if (!egv) @@ -1189,23 +1191,23 @@ PP(pp_getc) { dVAR; dSP; dTARGET; IO *io = NULL; - MAGIC *mg; GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs; - if (gv && (io = GvIO(gv)) - && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) - { - const I32 gimme = GIMME_V; - PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)io, mg)); - PUTBACK; - ENTER; - call_method("GETC", gimme); - LEAVE; - SPAGAIN; - if (gimme == G_SCALAR) - SvSetMagicSV_nosteal(TARG, TOPs); - RETURN; + if (gv && (io = GvIO(gv))) { + MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar); + if (mg) { + const I32 gimme = GIMME_V; + PUSHMARK(SP); + XPUSHs(SvTIED_obj((SV*)io, mg)); + PUTBACK; + ENTER; + call_method("GETC", gimme); + LEAVE; + SPAGAIN; + if (gimme == G_SCALAR) + SvSetMagicSV_nosteal(TARG, TOPs); + RETURN; + } } if (!gv || do_eof(gv)) { /* make sure we have fp with something */ if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY)) @@ -1259,6 +1261,7 @@ PP(pp_enterwrite) register IO *io; GV *fgv; CV *cv; + SV * tmpsv = NULL; if (MAXARG == 0) gv = PL_defoutgv; @@ -1277,17 +1280,19 @@ PP(pp_enterwrite) else fgv = gv; - if (!fgv) { - DIE(aTHX_ "Not a format reference"); - } + if (!fgv) + goto not_a_format_reference; + cv = GvFORM(fgv); if (!cv) { - SV * const tmpsv = sv_newmortal(); const char *name; + tmpsv = sv_newmortal(); gv_efullname4(tmpsv, fgv, NULL, FALSE); name = SvPV_nolen_const(tmpsv); if (name && *name) DIE(aTHX_ "Undefined format \"%s\" called", name); + + not_a_format_reference: DIE(aTHX_ "Not a format reference"); } if (CvCLONE(cv)) @@ -1431,30 +1436,30 @@ PP(pp_prtf) IO *io; PerlIO *fp; SV *sv; - MAGIC *mg; GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv; - if (gv && (io = GvIO(gv)) - && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) - { - if (MARK == ORIGMARK) { - MEXTEND(SP, 1); - ++MARK; - Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); - ++SP; + if (gv && (io = GvIO(gv))) { + MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar); + if (mg) { + if (MARK == ORIGMARK) { + MEXTEND(SP, 1); + ++MARK; + Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); + ++SP; + } + PUSHMARK(MARK - 1); + *MARK = SvTIED_obj((SV*)io, mg); + PUTBACK; + ENTER; + call_method("PRINTF", G_SCALAR); + LEAVE; + SPAGAIN; + MARK = ORIGMARK + 1; + *MARK = *SP; + SP = MARK; + RETURN; } - PUSHMARK(MARK - 1); - *MARK = SvTIED_obj((SV*)io, mg); - PUTBACK; - ENTER; - call_method("PRINTF", G_SCALAR); - LEAVE; - SPAGAIN; - MARK = ORIGMARK + 1; - *MARK = *SP; - SP = MARK; - RETURN; } sv = newSV(0); @@ -1475,6 +1480,8 @@ PP(pp_prtf) goto just_say_no; } else { + if (SvTAINTED(MARK[1])) + TAINT_PROPER("printf"); do_sprintf(sv, SP - MARK, MARK + 1); if (!do_print(sv, fp)) goto just_say_no; @@ -1609,7 +1616,7 @@ PP(pp_sysread) buffer = SvGROW(bufsv, (STRLEN)(length+1)); /* 'offset' means 'flags' here */ count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset, - (struct sockaddr *)namebuf, &bufsize); + (struct sockaddr *)namebuf, &bufsize); if (count < 0) RETPUSHUNDEF; #ifdef EPOC @@ -1777,102 +1784,163 @@ PP(pp_send) IO *io; SV *bufsv; const char *buffer; - Size_t length = 0; SSize_t retval; STRLEN blen; - MAGIC *mg; + STRLEN orig_blen_bytes; const int op_type = PL_op->op_type; + bool doing_utf8; + U8 *tmpbuf = NULL; GV *const gv = (GV*)*++MARK; if (PL_op->op_type == OP_SYSWRITE - && gv && (io = GvIO(gv)) - && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) - { - SV *sv; + && gv && (io = GvIO(gv))) { + MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar); + if (mg) { + SV *sv; + + if (MARK == SP - 1) { + EXTEND(SP, 1000); + sv = sv_2mortal(newSViv(sv_len(*SP))); + PUSHs(sv); + PUTBACK; + } - if (MARK == SP - 1) { - EXTEND(SP, 1000); - sv = sv_2mortal(newSViv(sv_len(*SP))); + PUSHMARK(ORIGMARK); + *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg); + ENTER; + call_method("WRITE", G_SCALAR); + LEAVE; + SPAGAIN; + sv = POPs; + SP = ORIGMARK; PUSHs(sv); - PUTBACK; + RETURN; } - - PUSHMARK(ORIGMARK); - *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg); - ENTER; - call_method("WRITE", G_SCALAR); - LEAVE; - SPAGAIN; - sv = POPs; - SP = ORIGMARK; - PUSHs(sv); - RETURN; } if (!gv) goto say_undef; bufsv = *++MARK; - if (op_type == OP_SYSWRITE) { - if (MARK >= SP) { - length = (Size_t) sv_len(bufsv); - } else { -#if Size_t_size > IVSIZE - length = (Size_t)SvNVx(*++MARK); -#else - length = (Size_t)SvIVx(*++MARK); -#endif - if ((SSize_t)length < 0) - DIE(aTHX_ "Negative length"); - } - } SETERRNO(0,0); io = GvIO(gv); - if (!io || !IoIFP(io)) { + if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) { retval = -1; - if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) { + if (io && IoIFP(io)) + report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); + else + report_evil_fh(gv, io, PL_op->op_type); + } SETERRNO(EBADF,RMS_IFI); goto say_undef; } + /* Do this first to trigger any overloading. */ + buffer = SvPV_const(bufsv, blen); + orig_blen_bytes = blen; + doing_utf8 = DO_UTF8(bufsv); + if (PerlIO_isutf8(IoIFP(io))) { if (!SvUTF8(bufsv)) { - bufsv = sv_2mortal(newSVsv(bufsv)); - buffer = sv_2pvutf8(bufsv, &blen); - } else - buffer = SvPV_const(bufsv, blen); + /* We don't modify the original scalar. */ + tmpbuf = bytes_to_utf8((const U8*) buffer, &blen); + buffer = (char *) tmpbuf; + doing_utf8 = TRUE; + } } - else { - if (DO_UTF8(bufsv)) { - /* Not modifying source SV, so making a temporary copy. */ - bufsv = sv_2mortal(newSVsv(bufsv)); - sv_utf8_downgrade(bufsv, FALSE); - } - buffer = SvPV_const(bufsv, blen); + else if (doing_utf8) { + STRLEN tmplen = blen; + U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8); + if (!doing_utf8) { + tmpbuf = result; + buffer = (char *) tmpbuf; + blen = tmplen; + } + else { + assert((char *)result == buffer); + Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op)); + } } if (op_type == OP_SYSWRITE) { + Size_t length = 0; /* This length is in characters. */ + STRLEN blen_chars; IV offset; - if (DO_UTF8(bufsv)) { - /* length and offset are in chars */ - blen = sv_len_utf8(bufsv); + + if (doing_utf8) { + if (tmpbuf) { + /* The SV is bytes, and we've had to upgrade it. */ + blen_chars = orig_blen_bytes; + } else { + /* The SV really is UTF-8. */ + if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) { + /* Don't call sv_len_utf8 again because it will call magic + or overloading a second time, and we might get back a + different result. */ + blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen); + } else { + /* It's safe, and it may well be cached. */ + blen_chars = sv_len_utf8(bufsv); + } + } + } else { + blen_chars = blen; + } + + if (MARK >= SP) { + length = blen_chars; + } else { +#if Size_t_size > IVSIZE + length = (Size_t)SvNVx(*++MARK); +#else + length = (Size_t)SvIVx(*++MARK); +#endif + if ((SSize_t)length < 0) { + Safefree(tmpbuf); + DIE(aTHX_ "Negative length"); + } } + if (MARK < SP) { offset = SvIVx(*++MARK); if (offset < 0) { - if (-offset > (IV)blen) + if (-offset > (IV)blen_chars) { + Safefree(tmpbuf); DIE(aTHX_ "Offset outside string"); - offset += blen; - } else if (offset >= (IV)blen && blen > 0) + } + offset += blen_chars; + } else if (offset >= (IV)blen_chars && blen_chars > 0) { + Safefree(tmpbuf); DIE(aTHX_ "Offset outside string"); + } } else offset = 0; - if (length > blen - offset) - length = blen - offset; - if (DO_UTF8(bufsv)) { - buffer = (const char*)utf8_hop((const U8 *)buffer, offset); - length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer; + if (length > blen_chars - offset) + length = blen_chars - offset; + if (doing_utf8) { + /* Here we convert length from characters to bytes. */ + if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) { + /* Either we had to convert the SV, or the SV is magical, or + the SV has overloading, in which case we can't or mustn't + or mustn't call it again. */ + + buffer = (const char*)utf8_hop((const U8 *)buffer, offset); + length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer; + } else { + /* It's a real UTF-8 SV, and it's not going to change under + us. Take advantage of any cache. */ + I32 start = offset; + I32 len_I32 = length; + + /* Convert the start and end character positions to bytes. + Remember that the second argument to sv_pos_u2b is relative + to the first. */ + sv_pos_u2b(bufsv, &start, &len_I32); + + buffer += start; + length = len_I32; + } } else { buffer = buffer+offset; @@ -1908,11 +1976,14 @@ PP(pp_send) else DIE(aTHX_ PL_no_sock_func, "send"); #endif + if (retval < 0) goto say_undef; SP = ORIGMARK; - if (DO_UTF8(bufsv)) + if (doing_utf8) retval = utf8_length((U8*)buffer, (U8*)buffer + retval); + + Safefree(tmpbuf); #if Size_t_size > IVSIZE PUSHn(retval); #else @@ -1921,6 +1992,7 @@ PP(pp_send) RETURN; say_undef: + Safefree(tmpbuf); SP = ORIGMARK; RETPUSHUNDEF; } @@ -1940,7 +2012,12 @@ PP(pp_eof) IoLINES(io) = 0; IoFLAGS(io) &= ~IOf_START; do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL); - sv_setpvn(GvSV(gv), "-", 1); + if ( GvSV(gv) ) { + sv_setpvn(GvSV(gv), "-", 1); + } + else { + GvSV(gv) = newSVpvn("-", 1); + } SvSETMAGIC(GvSV(gv)); } else if (!nextargv(gv)) @@ -1977,23 +2054,23 @@ PP(pp_tell) dVAR; dSP; dTARGET; GV *gv; IO *io; - MAGIC *mg; if (MAXARG != 0) PL_last_in_gv = (GV*)POPs; gv = PL_last_in_gv; - if (gv && (io = GvIO(gv)) - && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) - { - PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)io, mg)); - PUTBACK; - ENTER; - call_method("TELL", G_SCALAR); - LEAVE; - SPAGAIN; - RETURN; + if (gv && (io = GvIO(gv))) { + MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar); + if (mg) { + PUSHMARK(SP); + XPUSHs(SvTIED_obj((SV*)io, mg)); + PUTBACK; + ENTER; + call_method("TELL", G_SCALAR); + LEAVE; + SPAGAIN; + RETURN; + } } #if LSEEKSIZE > IVSIZE @@ -2007,34 +2084,34 @@ PP(pp_tell) PP(pp_sysseek) { dVAR; dSP; - IO *io; const int whence = POPi; #if LSEEKSIZE > IVSIZE const Off_t offset = (Off_t)SvNVx(POPs); #else const Off_t offset = (Off_t)SvIVx(POPs); #endif - MAGIC *mg; GV * const gv = PL_last_in_gv = (GV*)POPs; + IO *io; - if (gv && (io = GvIO(gv)) - && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) - { - PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)io, mg)); + if (gv && (io = GvIO(gv))) { + MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar); + if (mg) { + PUSHMARK(SP); + XPUSHs(SvTIED_obj((SV*)io, mg)); #if LSEEKSIZE > IVSIZE - XPUSHs(sv_2mortal(newSVnv((NV) offset))); + XPUSHs(sv_2mortal(newSVnv((NV) offset))); #else - XPUSHs(sv_2mortal(newSViv(offset))); + XPUSHs(sv_2mortal(newSViv(offset))); #endif - XPUSHs(sv_2mortal(newSViv(whence))); - PUTBACK; - ENTER; - call_method("SEEK", G_SCALAR); - LEAVE; - SPAGAIN; - RETURN; + XPUSHs(sv_2mortal(newSViv(whence))); + PUTBACK; + ENTER; + call_method("SEEK", G_SCALAR); + LEAVE; + SPAGAIN; + RETURN; + } } if (PL_op->op_type == OP_SEEK) @@ -2384,19 +2461,13 @@ PP(pp_bind) GV * const gv = (GV*)POPs; register IO * const io = GvIOn(gv); STRLEN len; - int bind_ok = 0; if (!io || !IoIFP(io)) goto nuts; addr = SvPV_const(addrsv, len); TAINT_PROPER("bind"); - if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), - (struct sockaddr *)addr, len) >= 0) - bind_ok = 1; - - - if (bind_ok) + if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) RETPUSHYES; else RETPUSHUNDEF; @@ -2494,6 +2565,17 @@ PP(pp_accept) nstio = GvIOn(ngv); fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len); +#if defined(OEMVS) + if (len == 0) { + /* Some platforms indicate zero length when an AF_UNIX client is + * not bound. Simulate a non-zero-length sockaddr structure in + * this case. */ + namebuf[0] = 0; /* sun_len */ + namebuf[1] = AF_UNIX; /* sun_family */ + len = 2; + } +#endif + if (fd < 0) goto badexit; if (IoIFP(nstio)) @@ -2706,7 +2788,8 @@ PP(pp_stat) { dVAR; dSP; - GV *gv; + GV *gv = NULL; + IO *io; I32 gimme; I32 max = 13; @@ -2717,7 +2800,7 @@ PP(pp_stat) do_fstat_warning_check: if (ckWARN(WARN_IO)) Perl_warner(aTHX_ packWARN(WARN_IO), - "lstat() on filehandle %s", GvENAME(gv)); + "lstat() on filehandle %s", gv ? GvENAME(gv) : ""); } else if (PL_laststype != OP_LSTAT) Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat"); } @@ -2727,9 +2810,23 @@ PP(pp_stat) PL_laststype = OP_STAT; PL_statgv = gv; sv_setpvn(PL_statname, "", 0); - PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv)) - ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1); - } + if(gv) { + io = GvIO(gv); + do_fstat_have_io: + if (io) { + if (IoIFP(io)) { + PL_laststatval = + PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache); + } else if (IoDIRP(io)) { + PL_laststatval = + PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache); + } else { + PL_laststatval = -1; + } + } + } + } + if (PL_laststatval < 0) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, GvIO(gv), PL_op->op_type); @@ -2741,13 +2838,18 @@ PP(pp_stat) if (SvTYPE(sv) == SVt_PVGV) { gv = (GV*)sv; goto do_fstat; - } - else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { - gv = (GV*)SvRV(sv); - if (PL_op->op_type == OP_LSTAT) - goto do_fstat_warning_check; - goto do_fstat; - } + } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { + gv = (GV*)SvRV(sv); + if (PL_op->op_type == OP_LSTAT) + goto do_fstat_warning_check; + goto do_fstat; + } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { + io = (IO*)SvRV(sv); + if (PL_op->op_type == OP_LSTAT) + goto do_fstat_warning_check; + goto do_fstat_have_io; + } + sv_setpv(PL_statname, SvPV_nolen_const(sv)); PL_statgv = NULL; PL_laststype = PL_op->op_type; @@ -2808,9 +2910,9 @@ PP(pp_stat) PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime))); PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime))); #else - PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime))); - PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime))); - PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime))); + PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_atime))); + PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_mtime))); + PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_ctime))); #endif #ifdef USE_STAT_BLOCKS PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize))); @@ -2911,7 +3013,7 @@ PP(pp_ftrread) if (use_access) { #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS) - const char *const name = POPpx; + const char *name = POPpx; if (effective) { # ifdef PERL_EFF_ACCESS result = PERL_EFF_ACCESS(name, access_mode); @@ -3231,7 +3333,7 @@ PP(pp_fttext) #if defined(DOSISH) || defined(USEMYBINMODE) /* ignore trailing ^Z on short files */ - if (len && len < sizeof(tbuf) && tbuf[len-1] == 26) + if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26) --len; #endif @@ -3300,7 +3402,7 @@ PP(pp_chdir) gv = (GV*)SvRV(sv); } else { - tmps = SvPVx_nolen_const(sv); + tmps = SvPV_nolen_const(sv); } } @@ -3331,15 +3433,10 @@ PP(pp_chdir) #ifdef HAS_FCHDIR IO* const io = GvIO(gv); if (io) { - if (IoIFP(io)) { - PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0); - } - else if (IoDIRP(io)) { -#ifdef HAS_DIRFD - PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0); -#else - DIE(aTHX_ PL_no_func, "dirfd"); -#endif + if (IoDIRP(io)) { + PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0); + } else if (IoIFP(io)) { + PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0); } else { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) @@ -3500,15 +3597,17 @@ S_dooneliner(pTHX_ const char *cmd, const char *filename) char *s; PerlIO *myfp; int anum = 1; + Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10; - Newx(cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char); - strcpy(cmdline, cmd); - strcat(cmdline, " "); + Newx(cmdline, size, char); + my_strlcpy(cmdline, cmd, size); + my_strlcat(cmdline, " ", size); for (s = cmdline + strlen(cmdline); *filename; ) { *s++ = '\\'; *s++ = *filename++; } - strcpy(s, " 2>&1"); + if (s - cmdline < size) + my_strlcpy(s, " 2>&1", size - (s - cmdline)); myfp = PerlProc_popen(cmdline, "r"); Safefree(cmdline); @@ -3657,6 +3756,9 @@ PP(pp_open_dir) if (!io) goto nope; + if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED)) + Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), + "Opening filehandle %s also as a directory", GvENAME(gv)); if (IoDIRP(io)) PerlDir_close(IoDIRP(io)); if (!(IoDIRP(io) = PerlDir_open(dirname))) @@ -3711,8 +3813,7 @@ PP(pp_readdir) SvTAINTED_on(sv); #endif XPUSHs(sv_2mortal(sv)); - } - while (gimme == G_ARRAY); + } while (gimme == G_ARRAY); if (!dp && gimme != G_ARRAY) goto nope; @@ -3897,7 +3998,7 @@ PP(pp_fork) PP(pp_wait) { -#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) +#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__) dVAR; dSP; dTARGET; Pid_t childpid; int argflags; @@ -3925,7 +4026,7 @@ PP(pp_wait) PP(pp_waitpid) { -#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) +#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__) dVAR; dSP; dTARGET; const int optype = POPi; const Pid_t pid = TOPi; @@ -3956,6 +4057,11 @@ PP(pp_waitpid) PP(pp_system) { dVAR; dSP; dMARK; dORIGMARK; dTARGET; +#if defined(__LIBCATAMOUNT__) + PL_statusvalue = -1; + SP = ORIGMARK; + XPUSHi(-1); +#else I32 value; int result; @@ -4013,7 +4119,8 @@ PP(pp_system) SP = ORIGMARK; if (did_pipes) { int errkid; - int n = 0, n1; + unsigned n = 0; + SSize_t n1; while (n < sizeof(int)) { n1 = PerlLIO_read(pp[0], @@ -4078,7 +4185,8 @@ PP(pp_system) do_execfree(); SP = ORIGMARK; XPUSHi(result ? value : STATUS_CURRENT); -#endif /* !FORK or VMS */ +#endif /* !FORK or VMS or OS/2 */ +#endif RETURN; } @@ -4543,7 +4651,7 @@ PP(pp_ghostent) const int addrtype = POPi; SV * const addrsv = POPs; STRLEN addrlen; - Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen); + const char *addr = (char *)SvPVbyte(addrsv, addrlen); hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype); #else @@ -4583,7 +4691,7 @@ PP(pp_ghostent) if (hent) { PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0))); - PUSHs(S_space_join_names_mortal(aTHX_ hent->h_aliases)); + PUSHs(space_join_names_mortal(hent->h_aliases)); PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype))); len = hent->h_length; PUSHs(sv_2mortal(newSViv((IV)len))); @@ -4666,7 +4774,7 @@ PP(pp_gnetent) if (nent) { PUSHs(sv_2mortal(newSVpv(nent->n_name, 0))); - PUSHs(S_space_join_names_mortal(aTHX_ nent->n_aliases)); + PUSHs(space_join_names_mortal(nent->n_aliases)); PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype))); PUSHs(sv_2mortal(newSViv((IV)nent->n_net))); } @@ -4727,7 +4835,7 @@ PP(pp_gprotoent) if (pent) { PUSHs(sv_2mortal(newSVpv(pent->p_name, 0))); - PUSHs(S_space_join_names_mortal(aTHX_ pent->p_aliases)); + PUSHs(space_join_names_mortal(pent->p_aliases)); PUSHs(sv_2mortal(newSViv((IV)pent->p_proto))); } @@ -4797,7 +4905,7 @@ PP(pp_gservent) if (sent) { PUSHs(sv_2mortal(newSVpv(sent->s_name, 0))); - PUSHs(S_space_join_names_mortal(aTHX_ sent->s_aliases)); + PUSHs(space_join_names_mortal(sent->s_aliases)); #ifdef HAS_NTOHS PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port)))); #else @@ -5111,7 +5219,7 @@ PP(pp_gpwent) # ifdef PWGECOS PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0))); # else - PUSHs(sv_mortalcopy(&PL_sv_no)); + PUSHs(sv = sv_mortalcopy(&PL_sv_no)); # endif # ifndef INCOMPLETE_TAINTS /* pw_gecos is tainted because user himself can diddle with it. */ @@ -5214,7 +5322,7 @@ PP(pp_ggrent) * but the gr_mem is poisonous anyway. * So yes, you cannot get the list of group * members if building multithreaded in UNICOS/mk. */ - PUSHs(S_space_join_names_mortal(aTHX_ grent->gr_mem)); + PUSHs(space_join_names_mortal(grent->gr_mem)); #endif }