X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=23664908109e86276f54b3c3db2919d49c806e8d;hb=d1ca9ea32e7b8d5812a70687974b0e642057ff99;hp=18c860bc7f8438ce7b21e6fd862123a562e90c01;hpb=89261a6c6a337d08799db0ac0d518e62472ccf40;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index 18c860b..2366490 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -87,7 +87,7 @@ extern int h_errno; #ifndef getpwent struct passwd *getpwent (void); #elif defined (VMS) && defined (my_getpwent) - struct passwd *Perl_my_getpwent (void); + struct passwd *Perl_my_getpwent (pTHX); #endif # endif #endif @@ -339,7 +339,7 @@ PP(pp_backtick) mode = "rb"; else if (PL_op->op_private & OPpOPEN_IN_CRLF) mode = "rt"; - fp = PerlProc_popen((char*)tmps, (char *)mode); + fp = PerlProc_popen(tmps, mode); if (fp) { const char *type = NULL; if (PL_curcop->cop_io) { @@ -378,11 +378,11 @@ PP(pp_backtick) SvTAINTED_on(sv); } } - STATUS_NATIVE_SET(PerlProc_pclose(fp)); + STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp)); TAINT; /* "I believe that this is not gratuitous!" */ } else { - STATUS_NATIVE_SET(-1); + STATUS_NATIVE_CHILD_SET(-1); if (gimme == G_SCALAR) RETPUSHUNDEF; } @@ -511,13 +511,16 @@ PP(pp_die) sv_setsv(error,*PL_stack_sp--); } } - DIE_NULL; + DIE(aTHX_ Nullch); } else { if (SvPOK(error) && SvCUR(error)) sv_catpv(error, "\t...propagated"); tmpsv = error; - tmps = SvPV_const(tmpsv, len); + if (SvOK(tmpsv)) + tmps = SvPV_const(tmpsv, len); + else + tmps = Nullch; } } if (!tmps || !len) @@ -564,11 +567,11 @@ PP(pp_open) sv = *++MARK; } else { - sv = GvSV(gv); + sv = GvSVn(gv); } tmps = SvPV_const(sv, len); - ok = do_openn(gv, (char *)tmps, len, FALSE, O_RDONLY, 0, Nullfp, MARK+1, (SP-MARK)); + ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, MARK+1, (SP-MARK)); SP = ORIGMARK; if (ok) PUSHi( (I32)PL_forkprocess ); @@ -904,8 +907,7 @@ PP(pp_untie) LEAVE; SPAGAIN; } - else if (ckWARN(WARN_UNTIE)) { - if (mg && SvREFCNT(obj) > 1) + else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) { Perl_warner(aTHX_ packWARN(WARN_UNTIE), "untie attempted while %"UVuf" inner references still exist", (UV)SvREFCNT(obj) - 1 ) ; @@ -1104,7 +1106,7 @@ PP(pp_sselect) #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 s = SvPVX(sv); - New(403, fd_sets[i], growsize, char); + Newx(fd_sets[i], growsize, char); for (offset = 0; offset < growsize; offset += masksize) { for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) fd_sets[i][j+offset] = s[(k % masksize) + offset]; @@ -1146,10 +1148,7 @@ PP(pp_sselect) } } - if (nfound == -1) - PUSHs(&PL_sv_undef); - else - PUSHi(nfound); + PUSHi(nfound); if (GIMME == G_ARRAY && tbuf) { value = (NV)(timebuf.tv_sec) + (NV)(timebuf.tv_usec) / 1000000.0; @@ -1229,8 +1228,8 @@ PP(pp_getc) RETURN; } if (!gv || do_eof(gv)) { /* make sure we have fp with something */ - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED) - && (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))) + if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY)) + && ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; @@ -1270,7 +1269,8 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp); PUSHFORMAT(cx); cx->blk_sub.retop = retop; - PAD_SET_CUR(CvPADLIST(cv), 1); + SAVECOMPPAD(); + PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); setdefout(gv); /* locally select filehandle so $% et al work */ return CvSTART(cv); @@ -1330,8 +1330,6 @@ PP(pp_leavewrite) SV **newsp; I32 gimme; register PERL_CONTEXT *cx; - PERL_UNUSED_VAR(newsp); - PERL_UNUSED_VAR(gimme); DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n", (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget))); @@ -1445,6 +1443,8 @@ PP(pp_leavewrite) /* bad_ofp: */ PL_formtarget = PL_bodytarget; PUTBACK; + PERL_UNUSED_VAR(newsp); + PERL_UNUSED_VAR(gimme); return cx->blk_sub.retop; } @@ -1534,7 +1534,7 @@ PP(pp_sysopen) /* Need TIEHANDLE method ? */ const char * const tmps = SvPV_const(sv, len); /* FIXME? do_open should do const */ - if (do_open(gv, (char*)tmps, len, TRUE, mode, perm, Nullfp)) { + if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) { IoLINES(GvIOp(gv)) = 0; PUSHs(&PL_sv_yes); } @@ -1968,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, (char *)"-", 1, FALSE, O_RDONLY, 0, Nullfp); + do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp); sv_setpvn(GvSV(gv), "-", 1); SvSETMAGIC(GvSV(gv)); } @@ -2757,7 +2757,7 @@ PP(pp_getpeername) static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"; /* If the call succeeded, make sure we don't have a zeroed port/addr */ if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET && - !memcmp((char *)SvPVX_const(sv) + sizeof(u_short), nowhere, + !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere, sizeof(u_short) + sizeof(struct in_addr))) { goto nuts2; } @@ -3539,19 +3539,30 @@ PP(pp_ftbinary) PP(pp_chdir) { dSP; dTARGET; - const char *tmps; - SV **svp; + const char *tmps = 0; + GV *gv = NULL; - if( MAXARG == 1 ) - tmps = POPpconstx; - else - tmps = 0; + if( MAXARG == 1 ) { + SV * const sv = POPs; + if (SvTYPE(sv) == SVt_PVGV) { + gv = (GV*)sv; + } + else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { + gv = (GV*)SvRV(sv); + } + else { + tmps = SvPVx_nolen_const(sv); + } + } + + if( !gv && (!tmps || !*tmps) ) { + HV * const table = GvHVn(PL_envgv); + SV **svp; - if( !tmps || !*tmps ) { - if ( (svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE)) - || (svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE)) + if ( (svp = hv_fetch(table, "HOME", 4, FALSE)) + || (svp = hv_fetch(table, "LOGDIR", 6, FALSE)) #ifdef VMS - || (svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE)) + || (svp = hv_fetch(table, "SYS$LOGIN", 9, FALSE)) #endif ) { @@ -3567,7 +3578,33 @@ PP(pp_chdir) } TAINT_PROPER("chdir"); - PUSHi( PerlDir_chdir(tmps) >= 0 ); + if (gv) { +#ifdef HAS_FCHDIR + IO* const io = GvIO(gv); + if (io) { + if (IoIFP(io)) { + PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0); + } + else if (IoDIRP(io)) { +#ifdef HAS_DIRFD + PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0); +#else + DIE(aTHX_ PL_no_func, "dirfd"); +#endif + } + else { + PUSHi(0); + } + } + else { + PUSHi(0); + } +#else + DIE(aTHX_ PL_no_func, "fchdir"); +#endif + } + else + PUSHi( PerlDir_chdir(tmps) >= 0 ); #ifdef VMS /* Clear the DEFAULT element of ENV so we'll get the new value * in the future. */ @@ -3721,7 +3758,7 @@ S_dooneliner(pTHX_ const char *cmd, const char *filename) PerlIO *myfp; int anum = 1; - New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char); + Newx(cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char); strcpy(cmdline, cmd); strcat(cmdline, " "); for (s = cmdline + strlen(cmdline); *filename; ) { @@ -4112,9 +4149,9 @@ PP(pp_wait) } # 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_CHILD_SET((childpid && childpid != -1) ? argflags : -1); # else - STATUS_NATIVE_SET((childpid > 0) ? argflags : -1); + STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1); # endif XPUSHi(childpid); RETURN; @@ -4144,9 +4181,9 @@ PP(pp_waitpid) } # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) /* 0 and -1 are both error returns (the former applies to WNOHANG case) */ - STATUS_NATIVE_SET((result && result != -1) ? argflags : -1); + STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1); # else - STATUS_NATIVE_SET((result > 0) ? argflags : -1); + STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1); # endif SETi(result); RETURN; @@ -4200,8 +4237,8 @@ PP(pp_system) if (did_pipes) PerlLIO_close(pp[1]); #ifndef PERL_MICRO - rsignal_save(SIGINT, SIG_IGN, &ihand); - rsignal_save(SIGQUIT, SIG_IGN, &qhand); + rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand); + rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand); #endif do { result = wait4pid(childpid, &status, 0); @@ -4210,7 +4247,7 @@ PP(pp_system) (void)rsignal_restore(SIGINT, &ihand); (void)rsignal_restore(SIGQUIT, &qhand); #endif - STATUS_NATIVE_SET(result == -1 ? -1 : status); + STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status); do_execfree(); /* free any memory child malloced on fork */ SP = ORIGMARK; if (did_pipes) { @@ -4230,7 +4267,7 @@ PP(pp_system) if (n != sizeof(int)) DIE(aTHX_ "panic: kid popen errno read"); errno = errkid; /* Propagate errno from kid */ - STATUS_CURRENT = -1; + STATUS_NATIVE_CHILD_SET(-1); } } PUSHi(STATUS_CURRENT); @@ -4276,7 +4313,7 @@ PP(pp_system) } if (PL_statusvalue == -1) /* hint that value must be returned as is */ result = 1; - STATUS_NATIVE_SET(value); + STATUS_NATIVE_CHILD_SET(value); do_execfree(); SP = ORIGMARK; PUSHi(result ? value : STATUS_CURRENT); @@ -4532,14 +4569,16 @@ static struct tm *S_my_localtime (pTHX_ Time_t *tp) * Given that legal timezones are typically between GMT-12 and GMT+12 * we turn back the clock 23 hours before calling the localtime * function, and add those to the return value. This will never cause - * day wrapping problems, since the edge case is Jan *19* + * day wrapping problems, since the edge case is Tue Jan *19* */ T = *tp - 82800; /* 23 hour. allows up to GMT-23 */ P = localtime (&T); P->tm_hour += 23; if (P->tm_hour >= 24) { P->tm_hour -= 24; - P->tm_mday++; + P->tm_mday++; /* 18 -> 19 */ + P->tm_wday++; /* Mon -> Tue */ + P->tm_yday++; /* 18 -> 19 */ } return (P); } /* S_my_localtime */ @@ -4830,7 +4869,7 @@ PP(pp_ghostent) h_errno = PL_reentrant_buffer->_gethostent_errno; # endif #endif - STATUS_NATIVE_SET(h_errno); + STATUS_UNIX_SET(h_errno); } #endif @@ -4941,7 +4980,7 @@ PP(pp_gnetent) h_errno = PL_reentrant_buffer->_getnetent_errno; # endif #endif - STATUS_NATIVE_SET(h_errno); + STATUS_UNIX_SET(h_errno); } #endif