X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=aa36bef9aae5e46f0ef98ba720914f1acdfd4309;hb=e91d68d56f1589ba6c8f530bcf8cdeb3d8943dcf;hp=a7c94144ff14fad0774d29d8cf2e2d96c0ac3df2;hpb=1d0eb99ac8ec0dfd859e9def067c632124d58343;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index a7c9414..aa36bef 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. @@ -197,11 +197,6 @@ void setservent(int); void endservent(void); #endif -#if defined(__osf__) && defined(__cplusplus) && !defined(_XOPEN_SOURCE_EXTENDED) -extern int readlink(const char *, char *, size_t); -extern int fchdir(int); -#endif - #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */ /* AIX 5.2 and below use mktime for localtime, and defines the edge case @@ -442,6 +437,7 @@ PP(pp_warn) else if (SP == MARK) { tmpsv = &PL_sv_no; EXTEND(SP, 1); + SP = MARK + 1; } else { tmpsv = TOPs; @@ -458,7 +454,7 @@ PP(pp_warn) if (!tmps || !len) tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong")); - Perl_warn(aTHX_ "%"SVf, (void*)tmpsv); + Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv)); RETSETYES; } @@ -522,7 +518,7 @@ PP(pp_die) if (!tmps || !len) tmpsv = sv_2mortal(newSVpvs("Died")); - DIE(aTHX_ "%"SVf, (void*)tmpsv); + DIE(aTHX_ "%"SVf, SVfARG(tmpsv)); } /* I/O. */ @@ -542,10 +538,15 @@ PP(pp_open) if (!isGV(gv)) DIE(aTHX_ PL_no_usym, "filehandle"); + if ((io = GvIOp(gv))) { MAGIC *mg; IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; + 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 ... */ @@ -712,8 +713,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); @@ -771,22 +776,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; } } @@ -844,10 +850,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, (void*)*MARK); + methname, SVfARG(*MARK)); } ENTER; PUSHSTACKi(PERLSI_MAGIC); @@ -946,7 +952,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"); @@ -1489,6 +1495,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; @@ -1831,10 +1839,14 @@ PP(pp_send) 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; } @@ -2798,7 +2810,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"); } @@ -2912,9 +2924,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))); @@ -3015,7 +3027,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); @@ -3335,7 +3347,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 @@ -3435,15 +3447,14 @@ 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)) { + if (IoDIRP(io)) { #ifdef HAS_DIRFD PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0); #else DIE(aTHX_ PL_no_func, "dirfd"); #endif + } else if (IoIFP(io)) { + PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0); } else { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) @@ -3763,6 +3774,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)))