X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f5a29b03d6424b21aad3d841127a2c7b87eb6888..14178d348d5e4cc1291b5c8895bf9f630e485832:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index 8c0820f..00de34a 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -1,6 +1,6 @@ /* pp_sys.c * - * Copyright (c) 1991-1999, Larry Wall + * Copyright (c) 1991-2000, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -22,6 +22,11 @@ /* Shadow password support for solaris - pdo@cs.umd.edu * Not just Solaris: at least HP-UX, IRIX, Linux. * the API is from SysV. --jhi */ +#ifdef __hpux__ +/* There is a MAXINT coming from <- <- + * and another MAXINT from "perl.h" <- . */ +#undef MAXINT +#endif #include #endif @@ -72,7 +77,7 @@ extern "C" int syscall(unsigned long,...); compiling multithreaded and singlethreaded ($ccflags et al). HOST_NOT_FOUND is typically defined in . */ -#if defined(HOST_NOT_FOUND) && !defined(h_errno) +#if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__) extern int h_errno; #endif @@ -107,27 +112,12 @@ extern int h_errno; # include # endif #endif -#ifdef I_FCNTL -#include -#endif -#ifdef I_SYS_FILE -#include -#endif /* Put this after #includes because fork and vfork prototypes may conflict. */ #ifndef HAS_VFORK # define vfork fork #endif -/* Put this after #includes because defines _XOPEN_*. */ -#ifndef Sock_size_t -# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__) -# define Sock_size_t Size_t -# else -# define Sock_size_t int -# endif -#endif - #ifdef HAS_CHSIZE # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */ # undef my_chsize @@ -187,6 +177,10 @@ static char zero_but_true[ZBTLEN + 1] = "0 but true"; # include #endif +#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC) +# define FD_CLOEXEC 1 /* NeXT needs this */ +#endif + #undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */ #undef PERL_EFF_ACCESS_W_OK #undef PERL_EFF_ACCESS_X_OK @@ -238,7 +232,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) Gid_t egid = getegid(); int res; - MUTEX_LOCK(&PL_cred_mutex); + LOCK_CRED_MUTEX; #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID) Perl_croak(aTHX_ "switching effective uid is not implemented"); #else @@ -284,7 +278,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) #endif #endif Perl_croak(aTHX_ "leaving effective gid failed"); - MUTEX_UNLOCK(&PL_cred_mutex); + UNLOCK_CRED_MUTEX; return res; } @@ -310,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]; @@ -362,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 @@ -402,7 +405,7 @@ PP(pp_indread) PP(pp_rcatline) { - PL_last_in_gv = cGVOP->op_gv; + PL_last_in_gv = cGVOP_gv; return do_readline(); } @@ -433,7 +436,7 @@ PP(pp_warn) if (!tmps || !len) tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26)); - Perl_warn(aTHX_ "%_", tmpsv); + Perl_warn(aTHX_ "%"SVf, tmpsv); RETSETYES; } @@ -466,8 +469,8 @@ PP(pp_die) HV *stash = SvSTASH(SvRV(error)); GV *gv = gv_fetchmethod(stash, "PROPAGATE"); if (gv) { - SV *file = sv_2mortal(newSVsv(GvSV(PL_curcop->cop_filegv))); - SV *line = sv_2mortal(newSViv(PL_curcop->cop_line)); + SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0)); + SV *line = sv_2mortal(newSVuv(CopLINE(PL_curcop))); EXTEND(SP, 3); PUSHMARK(SP); PUSHs(error); @@ -491,7 +494,7 @@ PP(pp_die) if (!tmps || !len) tmpsv = sv_2mortal(newSVpvn("Died", 4)); - DIE(aTHX_ "%_", tmpsv); + DIE(aTHX_ "%"SVf, tmpsv); } /* I/O. */ @@ -523,23 +526,7 @@ PP(pp_open) if (GvIOp(gv)) IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; -#if 0 /* no undef means tmpfile() yet */ - if (sv == &PL_sv_undef) { -#ifdef PerlIO - PerlIO *fp = PerlIO_tmpfile(); -#else - PerlIO *fp = tmpfile(); -#endif - if (fp != Nullfp && do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) - PUSHi( (I32)PL_forkprocess ); - else - RETPUSHUNDEF; - RETURN; - } -#endif /* no undef means tmpfile() yet */ - - - if (mg = SvTIED_mg((SV*)gv, 'q')) { + if ((mg = SvTIED_mg((SV*)gv, 'q'))) { PUSHMARK(SP); XPUSHs(SvTIED_obj((SV*)gv, mg)); XPUSHs(sv); @@ -574,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; @@ -705,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); @@ -726,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; @@ -815,18 +806,11 @@ PP(pp_untie) if (ckWARN(WARN_UNTIE)) { MAGIC * mg ; - if (mg = SvTIED_mg(sv, how)) { -#ifdef IV_IS_QUAD + if ((mg = SvTIED_mg(sv, how))) { if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1) Perl_warner(aTHX_ WARN_UNTIE, - "untie attempted while %" PERL_PRIu64 " inner references still exist", + "untie attempted while %"UVuf" inner references still exist", (UV)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ; -#else - if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1) - Perl_warner(aTHX_ WARN_UNTIE, - "untie attempted while %lu inner references still exist", - (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ; -#endif } } @@ -841,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); @@ -880,9 +864,9 @@ PP(pp_dbmopen) PUSHs(sv); PUSHs(left); if (SvIV(right)) - PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT))); + PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT))); else - PUSHs(sv_2mortal(newSViv(O_RDWR))); + PUSHs(sv_2mortal(newSVuv(O_RDWR))); PUSHs(right); PUTBACK; call_sv((SV*)GvCV(gv), G_SCALAR); @@ -893,7 +877,7 @@ PP(pp_dbmopen) PUSHMARK(SP); PUSHs(sv); PUSHs(left); - PUSHs(sv_2mortal(newSViv(O_RDONLY))); + PUSHs(sv_2mortal(newSVuv(O_RDONLY))); PUSHs(right); PUTBACK; call_sv((SV*)GvCV(gv), G_SCALAR); @@ -957,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 @@ -1105,14 +1089,12 @@ PP(pp_getc) GV *gv; MAGIC *mg; - if (MAXARG <= 0) + if (MAXARG == 0) gv = PL_stdingv; else gv = (GV*)POPs; - if (!gv) - gv = PL_argvgv; - 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)); @@ -1152,9 +1134,9 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) SAVETMPS; push_return(retop); - PUSHBLOCK(cx, CXt_SUB, PL_stack_sp); + PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp); PUSHFORMAT(cx); - SAVESPTR(PL_curpad); + SAVEVPTR(PL_curpad); PL_curpad = AvARRAY((AV*)svp[1]); setdefout(gv); /* locally select filehandle so $% et al work */ @@ -1287,15 +1269,15 @@ PP(pp_leavewrite) fp = IoOFP(io); if (!fp) { if (ckWARN2(WARN_CLOSED,WARN_IO)) { - SV* sv = sv_newmortal(); - gv_efullname3(sv, gv, Nullch); - if (IoIFP(io)) + if (IoIFP(io)) { + SV* sv = sv_newmortal(); + gv_efullname3(sv, gv, Nullch); Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for input", SvPV_nolen(sv)); + } else if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, - "Write on closed filehandle %s", SvPV_nolen(sv)); + report_closed_fh(gv, io, "write", "filehandle"); } PUSHs(&PL_sv_no); } @@ -1336,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; @@ -1368,14 +1350,14 @@ PP(pp_prtf) } else if (!(fp = IoOFP(io))) { if (ckWARN2(WARN_CLOSED,WARN_IO)) { - gv_efullname3(sv, gv, Nullch); - if (IoIFP(io)) + if (IoIFP(io)) { + gv_efullname3(sv, gv, Nullch); Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for input", SvPV(sv,n_a)); + } else if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, - "printf on closed filehandle %s", SvPV(sv,n_a)); + report_closed_fh(gv, io, "printf", "filehandle"); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; @@ -1561,8 +1543,8 @@ PP(pp_sysread) length = -1; } if (length < 0) { - if (IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout() - || IoIFP(io) == PerlIO_stderr()) + if ((IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout() + || IoIFP(io) == PerlIO_stderr()) && ckWARN(WARN_IO)) { SV* sv = sv_newmortal(); gv_efullname3(sv, gv, Nullch); @@ -1606,10 +1588,11 @@ PP(pp_send) djSP; dMARK; dORIGMARK; dTARGET; GV *gv; IO *io; - int offset; SV *bufsv; char *buffer; - int length; + Size_t length; + SSize_t retval; + IV offset; STRLEN blen; MAGIC *mg; @@ -1632,18 +1615,22 @@ PP(pp_send) goto say_undef; bufsv = *++MARK; buffer = SvPV(bufsv, blen); - length = SvIVx(*++MARK); - if (length < 0) +#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)) { - length = -1; + retval = -1; if (ckWARN(WARN_CLOSED)) { if (PL_op->op_type == OP_SYSWRITE) - Perl_warner(aTHX_ WARN_CLOSED, "Syswrite on closed filehandle"); + report_closed_fh(gv, io, "syswrite", "filehandle"); else - Perl_warner(aTHX_ WARN_CLOSED, "Send on closed socket"); + report_closed_fh(gv, io, "send", "socket"); } } else if (PL_op->op_type == OP_SYSWRITE) { @@ -1661,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); } } @@ -1677,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: @@ -1709,10 +1700,28 @@ PP(pp_eof) GV *gv; MAGIC *mg; - if (MAXARG <= 0) - gv = PL_last_in_gv; + if (MAXARG == 0) { + if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */ + IO *io; + gv = PL_last_in_gv = PL_argvgv; + io = GvIO(gv); + if (io && !IoIFP(io)) { + if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) { + IoLINES(io) = 0; + IoFLAGS(io) &= ~IOf_START; + do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp); + sv_setpvn(GvSV(gv), "-", 1); + SvSETMAGIC(GvSV(gv)); + } + else if (!nextargv(gv)) + RETPUSHYES; + } + } + else + gv = PL_last_in_gv; /* eof */ + } else - gv = PL_last_in_gv = (GV*)POPs; + gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */ if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) { PUSHMARK(SP); @@ -1735,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; @@ -1751,7 +1760,11 @@ PP(pp_tell) RETURN; } +#if LSEEKSIZE > IVSIZE + PUSHn( do_tell(gv) ); +#else PUSHi( do_tell(gv) ); +#endif RETURN; } @@ -1765,7 +1778,11 @@ PP(pp_sysseek) djSP; GV *gv; int whence = POPi; +#if LSEEKSIZE > IVSIZE + Off_t offset = (Off_t)SvNVx(POPs); +#else Off_t offset = (Off_t)SvIVx(POPs); +#endif MAGIC *mg; gv = PL_last_in_gv = (GV*)POPs; @@ -1773,8 +1790,12 @@ PP(pp_sysseek) if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) { PUSHMARK(SP); XPUSHs(SvTIED_obj((SV*)gv, mg)); - XPUSHs(sv_2mortal(newSViv((IV) offset))); - XPUSHs(sv_2mortal(newSViv((IV) whence))); +#if LSEEKSIZE > IVSIZE + XPUSHs(sv_2mortal(newSVnv((NV) offset))); +#else + XPUSHs(sv_2mortal(newSViv(offset))); +#endif + XPUSHs(sv_2mortal(newSViv(whence))); PUTBACK; ENTER; call_method("SEEK", G_SCALAR); @@ -1786,10 +1807,19 @@ PP(pp_sysseek) if (PL_op->op_type == OP_SEEK) PUSHs(boolSV(do_seek(gv, offset, whence))); else { - Off_t n = do_sysseek(gv, offset, whence); - PUSHs((n < 0) ? &PL_sv_undef - : sv_2mortal(n ? newSViv((IV)n) - : newSVpvn(zero_but_true, ZBTLEN))); + Off_t sought = do_sysseek(gv, offset, whence); + if (sought < 0) + PUSHs(&PL_sv_undef); + else { + SV* sv = sought ? +#if LSEEKSIZE > IVSIZE + newSVnv((NV)sought) +#else + newSViv(sought) +#endif + : newSVpvn(zero_but_true, ZBTLEN); + PUSHs(sv_2mortal(sv)); + } } RETURN; } @@ -1797,24 +1827,41 @@ 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) { tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO); do_ftruncate: TAINT_PROPER("truncate"); - if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) || + if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv))) + result = 0; + else { + PerlIO_flush(IoIFP(GvIOp(tmpgv))); #ifdef HAS_TRUNCATE - ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) + if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) #else - my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) + if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) #endif - result = 0; + result = 0; + } } else { SV *sv = POPs; @@ -1894,7 +1941,7 @@ PP(pp_ioctl) } else { retval = SvIV(argsv); - s = (char*)retval; /* ouch */ + s = INT2PTR(char*,retval); /* ouch */ } TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl"); @@ -1945,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; @@ -1957,8 +2004,12 @@ PP(pp_flock) (void)PerlIO_flush(fp); value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0); } - else + else { value = 0; + SETERRNO(EBADF,RMS$_IFI); + if (ckWARN(WARN_CLOSED)) + report_closed_fh(gv, GvIO(gv), "flock", "filehandle"); + } PUSHi(value); RETURN; #else @@ -2003,6 +2054,9 @@ PP(pp_socket) if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd); RETPUSHUNDEF; } +#if defined(HAS_FCNTL) && defined(F_SETFD) + fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ +#endif RETPUSHYES; #else @@ -2053,6 +2107,10 @@ PP(pp_sockpair) if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]); RETPUSHUNDEF; } +#if defined(HAS_FCNTL) && defined(F_SETFD) + fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */ + fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */ +#endif RETPUSHYES; #else @@ -2111,7 +2169,7 @@ PP(pp_bind) nuts: if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, "bind() on closed fd"); + report_closed_fh(gv, io, "bind", "socket"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else @@ -2141,7 +2199,7 @@ PP(pp_connect) nuts: if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, "connect() on closed fd"); + report_closed_fh(gv, io, "connect", "socket"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else @@ -2167,7 +2225,7 @@ PP(pp_listen) nuts: if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, "listen() on closed fd"); + report_closed_fh(gv, io, "listen", "socket"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else @@ -2215,13 +2273,16 @@ PP(pp_accept) if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd); goto badexit; } +#if defined(HAS_FCNTL) && defined(F_SETFD) + fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ +#endif PUSHp((char *)&saddr, len); RETURN; nuts: if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, "accept() on closed fd"); + report_closed_fh(ggv, ggv ? GvIO(ggv) : 0, "accept", "socket"); SETERRNO(EBADF,SS$_IVCHAN); badexit: @@ -2248,7 +2309,7 @@ PP(pp_shutdown) nuts: if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, "shutdown() on closed fd"); + report_closed_fh(gv, io, "shutdown", "socket"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else @@ -2327,7 +2388,9 @@ PP(pp_ssockopt) nuts: if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, "[gs]etsockopt() on closed fd"); + report_closed_fh(gv, io, + optype == OP_GSOCKOPT ? "getsockopt" : "setsockopt", + "socket"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; @@ -2400,7 +2463,10 @@ PP(pp_getpeername) nuts: if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, "get{sock, peer}name() on closed fd"); + report_closed_fh(gv, io, + optype == OP_GETSOCKNAME ? "getsockname" + : "getpeername", + "socket"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; @@ -2426,7 +2492,7 @@ PP(pp_stat) STRLEN n_a; if (PL_op->op_flags & OPf_REF) { - tmpgv = cGVOP->op_gv; + tmpgv = cGVOP_gv; do_fstat: if (tmpgv != PL_defgv) { PL_laststype = OP_STAT; @@ -2475,16 +2541,36 @@ PP(pp_stat) EXTEND_MORTAL(max); PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev))); PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino))); - PUSHs(sv_2mortal(newSViv(PL_statcache.st_mode))); - PUSHs(sv_2mortal(newSViv(PL_statcache.st_nlink))); + PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode))); + PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink))); +#if Uid_t_size > IVSIZE + PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid))); +#else +# if Uid_t_sign <= 0 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid))); +# else + PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid))); +# endif +#endif +#if Gid_t_size > IVSIZE + PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid))); +#else +# if Gid_t_sign <= 0 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid))); +# else + PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid))); +# endif +#endif #ifdef USE_STAT_RDEV PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev))); #else PUSHs(sv_2mortal(newSVpvn("", 0))); #endif +#if Off_t_size > IVSIZE + PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size))); +#else PUSHs(sv_2mortal(newSViv(PL_statcache.st_size))); +#endif #ifdef BIG_TIME PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime))); PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime))); @@ -2495,8 +2581,8 @@ PP(pp_stat) PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime))); #endif #ifdef USE_STAT_BLOCKS - PUSHs(sv_2mortal(newSViv(PL_statcache.st_blksize))); - PUSHs(sv_2mortal(newSViv(PL_statcache.st_blocks))); + PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize))); + PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks))); #else PUSHs(sv_2mortal(newSVpvn("", 0))); PUSHs(sv_2mortal(newSVpvn("", 0))); @@ -2687,7 +2773,8 @@ PP(pp_ftrowned) djSP; if (result < 0) RETPUSHUNDEF; - if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? PL_euid : PL_uid) ) + if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? + PL_euid : PL_uid) ) RETPUSHYES; RETPUSHNO; } @@ -2698,7 +2785,7 @@ PP(pp_ftzero) djSP; if (result < 0) RETPUSHUNDEF; - if (!PL_statcache.st_size) + if (PL_statcache.st_size == 0) RETPUSHYES; RETPUSHNO; } @@ -2709,7 +2796,11 @@ PP(pp_ftsize) djSP; dTARGET; if (result < 0) RETPUSHUNDEF; +#if Off_t_size > IVSIZE + PUSHn(PL_statcache.st_size); +#else PUSHi(PL_statcache.st_size); +#endif RETURN; } @@ -2871,7 +2962,7 @@ PP(pp_fttty) STRLEN n_a; if (PL_op->op_flags & OPf_REF) - gv = cGVOP->op_gv; + gv = cGVOP_gv; else if (isGV(TOPs)) gv = (GV*)POPs; else if (SvROK(TOPs) && isGV(SvRV(TOPs))) @@ -2910,9 +3001,10 @@ PP(pp_fttext) register SV *sv; GV *gv; STRLEN n_a; + PerlIO *fp; if (PL_op->op_flags & OPf_REF) - gv = cGVOP->op_gv; + gv = cGVOP_gv; else if (isGV(TOPs)) gv = (GV*)POPs; else if (SvROK(TOPs) && isGV(SvRV(TOPs))) @@ -2961,9 +3053,11 @@ PP(pp_fttext) len = 512; } else { - if (ckWARN(WARN_UNOPENED)) + if (ckWARN(WARN_UNOPENED)) { + gv = cGVOP_gv; Perl_warner(aTHX_ WARN_UNOPENED, "Test on unopened file <%s>", - GvENAME(cGVOP->op_gv)); + GvENAME(gv)); + } SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; } @@ -2974,21 +3068,19 @@ PP(pp_fttext) PL_statgv = Nullgv; PL_laststatval = -1; sv_setpv(PL_statname, SvPV(sv, n_a)); -#ifdef HAS_OPEN3 - i = PerlLIO_open3(SvPV(sv, n_a), O_RDONLY, 0); -#else - i = PerlLIO_open(SvPV(sv, n_a), 0); -#endif - if (i < 0) { + if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) { if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n')) Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open"); RETPUSHUNDEF; } - PL_laststatval = PerlLIO_fstat(i, &PL_statcache); - if (PL_laststatval < 0) + PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache); + if (PL_laststatval < 0) { + (void)PerlIO_close(fp); RETPUSHUNDEF; - len = PerlLIO_read(i, tbuf, 512); - (void)PerlLIO_close(i); + } + do_binmode(fp, '<', O_BINARY); + len = PerlIO_read(fp, tbuf, sizeof(tbuf)); + (void)PerlIO_close(fp); if (len <= 0) { if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT) RETPUSHNO; /* special case NFS directories */ @@ -3000,6 +3092,12 @@ PP(pp_fttext) /* now scan s to look for textiness */ /* XXX ASCII dependent code */ +#if defined(DOSISH) || defined(USEMYBINMODE) + /* ignore trailing ^Z on short files */ + if (len && len < sizeof(tbuf) && tbuf[len-1] == 26) + --len; +#endif + for (i = 0; i < len; i++, s++) { if (!*s) { /* null never allowed in text */ odd += len; @@ -3009,8 +3107,29 @@ PP(pp_fttext) else if (!(isPRINT(*s) || isSPACE(*s))) odd++; #else - else if (*s & 128) + else if (*s & 128) { +#ifdef USE_LOCALE + 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' && *s != '\t' && *s != '\f' && *s != 27) @@ -3163,7 +3282,7 @@ PP(pp_link) char *tmps2 = POPpx; char *tmps = SvPV(TOPs, n_a); TAINT_PROPER("link"); - SETi( link(tmps, tmps2) >= 0 ); + SETi( PerlLIO_link(tmps, tmps2) >= 0 ); #else DIE(aTHX_ PL_no_func, "Unsupported function link"); #endif @@ -3300,12 +3419,19 @@ S_dooneliner(pTHX_ char *cmd, char *filename) PP(pp_mkdir) { djSP; dTARGET; - int mode = POPi; + int mode; #ifndef HAS_MKDIR int oldumask; #endif STRLEN n_a; - char *tmps = SvPV(TOPs, n_a); + char *tmps; + + if (MAXARG > 1) + mode = POPi; + else + mode = 0777; + + tmps = SvPV(TOPs, n_a); TAINT_PROPER("mkdir"); #ifdef HAS_MKDIR @@ -3381,14 +3507,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)); } @@ -3402,7 +3529,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)); } @@ -3538,20 +3666,31 @@ PP(pp_fork) RETSETUNDEF; if (!childpid) { /*SUPPRESS 560*/ - if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV)) - sv_setiv(GvSV(tmpgv), (IV)getpid()); + 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 */ } PUSHi(childpid); RETURN; #else +# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) + djSP; dTARGET; + Pid_t childpid; + + EXTEND(SP, 1); + PERL_FLUSHALL_FOR_CHILD; + childpid = PerlProc_fork(); + PUSHi(childpid); + RETURN; +# else DIE(aTHX_ PL_no_func, "Unsupported function fork"); +# endif #endif } PP(pp_wait) { -#if !defined(DOSISH) || defined(OS2) || defined(WIN32) +#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) djSP; dTARGET; Pid_t childpid; int argflags; @@ -3567,7 +3706,7 @@ PP(pp_wait) PP(pp_waitpid) { -#if !defined(DOSISH) || defined(OS2) || defined(WIN32) +#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) djSP; dTARGET; Pid_t childpid; int optype; @@ -3648,7 +3787,7 @@ PP(pp_system) PerlLIO_close(pp[0]); if (n) { /* Error */ if (n != sizeof(int)) - Perl_croak(aTHX_ "panic: kid popen errno read"); + DIE(aTHX_ "panic: kid popen errno read"); errno = errkid; /* Propagate errno from kid */ STATUS_CURRENT = -1; } @@ -3731,6 +3870,12 @@ PP(pp_exec) # endif #endif } + +#if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) + if (value >= 0) + my_exit(value); +#endif + SP = ORIGMARK; PUSHi(value); RETURN; @@ -3775,7 +3920,7 @@ PP(pp_getpgrp) #ifdef BSD_GETPGRP pgrp = (I32)BSD_GETPGRP(pid); #else - if (pid != 0 && pid != getpid()) + if (pid != 0 && pid != PerlProc_getpid()) DIE(aTHX_ "POSIX getpgrp can't take an argument"); pgrp = getpgrp(); #endif @@ -3805,8 +3950,11 @@ PP(pp_setpgrp) #ifdef BSD_SETPGRP SETi( BSD_SETPGRP(pid, pgrp) >= 0 ); #else - if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid())) - DIE(aTHX_ "POSIX setpgrp can't take an argument"); + if ((pgrp != 0 && pgrp != PerlProc_getpid()) + || (pid != 0 && pid != PerlProc_getpid())) + { + DIE(aTHX_ "setpgrp can't take arguments"); + } SETi( setpgrp() >= 0 ); #endif /* USE_BSDPGRP */ RETURN; @@ -3935,18 +4083,17 @@ PP(pp_gmtime) EXTEND(SP, 9); EXTEND_MORTAL(9); if (GIMME != G_ARRAY) { - dTARGET; SV *tsv; if (!tmbuf) RETPUSHUNDEF; tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d", dayname[tmbuf->tm_wday], monname[tmbuf->tm_mon], - (IV)tmbuf->tm_mday, - (IV)tmbuf->tm_hour, - (IV)tmbuf->tm_min, - (IV)tmbuf->tm_sec, - (IV)tmbuf->tm_year + 1900); + tmbuf->tm_mday, + tmbuf->tm_hour, + tmbuf->tm_min, + tmbuf->tm_sec, + tmbuf->tm_year + 1900); PUSHs(sv_2mortal(tsv)); } else if (tmbuf) { @@ -4620,7 +4767,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; @@ -4634,7 +4781,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) { @@ -4658,7 +4809,11 @@ PP(pp_gpwent) PUSHs(sv = sv_newmortal()); if (pwent) { if (which == OP_GPWNAM) +#if Uid_t_sign <= 0 sv_setiv(sv, (IV)pwent->pw_uid); +#else + sv_setuv(sv, (UV)pwent->pw_uid); +#endif else sv_setpv(sv, pwent->pw_name); } @@ -4680,13 +4835,24 @@ PP(pp_gpwent) sv_setpv(sv, pwent->pw_passwd); # endif #endif +#ifndef INCOMPLETE_TAINTS + /* passwd is tainted because user himself can diddle with it. */ + SvTAINTED_on(sv); +#endif PUSHs(sv = sv_mortalcopy(&PL_sv_no)); +#if Uid_t_sign <= 0 sv_setiv(sv, (IV)pwent->pw_uid); +#else + sv_setuv(sv, (UV)pwent->pw_uid); +#endif PUSHs(sv = sv_mortalcopy(&PL_sv_no)); +#if Uid_t_sign <= 0 sv_setiv(sv, (IV)pwent->pw_gid); - +#else + sv_setuv(sv, (UV)pwent->pw_gid); +#endif /* pw_change, pw_quota, and pw_age are mutually exclusive. */ PUSHs(sv = sv_mortalcopy(&PL_sv_no)); #ifdef PWCHANGE @@ -4725,6 +4891,10 @@ PP(pp_gpwent) PUSHs(sv = sv_mortalcopy(&PL_sv_no)); sv_setpv(sv, pwent->pw_shell); +#ifndef INCOMPLETE_TAINTS + /* pw_shell is tainted because user himself can diddle with it. */ + SvTAINTED_on(sv); +#endif #ifdef PWEXPIRE PUSHs(sv = sv_mortalcopy(&PL_sv_no)); @@ -4740,7 +4910,7 @@ PP(pp_gpwent) PP(pp_spwent) { djSP; -#if defined(HAS_PASSWD) && defined(HAS_SETPWENT) && !defined(CYGWIN) +#if defined(HAS_PASSWD) && defined(HAS_SETPWENT) setpwent(); # ifdef HAS_SETSPENT setspent(); @@ -4786,7 +4956,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; @@ -4798,7 +4968,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) { @@ -4885,7 +5059,6 @@ PP(pp_syscall) unsigned long a[20]; register I32 i = 0; I32 retval = -1; - MAGIC *mg; STRLEN n_a; if (PL_tainting) {