X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/fdd78bafb83473399368c22ad797c178b3913c97..866c78d1cf6feeffe34601c244c137d8b30ec2e4:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index 690bc9d..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. @@ -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 @@ -302,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) @@ -442,6 +422,7 @@ PP(pp_warn) else if (SP == MARK) { tmpsv = &PL_sv_no; EXTEND(SP, 1); + SP = MARK + 1; } else { tmpsv = TOPs; @@ -458,7 +439,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; } @@ -482,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; @@ -522,7 +503,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 +523,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 +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); @@ -771,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; } } @@ -844,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, (void*)*MARK); + methname, SVfARG(*MARK)); } ENTER; PUSHSTACKi(PERLSI_MAGIC); @@ -946,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"); @@ -1270,6 +1261,7 @@ PP(pp_enterwrite) register IO *io; GV *fgv; CV *cv; + SV * tmpsv = NULL; if (MAXARG == 0) gv = PL_defoutgv; @@ -1293,8 +1285,8 @@ PP(pp_enterwrite) 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) @@ -1488,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; @@ -1622,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 @@ -1830,10 +1824,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; } @@ -2014,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)) @@ -2785,7 +2788,7 @@ PP(pp_stat) { dVAR; dSP; - GV *gv; + GV *gv = NULL; IO *io; I32 gimme; I32 max = 13; @@ -2797,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"); } @@ -2815,12 +2818,8 @@ PP(pp_stat) PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache); } else if (IoDIRP(io)) { -#ifdef HAS_DIRFD PL_laststatval = - PerlLIO_fstat(dirfd(IoDIRP(io)), &PL_statcache); -#else - DIE(aTHX_ PL_no_func, "dirfd"); -#endif + PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache); } else { PL_laststatval = -1; } @@ -2911,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))); @@ -3014,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); @@ -3334,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 @@ -3403,7 +3402,7 @@ PP(pp_chdir) gv = (GV*)SvRV(sv); } else { - tmps = SvPVx_nolen_const(sv); + tmps = SvPV_nolen_const(sv); } } @@ -3434,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)) @@ -3762,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))) @@ -4001,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; @@ -4029,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; @@ -4060,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; @@ -4183,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; } @@ -4648,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 @@ -5216,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. */