X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=a75b87c23ea0116c3144abe75977bd5d0a33f672;hb=939d5c9d7fd5daa1517af4234ad971505e83f908;hp=e125fb93ed66b095f49dfa621ee53e010699e24a;hpb=5df617be18e4372550725f3369e8e3fd641cce19;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index e125fb9..a75b87c 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, 2004, 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. @@ -45,12 +45,6 @@ # include #endif -#ifdef HAS_SYSCALL -#ifdef __cplusplus -extern "C" int syscall(unsigned long,...); -#endif -#endif - #ifdef I_SYS_WAIT # include #endif @@ -125,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 @@ -173,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 @@ -321,17 +321,17 @@ PP(pp_backtick) PerlIO *fp; STRLEN n_a; char *tmps = POPpx; - I32 gimme = GIMME_V; - char *mode = "r"; + const I32 gimme = GIMME_V; + const char *mode = "r"; TAINT_PROPER("``"); if (PL_op->op_private & OPpOPEN_IN_RAW) mode = "rb"; else if (PL_op->op_private & OPpOPEN_IN_CRLF) mode = "rt"; - fp = PerlProc_popen(tmps, mode); + fp = PerlProc_popen(tmps, (char *)mode); if (fp) { - char *type = NULL; + const char *type = NULL; if (PL_curcop->cop_io) { type = SvPV_nolen(PL_curcop->cop_io); } @@ -345,13 +345,14 @@ PP(pp_backtick) ; } 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); } @@ -366,8 +367,7 @@ PP(pp_backtick) } 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); } @@ -386,6 +386,7 @@ PP(pp_backtick) PP(pp_glob) { + dVAR; OP *result; tryAMAGICunTARGET(iter, -1); @@ -432,7 +433,7 @@ PP(pp_warn) { dSP; dMARK; SV *tmpsv; - char *tmps; + const char *tmps; STRLEN len; if (SP - MARK != 1) { dTARGET; @@ -462,7 +463,7 @@ PP(pp_warn) PP(pp_die) { dSP; dMARK; - char *tmps; + const char *tmps; SV *tmpsv; STRLEN len; bool multiarg = 0; @@ -523,7 +524,7 @@ PP(pp_die) PP(pp_open) { - dSP; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; GV *gv; @@ -574,7 +575,7 @@ PP(pp_open) PP(pp_close) { - dSP; + dVAR; dSP; GV *gv; IO *io; MAGIC *mg; @@ -659,7 +660,7 @@ badexit: PP(pp_fileno) { - dSP; dTARGET; + dVAR; dSP; dTARGET; GV *gv; IO *io; PerlIO *fp; @@ -697,8 +698,9 @@ PP(pp_fileno) PP(pp_umask) { - dSP; dTARGET; + dSP; #ifdef HAS_UMASK + dTARGET; Mode_t anum; if (MAXARG < 1) { @@ -722,7 +724,7 @@ PP(pp_umask) PP(pp_binmode) { - dSP; + dVAR; dSP; GV *gv; IO *io; PerlIO *fp; @@ -782,14 +784,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 char *methname; int how = PERL_MAGIC_tied; U32 items; @@ -872,7 +873,7 @@ PP(pp_tie) PP(pp_untie) { - dSP; + dVAR; dSP; MAGIC *mg; SV *sv = POPs; char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) @@ -932,7 +933,7 @@ PP(pp_tied) PP(pp_dbmopen) { - dSP; + dVAR; dSP; HV *hv; dPOPPOPssrl; HV* stash; @@ -1134,7 +1135,10 @@ PP(pp_sselect) } } - PUSHi(nfound); + if (nfound == -1) + PUSHs(&PL_sv_undef); + else + PUSHi(nfound); if (GIMME == G_ARRAY && tbuf) { value = (NV)(timebuf.tv_sec) + (NV)(timebuf.tv_usec) / 1000000.0; @@ -1193,7 +1197,7 @@ PP(pp_select) PP(pp_getc) { - dSP; dTARGET; + dVAR; dSP; dTARGET; GV *gv; IO *io = NULL; MAGIC *mg; @@ -1206,7 +1210,7 @@ PP(pp_getc) 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; @@ -1226,7 +1230,7 @@ PP(pp_getc) 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 */ @@ -1250,8 +1254,9 @@ 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; @@ -1311,7 +1316,7 @@ PP(pp_enterwrite) PP(pp_leavewrite) { - dSP; + dVAR; dSP; GV *gv = cxstack[cxstack_ix].blk_sub.gv; register IO *io = GvIOp(gv); PerlIO *ofp = IoOFP(io); @@ -1340,20 +1345,20 @@ PP(pp_leavewrite) 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(PL_formtarget); if (lines <= 0) /* Yow, header didn't even fit!!! */ goto forget_top; while (lines-- > 0) { @@ -1363,7 +1368,7 @@ PP(pp_leavewrite) s++; } if (s) { - STRLEN save = SvCUR(PL_formtarget); + const STRLEN save = SvCUR(PL_formtarget); SvCUR_set(PL_formtarget, s - SvPVX(PL_formtarget)); do_print(PL_formtarget, ofp); SvCUR_set(PL_formtarget, save); @@ -1439,7 +1444,7 @@ PP(pp_leavewrite) PP(pp_prtf) { - dSP; dMARK; dORIGMARK; + dVAR; dSP; dMARK; dORIGMARK; GV *gv; IO *io; PerlIO *fp; @@ -1543,7 +1548,7 @@ PP(pp_sysopen) PP(pp_sysread) { - dSP; dMARK; dORIGMARK; dTARGET; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; int offset; GV *gv; IO *io; @@ -1682,7 +1687,7 @@ PP(pp_sysread) (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; @@ -1697,8 +1702,8 @@ PP(pp_sysread) SvCUR_set(bufsv, offset); read_target = sv_newmortal(); - SvUPGRADE(read_target, SVt_PV); - buffer = SvGROW(read_target, length + 1); + (void)SvUPGRADE(read_target, SVt_PV); + buffer = SvGROW(read_target, (STRLEN)(length + 1)); } if (PL_op->op_type == OP_SYSREAD) { @@ -1797,7 +1802,7 @@ PP(pp_sysread) PP(pp_syswrite) { - dSP; + dVAR; dSP; int items = (SP - PL_stack_base) - TOPMARK; if (items == 2) { SV *sv; @@ -1811,7 +1816,7 @@ PP(pp_syswrite) PP(pp_send) { - dSP; dMARK; dORIGMARK; dTARGET; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; GV *gv; IO *io; SV *bufsv; @@ -1953,7 +1958,7 @@ PP(pp_recv) PP(pp_eof) { - dSP; + dVAR; dSP; GV *gv; IO *io; MAGIC *mg; @@ -1967,7 +1972,7 @@ PP(pp_eof) 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); + do_open(gv, (char *)"-", 1, FALSE, O_RDONLY, 0, Nullfp); sv_setpvn(GvSV(gv), "-", 1); SvSETMAGIC(GvSV(gv)); } @@ -2000,7 +2005,7 @@ PP(pp_eof) PP(pp_tell) { - dSP; dTARGET; + dVAR; dSP; dTARGET; GV *gv; IO *io; MAGIC *mg; @@ -2038,7 +2043,7 @@ PP(pp_seek) PP(pp_sysseek) { - dSP; + dVAR; dSP; GV *gv; IO *io; int whence = POPi; @@ -2109,7 +2114,6 @@ 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) { int result = 1; GV *tmpgv; @@ -2184,9 +2188,6 @@ PP(pp_truncate) SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } -#else - DIE(aTHX_ "truncate not implemented"); -#endif } PP(pp_fcntl) @@ -2199,7 +2200,7 @@ PP(pp_ioctl) dSP; dTARGET; SV *argsv = POPs; unsigned int func = POPu; - int optype = PL_op->op_type; + const int optype = PL_op->op_type; char *s; IV retval; GV *gv = (GV*)POPs; @@ -2821,7 +2822,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); } @@ -2846,12 +2847,10 @@ PP(pp_stat) } sv_setpv(PL_statname, SvPV(sv,n_a)); 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); else -#endif PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache); if (PL_laststatval < 0) { if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n')) @@ -3424,7 +3423,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)) { @@ -3465,7 +3464,6 @@ 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"))) { @@ -3930,7 +3928,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); @@ -3973,7 +3971,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. @@ -4184,7 +4182,6 @@ PP(pp_system) I32 value; STRLEN n_a; int result; - I32 did_pipes = 0; if (PL_tainting) { TAINT_ENV(); @@ -4201,6 +4198,7 @@ PP(pp_system) { Pid_t childpid; int pp[2]; + I32 did_pipes = 0; if (PerlProc_pipe(pp) >= 0) did_pipes = 1; @@ -4282,14 +4280,14 @@ 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); @@ -4379,6 +4377,12 @@ PP(pp_getppid) #ifdef HAS_GETPPID dSP; dTARGET; # ifdef THREADS_HAVE_PIDS + { + IV cur_ppid = getppid(); + if (cur_ppid == 1) + /* maybe the parent process has died. Refresh ppid cache */ + PL_ppid = cur_ppid; + } XPUSHi( PL_ppid ); # else XPUSHi( getppid() ); @@ -4533,10 +4537,12 @@ 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); @@ -5869,3 +5875,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: + */