X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=78cf48b945b6ed4298a7a87063e5b85b3195d0d6;hb=2e0de35c58680e1e008b1d014c5b9ccec5b78282;hp=5ff5c924a6e4237597982d3a778a5f768a8aa0f9;hpb=a4af207cede5b404b66a75e2aef9bcb3117451b7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index 5ff5c92..78cf48b 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -1,6 +1,7 @@ /* pp_sys.c * - * Copyright (c) 1991-2002, Larry Wall + * Copyright (C) 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, 2004, 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. @@ -14,6 +15,15 @@ * a rumour and a trouble as of great engines throbbing and labouring. */ +/* This file contains system pp ("push/pop") functions that + * execute the opcodes that make up a perl program. A typical pp function + * expects to find its arguments on the stack, and usually pushes its + * results onto the stack, hence the 'pp' terminology. Each OP structure + * contains a pointer to the relevant pp_foo() function. + * + * By 'system', we mean ops which interact with the OS, such as pp_open(). + */ + #include "EXTERN.h" #define PERL_IN_PP_SYS_C #include "perl.h" @@ -175,6 +185,18 @@ static char zero_but_true[ZBTLEN + 1] = "0 but true"; #include "reentr.h" +#ifdef __Lynx__ +/* Missing protos on LynxOS */ +void sethostent(int); +void endhostent(void); +void setnetent(int); +void endnetent(void); +void setprotoent(int); +void endprotoent(void); +void setservent(int); +void endservent(void); +#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 @@ -422,7 +444,7 @@ PP(pp_warn) tmpsv = TOPs; } tmps = SvPV(tmpsv, len); - if (!tmps || !len) { + if ((!tmps || !len) && PL_errgv) { SV *error = ERRSV; (void)SvUPGRADE(error, SVt_PV); if (SvPOK(error) && SvCUR(error)) @@ -457,7 +479,7 @@ PP(pp_die) } else { tmpsv = TOPs; - tmps = (SvROK(tmpsv) && PL_in_eval) ? Nullch : SvPV(tmpsv, len); + tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len); } if (!tmps || !len) { SV *error = ERRSV; @@ -482,7 +504,7 @@ PP(pp_die) sv_setsv(error,*PL_stack_sp--); } } - DIE(aTHX_ Nullformat); + DIE_NULL; } else { if (SvPOK(error) && SvCUR(error)) @@ -608,8 +630,8 @@ PP(pp_pipe_op) if (PerlProc_pipe(fd) < 0) goto badexit; - IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"); - IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"); + IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE); + IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE); IoOFP(rstio) = IoIFP(rstio); IoIFP(wstio) = IoOFP(wstio); IoTYPE(rstio) = IoTYPE_RDONLY; @@ -734,12 +756,21 @@ PP(pp_binmode) if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); + SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } PUTBACK; if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp), (discp) ? SvPV_nolen(discp) : Nullch)) { + if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { + if (!PerlIO_binmode(aTHX_ IoOFP(io),IoTYPE(io), + mode_from_discipline(discp), + (discp) ? SvPV_nolen(discp) : Nullch)) { + SPAGAIN; + RETPUSHUNDEF; + } + } SPAGAIN; RETPUSHYES; } @@ -761,7 +792,6 @@ PP(pp_tie) char *methname; int how = PERL_MAGIC_tied; U32 items; - STRLEN n_a; varsv = *++MARK; switch(SvTYPE(varsv)) { @@ -808,8 +838,8 @@ PP(pp_tie) */ stash = gv_stashsv(*MARK, FALSE); if (!stash || !(gv = gv_fetchmethod(stash, methname))) { - DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"", - methname, SvPV(*MARK,n_a)); + DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"", + methname, *MARK); } ENTER; PUSHSTACKi(PERLSI_MAGIC); @@ -827,10 +857,12 @@ PP(pp_tie) if (sv_isobject(sv)) { sv_unmagic(varsv, how); /* Croak if a self-tie on an aggregate is attempted. */ - if (varsv == SvRV(sv) && how == PERL_MAGIC_tied) + if (varsv == SvRV(sv) && + (SvTYPE(varsv) == SVt_PVAV || + SvTYPE(varsv) == SVt_PVHV)) Perl_croak(aTHX_ "Self-ties of arrays and hashes are not supported"); - sv_magic(varsv, sv, how, Nullch, 0); + sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0); } LEAVE; SP = PL_stack_base + markoff; @@ -850,7 +882,7 @@ PP(pp_untie) RETPUSHYES; if ((mg = SvTIED_mg(sv, how))) { - SV *obj = SvRV(mg->mg_obj); + SV *obj = SvRV(SvTIED_obj(sv, mg)); GV *gv; CV *cv = NULL; if (obj) { @@ -872,8 +904,8 @@ PP(pp_untie) (UV)SvREFCNT(obj) - 1 ) ; } } - sv_unmagic(sv, how) ; } + sv_unmagic(sv, how) ; RETPUSHYES; } @@ -1013,15 +1045,19 @@ PP(pp_sselect) Zero(&fd_sets[0], 4, char*); #endif -# if SELECT_MIN_BITS > 1 +# if SELECT_MIN_BITS == 1 + growsize = sizeof(fd_set); +# else +# if defined(__GLIBC__) && defined(__FD_SETSIZE) +# undef SELECT_MIN_BITS +# define SELECT_MIN_BITS __FD_SETSIZE +# endif /* 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, 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 - growsize = sizeof(fd_set); # endif sv = SP[4]; @@ -1066,12 +1102,23 @@ PP(pp_sselect) #endif } +#ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST + /* Can't make just the (void*) conditional because that would be + * cpp #if within cpp macro, and not all compilers like that. */ + nfound = PerlSock_select( + maxlen * 8, + (Select_fd_set_t) fd_sets[1], + (Select_fd_set_t) fd_sets[2], + (Select_fd_set_t) fd_sets[3], + (void*) tbuf); /* Workaround for compiler bug. */ +#else nfound = PerlSock_select( maxlen * 8, (Select_fd_set_t) fd_sets[1], (Select_fd_set_t) fd_sets[2], (Select_fd_set_t) fd_sets[3], tbuf); +#endif for (i = 1; i <= 3; i++) { if (fd_sets[i]) { sv = SP[i]; @@ -1175,6 +1222,7 @@ PP(pp_getc) if (ckWARN2(WARN_UNOPENED,WARN_CLOSED) && (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))) report_evil_fh(gv, io, PL_op->op_type); + SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } TAINT; @@ -1204,17 +1252,14 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) { register PERL_CONTEXT *cx; I32 gimme = GIMME_V; - AV* padlist = CvPADLIST(cv); - SV** svp = AvARRAY(padlist); ENTER; SAVETMPS; - push_return(retop); PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp); PUSHFORMAT(cx); - SAVEVPTR(PL_curpad); - PL_curpad = AvARRAY((AV*)svp[1]); + cx->blk_sub.retop = retop; + PAD_SET_CUR(CvPADLIST(cv), 1); setdefout(gv); /* locally select filehandle so $% et al work */ return CvSTART(cv); @@ -1291,11 +1336,11 @@ PP(pp_leavewrite) if (!IoTOP_NAME(io)) { if (!IoFMT_NAME(io)) IoFMT_NAME(io) = savepv(GvNAME(gv)); - topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io))); - topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM); + topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv))); + topgv = gv_fetchsv(topname, FALSE, SVt_PVFM); if ((topgv && GvFORM(topgv)) || !gv_fetchpv("top",FALSE,SVt_PVFM)) - IoTOP_NAME(io) = savepv(SvPVX(topname)); + IoTOP_NAME(io) = savesvpv(topname); else IoTOP_NAME(io) = savepv("top"); } @@ -1363,21 +1408,8 @@ PP(pp_leavewrite) fp = IoOFP(io); if (!fp) { if (ckWARN2(WARN_CLOSED,WARN_IO)) { - if (IoIFP(io)) { - /* integrate with report_evil_fh()? */ - char *name = NULL; - if (isGV(gv)) { - SV* sv = sv_newmortal(); - gv_efullname4(sv, gv, Nullch, FALSE); - name = SvPV_nolen(sv); - } - if (name && *name) - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle %s opened only for input", name); - else - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle opened only for input"); - } + if (IoIFP(io)) + report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); else if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); } @@ -1402,7 +1434,7 @@ PP(pp_leavewrite) /* bad_ofp: */ PL_formtarget = PL_bodytarget; PUTBACK; - return pop_return(); + return cx->blk_sub.retop; } PP(pp_prtf) @@ -1445,29 +1477,17 @@ PP(pp_prtf) if (!(io = GvIO(gv))) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,RMS$_IFI); + SETERRNO(EBADF,RMS_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { if (ckWARN2(WARN_CLOSED,WARN_IO)) { - /* integrate with report_evil_fh()? */ - if (IoIFP(io)) { - char *name = NULL; - if (isGV(gv)) { - gv_efullname4(sv, gv, Nullch, FALSE); - name = SvPV_nolen(sv); - } - if (name && *name) - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle %s opened only for input", name); - else - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle opened only for input"); - } + if (IoIFP(io)) + report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); else if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); } - SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); + SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); goto just_say_no; } else { @@ -1535,6 +1555,8 @@ PP(pp_sysread) STRLEN blen; MAGIC *mg; int fp_utf8; + int buffer_utf8; + SV *read_target; Size_t got = 0; Size_t wanted; bool charstart = FALSE; @@ -1572,15 +1594,21 @@ PP(pp_sysread) else offset = 0; io = GvIO(gv); - if (!io || !IoIFP(io)) + if (!io || !IoIFP(io)) { + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); + SETERRNO(EBADF,RMS_IFI); goto say_undef; + } if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) { buffer = SvPVutf8_force(bufsv, blen); - /* UTF8 may not have been set if they are all low bytes */ + /* UTF-8 may not have been set if they are all low bytes */ SvUTF8_on(bufsv); + buffer_utf8 = 0; } else { buffer = SvPV_force(bufsv, blen); + buffer_utf8 = !IN_BYTES && SvUTF8(bufsv); } if (length < 0) DIE(aTHX_ "Negative length"); @@ -1641,15 +1669,37 @@ PP(pp_sysread) } if (DO_UTF8(bufsv)) { /* convert offset-as-chars to offset-as-bytes */ - offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer; + if (offset >= (int)blen) + offset += SvCUR(bufsv) - blen; + else + offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer; } more_bytes: bufsize = SvCUR(bufsv); + /* Allocating length + offset + 1 isn't perfect in the case of reading + bytes from a byte file handle into a UTF8 buffer, but it won't harm us + unduly. + (should be 2 * length + offset + 1, or possibly something longer if + PL_encoding is true) */ buffer = SvGROW(bufsv, (STRLEN)(length+offset+1)); if (offset > bufsize) { /* Zero any newly allocated space */ Zero(buffer+bufsize, offset-bufsize, char); } buffer = buffer + offset; + if (!buffer_utf8) { + read_target = bufsv; + } else { + /* Best to read the bytes into a new SV, upgrade that to UTF8, then + concatenate it to the current buffer. */ + + /* Truncate the existing buffer to the start of where we will be + reading to: */ + SvCUR_set(bufsv, offset); + + read_target = sv_newmortal(); + SvUPGRADE(read_target, SVt_PV); + buffer = SvGROW(read_target, length + 1); + } if (PL_op->op_type == OP_SYSREAD) { #ifdef PERL_SOCK_SYSREAD_IS_RECV @@ -1686,26 +1736,12 @@ PP(pp_sysread) } if (count < 0) { if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO)) - { - /* integrate with report_evil_fh()? */ - char *name = NULL; - if (isGV(gv)) { - SV* sv = sv_newmortal(); - gv_efullname4(sv, gv, Nullch, FALSE); - name = SvPV_nolen(sv); - } - if (name && *name) - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle %s opened only for output", name); - else - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle opened only for output"); - } + report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY); goto say_undef; } - SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv))); - *SvEND(bufsv) = '\0'; - (void)SvPOK_only(bufsv); + SvCUR_set(read_target, count+(buffer - SvPVX(read_target))); + *SvEND(read_target) = '\0'; + (void)SvPOK_only(read_target); if (fp_utf8 && !IN_BYTES) { /* Look at utf8 we got back and count the characters */ char *bend = buffer + count; @@ -1741,6 +1777,11 @@ PP(pp_sysread) count = got; SvUTF8_on(bufsv); } + else if (buffer_utf8) { + /* Let svcatsv upgrade the bytes we read in to utf8. + The buffer is a mortal so will be freed soon. */ + sv_catsv_nomg(bufsv, read_target); + } SvSETMAGIC(bufsv); /* This should not be marked tainted if the fp is marked clean */ if (!(IoFLAGS(io) & IOf_UNTAINT)) @@ -1814,16 +1855,24 @@ PP(pp_send) retval = -1; if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); + SETERRNO(EBADF,RMS_IFI); goto say_undef; } if (PerlIO_isutf8(IoIFP(io))) { - buffer = SvPVutf8(bufsv, blen); + if (!SvUTF8(bufsv)) { + bufsv = sv_2mortal(newSVsv(bufsv)); + buffer = sv_2pvutf8(bufsv, &blen); + } else + buffer = SvPV(bufsv, blen); } else { - if (DO_UTF8(bufsv)) - sv_utf8_downgrade(bufsv, FALSE); - buffer = SvPV(bufsv, blen); + 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(bufsv, blen); } if (PL_op->op_type == OP_SYSWRITE) { @@ -2051,7 +2100,7 @@ PP(pp_truncate) /* XXX Configure probe for the length type of *truncate() needed XXX */ Off_t len; -#if Size_t_size > IVSIZE +#if Off_t_size > IVSIZE len = (Off_t)POPn; #else len = (Off_t)POPi; @@ -2062,38 +2111,51 @@ PP(pp_truncate) SETERRNO(0,0); #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP) { - STRLEN n_a; int result = 1; GV *tmpgv; - + IO *io; + if (PL_op->op_flags & OPf_SPECIAL) { - tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO); + tmpgv = gv_fetchsv(POPs, FALSE, SVt_PVIO); - do_ftruncate: - TAINT_PROPER("truncate"); - if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv))) - result = 0; + do_ftruncate_gv: + if (!GvIO(tmpgv)) + result = 0; else { - PerlIO_flush(IoIFP(GvIOp(tmpgv))); + PerlIO *fp; + io = GvIOp(tmpgv); + do_ftruncate_io: + TAINT_PROPER("truncate"); + if (!(fp = IoIFP(io))) { + result = 0; + } + else { + PerlIO_flush(fp); #ifdef HAS_TRUNCATE - if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) + if (ftruncate(PerlIO_fileno(fp), len) < 0) #else - if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) + if (my_chsize(PerlIO_fileno(fp), len) < 0) #endif - result = 0; + result = 0; + } } } else { SV *sv = POPs; char *name; - + STRLEN n_a; + if (SvTYPE(sv) == SVt_PVGV) { tmpgv = (GV*)sv; /* *main::FRED for example */ - goto do_ftruncate; + goto do_ftruncate_gv; } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */ - goto do_ftruncate; + goto do_ftruncate_gv; + } + else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { + io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */ + goto do_ftruncate_io; } name = SvPV(sv, n_a); @@ -2119,7 +2181,7 @@ PP(pp_truncate) if (result) RETPUSHYES; if (!errno) - SETERRNO(EBADF,RMS$_IFI); + SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } #else @@ -2146,7 +2208,7 @@ PP(pp_ioctl) if (!io || !argsv || !IoIFP(io)) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */ + SETERRNO(EBADF,RMS_IFI); /* well, sort of... */ RETPUSHUNDEF; } @@ -2176,16 +2238,17 @@ PP(pp_ioctl) DIE(aTHX_ "ioctl is not implemented"); #endif else -#ifdef HAS_FCNTL +#ifndef HAS_FCNTL + DIE(aTHX_ "fcntl is not implemented"); +#else #if defined(OS2) && defined(__EMX__) retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s); #else retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s); #endif -#else - DIE(aTHX_ "fcntl is not implemented"); #endif +#if defined(HAS_IOCTL) || defined(HAS_FCNTL) if (SvPOK(argsv)) { if (s[SvCUR(argsv)] != 17) DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument", @@ -2202,6 +2265,7 @@ PP(pp_ioctl) else { PUSHp(zero_but_true, ZBTLEN); } +#endif RETURN; } @@ -2234,7 +2298,7 @@ PP(pp_flock) if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); value = 0; - SETERRNO(EBADF,RMS$_IFI); + SETERRNO(EBADF,RMS_IFI); } PUSHi(value); RETURN; @@ -2264,7 +2328,7 @@ PP(pp_socket) report_evil_fh(gv, io, PL_op->op_type); if (IoIFP(io)) do_close(gv, FALSE); - SETERRNO(EBADF,LIB$_INVARG); + SETERRNO(EBADF,LIB_INVARG); RETPUSHUNDEF; } @@ -2275,8 +2339,8 @@ PP(pp_socket) fd = PerlSock_socket(domain, type, protocol); if (fd < 0) RETPUSHUNDEF; - IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */ - IoOFP(io) = PerlIO_fdopen(fd, "w"); + IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */ + IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE); IoTYPE(io) = IoTYPE_SOCKET; if (!IoIFP(io) || !IoOFP(io)) { if (IoIFP(io)) PerlIO_close(IoIFP(io)); @@ -2337,11 +2401,11 @@ PP(pp_sockpair) TAINT_PROPER("socketpair"); if (PerlSock_socketpair(domain, type, protocol, fd) < 0) RETPUSHUNDEF; - IoIFP(io1) = PerlIO_fdopen(fd[0], "r"); - IoOFP(io1) = PerlIO_fdopen(fd[0], "w"); + IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE); + IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE); IoTYPE(io1) = IoTYPE_SOCKET; - IoIFP(io2) = PerlIO_fdopen(fd[1], "r"); - IoOFP(io2) = PerlIO_fdopen(fd[1], "w"); + IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE); + IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE); IoTYPE(io2) = IoTYPE_SOCKET; if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) { if (IoIFP(io1)) PerlIO_close(IoIFP(io1)); @@ -2415,7 +2479,7 @@ PP(pp_bind) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "bind"); @@ -2445,7 +2509,7 @@ PP(pp_connect) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "connect"); @@ -2471,7 +2535,7 @@ PP(pp_listen) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "listen"); @@ -2486,10 +2550,13 @@ PP(pp_accept) GV *ggv; register IO *nstio; register IO *gstio; - struct sockaddr saddr; /* use a struct to avoid alignment problems */ - Sock_size_t len = sizeof saddr; + char namebuf[MAXPATHLEN]; +#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__) + Sock_size_t len = sizeof (struct sockaddr_in); +#else + Sock_size_t len = sizeof namebuf; +#endif int fd; - int fd2; ggv = (GV*)POPs; ngv = (GV*)POPs; @@ -2504,17 +2571,13 @@ PP(pp_accept) goto nuts; nstio = GvIOn(ngv); - fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len); + fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len); if (fd < 0) goto badexit; if (IoIFP(nstio)) do_close(ngv, FALSE); - IoIFP(nstio) = PerlIO_fdopen(fd, "r"); - /* FIXME: we dup(fd) here so that refcounting of fd's does not inhibit - fclose of IoOFP's FILE * - and hence leak memory. - Special treatment of _this_ case of IoIFP != IoOFP seems wrong. - */ - IoOFP(nstio) = PerlIO_fdopen(fd2 = PerlLIO_dup(fd), "w"); + IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); + IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE); IoTYPE(nstio) = IoTYPE_SOCKET; if (!IoIFP(nstio) || !IoOFP(nstio)) { if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio)); @@ -2524,21 +2587,23 @@ PP(pp_accept) } #if defined(HAS_FCNTL) && defined(F_SETFD) fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ - fcntl(fd2, F_SETFD, fd2 > PL_maxsysfd); /* ensure close-on-exec */ #endif #ifdef EPOC - len = sizeof saddr; /* EPOC somehow truncates info */ + len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */ setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */ #endif +#ifdef __SCO_VERSION__ + len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */ +#endif - PUSHp((char *)&saddr, len); + PUSHp(namebuf, len); RETURN; nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type); - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); badexit: RETPUSHUNDEF; @@ -2565,7 +2630,7 @@ PP(pp_shutdown) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "shutdown"); @@ -2644,7 +2709,7 @@ PP(pp_ssockopt) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, optype); - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); nuts2: RETPUSHUNDEF; @@ -2717,7 +2782,7 @@ PP(pp_getpeername) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, optype); - SETERRNO(EBADF,SS$_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); nuts2: RETPUSHUNDEF; @@ -2832,7 +2897,7 @@ PP(pp_stat) PUSHs(sv_2mortal(newSVpvn("", 0))); #endif #if Off_t_size > IVSIZE - PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size))); + PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size))); #else PUSHs(sv_2mortal(newSViv(PL_statcache.st_size))); #endif @@ -2856,14 +2921,24 @@ PP(pp_stat) RETURN; } +/* This macro is used by the stacked filetest operators : + * if the previous filetest failed, short-circuit and pass its value. + * Else, discard it from the stack and continue. --rgs + */ +#define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \ + if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \ + else { (void)POPs; PUTBACK; } \ + } + PP(pp_ftrread) { I32 result; dSP; + STACKED_FTEST_CHECK; #if defined(HAS_ACCESS) && defined(R_OK) - STRLEN n_a; - if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = access(TOPpx, R_OK); + if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { + STRLEN n_a; + result = access(POPpx, R_OK); if (result == 0) RETPUSHYES; if (result < 0) @@ -2887,10 +2962,11 @@ PP(pp_ftrwrite) { I32 result; dSP; + STACKED_FTEST_CHECK; #if defined(HAS_ACCESS) && defined(W_OK) - STRLEN n_a; - if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = access(TOPpx, W_OK); + if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { + STRLEN n_a; + result = access(POPpx, W_OK); if (result == 0) RETPUSHYES; if (result < 0) @@ -2914,10 +2990,11 @@ PP(pp_ftrexec) { I32 result; dSP; + STACKED_FTEST_CHECK; #if defined(HAS_ACCESS) && defined(X_OK) - STRLEN n_a; - if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = access(TOPpx, X_OK); + if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { + STRLEN n_a; + result = access(POPpx, X_OK); if (result == 0) RETPUSHYES; if (result < 0) @@ -2941,10 +3018,11 @@ PP(pp_fteread) { I32 result; dSP; + STACKED_FTEST_CHECK; #ifdef PERL_EFF_ACCESS_R_OK - STRLEN n_a; - if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = PERL_EFF_ACCESS_R_OK(TOPpx); + if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { + STRLEN n_a; + result = PERL_EFF_ACCESS_R_OK(POPpx); if (result == 0) RETPUSHYES; if (result < 0) @@ -2968,10 +3046,11 @@ PP(pp_ftewrite) { I32 result; dSP; + STACKED_FTEST_CHECK; #ifdef PERL_EFF_ACCESS_W_OK - STRLEN n_a; - if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = PERL_EFF_ACCESS_W_OK(TOPpx); + if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { + STRLEN n_a; + result = PERL_EFF_ACCESS_W_OK(POPpx); if (result == 0) RETPUSHYES; if (result < 0) @@ -2995,10 +3074,11 @@ PP(pp_fteexec) { I32 result; dSP; + STACKED_FTEST_CHECK; #ifdef PERL_EFF_ACCESS_X_OK - STRLEN n_a; - if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) { - result = PERL_EFF_ACCESS_X_OK(TOPpx); + if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { + STRLEN n_a; + result = PERL_EFF_ACCESS_X_OK(POPpx); if (result == 0) RETPUSHYES; if (result < 0) @@ -3020,8 +3100,11 @@ PP(pp_fteexec) PP(pp_ftis) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; RETPUSHYES; @@ -3034,8 +3117,11 @@ PP(pp_fteowned) PP(pp_ftrowned) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? @@ -3046,8 +3132,11 @@ PP(pp_ftrowned) PP(pp_ftzero) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (PL_statcache.st_size == 0) @@ -3057,8 +3146,11 @@ PP(pp_ftzero) PP(pp_ftsize) { - I32 result = my_stat(); + I32 result; dSP; dTARGET; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; #if Off_t_size > IVSIZE @@ -3071,38 +3163,50 @@ PP(pp_ftsize) PP(pp_ftmtime) { - I32 result = my_stat(); + I32 result; dSP; dTARGET; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; - PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 ); + PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 ); RETURN; } PP(pp_ftatime) { - I32 result = my_stat(); + I32 result; dSP; dTARGET; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; - PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 ); + PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 ); RETURN; } PP(pp_ftctime) { - I32 result = my_stat(); + I32 result; dSP; dTARGET; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; - PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 ); + PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 ); RETURN; } PP(pp_ftsock) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (S_ISSOCK(PL_statcache.st_mode)) @@ -3112,8 +3216,11 @@ PP(pp_ftsock) PP(pp_ftchr) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (S_ISCHR(PL_statcache.st_mode)) @@ -3123,8 +3230,11 @@ PP(pp_ftchr) PP(pp_ftblk) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (S_ISBLK(PL_statcache.st_mode)) @@ -3134,8 +3244,11 @@ PP(pp_ftblk) PP(pp_ftfile) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (S_ISREG(PL_statcache.st_mode)) @@ -3145,8 +3258,11 @@ PP(pp_ftfile) PP(pp_ftdir) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (S_ISDIR(PL_statcache.st_mode)) @@ -3156,8 +3272,11 @@ PP(pp_ftdir) PP(pp_ftpipe) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (S_ISFIFO(PL_statcache.st_mode)) @@ -3180,7 +3299,9 @@ PP(pp_ftsuid) { dSP; #ifdef S_ISUID - I32 result = my_stat(); + I32 result; + STACKED_FTEST_CHECK; + result = my_stat(); SPAGAIN; if (result < 0) RETPUSHUNDEF; @@ -3194,7 +3315,9 @@ PP(pp_ftsgid) { dSP; #ifdef S_ISGID - I32 result = my_stat(); + I32 result; + STACKED_FTEST_CHECK; + result = my_stat(); SPAGAIN; if (result < 0) RETPUSHUNDEF; @@ -3208,7 +3331,9 @@ PP(pp_ftsvtx) { dSP; #ifdef S_ISVTX - I32 result = my_stat(); + I32 result; + STACKED_FTEST_CHECK; + result = my_stat(); SPAGAIN; if (result < 0) RETPUSHUNDEF; @@ -3223,8 +3348,9 @@ PP(pp_fttty) dSP; int fd; GV *gv; - char *tmps = Nullch; - STRLEN n_a; + SV *tmpsv = Nullsv; + + STACKED_FTEST_CHECK; if (PL_op->op_flags & OPf_REF) gv = cGVOP_gv; @@ -3233,12 +3359,18 @@ PP(pp_fttty) else if (SvROK(TOPs) && isGV(SvRV(TOPs))) gv = (GV*)SvRV(POPs); else - gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO); + gv = gv_fetchsv(tmpsv = POPs, FALSE, SVt_PVIO); if (GvIO(gv) && IoIFP(GvIOp(gv))) fd = PerlIO_fileno(IoIFP(GvIOp(gv))); - else if (tmps && isDIGIT(*tmps)) - fd = atoi(tmps); + else if (tmpsv && SvOK(tmpsv)) { + STRLEN n_a; + char *tmps = SvPV(tmpsv, n_a); + if (isDIGIT(*tmps)) + fd = atoi(tmps); + else + RETPUSHUNDEF; + } else RETPUSHUNDEF; if (PerlLIO_isatty(fd)) @@ -3268,6 +3400,8 @@ PP(pp_fttext) STRLEN n_a; PerlIO *fp; + STACKED_FTEST_CHECK; + if (PL_op->op_flags & OPf_REF) gv = cGVOP_gv; else if (isGV(TOPs)) @@ -3323,7 +3457,7 @@ PP(pp_fttext) gv = cGVOP_gv; report_evil_fh(gv, GvIO(gv), PL_op->op_type); } - SETERRNO(EBADF,RMS$_IFI); + SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } } @@ -3335,7 +3469,7 @@ PP(pp_fttext) PL_laststype = OP_STAT; sv_setpv(PL_statname, SvPV(sv, n_a)); if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) { - if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n')) + if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n')) Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); RETPUSHUNDEF; } @@ -3652,21 +3786,21 @@ S_dooneliner(pTHX_ char *cmd, char *filename) #define EACCES EPERM #endif if (instr(s, "cannot make")) - SETERRNO(EEXIST,RMS$_FEX); + SETERRNO(EEXIST,RMS_FEX); else if (instr(s, "existing file")) - SETERRNO(EEXIST,RMS$_FEX); + SETERRNO(EEXIST,RMS_FEX); else if (instr(s, "ile exists")) - SETERRNO(EEXIST,RMS$_FEX); + SETERRNO(EEXIST,RMS_FEX); else if (instr(s, "non-exist")) - SETERRNO(ENOENT,RMS$_FNF); + SETERRNO(ENOENT,RMS_FNF); else if (instr(s, "does not exist")) - SETERRNO(ENOENT,RMS$_FNF); + SETERRNO(ENOENT,RMS_FNF); else if (instr(s, "not empty")) - SETERRNO(EBUSY,SS$_DEVOFFLINE); + SETERRNO(EBUSY,SS_DEVOFFLINE); else if (instr(s, "cannot access")) - SETERRNO(EACCES,RMS$_PRV); + SETERRNO(EACCES,RMS_PRV); else - SETERRNO(EPERM,RMS$_PRV); + SETERRNO(EPERM,RMS_PRV); return 0; } else { /* some mkdirs return no failure indication */ @@ -3676,7 +3810,7 @@ S_dooneliner(pTHX_ char *cmd, char *filename) if (anum) SETERRNO(0,0); else - SETERRNO(EACCES,RMS$_PRV); /* a guess */ + SETERRNO(EACCES,RMS_PRV); /* a guess */ } return anum; } @@ -3685,6 +3819,26 @@ S_dooneliner(pTHX_ char *cmd, char *filename) } #endif +/* This macro removes trailing slashes from a directory name. + * Different operating and file systems take differently to + * trailing slashes. According to POSIX 1003.1 1996 Edition + * any number of trailing slashes should be allowed. + * Thusly we snip them away so that even non-conforming + * systems are happy. + * We should probably do this "filtering" for all + * the functions that expect (potentially) directory names: + * -d, chdir(), chmod(), chown(), chroot(), fcntl()?, + * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */ + +#define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV(TOPs, (len)); \ + if ((len) > 1 && (tmps)[(len)-1] == '/') { \ + do { \ + (len)--; \ + } while ((len) > 1 && (tmps)[(len)-1] == '/'); \ + (tmps) = savepvn((tmps), (len)); \ + (copy) = TRUE; \ + } + PP(pp_mkdir) { dSP; dTARGET; @@ -3701,22 +3855,7 @@ PP(pp_mkdir) else mode = 0777; - tmps = SvPV(TOPs, len); - /* Different operating and file systems take differently to - * trailing slashes. According to POSIX 1003.1 1996 Edition - * any number of trailing slashes should be allowed. - * Thusly we snip them away so that even non-conforming - * systems are happy. */ - /* We should probably do this "filtering" for all - * the functions that expect (potentially) directory names: - * -d, chdir(), chmod(), chown(), chroot(), fcntl()?, - * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */ - if (len > 1 && tmps[len-1] == '/') { - while (tmps[len] == '/' && len > 1) - len--; - tmps = savepvn(tmps, len); - copy = TRUE; - } + TRIMSLASHES(tmps,len,copy); TAINT_PROPER("mkdir"); #ifdef HAS_MKDIR @@ -3735,16 +3874,19 @@ PP(pp_mkdir) PP(pp_rmdir) { dSP; dTARGET; + STRLEN len; char *tmps; - STRLEN n_a; + bool copy = FALSE; - tmps = POPpx; + TRIMSLASHES(tmps,len,copy); TAINT_PROPER("rmdir"); #ifdef HAS_RMDIR - XPUSHi( PerlDir_rmdir(tmps) >= 0 ); + SETi( PerlDir_rmdir(tmps) >= 0 ); #else - XPUSHi( dooneliner("rmdir", tmps) ); + SETi( dooneliner("rmdir", tmps) ); #endif + if (copy) + Safefree(tmps); RETURN; } @@ -3770,7 +3912,7 @@ PP(pp_open_dir) RETPUSHYES; nope: if (!errno) - SETERRNO(EBADF,RMS$_DIR); + SETERRNO(EBADF,RMS_DIR); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "opendir"); @@ -3779,59 +3921,52 @@ nope: PP(pp_readdir) { -#if defined(Direntry_t) && defined(HAS_READDIR) - dSP; +#if !defined(Direntry_t) || !defined(HAS_READDIR) + DIE(aTHX_ PL_no_dir_func, "readdir"); +#else #if !defined(I_DIRENT) && !defined(VMS) Direntry_t *readdir (DIR *); #endif + dSP; + + SV *sv; + I32 gimme = GIMME; + GV *gv = (GV *)POPs; register Direntry_t *dp; - GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); - SV *sv; if (!io || !IoDIRP(io)) goto nope; - if (GIMME == G_ARRAY) { - /*SUPPRESS 560*/ - 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 - if (!(IoFLAGS(io) & IOf_UNTAINT)) - SvTAINTED_on(sv); -#endif - XPUSHs(sv_2mortal(sv)); - } - } - else { - if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) - goto nope; + do { + dp = (Direntry_t *)PerlDir_read(IoDIRP(io)); + if (!dp) + break; #ifdef DIRNAMLEN - sv = newSVpvn(dp->d_name, dp->d_namlen); + sv = newSVpvn(dp->d_name, dp->d_namlen); #else - sv = newSVpv(dp->d_name, 0); + sv = newSVpv(dp->d_name, 0); #endif #ifndef INCOMPLETE_TAINTS - if (!(IoFLAGS(io) & IOf_UNTAINT)) - SvTAINTED_on(sv); + if (!(IoFLAGS(io) & IOf_UNTAINT)) + SvTAINTED_on(sv); #endif - XPUSHs(sv_2mortal(sv)); + XPUSHs(sv_2mortal(sv)); } + while (gimme == G_ARRAY); + + if (!dp && gimme != G_ARRAY) + goto nope; + RETURN; nope: if (!errno) - SETERRNO(EBADF,RMS$_ISI); + SETERRNO(EBADF,RMS_ISI); if (GIMME == G_ARRAY) RETURN; else RETPUSHUNDEF; -#else - DIE(aTHX_ PL_no_dir_func, "readdir"); #endif } @@ -3856,7 +3991,7 @@ PP(pp_telldir) RETURN; nope: if (!errno) - SETERRNO(EBADF,RMS$_ISI); + SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "telldir"); @@ -3879,7 +4014,7 @@ PP(pp_seekdir) RETPUSHYES; nope: if (!errno) - SETERRNO(EBADF,RMS$_ISI); + SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "seekdir"); @@ -3900,7 +4035,7 @@ PP(pp_rewinddir) RETPUSHYES; nope: if (!errno) - SETERRNO(EBADF,RMS$_ISI); + SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "rewinddir"); @@ -3930,7 +4065,7 @@ PP(pp_closedir) RETPUSHYES; nope: if (!errno) - SETERRNO(EBADF,RMS$_IFI); + SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "closedir"); @@ -3958,6 +4093,9 @@ PP(pp_fork) sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid()); SvREADONLY_on(GvSV(tmpgv)); } +#ifdef THREADS_HAVE_PIDS + PL_ppid = (IV)getppid(); +#endif hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */ } PUSHi(childpid); @@ -3987,13 +4125,14 @@ PP(pp_wait) Pid_t childpid; int argflags; -#ifdef PERL_OLD_SIGNALS - childpid = wait4pid(-1, &argflags, 0); -#else - while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && errno == EINTR) { - PERL_ASYNC_CHECK(); + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) + childpid = wait4pid(-1, &argflags, 0); + else { + while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && + errno == EINTR) { + PERL_ASYNC_CHECK(); + } } -#endif # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) /* 0 and -1 are both error returns (the former applies to WNOHANG case) */ STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1); @@ -4011,26 +4150,28 @@ PP(pp_waitpid) { #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) dSP; dTARGET; - Pid_t childpid; + Pid_t pid; + Pid_t result; int optype; int argflags; optype = POPi; - childpid = TOPi; -#ifdef PERL_OLD_SIGNALS - childpid = wait4pid(childpid, &argflags, optype); -#else - while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && errno == EINTR) { - PERL_ASYNC_CHECK(); + pid = TOPi; + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) + result = wait4pid(pid, &argflags, optype); + else { + while ((result = wait4pid(pid, &argflags, optype)) == -1 && + errno == EINTR) { + PERL_ASYNC_CHECK(); + } } -#endif # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) /* 0 and -1 are both error returns (the former applies to WNOHANG case) */ - STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1); + STATUS_NATIVE_SET((result && result != -1) ? argflags : -1); # else - STATUS_NATIVE_SET((childpid > 0) ? argflags : -1); + STATUS_NATIVE_SET((result > 0) ? argflags : -1); # endif - SETi(childpid); + SETi(result); RETURN; #else DIE(aTHX_ PL_no_func, "waitpid"); @@ -4053,14 +4194,7 @@ PP(pp_system) break; } MARK = ORIGMARK; - /* XXX Remove warning at end of deprecation cycle --RD 2002-02 */ - if (SP - MARK == 1) { - TAINT_PROPER("system"); - } - else if (ckWARN2(WARN_TAINT, WARN_DEPRECATED)) { - Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED), - "Use of tainted arguments in %s is deprecated", "system"); - } + TAINT_PROPER("system"); } PERL_FLUSHALL_FOR_CHILD; #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO) @@ -4148,10 +4282,19 @@ PP(pp_system) result = 0; if (PL_op->op_flags & OPf_STACKED) { SV *really = *++MARK; +# if defined(WIN32) || defined(OS2) + value = (I32)do_aspawn(really, MARK, SP); +# else value = (I32)do_aspawn(really, (void **)MARK, (void **)SP); +# endif } - else if (SP - MARK != 1) + else if (SP - MARK != 1) { +# if defined(WIN32) || defined(OS2) + value = (I32)do_aspawn(Nullsv, MARK, SP); +# else value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP); +# endif + } else { value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a)); } @@ -4179,14 +4322,7 @@ PP(pp_exec) break; } MARK = ORIGMARK; - /* XXX Remove warning at end of deprecation cycle --RD 2002-02 */ - if (SP - MARK == 1) { - TAINT_PROPER("exec"); - } - else if (ckWARN2(WARN_TAINT, WARN_DEPRECATED)) { - Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED), - "Use of tainted arguments in %s is deprecated", "exec"); - } + TAINT_PROPER("exec"); } PERL_FLUSHALL_FOR_CHILD; if (PL_op->op_flags & OPf_STACKED) { @@ -4242,7 +4378,11 @@ PP(pp_getppid) { #ifdef HAS_GETPPID dSP; dTARGET; +# ifdef THREADS_HAVE_PIDS + XPUSHi( PL_ppid ); +# else XPUSHi( getppid() ); +# endif RETURN; #else DIE(aTHX_ PL_no_func, "getppid"); @@ -4347,26 +4487,6 @@ PP(pp_time) RETURN; } -/* XXX The POSIX name is CLK_TCK; it is to be preferred - to HZ. Probably. For now, assume that if the system - defines HZ, it does so correctly. (Will this break - on VMS?) - Probably we ought to use _sysconf(_SC_CLK_TCK), if - it's supported. --AD 9/96. -*/ - -#ifdef __BEOS__ -# define HZ 1000000 -#endif - -#ifndef HZ -# ifdef CLK_TCK -# define HZ CLK_TCK -# else -# define HZ 60 -# endif -#endif - PP(pp_tms) { #ifdef HAS_TIMES @@ -4380,15 +4500,27 @@ PP(pp_tms) /* is returned. */ #endif - PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ))); + PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick))); if (GIMME == G_ARRAY) { - PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ))); - PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ))); - PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ))); + PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick))); + PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick))); + PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick))); } RETURN; #else +# ifdef PERL_MICRO + dSP; + PUSHs(sv_2mortal(newSVnv((NV)0.0))); + EXTEND(SP, 4); + if (GIMME == G_ARRAY) { + PUSHs(sv_2mortal(newSVnv((NV)0.0))); + PUSHs(sv_2mortal(newSVnv((NV)0.0))); + PUSHs(sv_2mortal(newSVnv((NV)0.0))); + } + RETURN; +# else DIE(aTHX_ "times not implemented"); +# endif #endif /* HAS_TIMES */ } @@ -4964,6 +5096,9 @@ PP(pp_gservent) char *proto = POPpbytex; unsigned short port = (unsigned short)POPu; + if (proto && !*proto) + proto = Nullch; + #ifdef HAS_HTONS port = PerlSock_htons(port); #endif @@ -5149,7 +5284,7 @@ PP(pp_gpwent) * AIX getpwnam() is clever enough to return the encrypted password * only if the caller (euid?) is root. * - * There are at least two other shadow password APIs. Many platforms + * There are at least three other shadow password APIs. Many platforms * seem to contain more than one interface for accessing the shadow * password databases, possibly for compatibility reasons. * The getsp*() is by far he simplest one, the other two interfaces @@ -5171,6 +5306,12 @@ PP(pp_gpwent) * char *(getespw*(...).ufld.fd_encrypt) * Mention HAS_GETESPWNAM here so that Configure probes for it. * + * (AIX) + * struct userpw *getuserpw(); + * The password is in + * char *(getuserpw(...)).spw_upw_passwd + * (but the de facto standard getpwnam() should work okay) + * * Mention I_PROT here so that Configure probes for it. * * In HP-UX for getprpw*() the manual page claims that one should include @@ -5193,6 +5334,12 @@ PP(pp_gpwent) * --jhi */ +# if defined(__CYGWIN__) && defined(USE_REENTRANT_API) + /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r(): + * the pw_comment is left uninitialized. */ + PL_reentrant_buffer->_pwent_struct.pw_comment = NULL; +# endif + switch (which) { case OP_GPWNAM: { @@ -5209,6 +5356,9 @@ PP(pp_gpwent) case OP_GPWENT: # ifdef HAS_GETPWENT pwent = getpwent(); +#ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */ + if (pwent) pwent = getpwnam(pwent->pw_name); +#endif # else DIE(aTHX_ PL_no_func, "getpwent"); # endif @@ -5253,7 +5403,9 @@ PP(pp_gpwent) * Divert the urge to writing an extension instead. * * --jhi */ -# ifdef HAS_GETSPNAM + /* Some AIX setups falsely(?) detect some getspnam(), which + * has a different API than the Solaris/IRIX one. */ +# if defined(HAS_GETSPNAM) && !defined(_AIX) { struct spwd *spwent; int saverrno; /* Save and restore errno so that