X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=ea35136f8e0f6c002dcc111d40eb4d66b96c885f;hb=e089c33fa0594b6903e0709ffd95e3434fc2707a;hp=f7e254274f3f6f21fda71425e883421a79becc25;hpb=497b47a829dd93323de2c7f4f6815ab9f23d6ada;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index f7e2542..ea35136 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -104,11 +104,6 @@ extern int h_errno; # endif #endif -/* Put this after #includes because fork and vfork prototypes may conflict. */ -#ifndef HAS_VFORK -# define vfork fork -#endif - #ifdef HAS_CHSIZE # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */ # undef my_chsize @@ -394,15 +389,6 @@ PP(pp_glob) return result; } -#if 0 /* XXX never used! */ -PP(pp_indread) -{ - STRLEN n_a; - PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO); - return do_readline(); -} -#endif - PP(pp_rcatline) { PL_last_in_gv = cGVOP_gv; @@ -447,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); @@ -482,7 +471,7 @@ PP(pp_die) sv_setsv(error,*PL_stack_sp--); } } - DIE(aTHX_ Nullch); + DIE(aTHX_ Nullformat); } else { if (SvPOK(error) && SvCUR(error)) @@ -506,6 +495,7 @@ PP(pp_open) dTARGET; GV *gv; SV *sv; + IO *io; char *tmps; STRLEN len; MAGIC *mg; @@ -514,13 +504,13 @@ PP(pp_open) gv = (GV *)*++MARK; if (!isGV(gv)) DIE(aTHX_ PL_no_usym, "filehandle"); - if (GvIOp(gv)) + if ((io = GvIOp(gv))) IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; - if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) { + if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { /* Method's args are same as ours ... */ /* ... except handle is replaced by the object */ - *MARK-- = SvTIED_obj((SV*)gv, mg); + *MARK-- = SvTIED_obj((SV*)io, mg); PUSHMARK(MARK); PUTBACK; ENTER; @@ -553,6 +543,7 @@ PP(pp_close) { dSP; GV *gv; + IO *io; MAGIC *mg; if (MAXARG == 0) @@ -560,9 +551,11 @@ PP(pp_close) else gv = (GV*)POPs; - if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) { + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)gv, mg)); + XPUSHs(SvTIED_obj((SV*)io, mg)); PUTBACK; ENTER; call_method("CLOSE", G_SCALAR); @@ -642,9 +635,11 @@ PP(pp_fileno) RETPUSHUNDEF; gv = (GV*)POPs; - if (gv && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) { + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)gv, mg)); + XPUSHs(SvTIED_obj((SV*)io, mg)); PUTBACK; ENTER; call_method("FILENO", G_SCALAR); @@ -699,7 +694,6 @@ PP(pp_binmode) PerlIO *fp; MAGIC *mg; SV *discp = Nullsv; - STRLEN len = 0; if (MAXARG < 1) RETPUSHUNDEF; @@ -709,9 +703,11 @@ PP(pp_binmode) gv = (GV*)POPs; - if (gv && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) { + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)gv, mg)); + XPUSHs(SvTIED_obj((SV*)io, mg)); if (discp) XPUSHs(discp); PUTBACK; @@ -754,18 +750,24 @@ PP(pp_tie) switch(SvTYPE(varsv)) { case SVt_PVHV: methname = "TIEHASH"; + HvEITER((HV *)varsv) = Null(HE *); break; case SVt_PVAV: methname = "TIEARRAY"; break; case SVt_PVGV: -#ifdef GV_SHARED_CHECK - if (GvSHARED((GV*)varsv)) { - Perl_croak(aTHX_ "Attempt to tie shared GV"); +#ifdef GV_UNIQUE_CHECK + if (GvUNIQUE((GV*)varsv)) { + Perl_croak(aTHX_ "Attempt to tie unique GV"); } #endif methname = "TIEHANDLE"; how = PERL_MAGIC_tiedscalar; + /* For tied filehandles, we apply tiedscalar magic to the IO + slot of the GP rather than the GV itself. AMS 20010812 */ + if (!GvIOp(varsv)) + GvIOp(varsv) = newIO(); + varsv = (SV *)GvIOp(varsv); break; default: methname = "TIESCALAR"; @@ -824,12 +826,15 @@ PP(pp_tie) PP(pp_untie) { dSP; + MAGIC *mg; SV *sv = POPs; char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; - MAGIC * mg ; - if ((mg = SvTIED_mg(sv, how))) { + if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv))) + RETPUSHYES; + + if ((mg = SvTIED_mg(sv, how))) { SV *obj = SvRV(mg->mg_obj); GV *gv; CV *cv = NULL; @@ -850,18 +855,21 @@ PP(pp_untie) "untie attempted while %"UVuf" inner references still exist", (UV)SvREFCNT(obj) - 1 ) ; } + sv_unmagic(sv, how); } - sv_unmagic(sv, how); RETPUSHYES; } PP(pp_tied) { dSP; + MAGIC *mg; SV *sv = POPs; char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; - MAGIC *mg; + + if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv))) + RETPUSHUNDEF; if ((mg = SvTIED_mg(sv, how))) { SV *osv = SvTIED_obj(sv, mg); @@ -1124,6 +1132,7 @@ PP(pp_getc) { dSP; dTARGET; GV *gv; + IO *io; MAGIC *mg; if (MAXARG == 0) @@ -1131,10 +1140,12 @@ PP(pp_getc) else gv = (GV*)POPs; - if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) { + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { I32 gimme = GIMME_V; PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)gv, mg)); + XPUSHs(SvTIED_obj((SV*)io, mg)); PUTBACK; ENTER; call_method("GETC", gimme); @@ -1388,7 +1399,9 @@ PP(pp_prtf) else gv = PL_defoutgv; - if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) { + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { if (MARK == ORIGMARK) { MEXTEND(SP, 1); ++MARK; @@ -1396,7 +1409,7 @@ PP(pp_prtf) ++SP; } PUSHMARK(MARK - 1); - *MARK = SvTIED_obj((SV*)gv, mg); + *MARK = SvTIED_obj((SV*)io, mg); PUTBACK; ENTER; call_method("PRINTF", G_SCALAR); @@ -1506,13 +1519,14 @@ PP(pp_sysread) Size_t wanted; gv = (GV*)*++MARK; - if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) && - (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) + if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) + && gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { SV *sv; PUSHMARK(MARK-1); - *MARK = SvTIED_obj((SV*)gv, mg); + *MARK = SvTIED_obj((SV*)io, mg); ENTER; call_method("READ", G_SCALAR); LEAVE; @@ -1734,12 +1748,13 @@ PP(pp_send) gv = (GV*)*++MARK; if (PL_op->op_type == OP_SYSWRITE - && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) + && gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { SV *sv; PUSHMARK(MARK-1); - *MARK = SvTIED_obj((SV*)gv, mg); + *MARK = SvTIED_obj((SV*)io, mg); ENTER; call_method("WRITE", G_SCALAR); LEAVE; @@ -1855,6 +1870,7 @@ PP(pp_eof) { dSP; GV *gv; + IO *io; MAGIC *mg; if (MAXARG == 0) { @@ -1880,9 +1896,11 @@ PP(pp_eof) else gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */ - if (gv && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) { + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)gv, mg)); + XPUSHs(SvTIED_obj((SV*)io, mg)); PUTBACK; ENTER; call_method("EOF", G_SCALAR); @@ -1899,6 +1917,7 @@ PP(pp_tell) { dSP; dTARGET; GV *gv; + IO *io; MAGIC *mg; if (MAXARG == 0) @@ -1906,9 +1925,11 @@ PP(pp_tell) else gv = PL_last_in_gv = (GV*)POPs; - if (gv && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) { + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)gv, mg)); + XPUSHs(SvTIED_obj((SV*)io, mg)); PUTBACK; ENTER; call_method("TELL", G_SCALAR); @@ -1934,6 +1955,7 @@ PP(pp_sysseek) { dSP; GV *gv; + IO *io; int whence = POPi; #if LSEEKSIZE > IVSIZE Off_t offset = (Off_t)SvNVx(POPs); @@ -1944,9 +1966,11 @@ PP(pp_sysseek) gv = PL_last_in_gv = (GV*)POPs; - if (gv && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) { + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)gv, mg)); + XPUSHs(SvTIED_obj((SV*)io, mg)); #if LSEEKSIZE > IVSIZE XPUSHs(sv_2mortal(newSVnv((NV) offset))); #else @@ -2129,7 +2153,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 */ } @@ -2443,12 +2467,11 @@ 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"); IoTYPE(nstio) = IoTYPE_SOCKET; @@ -3354,27 +3377,29 @@ 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); + RETURN; + } + } + TAINT_PROPER("chdir"); PUSHi( PerlDir_chdir(tmps) >= 0 ); #ifdef VMS @@ -3877,7 +3902,7 @@ PP(pp_fork) EXTEND(SP, 1); PERL_FLUSHALL_FOR_CHILD; - childpid = fork(); + childpid = PerlProc_fork(); if (childpid < 0) RETSETUNDEF; if (!childpid) { @@ -3988,7 +4013,7 @@ PP(pp_system) if (PerlProc_pipe(pp) >= 0) did_pipes = 1; - while ((childpid = vfork()) == -1) { + while ((childpid = PerlProc_fork()) == -1) { if (errno != EAGAIN) { value = -1; SP = ORIGMARK; @@ -4016,7 +4041,7 @@ PP(pp_system) (void)rsignal_restore(SIGQUIT, &qhand); #endif STATUS_NATIVE_SET(result == -1 ? -1 : status); - do_execfree(); /* free any memory child malloced on vfork */ + do_execfree(); /* free any memory child malloced on fork */ SP = ORIGMARK; if (did_pipes) { int errkid; @@ -4122,11 +4147,6 @@ PP(pp_exec) #endif } -#if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) - if (value >= 0) - my_exit(value); -#endif - SP = ORIGMARK; PUSHi(value); RETURN; @@ -4324,10 +4344,10 @@ PP(pp_gmtime) else tmbuf = gmtime(&when); - EXTEND(SP, 9); - EXTEND_MORTAL(9); if (GIMME != G_ARRAY) { SV *tsv; + EXTEND(SP, 1); + EXTEND_MORTAL(1); if (!tmbuf) RETPUSHUNDEF; tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d", @@ -4341,7 +4361,9 @@ PP(pp_gmtime) PUSHs(sv_2mortal(tsv)); } else if (tmbuf) { - PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec))); + EXTEND(SP, 9); + EXTEND_MORTAL(9); + PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec))); PUSHs(sv_2mortal(newSViv(tmbuf->tm_min))); PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour))); PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));