X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=77a547edbd17b2c81fb6e04bb7d1dc1e5587fa3a;hb=a97fb7de1c49a8414fac8dd85b621cd0459704e2;hp=6de068f5ce066e8427886fdce726d1906444642c;hpb=6e6ef6b23f1f2cc3827f9559a7259c79757c4116;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index 6de068f..77a547e 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, 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. @@ -422,7 +423,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)) @@ -762,7 +763,6 @@ PP(pp_tie) char *methname; int how = PERL_MAGIC_tied; U32 items; - STRLEN n_a; varsv = *++MARK; switch(SvTYPE(varsv)) { @@ -809,8 +809,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); @@ -875,8 +875,8 @@ PP(pp_untie) (UV)SvREFCNT(obj) - 1 ) ; } } - sv_unmagic(sv, how) ; } + sv_unmagic(sv, how) ; RETPUSHYES; } @@ -1069,12 +1069,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]; @@ -2032,22 +2043,31 @@ PP(pp_truncate) STRLEN n_a; int result = 1; GV *tmpgv; - + IO *io; + 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))) - 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 { @@ -2056,11 +2076,15 @@ PP(pp_truncate) 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); @@ -2151,7 +2175,9 @@ PP(pp_ioctl) #else retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s); #endif +#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", @@ -2456,7 +2482,6 @@ PP(pp_accept) struct sockaddr saddr; /* use a struct to avoid alignment problems */ Sock_size_t len = sizeof saddr; int fd; - int fd2; ggv = (GV*)POPs; ngv = (GV*)POPs; @@ -2477,11 +2502,7 @@ PP(pp_accept) if (IoIFP(nstio)) do_close(ngv, FALSE); IoIFP(nstio) = PerlIO_fdopen(fd, "r"PIPESOCK_MODE); - /* 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"PIPESOCK_MODE); + IoOFP(nstio) = PerlIO_fdopen(fd, "w"PIPESOCK_MODE); IoTYPE(nstio) = IoTYPE_SOCKET; if (!IoIFP(nstio) || !IoOFP(nstio)) { if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio)); @@ -2491,13 +2512,15 @@ 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 */ setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */ #endif +#ifdef __SCO_VERSION__ + len = sizeof saddr; /* OpenUNIX 8 somehow truncates info */ +#endif PUSHp((char *)&saddr, len); RETURN; @@ -2829,8 +2852,8 @@ PP(pp_ftrread) dSP; #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)) { + result = access(POPpx, R_OK); if (result == 0) RETPUSHYES; if (result < 0) @@ -2856,8 +2879,8 @@ PP(pp_ftrwrite) dSP; #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)) { + result = access(POPpx, W_OK); if (result == 0) RETPUSHYES; if (result < 0) @@ -2883,8 +2906,8 @@ PP(pp_ftrexec) dSP; #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)) { + result = access(POPpx, X_OK); if (result == 0) RETPUSHYES; if (result < 0) @@ -2910,8 +2933,8 @@ PP(pp_fteread) dSP; #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)) { + result = PERL_EFF_ACCESS_R_OK(POPpx); if (result == 0) RETPUSHYES; if (result < 0) @@ -2937,8 +2960,8 @@ PP(pp_ftewrite) dSP; #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)) { + result = PERL_EFF_ACCESS_W_OK(POPpx); if (result == 0) RETPUSHYES; if (result < 0) @@ -2964,8 +2987,8 @@ PP(pp_fteexec) dSP; #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)) { + result = PERL_EFF_ACCESS_X_OK(POPpx); if (result == 0) RETPUSHYES; if (result < 0) @@ -3302,7 +3325,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,6 +3675,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; @@ -3668,22 +3711,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-1] == '/' && len > 1) - len--; - tmps = savepvn(tmps, len); - copy = TRUE; - } + TRIMSLASHES(tmps,len,copy); TAINT_PROPER("mkdir"); #ifdef HAS_MKDIR @@ -3702,16 +3730,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; } @@ -3957,13 +3988,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); @@ -3987,13 +4019,14 @@ PP(pp_waitpid) 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(); + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) + childpid = wait4pid(childpid, &argflags, optype); + else { + while ((childpid = wait4pid(childpid, &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); @@ -4111,14 +4144,14 @@ PP(pp_system) result = 0; if (PL_op->op_flags & OPf_STACKED) { SV *really = *++MARK; -# ifdef WIN32 +# 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) { -# ifdef WIN32 +# if defined(WIN32) || defined(OS2) value = (I32)do_aspawn(Nullsv, MARK, SP); # else value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);