X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/5b468f54a26b6cc5b994509b89b4ae0df54ab101..6fa35b067dd6fd8e20b4b357a4dc01750b05b084:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index cdcbc93..f8764c7 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -1,6 +1,6 @@ /* pp_sys.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (c) 1991-2002, 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. @@ -433,6 +433,9 @@ PP(pp_die) SV *tmpsv; STRLEN len; bool multiarg = 0; +#ifdef VMS + VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); +#endif if (SP - MARK != 1) { dTARGET; do_join(TARG, &PL_sv_no, MARK, SP); @@ -468,7 +471,7 @@ PP(pp_die) sv_setsv(error,*PL_stack_sp--); } } - DIE(aTHX_ Nullch); + DIE(aTHX_ Nullformat); } else { if (SvPOK(error) && SvCUR(error)) @@ -835,24 +838,26 @@ PP(pp_untie) SV *obj = SvRV(mg->mg_obj); GV *gv; CV *cv = NULL; - if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) && - isGV(gv) && (cv = GvCV(gv))) { - PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)gv, mg)); - XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1))); - PUTBACK; - ENTER; - call_sv((SV *)cv, G_VOID); - LEAVE; - SPAGAIN; - } - else if (ckWARN(WARN_UNTIE)) { - if (mg && SvREFCNT(obj) > 1) - Perl_warner(aTHX_ WARN_UNTIE, - "untie attempted while %"UVuf" inner references still exist", - (UV)SvREFCNT(obj) - 1 ) ; + if (obj) { + if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) && + isGV(gv) && (cv = GvCV(gv))) { + PUSHMARK(SP); + XPUSHs(SvTIED_obj((SV*)gv, mg)); + XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1))); + PUTBACK; + ENTER; + call_sv((SV *)cv, G_VOID); + LEAVE; + SPAGAIN; + } + else if (ckWARN(WARN_UNTIE)) { + if (mg && SvREFCNT(obj) > 1) + Perl_warner(aTHX_ WARN_UNTIE, + "untie attempted while %"UVuf" inner references still exist", + (UV)SvREFCNT(obj) - 1 ) ; + } } - sv_unmagic(sv, how); + sv_unmagic(sv, how) ; } RETPUSHYES; } @@ -1514,6 +1519,9 @@ PP(pp_sysread) int fp_utf8; Size_t got = 0; Size_t wanted; + bool charstart = FALSE; + STRLEN charskip = 0; + STRLEN skip = 0; gv = (GV*)*++MARK; if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) @@ -1560,6 +1568,10 @@ PP(pp_sysread) DIE(aTHX_ "Negative length"); wanted = length; + charstart = TRUE; + charskip = 0; + skip = 0; + #ifdef HAS_SOCKET if (PL_op->op_type == OP_RECV) { char namebuf[MAXPATHLEN]; @@ -1680,23 +1692,30 @@ PP(pp_sysread) /* Look at utf8 we got back and count the characters */ char *bend = buffer + count; while (buffer < bend) { - STRLEN skip = UTF8SKIP(buffer); - if (buffer+skip > bend) { + if (charstart) { + skip = UTF8SKIP(buffer); + charskip = 0; + } + if (buffer - charskip + skip > bend) { /* partial character - try for rest of it */ length = skip - (bend-buffer); offset = bend - SvPVX(bufsv); + charstart = FALSE; + charskip += count; goto more_bytes; } else { got++; buffer += skip; + charstart = TRUE; + charskip = 0; } } /* If we have not 'got' the number of _characters_ we 'wanted' get some more provided amount read (count) was what was requested (length) */ if (got < wanted && count == length) { - length = (wanted-got); + length = wanted - got; offset = bend - SvPVX(bufsv); goto more_bytes; } @@ -1846,6 +1865,8 @@ PP(pp_send) if (retval < 0) goto say_undef; SP = ORIGMARK; + if (DO_UTF8(bufsv)) + retval = utf8_length((U8*)buffer, (U8*)buffer + retval); #if Size_t_size > IVSIZE PUSHn(retval); #else @@ -2047,7 +2068,7 @@ PP(pp_truncate) else { SV *sv = POPs; char *name; - + if (SvTYPE(sv) == SVt_PVGV) { tmpgv = (GV*)sv; /* *main::FRED for example */ goto do_ftruncate; @@ -2150,7 +2171,7 @@ PP(pp_ioctl) if (SvPOK(argsv)) { if (s[SvCUR(argsv)] != 17) DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument", - PL_op_name[optype]); + OP_NAME(PL_op)); s[SvCUR(argsv)] = 0; /* put our null back */ SvSETMAGIC(argsv); /* Assume it has changed */ } @@ -2261,7 +2282,7 @@ PP(pp_socket) PP(pp_sockpair) { -#ifdef HAS_SOCKETPAIR +#if defined (HAS_SOCKETPAIR) || defined (HAS_SOCKET) dSP; GV *gv1; GV *gv2; @@ -2450,6 +2471,7 @@ 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; @@ -2464,14 +2486,17 @@ PP(pp_accept) goto nuts; nstio = GvIOn(ngv); - if (IoIFP(nstio)) - do_close(ngv, FALSE); - fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len); if (fd < 0) goto badexit; + if (IoIFP(nstio)) + do_close(ngv, FALSE); IoIFP(nstio) = PerlIO_fdopen(fd, "r"); - IoOFP(nstio) = PerlIO_fdopen(fd, "w"); + /* 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"); IoTYPE(nstio) = IoTYPE_SOCKET; if (!IoIFP(nstio) || !IoOFP(nstio)) { if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio)); @@ -2481,6 +2506,7 @@ 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 @@ -3375,27 +3401,30 @@ PP(pp_chdir) SV **svp; STRLEN n_a; - if (MAXARG < 1) - tmps = Nullch; + if( MAXARG == 1 ) + tmps = POPpx; else - tmps = POPpx; - if (!tmps || !*tmps) { - svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE); - if (svp) - tmps = SvPV(*svp, n_a); - } - if (!tmps || !*tmps) { - svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE); - if (svp) - tmps = SvPV(*svp, n_a); - } + tmps = 0; + + if( !tmps || !*tmps ) { + if ( (svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE)) + || (svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE)) #ifdef VMS - if (!tmps || !*tmps) { - svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE); - if (svp) - tmps = SvPV(*svp, n_a); - } + || (svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE)) #endif + ) + { + if( MAXARG == 1 ) + deprecate("chdir('') or chdir(undef) as chdir()"); + tmps = SvPV(*svp, n_a); + } + else { + PUSHi(0); + TAINT_PROPER("chdir"); + RETURN; + } + } + TAINT_PROPER("chdir"); PUSHi( PerlDir_chdir(tmps) >= 0 ); #ifdef VMS @@ -3493,9 +3522,8 @@ PP(pp_rename) PP(pp_link) { - dSP; #ifdef HAS_LINK - dTARGET; + dSP; dTARGET; STRLEN n_a; char *tmps2 = POPpx; char *tmps = SvPV(TOPs, n_a); @@ -3903,8 +3931,11 @@ PP(pp_fork) RETSETUNDEF; if (!childpid) { /*SUPPRESS 560*/ - if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) + if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) { + SvREADONLY_off(GvSV(tmpgv)); sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid()); + SvREADONLY_on(GvSV(tmpgv)); + } hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */ } PUSHi(childpid); @@ -4006,7 +4037,17 @@ PP(pp_system) Pid_t childpid; int status; Sigsave_t ihand,qhand; /* place to save signals during system() */ - + + if (PL_tainting) { + SV *cmd = NULL; + if (PL_op->op_flags & OPf_STACKED) + cmd = *(MARK + 1); + else if (SP - MARK != 1) + cmd = *SP; + if (cmd && *(SvPV_nolen(cmd)) != '/') + TAINT_ENV(); + } + if (PerlProc_pipe(pp) >= 0) did_pipes = 1; while ((childpid = PerlProc_fork()) == -1) { @@ -4042,7 +4083,7 @@ PP(pp_system) if (did_pipes) { int errkid; int n = 0, n1; - + while (n < sizeof(int)) { n1 = PerlLIO_read(pp[0], (void*)(((char*)&errkid)+n), @@ -4279,6 +4320,10 @@ PP(pp_time) it's supported. --AD 9/96. */ +#ifdef __BEOS__ +# define HZ 1000000 +#endif + #ifndef HZ # ifdef CLK_TCK # define HZ CLK_TCK