X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=f9db38e7acc2128afab630b603df70a93532b715;hb=68435ea717a7cd7f41241ff44917b542abd94222;hp=e4ec41ef0383751e32f9f31cc05103351e558d7f;hpb=6b980173bfa6365bee0d03ef9751b9376bcf91f6;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index e4ec41e..f9db38e 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. @@ -77,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 @@ -112,12 +112,6 @@ 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 @@ -247,7 +241,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 @@ -293,7 +287,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; } @@ -411,7 +405,7 @@ PP(pp_indread) PP(pp_rcatline) { - PL_last_in_gv = cGVOP; + PL_last_in_gv = cGVOP_gv; return do_readline(); } @@ -442,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; } @@ -475,7 +469,7 @@ PP(pp_die) HV *stash = SvSTASH(SvRV(error)); GV *gv = gv_fetchmethod(stash, "PROPAGATE"); if (gv) { - SV *file = sv_2mortal(newSVsv(CopFILESV(PL_curcop))); + SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0)); SV *line = sv_2mortal(newSViv(CopLINE(PL_curcop))); EXTEND(SP, 3); PUSHMARK(SP); @@ -500,7 +494,7 @@ PP(pp_die) if (!tmps || !len) tmpsv = sv_2mortal(newSVpvn("Died", 4)); - DIE(aTHX_ "%_", tmpsv); + DIE(aTHX_ "%"SVf, tmpsv); } /* I/O. */ @@ -1095,8 +1089,6 @@ PP(pp_getc) gv = PL_stdingv; else gv = (GV*)POPs; - if (!gv) - gv = PL_argvgv; if (mg = SvTIED_mg((SV*)gv, 'q')) { I32 gimme = GIMME_V; @@ -1138,9 +1130,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 */ @@ -1273,15 +1265,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); } @@ -1354,14 +1346,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; @@ -1631,9 +1623,9 @@ PP(pp_send) length = -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) { @@ -1703,10 +1695,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); @@ -1775,7 +1785,11 @@ PP(pp_sysseek) if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) { PUSHMARK(SP); XPUSHs(SvTIED_obj((SV*)gv, mg)); +#if LSEEKSIZE > IVSIZE + XPUSHs(sv_2mortal(newSVnv((NV) offset))); +#else XPUSHs(sv_2mortal(newSViv((IV) offset))); +#endif XPUSHs(sv_2mortal(newSViv((IV) whence))); PUTBACK; ENTER; @@ -1819,13 +1833,17 @@ PP(pp_truncate) 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; @@ -1968,8 +1986,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 @@ -2014,6 +2036,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 @@ -2064,6 +2089,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 @@ -2122,7 +2151,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 @@ -2152,7 +2181,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 @@ -2178,7 +2207,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 @@ -2226,13 +2255,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: @@ -2259,7 +2291,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 @@ -2338,7 +2370,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; @@ -2411,7 +2445,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; @@ -2437,7 +2474,7 @@ PP(pp_stat) STRLEN n_a; if (PL_op->op_flags & OPf_REF) { - tmpgv = cGVOP; + tmpgv = cGVOP_gv; do_fstat: if (tmpgv != PL_defgv) { PL_laststype = OP_STAT; @@ -2899,7 +2936,7 @@ PP(pp_fttty) STRLEN n_a; if (PL_op->op_flags & OPf_REF) - gv = cGVOP; + gv = cGVOP_gv; else if (isGV(TOPs)) gv = (GV*)POPs; else if (SvROK(TOPs) && isGV(SvRV(TOPs))) @@ -2941,7 +2978,7 @@ PP(pp_fttext) PerlIO *fp; if (PL_op->op_flags & OPf_REF) - gv = cGVOP; + gv = cGVOP_gv; else if (isGV(TOPs)) gv = (GV*)POPs; else if (SvROK(TOPs) && isGV(SvRV(TOPs))) @@ -2990,9 +3027,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)); + GvENAME(gv)); + } SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; } @@ -3337,12 +3376,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 @@ -3576,13 +3622,24 @@ PP(pp_fork) if (!childpid) { /*SUPPRESS 560*/ if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV)) - sv_setiv(GvSV(tmpgv), (IV)getpid()); + 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 } @@ -3768,6 +3825,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; @@ -3812,7 +3875,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 @@ -3842,8 +3905,11 @@ PP(pp_setpgrp) #ifdef BSD_SETPGRP SETi( BSD_SETPGRP(pid, pgrp) >= 0 ); #else - if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid())) + 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;