X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/65eba18fa4db1d6a117170ee75351b16dc792fca..a2bd7410d0183a5974c36ff0549fab8692d0713b:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index d8dc103..cf188f0 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, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 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. @@ -15,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" @@ -176,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 @@ -301,16 +322,16 @@ PP(pp_backtick) STRLEN n_a; char *tmps = POPpx; I32 gimme = GIMME_V; - char *mode = "r"; + const char *mode = "r"; TAINT_PROPER("``"); 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); + fp = PerlProc_popen(tmps, (char *)mode); if (fp) { - char *type = NULL; + const char *type = NULL; if (PL_curcop->cop_io) { type = SvPV_nolen(PL_curcop->cop_io); } @@ -324,13 +345,14 @@ PP(pp_backtick) ; } else if (gimme == G_SCALAR) { - SV *oldrs = PL_rs; + ENTER; + SAVESPTR(PL_rs); PL_rs = &PL_sv_undef; sv_setpv(TARG, ""); /* note that this preserves previous buffer */ while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch) /*SUPPRESS 530*/ ; - PL_rs = oldrs; + LEAVE; XPUSHs(TARG); SvTAINTED_on(TARG); } @@ -411,7 +433,7 @@ PP(pp_warn) { dSP; dMARK; SV *tmpsv; - char *tmps; + const char *tmps; STRLEN len; if (SP - MARK != 1) { dTARGET; @@ -441,7 +463,7 @@ PP(pp_warn) PP(pp_die) { dSP; dMARK; - char *tmps; + const char *tmps; SV *tmpsv; STRLEN len; bool multiarg = 0; @@ -483,7 +505,7 @@ PP(pp_die) sv_setsv(error,*PL_stack_sp--); } } - DIE(aTHX_ Nullformat); + DIE_NULL; } else { if (SvPOK(error) && SvCUR(error)) @@ -609,8 +631,8 @@ PP(pp_pipe_op) if (PerlProc_pipe(fd) < 0) goto badexit; - IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPESOCK_MODE); - IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPESOCK_MODE); + 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; @@ -768,7 +790,7 @@ PP(pp_tie) GV *gv; SV *sv; I32 markoff = MARK - PL_stack_base; - char *methname; + const char *methname; int how = PERL_MAGIC_tied; U32 items; @@ -1024,15 +1046,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]; @@ -1231,9 +1257,9 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) ENTER; SAVETMPS; - push_return(retop); PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp); PUSHFORMAT(cx); + cx->blk_sub.retop = retop; PAD_SET_CUR(CvPADLIST(cv), 1); setdefout(gv); /* locally select filehandle so $% et al work */ @@ -1311,17 +1337,17 @@ 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"); + IoTOP_NAME(io) = savepvn("top", 3); } topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM); if (!topgv || !GvFORM(topgv)) { - IoLINES_LEFT(io) = 100000000; + IoLINES_LEFT(io) = IoPAGE_LEN(io); goto forget_top; } IoTOP_GV(io) = topgv; @@ -1409,7 +1435,7 @@ PP(pp_leavewrite) /* bad_ofp: */ PL_formtarget = PL_bodytarget; PUTBACK; - return pop_return(); + return cx->blk_sub.retop; } PP(pp_prtf) @@ -1530,6 +1556,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; @@ -1575,11 +1603,13 @@ PP(pp_sysread) } 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"); @@ -1640,15 +1670,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, (STRLEN)(length + 1)); + } if (PL_op->op_type == OP_SYSREAD) { #ifdef PERL_SOCK_SYSREAD_IS_RECV @@ -1688,9 +1740,9 @@ PP(pp_sysread) 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; @@ -1726,6 +1778,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)) @@ -1804,12 +1861,19 @@ PP(pp_send) } 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) { @@ -1904,7 +1968,7 @@ PP(pp_eof) 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); + do_open(gv, (char *)"-", 1, FALSE, O_RDONLY, 0, Nullfp); sv_setpvn(GvSV(gv), "-", 1); SvSETMAGIC(GvSV(gv)); } @@ -2046,15 +2110,13 @@ PP(pp_truncate) * 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) { - 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_gv: if (!GvIO(tmpgv)) @@ -2081,7 +2143,8 @@ PP(pp_truncate) else { SV *sv = POPs; char *name; - + STRLEN n_a; + if (SvTYPE(sv) == SVt_PVGV) { tmpgv = (GV*)sv; /* *main::FRED for example */ goto do_ftruncate_gv; @@ -2121,9 +2184,6 @@ PP(pp_truncate) SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } -#else - DIE(aTHX_ "truncate not implemented"); -#endif } PP(pp_fcntl) @@ -2136,7 +2196,7 @@ PP(pp_ioctl) dSP; dTARGET; SV *argsv = POPs; unsigned int func = POPu; - int optype = PL_op->op_type; + const int optype = PL_op->op_type; char *s; IV retval; GV *gv = (GV*)POPs; @@ -2276,8 +2336,8 @@ PP(pp_socket) fd = PerlSock_socket(domain, type, protocol); if (fd < 0) RETPUSHUNDEF; - IoIFP(io) = PerlIO_fdopen(fd, "r"PIPESOCK_MODE); /* stdio gets confused about sockets */ - IoOFP(io) = PerlIO_fdopen(fd, "w"PIPESOCK_MODE); + 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)); @@ -2338,11 +2398,11 @@ PP(pp_sockpair) TAINT_PROPER("socketpair"); if (PerlSock_socketpair(domain, type, protocol, fd) < 0) RETPUSHUNDEF; - IoIFP(io1) = PerlIO_fdopen(fd[0], "r"PIPESOCK_MODE); - IoOFP(io1) = PerlIO_fdopen(fd[0], "w"PIPESOCK_MODE); + 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"PIPESOCK_MODE); - IoOFP(io2) = PerlIO_fdopen(fd[1], "w"PIPESOCK_MODE); + 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)); @@ -2513,8 +2573,8 @@ PP(pp_accept) goto badexit; if (IoIFP(nstio)) do_close(ngv, FALSE); - IoIFP(nstio) = PerlIO_fdopen(fd, "r"PIPESOCK_MODE); - IoOFP(nstio) = PerlIO_fdopen(fd, "w"PIPESOCK_MODE); + 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)); @@ -2783,12 +2843,10 @@ PP(pp_stat) } sv_setpv(PL_statname, SvPV(sv,n_a)); PL_statgv = Nullgv; -#ifdef HAS_LSTAT PL_laststype = PL_op->op_type; if (PL_op->op_type == OP_LSTAT) PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache); else -#endif PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache); if (PL_laststatval < 0) { if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n')) @@ -2858,13 +2916,23 @@ 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_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { + STRLEN n_a; result = access(POPpx, R_OK); if (result == 0) RETPUSHYES; @@ -2889,9 +2957,10 @@ PP(pp_ftrwrite) { I32 result; dSP; + STACKED_FTEST_CHECK; #if defined(HAS_ACCESS) && defined(W_OK) - STRLEN n_a; if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { + STRLEN n_a; result = access(POPpx, W_OK); if (result == 0) RETPUSHYES; @@ -2916,9 +2985,10 @@ PP(pp_ftrexec) { I32 result; dSP; + STACKED_FTEST_CHECK; #if defined(HAS_ACCESS) && defined(X_OK) - STRLEN n_a; if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { + STRLEN n_a; result = access(POPpx, X_OK); if (result == 0) RETPUSHYES; @@ -2943,9 +3013,10 @@ PP(pp_fteread) { I32 result; dSP; + STACKED_FTEST_CHECK; #ifdef PERL_EFF_ACCESS_R_OK - STRLEN n_a; if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { + STRLEN n_a; result = PERL_EFF_ACCESS_R_OK(POPpx); if (result == 0) RETPUSHYES; @@ -2970,9 +3041,10 @@ PP(pp_ftewrite) { I32 result; dSP; + STACKED_FTEST_CHECK; #ifdef PERL_EFF_ACCESS_W_OK - STRLEN n_a; if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { + STRLEN n_a; result = PERL_EFF_ACCESS_W_OK(POPpx); if (result == 0) RETPUSHYES; @@ -2997,9 +3069,10 @@ PP(pp_fteexec) { I32 result; dSP; + STACKED_FTEST_CHECK; #ifdef PERL_EFF_ACCESS_X_OK - STRLEN n_a; if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { + STRLEN n_a; result = PERL_EFF_ACCESS_X_OK(POPpx); if (result == 0) RETPUSHYES; @@ -3022,8 +3095,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; @@ -3036,8 +3112,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 ? @@ -3048,8 +3127,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) @@ -3059,8 +3141,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 @@ -3073,38 +3158,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)) @@ -3114,8 +3211,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)) @@ -3125,8 +3225,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)) @@ -3136,8 +3239,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)) @@ -3147,8 +3253,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)) @@ -3158,8 +3267,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)) @@ -3182,7 +3294,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; @@ -3196,7 +3310,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; @@ -3210,7 +3326,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; @@ -3225,8 +3343,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; @@ -3235,12 +3354,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)) @@ -3270,6 +3395,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)) @@ -3333,7 +3460,6 @@ PP(pp_fttext) sv = POPs; really_filename: PL_statgv = Nullgv; - PL_laststatval = -1; PL_laststype = OP_STAT; sv_setpv(PL_statname, SvPV(sv, n_a)); if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) { @@ -3789,48 +3915,43 @@ 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)))) { + 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)); - } - } - else { - if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) - goto nope; -#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)); + XPUSHs(sv_2mortal(sv)); } + while (gimme == G_ARRAY); + + if (!dp && gimme != G_ARRAY) + goto nope; + RETURN; nope: @@ -3840,8 +3961,6 @@ nope: RETURN; else RETPUSHUNDEF; -#else - DIE(aTHX_ PL_no_dir_func, "readdir"); #endif } @@ -4025,27 +4144,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; + pid = TOPi; if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) - childpid = wait4pid(childpid, &argflags, optype); + result = wait4pid(pid, &argflags, optype); else { - while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && + while ((result = wait4pid(pid, &argflags, optype)) == -1 && errno == EINTR) { PERL_ASYNC_CHECK(); } } # 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"); @@ -4407,9 +4527,9 @@ PP(pp_gmtime) { dSP; Time_t when; - struct tm *tmbuf; - static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}; - static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun", + const struct tm *tmbuf; + static const char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}; + static const char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; if (MAXARG < 1) @@ -5158,7 +5278,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 @@ -5180,6 +5300,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 @@ -5202,6 +5328,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: { @@ -5265,7 +5397,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 @@ -5729,3 +5863,13 @@ lockf_emulate_flock(int fd, int operation) } #endif /* LOCKF_EMULATE_FLOCK */ + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * vim: shiftwidth=4: +*/