X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=23664908109e86276f54b3c3db2919d49c806e8d;hb=7e8780d0ba18db8e295db218f45a54490a467795;hp=259c926dc33f37b90ad5a1a0fa6d576a9f48ce69;hpb=460c8493c292a94fb1fbfccbd83eba5a346ddffa;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index 259c926..2366490 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -1,7 +1,7 @@ /* pp_sys.c * * Copyright (C) 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 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. @@ -15,6 +15,15 @@ * a rumour and a trouble as of great engines throbbing and labouring. */ +/* This file contains system pp ("push/pop") functions that + * execute the opcodes that make up a perl program. A typical pp function + * expects to find its arguments on the stack, and usually pushes its + * results onto the stack, hence the 'pp' terminology. Each OP structure + * contains a pointer to the relevant pp_foo() function. + * + * By 'system', we mean ops which interact with the OS, such as pp_open(). + */ + #include "EXTERN.h" #define PERL_IN_PP_SYS_C #include "perl.h" @@ -36,12 +45,6 @@ # include #endif -#ifdef HAS_SYSCALL -#ifdef __cplusplus -extern "C" int syscall(unsigned long,...); -#endif -#endif - #ifdef I_SYS_WAIT # include #endif @@ -84,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 @@ -116,6 +119,12 @@ extern int h_errno; # undef my_chsize # endif # define my_chsize PerlLIO_chsize +#else +# ifdef HAS_TRUNCATE +# define my_chsize PerlLIO_chsize +# else +I32 my_chsize(int fd, Off_t length); +# endif #endif #ifdef HAS_FLOCK @@ -164,7 +173,7 @@ extern int h_errno; #endif /* no flock() */ #define ZBTLEN 10 -static char zero_but_true[ZBTLEN + 1] = "0 but true"; +static const char zero_but_true[ZBTLEN + 1] = "0 but true"; #if defined(I_SYS_ACCESS) && !defined(R_OK) # include @@ -192,6 +201,15 @@ void endservent(void); #undef PERL_EFF_ACCESS_W_OK #undef PERL_EFF_ACCESS_X_OK +/* AIX 5.2 and below use mktime for localtime, and defines the edge case + * for time 0x7fffffff to be valid only in UTC. AIX 5.3 provides localtime64 + * available in the 32bit environment, which could warrant Configure + * checks in the future. + */ +#ifdef _AIX +#define LOCALTIME_EDGECASE_BROKEN +#endif + /* F_OK unused: if stat() cannot find it... */ #if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK) @@ -300,6 +318,8 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) STATIC int S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) { + (void)path; + (void)mode; Perl_croak(aTHX_ "switching effective uid is not implemented"); /*NOTREACHED*/ return -1; @@ -310,10 +330,9 @@ PP(pp_backtick) { dSP; dTARGET; PerlIO *fp; - STRLEN n_a; - char *tmps = POPpx; - I32 gimme = GIMME_V; - char *mode = "r"; + const char * const tmps = POPpconstx; + const I32 gimme = GIMME_V; + const char *mode = "r"; TAINT_PROPER("``"); if (PL_op->op_private & OPpOPEN_IN_RAW) @@ -322,9 +341,9 @@ PP(pp_backtick) mode = "rt"; fp = PerlProc_popen(tmps, mode); if (fp) { - char *type = NULL; + const char *type = NULL; if (PL_curcop->cop_io) { - type = SvPV_nolen(PL_curcop->cop_io); + type = SvPV_nolen_const(PL_curcop->cop_io); } if (type && *type) PerlIO_apply_layers(aTHX_ fp,mode,type); @@ -332,42 +351,38 @@ PP(pp_backtick) if (gimme == G_VOID) { char tmpbuf[256]; while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0) - /*SUPPRESS 530*/ ; } else if (gimme == G_SCALAR) { - SV *oldrs = PL_rs; + ENTER; + SAVESPTR(PL_rs); PL_rs = &PL_sv_undef; - sv_setpv(TARG, ""); /* note that this preserves previous buffer */ + sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */ while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch) - /*SUPPRESS 530*/ ; - PL_rs = oldrs; + LEAVE; XPUSHs(TARG); SvTAINTED_on(TARG); } else { - SV *sv; - for (;;) { - sv = NEWSV(56, 79); + SV * const sv = NEWSV(56, 79); if (sv_gets(sv, fp, 0) == Nullch) { SvREFCNT_dec(sv); break; } XPUSHs(sv_2mortal(sv)); if (SvLEN(sv) - SvCUR(sv) > 20) { - SvLEN_set(sv, SvCUR(sv)+1); - Renew(SvPVX(sv), SvLEN(sv), char); + SvPV_shrink_to_cur(sv); } 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; } @@ -377,6 +392,7 @@ PP(pp_backtick) PP(pp_glob) { + dVAR; OP *result; tryAMAGICunTARGET(iter, -1); @@ -423,7 +439,7 @@ PP(pp_warn) { dSP; dMARK; SV *tmpsv; - char *tmps; + const char *tmps; STRLEN len; if (SP - MARK != 1) { dTARGET; @@ -434,14 +450,14 @@ PP(pp_warn) else { tmpsv = TOPs; } - tmps = SvPV(tmpsv, len); + tmps = SvPV_const(tmpsv, len); if ((!tmps || !len) && PL_errgv) { - SV *error = ERRSV; - (void)SvUPGRADE(error, SVt_PV); + SV * const error = ERRSV; + SvUPGRADE(error, SVt_PV); if (SvPOK(error) && SvCUR(error)) sv_catpv(error, "\t...caught"); tmpsv = error; - tmps = SvPV(tmpsv, len); + tmps = SvPV_const(tmpsv, len); } if (!tmps || !len) tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26)); @@ -453,7 +469,7 @@ PP(pp_warn) PP(pp_die) { dSP; dMARK; - char *tmps; + const char *tmps; SV *tmpsv; STRLEN len; bool multiarg = 0; @@ -464,17 +480,17 @@ PP(pp_die) dTARGET; do_join(TARG, &PL_sv_no, MARK, SP); tmpsv = TARG; - tmps = SvPV(tmpsv, len); + tmps = SvPV_const(tmpsv, len); multiarg = 1; SP = MARK + 1; } else { tmpsv = TOPs; - tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len); + tmps = SvROK(tmpsv) ? Nullch : SvPV_const(tmpsv, len); } if (!tmps || !len) { SV *error = ERRSV; - (void)SvUPGRADE(error, SVt_PV); + SvUPGRADE(error, SVt_PV); if (multiarg ? SvROK(error) : SvROK(tmpsv)) { if (!multiarg) SvSetSV(error,tmpsv); @@ -495,13 +511,16 @@ PP(pp_die) sv_setsv(error,*PL_stack_sp--); } } - DIE(aTHX_ Nullformat); + DIE(aTHX_ Nullch); } else { if (SvPOK(error) && SvCUR(error)) sv_catpv(error, "\t...propagated"); tmpsv = error; - tmps = SvPV(tmpsv, len); + if (SvOK(tmpsv)) + tmps = SvPV_const(tmpsv, len); + else + tmps = Nullch; } } if (!tmps || !len) @@ -514,13 +533,13 @@ PP(pp_die) PP(pp_open) { - dSP; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; GV *gv; SV *sv; IO *io; - char *tmps; + const char *tmps; STRLEN len; MAGIC *mg; bool ok; @@ -548,10 +567,10 @@ PP(pp_open) sv = *++MARK; } else { - sv = GvSV(gv); + sv = GvSVn(gv); } - tmps = SvPV(sv, len); + tmps = SvPV_const(sv, len); ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, MARK+1, (SP-MARK)); SP = ORIGMARK; if (ok) @@ -565,7 +584,7 @@ PP(pp_open) PP(pp_close) { - dSP; + dVAR; dSP; GV *gv; IO *io; MAGIC *mg; @@ -650,7 +669,7 @@ badexit: PP(pp_fileno) { - dSP; dTARGET; + dVAR; dSP; dTARGET; GV *gv; IO *io; PerlIO *fp; @@ -688,8 +707,9 @@ PP(pp_fileno) PP(pp_umask) { - dSP; dTARGET; + dSP; #ifdef HAS_UMASK + dTARGET; Mode_t anum; if (MAXARG < 1) { @@ -701,7 +721,7 @@ PP(pp_umask) TAINT_PROPER("umask"); XPUSHi(anum); #else - /* Only DIE if trying to restrict permissions on `user' (self). + /* Only DIE if trying to restrict permissions on "user" (self). * Otherwise it's harmless and more useful to just return undef * since 'group' and 'other' concepts probably don't exist here. */ if (MAXARG >= 1 && (POPi & 0700)) @@ -713,7 +733,7 @@ PP(pp_umask) PP(pp_binmode) { - dSP; + dVAR; dSP; GV *gv; IO *io; PerlIO *fp; @@ -753,11 +773,11 @@ PP(pp_binmode) PUTBACK; if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp), - (discp) ? SvPV_nolen(discp) : Nullch)) { + (discp) ? SvPV_nolen_const(discp) : Nullch)) { if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { if (!PerlIO_binmode(aTHX_ IoOFP(io),IoTYPE(io), mode_from_discipline(discp), - (discp) ? SvPV_nolen(discp) : Nullch)) { + (discp) ? SvPV_nolen_const(discp) : Nullch)) { SPAGAIN; RETPUSHUNDEF; } @@ -773,14 +793,13 @@ PP(pp_binmode) PP(pp_tie) { - dSP; - dMARK; + dVAR; dSP; dMARK; SV *varsv; HV* stash; GV *gv; SV *sv; - I32 markoff = MARK - PL_stack_base; - char *methname; + const I32 markoff = MARK - PL_stack_base; + const char *methname; int how = PERL_MAGIC_tied; U32 items; @@ -788,7 +807,7 @@ PP(pp_tie) switch(SvTYPE(varsv)) { case SVt_PVHV: methname = "TIEHASH"; - HvEITER((HV *)varsv) = Null(HE *); + HvEITER_set((HV *)varsv, 0); break; case SVt_PVAV: methname = "TIEARRAY"; @@ -863,17 +882,17 @@ PP(pp_tie) PP(pp_untie) { - dSP; + dVAR; dSP; MAGIC *mg; SV *sv = POPs; - char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) + const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv))) RETPUSHYES; if ((mg = SvTIED_mg(sv, how))) { - SV *obj = SvRV(SvTIED_obj(sv, mg)); + SV * const obj = SvRV(SvTIED_obj(sv, mg)); GV *gv; CV *cv = NULL; if (obj) { @@ -888,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 ) ; @@ -903,9 +921,9 @@ PP(pp_untie) PP(pp_tied) { dSP; - MAGIC *mg; + const MAGIC *mg; SV *sv = POPs; - char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) + const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv))) @@ -923,14 +941,13 @@ PP(pp_tied) PP(pp_dbmopen) { - dSP; - HV *hv; + dVAR; dSP; dPOPPOPssrl; HV* stash; GV *gv; SV *sv; - hv = (HV*)POPs; + HV * const hv = (HV*)POPs; sv = sv_mortalcopy(&PL_sv_no); sv_setpv(sv, "AnyDBM_File"); @@ -998,7 +1015,6 @@ PP(pp_sselect) struct timeval *tbuf = &timebuf; I32 growsize; char *fd_sets[4]; - STRLEN n_a; #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 I32 masksize; I32 offset; @@ -1014,9 +1030,16 @@ PP(pp_sselect) SP -= 4; for (i = 1; i <= 3; i++) { - if (!SvPOK(SP[i])) + SV *sv = SP[i]; + if (SvOK(sv) && SvREADONLY(sv)) { + if (SvIsCOW(sv)) + sv_force_normal_flags(sv, 0); + if (SvREADONLY(sv)) + DIE(aTHX_ PL_no_modify); + } + if (!SvPOK(sv)) continue; - j = SvCUR(SP[i]); + j = SvCUR(sv); if (maxlen < j) maxlen = j; } @@ -1070,7 +1093,7 @@ PP(pp_sselect) continue; } else if (!SvPOK(sv)) - SvPV_force(sv,n_a); /* force string conversion */ + SvPV_force_nolen(sv); /* force string conversion */ j = SvLEN(sv); if (j < growsize) { Sv_Grow(sv, growsize); @@ -1083,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]; @@ -1151,10 +1174,10 @@ Perl_setdefout(pTHX_ GV *gv) PP(pp_select) { dSP; dTARGET; - GV *newdefout, *egv; + GV *egv; HV *hv; - newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL; + GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL; egv = GvEGV(PL_defoutgv); if (!egv) @@ -1163,7 +1186,7 @@ PP(pp_select) if (! hv) XPUSHs(&PL_sv_undef); else { - GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE); + GV ** const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE); if (gvp && *gvp == egv) { gv_efullname4(TARG, PL_defoutgv, Nullch, TRUE); XPUSHTARG; @@ -1184,20 +1207,15 @@ PP(pp_select) PP(pp_getc) { - dSP; dTARGET; - GV *gv; + dVAR; dSP; dTARGET; IO *io = NULL; MAGIC *mg; - - if (MAXARG == 0) - gv = PL_stdingv; - else - gv = (GV*)POPs; + GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs; if (gv && (io = GvIO(gv)) && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { - I32 gimme = GIMME_V; + const I32 gimme = GIMME_V; PUSHMARK(SP); XPUSHs(SvTIED_obj((SV*)io, mg)); PUTBACK; @@ -1210,18 +1228,18 @@ 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; } TAINT; - sv_setpv(TARG, " "); + sv_setpvn(TARG, " ", 1); *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */ if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) { /* Find out how many bytes the char needs */ - Size_t len = UTF8SKIP(SvPVX(TARG)); + Size_t len = UTF8SKIP(SvPVX_const(TARG)); if (len > 1) { SvGROW(TARG,len+1); len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1); @@ -1241,16 +1259,18 @@ PP(pp_read) STATIC OP * S_doform(pTHX_ CV *cv, GV *gv, OP *retop) { + dVAR; register PERL_CONTEXT *cx; - I32 gimme = GIMME_V; + const I32 gimme = GIMME_V; ENTER; SAVETMPS; - push_return(retop); PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp); PUSHFORMAT(cx); - PAD_SET_CUR(CvPADLIST(cv), 1); + cx->blk_sub.retop = retop; + SAVECOMPPAD(); + PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); setdefout(gv); /* locally select filehandle so $% et al work */ return CvSTART(cv); @@ -1283,14 +1303,14 @@ PP(pp_enterwrite) cv = GvFORM(fgv); if (!cv) { - char *name = NULL; if (fgv) { - SV *tmpsv = sv_newmortal(); + SV * const tmpsv = sv_newmortal(); + const char *name; gv_efullname4(tmpsv, fgv, Nullch, FALSE); - name = SvPV_nolen(tmpsv); + name = SvPV_nolen_const(tmpsv); + if (name && *name) + DIE(aTHX_ "Undefined format \"%s\" called", name); } - if (name && *name) - DIE(aTHX_ "Undefined format \"%s\" called", name); DIE(aTHX_ "Not a format reference"); } if (CvCLONE(cv)) @@ -1302,10 +1322,10 @@ PP(pp_enterwrite) PP(pp_leavewrite) { - dSP; - GV *gv = cxstack[cxstack_ix].blk_sub.gv; - register IO *io = GvIOp(gv); - PerlIO *ofp = IoOFP(io); + dVAR; dSP; + GV * const gv = cxstack[cxstack_ix].blk_sub.gv; + register IO * const io = GvIOp(gv); + PerlIO * const ofp = IoOFP(io); PerlIO *fp; SV **newsp; I32 gimme; @@ -1322,29 +1342,29 @@ PP(pp_leavewrite) CV *cv; if (!IoTOP_GV(io)) { GV *topgv; - SV *topname; if (!IoTOP_NAME(io)) { + SV *topname; if (!IoFMT_NAME(io)) IoFMT_NAME(io) = savepv(GvNAME(gv)); - topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io))); - topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM); + topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv))); + topgv = gv_fetchsv(topname, FALSE, SVt_PVFM); if ((topgv && GvFORM(topgv)) || !gv_fetchpv("top",FALSE,SVt_PVFM)) - IoTOP_NAME(io) = savepv(SvPVX(topname)); + IoTOP_NAME(io) = savesvpv(topname); else - IoTOP_NAME(io) = savepv("top"); + IoTOP_NAME(io) = savepvn("top", 3); } topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM); if (!topgv || !GvFORM(topgv)) { - IoLINES_LEFT(io) = 100000000; + IoLINES_LEFT(io) = IoPAGE_LEN(io); goto forget_top; } IoTOP_GV(io) = topgv; } if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */ I32 lines = IoLINES_LEFT(io); - char *s = SvPVX(PL_formtarget); + const char *s = SvPVX_const(PL_formtarget); if (lines <= 0) /* Yow, header didn't even fit!!! */ goto forget_top; while (lines-- > 0) { @@ -1354,8 +1374,8 @@ PP(pp_leavewrite) s++; } if (s) { - STRLEN save = SvCUR(PL_formtarget); - SvCUR_set(PL_formtarget, s - SvPVX(PL_formtarget)); + const STRLEN save = SvCUR(PL_formtarget); + SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget)); do_print(PL_formtarget, ofp); SvCUR_set(PL_formtarget, save); sv_chop(PL_formtarget, s); @@ -1372,20 +1392,18 @@ PP(pp_leavewrite) if (!fgv) DIE(aTHX_ "bad top format reference"); cv = GvFORM(fgv); - { - char *name = NULL; - if (!cv) { - SV *sv = sv_newmortal(); - gv_efullname4(sv, fgv, Nullch, FALSE); - name = SvPV_nolen(sv); - } + if (!cv) { + SV * const sv = sv_newmortal(); + const char *name; + gv_efullname4(sv, fgv, Nullch, FALSE); + name = SvPV_nolen_const(sv); if (name && *name) - DIE(aTHX_ "Undefined top format \"%s\" called",name); - /* why no: - else - DIE(aTHX_ "Undefined top format called"); - ?*/ + DIE(aTHX_ "Undefined top format \"%s\" called",name); } + /* why no: + else + DIE(aTHX_ "Undefined top format called"); + ?*/ if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); return doform(cv,gv,PL_op); @@ -1425,12 +1443,14 @@ PP(pp_leavewrite) /* bad_ofp: */ PL_formtarget = PL_bodytarget; PUTBACK; - return pop_return(); + PERL_UNUSED_VAR(newsp); + PERL_UNUSED_VAR(gimme); + return cx->blk_sub.retop; } PP(pp_prtf) { - dSP; dMARK; dORIGMARK; + dVAR; dSP; dMARK; dORIGMARK; GV *gv; IO *io; PerlIO *fp; @@ -1505,23 +1525,15 @@ PP(pp_prtf) PP(pp_sysopen) { dSP; - GV *gv; - SV *sv; - char *tmps; + const int perm = (MAXARG > 3) ? POPi : 0666; + const int mode = POPi; + SV * const sv = POPs; + GV * const gv = (GV *)POPs; STRLEN len; - int mode, perm; - - if (MAXARG > 3) - perm = POPi; - else - perm = 0666; - mode = POPi; - sv = POPs; - gv = (GV *)POPs; /* Need TIEHANDLE method ? */ - - tmps = SvPV(sv, len); + const char * const tmps = SvPV_const(sv, len); + /* FIXME? do_open should do const */ if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) { IoLINES(GvIOp(gv)) = 0; PUSHs(&PL_sv_yes); @@ -1534,9 +1546,8 @@ PP(pp_sysopen) PP(pp_sysread) { - dSP; dMARK; dORIGMARK; dTARGET; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; int offset; - GV *gv; IO *io; char *buffer; SSize_t length; @@ -1544,31 +1555,33 @@ PP(pp_sysread) Sock_size_t bufsize; SV *bufsv; STRLEN blen; - MAGIC *mg; int fp_utf8; + int buffer_utf8; + SV *read_target; Size_t got = 0; Size_t wanted; bool charstart = FALSE; STRLEN charskip = 0; STRLEN skip = 0; - gv = (GV*)*++MARK; + GV * const gv = (GV*)*++MARK; 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))) + && gv && (io = GvIO(gv)) ) { - SV *sv; - - PUSHMARK(MARK-1); - *MARK = SvTIED_obj((SV*)io, mg); - ENTER; - call_method("READ", G_SCALAR); - LEAVE; - SPAGAIN; - sv = POPs; - SP = ORIGMARK; - PUSHs(sv); - RETURN; + const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar); + if (mg) { + SV *sv; + PUSHMARK(MARK-1); + *MARK = SvTIED_obj((SV*)io, mg); + ENTER; + call_method("READ", G_SCALAR); + LEAVE; + SPAGAIN; + sv = POPs; + SP = ORIGMARK; + PUSHs(sv); + RETURN; + } } if (!gv) @@ -1593,9 +1606,11 @@ PP(pp_sysread) buffer = SvPVutf8_force(bufsv, blen); /* UTF-8 may not have been set if they are all low bytes */ SvUTF8_on(bufsv); + buffer_utf8 = 0; } else { buffer = SvPV_force(bufsv, blen); + buffer_utf8 = !IN_BYTES && SvUTF8(bufsv); } if (length < 0) DIE(aTHX_ "Negative length"); @@ -1656,15 +1671,37 @@ PP(pp_sysread) } if (DO_UTF8(bufsv)) { /* convert offset-as-chars to offset-as-bytes */ - offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer; + if (offset >= (int)blen) + offset += SvCUR(bufsv) - blen; + else + offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer; } more_bytes: bufsize = SvCUR(bufsv); + /* Allocating length + offset + 1 isn't perfect in the case of reading + bytes from a byte file handle into a UTF8 buffer, but it won't harm us + unduly. + (should be 2 * length + offset + 1, or possibly something longer if + PL_encoding is true) */ buffer = SvGROW(bufsv, (STRLEN)(length+offset+1)); - if (offset > bufsize) { /* Zero any newly allocated space */ + if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */ Zero(buffer+bufsize, offset-bufsize, char); } buffer = buffer + offset; + if (!buffer_utf8) { + read_target = bufsv; + } else { + /* Best to read the bytes into a new SV, upgrade that to UTF8, then + concatenate it to the current buffer. */ + + /* Truncate the existing buffer to the start of where we will be + reading to: */ + SvCUR_set(bufsv, offset); + + read_target = sv_newmortal(); + SvUPGRADE(read_target, SVt_PV); + buffer = SvGROW(read_target, (STRLEN)(length + 1)); + } if (PL_op->op_type == OP_SYSREAD) { #ifdef PERL_SOCK_SYSREAD_IS_RECV @@ -1704,12 +1741,12 @@ PP(pp_sysread) report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY); goto say_undef; } - SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv))); - *SvEND(bufsv) = '\0'; - (void)SvPOK_only(bufsv); + SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target))); + *SvEND(read_target) = '\0'; + (void)SvPOK_only(read_target); if (fp_utf8 && !IN_BYTES) { /* Look at utf8 we got back and count the characters */ - char *bend = buffer + count; + const char *bend = buffer + count; while (buffer < bend) { if (charstart) { skip = UTF8SKIP(buffer); @@ -1718,7 +1755,7 @@ PP(pp_sysread) if (buffer - charskip + skip > bend) { /* partial character - try for rest of it */ length = skip - (bend-buffer); - offset = bend - SvPVX(bufsv); + offset = bend - SvPVX_const(bufsv); charstart = FALSE; charskip += count; goto more_bytes; @@ -1735,13 +1772,18 @@ PP(pp_sysread) */ if (got < wanted && count == length) { length = wanted - got; - offset = bend - SvPVX(bufsv); + offset = bend - SvPVX_const(bufsv); goto more_bytes; } /* return value is character count */ count = got; SvUTF8_on(bufsv); } + else if (buffer_utf8) { + /* Let svcatsv upgrade the bytes we read in to utf8. + The buffer is a mortal so will be freed soon. */ + sv_catsv_nomg(bufsv, read_target); + } SvSETMAGIC(bufsv); /* This should not be marked tainted if the fp is marked clean */ if (!(IoFLAGS(io) & IOf_UNTAINT)) @@ -1757,8 +1799,8 @@ PP(pp_sysread) PP(pp_syswrite) { - dSP; - int items = (SP - PL_stack_base) - TOPMARK; + dVAR; dSP; + const int items = (SP - PL_stack_base) - TOPMARK; if (items == 2) { SV *sv; EXTEND(SP, 1); @@ -1771,11 +1813,11 @@ PP(pp_syswrite) PP(pp_send) { - dSP; dMARK; dORIGMARK; dTARGET; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; GV *gv; IO *io; SV *bufsv; - char *buffer; + const char *buffer; Size_t length; SSize_t retval; STRLEN blen; @@ -1820,7 +1862,11 @@ PP(pp_send) } if (PerlIO_isutf8(IoIFP(io))) { - buffer = SvPVutf8(bufsv, blen); + if (!SvUTF8(bufsv)) { + bufsv = sv_2mortal(newSVsv(bufsv)); + buffer = sv_2pvutf8(bufsv, &blen); + } else + buffer = SvPV_const(bufsv, blen); } else { if (DO_UTF8(bufsv)) { @@ -1828,7 +1874,7 @@ PP(pp_send) bufsv = sv_2mortal(newSVsv(bufsv)); sv_utf8_downgrade(bufsv, FALSE); } - buffer = SvPV(bufsv, blen); + buffer = SvPV_const(bufsv, blen); } if (PL_op->op_type == OP_SYSWRITE) { @@ -1850,7 +1896,7 @@ PP(pp_send) if (length > blen - offset) length = blen - offset; if (DO_UTF8(bufsv)) { - buffer = (char*)utf8_hop((U8 *)buffer, offset); + buffer = (const char*)utf8_hop((const U8 *)buffer, offset); length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer; } else { @@ -1871,9 +1917,8 @@ PP(pp_send) } #ifdef HAS_SOCKET else if (SP > MARK) { - char *sockbuf; STRLEN mlen; - sockbuf = SvPVx(*++MARK, mlen); + char * const sockbuf = SvPVx(*++MARK, mlen); /* length is really flags */ retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length, (struct sockaddr *)sockbuf, mlen); @@ -1909,7 +1954,7 @@ PP(pp_recv) PP(pp_eof) { - dSP; + dVAR; dSP; GV *gv; IO *io; MAGIC *mg; @@ -1956,7 +2001,7 @@ PP(pp_eof) PP(pp_tell) { - dSP; dTARGET; + dVAR; dSP; dTARGET; GV *gv; IO *io; MAGIC *mg; @@ -1994,10 +2039,10 @@ PP(pp_seek) PP(pp_sysseek) { - dSP; + dVAR; dSP; GV *gv; IO *io; - int whence = POPi; + const int whence = POPi; #if LSEEKSIZE > IVSIZE Off_t offset = (Off_t)SvNVx(POPs); #else @@ -2065,15 +2110,13 @@ PP(pp_truncate) * might not be signed: if it is not, clever compilers will moan. */ /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */ SETERRNO(0,0); -#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP) { - STRLEN n_a; int result = 1; GV *tmpgv; IO *io; if (PL_op->op_flags & OPf_SPECIAL) { - tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO); + tmpgv = gv_fetchsv(POPs, FALSE, SVt_PVIO); do_ftruncate_gv: if (!GvIO(tmpgv)) @@ -2099,8 +2142,8 @@ PP(pp_truncate) } else { SV *sv = POPs; - char *name; - + const char *name; + if (SvTYPE(sv) == SVt_PVGV) { tmpgv = (GV*)sv; /* *main::FRED for example */ goto do_ftruncate_gv; @@ -2114,7 +2157,7 @@ PP(pp_truncate) goto do_ftruncate_io; } - name = SvPV(sv, n_a); + name = SvPV_nolen_const(sv); TAINT_PROPER("truncate"); #ifdef HAS_TRUNCATE if (truncate(name, len) < 0) @@ -2140,9 +2183,6 @@ PP(pp_truncate) SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } -#else - DIE(aTHX_ "truncate not implemented"); -#endif } PP(pp_fcntl) @@ -2154,8 +2194,8 @@ PP(pp_ioctl) { dSP; dTARGET; SV *argsv = POPs; - unsigned int func = POPu; - int optype = PL_op->op_type; + const unsigned int func = POPu; + const int optype = PL_op->op_type; char *s; IV retval; GV *gv = (GV*)POPs; @@ -2392,7 +2432,8 @@ PP(pp_bind) extern void GETUSERMODE(); #endif SV *addrsv = POPs; - char *addr; + /* OK, so on what platform does bind modify addr? */ + const char *addr; GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); STRLEN len; @@ -2404,7 +2445,7 @@ PP(pp_bind) if (!io || !IoIFP(io)) goto nuts; - addr = SvPV(addrsv, len); + addr = SvPV_const(addrsv, len); TAINT_PROPER("bind"); #ifdef MPE /* Deal with MPE bind() peculiarities */ if (((struct sockaddr *)addr)->sa_family == AF_INET) { @@ -2447,7 +2488,7 @@ PP(pp_connect) #ifdef HAS_SOCKET dSP; SV *addrsv = POPs; - char *addr; + const char *addr; GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); STRLEN len; @@ -2455,7 +2496,7 @@ PP(pp_connect) if (!io || !IoIFP(io)) goto nuts; - addr = SvPV(addrsv, len); + addr = SvPV_const(addrsv, len); TAINT_PROPER("connect"); if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) RETPUSHYES; @@ -2642,16 +2683,16 @@ PP(pp_ssockopt) PUSHs(sv); break; case OP_SSOCKOPT: { - char *buf; + const char *buf; int aint; if (SvPOKp(sv)) { STRLEN l; - buf = SvPV(sv, l); + buf = SvPV_const(sv, l); len = l; } else { aint = (int)SvIV(sv); - buf = (char*)&aint; + buf = (const char*)&aint; len = sizeof(int); } if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0) @@ -2715,8 +2756,8 @@ 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(sv))->sa_family == AF_INET && - !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere, + if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET && + !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere, sizeof(u_short) + sizeof(struct in_addr))) { goto nuts2; } @@ -2760,7 +2801,6 @@ PP(pp_stat) GV *gv; I32 gimme; I32 max = 13; - STRLEN n_a; if (PL_op->op_flags & OPf_REF) { gv = cGVOP_gv; @@ -2777,7 +2817,7 @@ PP(pp_stat) if (gv != PL_defgv) { PL_laststype = OP_STAT; PL_statgv = gv; - sv_setpv(PL_statname, ""); + sv_setpvn(PL_statname, "", 0); PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv)) ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1); } @@ -2800,17 +2840,15 @@ PP(pp_stat) "lstat() on filehandle %s", GvENAME(gv)); goto do_fstat; } - sv_setpv(PL_statname, SvPV(sv,n_a)); + sv_setpv(PL_statname, SvPV_nolen_const(sv)); PL_statgv = Nullgv; -#ifdef HAS_LSTAT PL_laststype = PL_op->op_type; if (PL_op->op_type == OP_LSTAT) - PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache); + PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache); else -#endif - PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache); + PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache); if (PL_laststatval < 0) { - if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n')) + if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n')) Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); max = 0; } @@ -2877,12 +2915,21 @@ PP(pp_stat) RETURN; } +/* This macro is used by the stacked filetest operators : + * if the previous filetest failed, short-circuit and pass its value. + * Else, discard it from the stack and continue. --rgs + */ +#define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \ + if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \ + else { (void)POPs; PUTBACK; } \ + } + PP(pp_ftrread) { I32 result; dSP; + STACKED_FTEST_CHECK; #if defined(HAS_ACCESS) && defined(R_OK) - STRLEN n_a; if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { result = access(POPpx, R_OK); if (result == 0) @@ -2908,8 +2955,8 @@ PP(pp_ftrwrite) { I32 result; dSP; + STACKED_FTEST_CHECK; #if defined(HAS_ACCESS) && defined(W_OK) - STRLEN n_a; if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { result = access(POPpx, W_OK); if (result == 0) @@ -2935,8 +2982,8 @@ PP(pp_ftrexec) { I32 result; dSP; + STACKED_FTEST_CHECK; #if defined(HAS_ACCESS) && defined(X_OK) - STRLEN n_a; if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { result = access(POPpx, X_OK); if (result == 0) @@ -2962,8 +3009,8 @@ PP(pp_fteread) { I32 result; dSP; + STACKED_FTEST_CHECK; #ifdef PERL_EFF_ACCESS_R_OK - STRLEN n_a; if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { result = PERL_EFF_ACCESS_R_OK(POPpx); if (result == 0) @@ -2989,8 +3036,8 @@ PP(pp_ftewrite) { I32 result; dSP; + STACKED_FTEST_CHECK; #ifdef PERL_EFF_ACCESS_W_OK - STRLEN n_a; if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { result = PERL_EFF_ACCESS_W_OK(POPpx); if (result == 0) @@ -3016,8 +3063,8 @@ PP(pp_fteexec) { I32 result; dSP; + STACKED_FTEST_CHECK; #ifdef PERL_EFF_ACCESS_X_OK - STRLEN n_a; if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { result = PERL_EFF_ACCESS_X_OK(POPpx); if (result == 0) @@ -3041,8 +3088,11 @@ PP(pp_fteexec) PP(pp_ftis) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; RETPUSHYES; @@ -3055,8 +3105,11 @@ PP(pp_fteowned) PP(pp_ftrowned) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? @@ -3067,8 +3120,11 @@ PP(pp_ftrowned) PP(pp_ftzero) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (PL_statcache.st_size == 0) @@ -3078,8 +3134,11 @@ PP(pp_ftzero) PP(pp_ftsize) { - I32 result = my_stat(); + I32 result; dSP; dTARGET; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; #if Off_t_size > IVSIZE @@ -3092,8 +3151,11 @@ PP(pp_ftsize) PP(pp_ftmtime) { - I32 result = my_stat(); + I32 result; dSP; dTARGET; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 ); @@ -3102,8 +3164,11 @@ PP(pp_ftmtime) PP(pp_ftatime) { - I32 result = my_stat(); + I32 result; dSP; dTARGET; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 ); @@ -3112,8 +3177,11 @@ PP(pp_ftatime) PP(pp_ftctime) { - I32 result = my_stat(); + I32 result; dSP; dTARGET; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 ); @@ -3122,8 +3190,11 @@ PP(pp_ftctime) PP(pp_ftsock) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (S_ISSOCK(PL_statcache.st_mode)) @@ -3133,8 +3204,11 @@ PP(pp_ftsock) PP(pp_ftchr) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (S_ISCHR(PL_statcache.st_mode)) @@ -3144,8 +3218,11 @@ PP(pp_ftchr) PP(pp_ftblk) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (S_ISBLK(PL_statcache.st_mode)) @@ -3155,8 +3232,11 @@ PP(pp_ftblk) PP(pp_ftfile) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (S_ISREG(PL_statcache.st_mode)) @@ -3166,8 +3246,11 @@ PP(pp_ftfile) PP(pp_ftdir) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (S_ISDIR(PL_statcache.st_mode)) @@ -3177,8 +3260,11 @@ PP(pp_ftdir) PP(pp_ftpipe) { - I32 result = my_stat(); + I32 result; dSP; + STACKED_FTEST_CHECK; + result = my_stat(); + SPAGAIN; if (result < 0) RETPUSHUNDEF; if (S_ISFIFO(PL_statcache.st_mode)) @@ -3201,7 +3287,9 @@ PP(pp_ftsuid) { dSP; #ifdef S_ISUID - I32 result = my_stat(); + I32 result; + STACKED_FTEST_CHECK; + result = my_stat(); SPAGAIN; if (result < 0) RETPUSHUNDEF; @@ -3215,7 +3303,9 @@ PP(pp_ftsgid) { dSP; #ifdef S_ISGID - I32 result = my_stat(); + I32 result; + STACKED_FTEST_CHECK; + result = my_stat(); SPAGAIN; if (result < 0) RETPUSHUNDEF; @@ -3229,7 +3319,9 @@ PP(pp_ftsvtx) { dSP; #ifdef S_ISVTX - I32 result = my_stat(); + I32 result; + STACKED_FTEST_CHECK; + result = my_stat(); SPAGAIN; if (result < 0) RETPUSHUNDEF; @@ -3244,8 +3336,9 @@ PP(pp_fttty) dSP; int fd; GV *gv; - char *tmps = Nullch; - STRLEN n_a; + SV *tmpsv = Nullsv; + + STACKED_FTEST_CHECK; if (PL_op->op_flags & OPf_REF) gv = cGVOP_gv; @@ -3254,12 +3347,17 @@ PP(pp_fttty) else if (SvROK(TOPs) && isGV(SvRV(TOPs))) gv = (GV*)SvRV(POPs); else - gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO); + gv = gv_fetchsv(tmpsv = POPs, FALSE, SVt_PVIO); if (GvIO(gv) && IoIFP(GvIOp(gv))) fd = PerlIO_fileno(IoIFP(GvIOp(gv))); - else if (tmps && isDIGIT(*tmps)) - fd = atoi(tmps); + else if (tmpsv && SvOK(tmpsv)) { + const char *tmps = SvPV_nolen_const(tmpsv); + if (isDIGIT(*tmps)) + fd = atoi(tmps); + else + RETPUSHUNDEF; + } else RETPUSHUNDEF; if (PerlLIO_isatty(fd)) @@ -3286,9 +3384,10 @@ PP(pp_fttext) register IO *io; register SV *sv; GV *gv; - STRLEN n_a; PerlIO *fp; + STACKED_FTEST_CHECK; + if (PL_op->op_flags & OPf_REF) gv = cGVOP_gv; else if (isGV(TOPs)) @@ -3311,7 +3410,7 @@ PP(pp_fttext) else { PL_statgv = gv; PL_laststatval = -1; - sv_setpv(PL_statname, ""); + sv_setpvn(PL_statname, "", 0); io = GvIO(PL_statgv); } if (io && IoIFP(io)) { @@ -3352,11 +3451,11 @@ PP(pp_fttext) sv = POPs; really_filename: PL_statgv = Nullgv; - PL_laststatval = -1; 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(PL_statname, n_a), '\n')) + sv_setpv(PL_statname, SvPV_nolen_const(sv)); + if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) { + if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), + '\n')) Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); RETPUSHUNDEF; } @@ -3440,26 +3539,36 @@ PP(pp_ftbinary) PP(pp_chdir) { dSP; dTARGET; - char *tmps; - SV **svp; - STRLEN n_a; + const char *tmps = 0; + GV *gv = NULL; - if( MAXARG == 1 ) - tmps = POPpx; - 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 ) { if( MAXARG == 1 ) deprecate("chdir('') or chdir(undef) as chdir()"); - tmps = SvPV(*svp, n_a); + tmps = SvPV_nolen_const(*svp); } else { PUSHi(0); @@ -3469,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. */ @@ -3496,7 +3631,6 @@ PP(pp_chroot) { #ifdef HAS_CHROOT dSP; dTARGET; - STRLEN n_a; char *tmps = POPpx; TAINT_PROPER("chroot"); PUSHi( chroot(tmps) >= 0 ); @@ -3540,10 +3674,8 @@ PP(pp_rename) { dSP; dTARGET; int anum; - STRLEN n_a; - - char *tmps2 = POPpx; - char *tmps = SvPV(TOPs, n_a); + const char *tmps2 = POPpconstx; + const char *tmps = SvPV_nolen_const(TOPs); TAINT_PROPER("rename"); #ifdef HAS_RENAME anum = PerlLIO_rename(tmps, tmps2); @@ -3567,9 +3699,8 @@ PP(pp_link) { #ifdef HAS_LINK dSP; dTARGET; - STRLEN n_a; - char *tmps2 = POPpx; - char *tmps = SvPV(TOPs, n_a); + const char *tmps2 = POPpconstx; + const char *tmps = SvPV_nolen_const(TOPs); TAINT_PROPER("link"); SETi( PerlLIO_link(tmps, tmps2) >= 0 ); RETURN; @@ -3582,9 +3713,8 @@ PP(pp_symlink) { #ifdef HAS_SYMLINK dSP; dTARGET; - STRLEN n_a; - char *tmps2 = POPpx; - char *tmps = SvPV(TOPs, n_a); + const char *tmps2 = POPpconstx; + const char *tmps = SvPV_nolen_const(TOPs); TAINT_PROPER("symlink"); SETi( symlink(tmps, tmps2) >= 0 ); RETURN; @@ -3598,15 +3728,14 @@ PP(pp_readlink) dSP; #ifdef HAS_SYMLINK dTARGET; - char *tmps; + const char *tmps; char buf[MAXPATHLEN]; int len; - STRLEN n_a; #ifndef INCOMPLETE_TAINTS TAINT; #endif - tmps = POPpx; + tmps = POPpconstx; len = readlink(tmps, buf, sizeof(buf) - 1); EXTEND(SP, 1); if (len < 0) @@ -3621,15 +3750,15 @@ PP(pp_readlink) #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) STATIC int -S_dooneliner(pTHX_ char *cmd, char *filename) +S_dooneliner(pTHX_ const char *cmd, const char *filename) { - char *save_filename = filename; + char * const save_filename = filename; char *cmdline; char *s; 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; ) { @@ -3717,7 +3846,7 @@ S_dooneliner(pTHX_ char *cmd, char *filename) * -d, chdir(), chmod(), chown(), chroot(), fcntl()?, * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */ -#define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV(TOPs, (len)); \ +#define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \ if ((len) > 1 && (tmps)[(len)-1] == '/') { \ do { \ (len)--; \ @@ -3734,7 +3863,7 @@ PP(pp_mkdir) int oldumask; #endif STRLEN len; - char *tmps; + const char *tmps; bool copy = FALSE; if (MAXARG > 1) @@ -3762,7 +3891,7 @@ PP(pp_rmdir) { dSP; dTARGET; STRLEN len; - char *tmps; + const char *tmps; bool copy = FALSE; TRIMSLASHES(tmps,len,copy); @@ -3783,8 +3912,7 @@ PP(pp_open_dir) { #if defined(Direntry_t) && defined(HAS_READDIR) dSP; - STRLEN n_a; - char *dirname = POPpx; + const char *dirname = POPpconstx; GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); @@ -3817,7 +3945,7 @@ PP(pp_readdir) dSP; SV *sv; - I32 gimme = GIMME; + const I32 gimme = GIMME; GV *gv = (GV *)POPs; register Direntry_t *dp; register IO *io = GvIOn(gv); @@ -3860,7 +3988,7 @@ nope: PP(pp_telldir) { #if defined(HAS_TELLDIR) || defined(telldir) - dSP; dTARGET; + dVAR; dSP; dTARGET; /* XXX does _anyone_ need this? --AD 2/20/1998 */ /* XXX netbsd still seemed to. XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style. @@ -3974,7 +4102,6 @@ PP(pp_fork) if (childpid < 0) RETSETUNDEF; if (!childpid) { - /*SUPPRESS 560*/ if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) { SvREADONLY_off(GvSV(tmpgv)); sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid()); @@ -4022,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; @@ -4054,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; @@ -4069,14 +4196,12 @@ PP(pp_system) { dSP; dMARK; dORIGMARK; dTARGET; I32 value; - STRLEN n_a; int result; - I32 did_pipes = 0; if (PL_tainting) { TAINT_ENV(); while (++MARK <= SP) { - (void)SvPV_nolen(*MARK); /* stringify for taint check */ + (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ if (PL_tainted) break; } @@ -4088,6 +4213,7 @@ PP(pp_system) { Pid_t childpid; int pp[2]; + I32 did_pipes = 0; if (PerlProc_pipe(pp) >= 0) did_pipes = 1; @@ -4111,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); @@ -4121,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) { @@ -4141,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); @@ -4160,7 +4286,7 @@ PP(pp_system) else if (SP - MARK != 1) value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes); else { - value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes); + value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes); } PerlProc__exit(-1); } @@ -4169,25 +4295,25 @@ PP(pp_system) result = 0; if (PL_op->op_flags & OPf_STACKED) { SV *really = *++MARK; -# if defined(WIN32) || defined(OS2) +# if defined(WIN32) || defined(OS2) || defined(SYMBIAN) value = (I32)do_aspawn(really, MARK, SP); # else value = (I32)do_aspawn(really, (void **)MARK, (void **)SP); # endif } else if (SP - MARK != 1) { -# if defined(WIN32) || defined(OS2) +# if defined(WIN32) || defined(OS2) || defined(SYMBIAN) value = (I32)do_aspawn(Nullsv, MARK, SP); # else value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP); # endif } else { - value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a)); + value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP))); } 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); @@ -4199,12 +4325,11 @@ PP(pp_exec) { dSP; dMARK; dORIGMARK; dTARGET; I32 value; - STRLEN n_a; if (PL_tainting) { TAINT_ENV(); while (++MARK <= SP) { - (void)SvPV_nolen(*MARK); /* stringify for taint check */ + (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ if (PL_tainted) break; } @@ -4231,13 +4356,13 @@ PP(pp_exec) #endif else { #ifdef VMS - value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a)); + value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); #else # ifdef __OPEN_VM - (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a)); + (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP))); value = 0; # else - value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a)); + value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); # endif #endif } @@ -4266,6 +4391,9 @@ PP(pp_getppid) #ifdef HAS_GETPPID dSP; dTARGET; # ifdef THREADS_HAVE_PIDS + if (PL_ppid != 1 && getppid() == 1) + /* maybe the parent process has died. Refresh ppid cache */ + PL_ppid = 1; XPUSHi( PL_ppid ); # else XPUSHi( getppid() ); @@ -4416,14 +4544,56 @@ PP(pp_localtime) return pp_gmtime(); } +#ifdef LOCALTIME_EDGECASE_BROKEN +static struct tm *S_my_localtime (pTHX_ Time_t *tp) +{ + auto time_t T; + auto struct tm *P; + + /* No workarounds in the valid range */ + if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000) + return (localtime (tp)); + + /* This edge case is to workaround the undefined behaviour, where the + * TIMEZONE makes the time go beyond the defined range. + * gmtime (0x7fffffff) => 2038-01-19 03:14:07 + * If there is a negative offset in TZ, like MET-1METDST, some broken + * implementations of localtime () (like AIX 5.2) barf with bogus + * return values: + * 0x7fffffff gmtime 2038-01-19 03:14:07 + * 0x7fffffff localtime 1901-12-13 21:45:51 + * 0x7fffffff mylocaltime 2038-01-19 04:14:07 + * 0x3c19137f gmtime 2001-12-13 20:45:51 + * 0x3c19137f localtime 2001-12-13 21:45:51 + * 0x3c19137f mylocaltime 2001-12-13 21:45:51 + * 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 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++; /* 18 -> 19 */ + P->tm_wday++; /* Mon -> Tue */ + P->tm_yday++; /* 18 -> 19 */ + } + return (P); +} /* S_my_localtime */ +#endif + PP(pp_gmtime) { dSP; Time_t when; - struct tm *tmbuf; - static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}; - static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun", - "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; + const struct tm *tmbuf; + static const char * const dayname[] = + {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}; + static const char * const monname[] = + {"Jan", "Feb", "Mar", "Apr", "May", "Jun", + "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; if (MAXARG < 1) (void)time(&when); @@ -4435,7 +4605,11 @@ PP(pp_gmtime) #endif if (PL_op->op_type == OP_LOCALTIME) +#ifdef LOCALTIME_EDGECASE_BROKEN + tmbuf = S_my_localtime(aTHX_ &when); +#else tmbuf = localtime(&when); +#endif else tmbuf = gmtime(&when); @@ -4659,7 +4833,6 @@ PP(pp_ghostent) #endif struct hostent *hent; unsigned long len; - STRLEN n_a; EXTEND(SP, 10); if (which == OP_GHBYNAME) { @@ -4696,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 @@ -4775,7 +4948,6 @@ PP(pp_gnetent) struct netent *getnetent(void); #endif struct netent *nent; - STRLEN n_a; if (which == OP_GNBYNAME){ #ifdef HAS_GETNETBYNAME @@ -4808,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 @@ -4876,7 +5048,6 @@ PP(pp_gprotoent) struct protoent *getprotoent(void); #endif struct protoent *pent; - STRLEN n_a; if (which == OP_GPBYNAME) { #ifdef HAS_GETPROTOBYNAME @@ -4963,7 +5134,6 @@ PP(pp_gservent) struct servent *getservent(void); #endif struct servent *sent; - STRLEN n_a; if (which == OP_GSBYNAME) { #ifdef HAS_GETSERVBYNAME @@ -5159,7 +5329,6 @@ PP(pp_gpwent) dSP; I32 which = PL_op->op_type; register SV *sv; - STRLEN n_a; struct passwd *pwent = NULL; /* * We currently support only the SysV getsp* shadow password interface. @@ -5438,7 +5607,6 @@ PP(pp_ggrent) register char **elem; register SV *sv; struct group *grent; - STRLEN n_a; if (which == OP_GGRNAM) { char* name = POPpbytex; @@ -5550,7 +5718,6 @@ PP(pp_syscall) unsigned long a[20]; register I32 i = 0; I32 retval = -1; - STRLEN n_a; if (PL_tainting) { while (++MARK <= SP) { @@ -5573,7 +5740,7 @@ PP(pp_syscall) else if (*MARK == &PL_sv_undef) a[i++] = 0; else - a[i++] = (unsigned long)SvPV_force(*MARK, n_a); + a[i++] = (unsigned long)SvPV_force_nolen(*MARK); if (i > 15) break; } @@ -5756,3 +5923,13 @@ lockf_emulate_flock(int fd, int operation) } #endif /* LOCKF_EMULATE_FLOCK */ + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */