X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=doio.c;h=2b2caa519f83647f6938da271385bc30b4b49ff1;hb=bfa0af6f4d529b278f8cb84f8526cffd75a4ff4d;hp=6b0c9f2840ce66fc413be25d116763766d289aad;hpb=b16276bb9e16a3b99d6fb450f4e0902e32b01f85;p=p5sagit%2Fp5-mst-13.2.git diff --git a/doio.c b/doio.c index 6b0c9f2..2b2caa5 100644 --- a/doio.c +++ b/doio.c @@ -1,7 +1,7 @@ /* doio.c * - * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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. @@ -9,10 +9,12 @@ */ /* - * "Far below them they saw the white waters pour into a foaming bowl, and - * then swirl darkly about a deep oval basin in the rocks, until they found - * their way out again through a narrow gate, and flowed away, fuming and - * chattering, into calmer and more level reaches." + * Far below them they saw the white waters pour into a foaming bowl, and + * then swirl darkly about a deep oval basin in the rocks, until they found + * their way out again through a narrow gate, and flowed away, fuming and + * chattering, into calmer and more level reaches. + * + * [p.684 of _The Lord of the Rings_, IV/vi: "The Forbidden Pool"] */ /* This file contains functions that do the actual I/O on behalf of ops. @@ -212,7 +214,7 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, goto say_false; } #endif /* USE_STDIO */ - name = SvOK(*svp) ? savesvpv (*svp) : savepvn ("", 0); + name = SvOK(*svp) ? savesvpv (*svp) : savepvs (""); SAVEFREEPV(name); } else { @@ -310,6 +312,7 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, else { PerlIO *that_fp = NULL; if (num_svs > 1) { + /* diag_listed_as: More than one argument to '%s' open */ Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io)); } while (isSPACE(*type)) @@ -396,6 +399,7 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, fp = PerlIO_stdout(); IoTYPE(io) = IoTYPE_STD; if (num_svs > 1) { + /* diag_listed_as: More than one argument to '%s' open */ Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD); } } @@ -429,6 +433,7 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, fp = PerlIO_stdin(); IoTYPE(io) = IoTYPE_STD; if (num_svs > 1) { + /* diag_listed_as: More than one argument to '%s' open */ Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD); } } @@ -624,7 +629,6 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, Pid_t pid; SV *sv; - LOCK_FDPID_MUTEX; sv = *av_fetch(PL_fdpid,fd,TRUE); SvUPGRADE(sv, SVt_IV); pid = SvIVX(sv); @@ -632,7 +636,6 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, sv = *av_fetch(PL_fdpid,savefd,TRUE); SvUPGRADE(sv, SVt_IV); SvIV_set(sv, pid); - UNLOCK_FDPID_MUTEX; } #endif @@ -661,9 +664,9 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, } #if defined(HAS_FCNTL) && defined(F_SETFD) if (fd >= 0) { - const int save_errno = errno; + dSAVE_ERRNO; fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */ - errno = save_errno; + RESTORE_ERRNO; } #endif IoIFP(io) = fp; @@ -766,7 +769,7 @@ Perl_nextargv(pTHX_ register GV *gv) const char *star = strchr(PL_inplace, '*'); if (star) { const char *begin = PL_inplace; - sv_setpvn(sv, "", 0); + sv_setpvs(sv, ""); do { sv_catpvn(sv, begin, star - begin); sv_catpvn(sv, PL_oldname, oldlen); @@ -809,8 +812,7 @@ Perl_nextargv(pTHX_ register GV *gv) do_close(gv,FALSE); (void)PerlLIO_unlink(SvPVX_const(sv)); (void)PerlLIO_rename(PL_oldname,SvPVX_const(sv)); - do_open(gv,(char*)SvPVX_const(sv),SvCUR(sv),PL_inplace!=0, - O_RDONLY,0,NULL); + do_open(gv,(char*)SvPVX_const(sv),SvCUR(sv),TRUE,O_RDONLY,0,NULL); #endif /* DOSISH */ #else (void)UNLINK(SvPVX_const(sv)); @@ -842,18 +844,16 @@ Perl_nextargv(pTHX_ register GV *gv) #endif } - sv_setpvn(sv,">",!PL_inplace); - sv_catpvn(sv,PL_oldname,oldlen); + sv_setpvn(sv,PL_oldname,oldlen); SETERRNO(0,0); /* in case sprintf set errno */ + if (!Perl_do_openn(aTHX_ PL_argvoutgv, (char*)SvPVX_const(sv), + SvCUR(sv), TRUE, #ifdef VMS - if (!do_open(PL_argvoutgv,(char*)SvPVX_const(sv),SvCUR(sv), - PL_inplace!=0,O_WRONLY|O_CREAT|O_TRUNC,0,NULL)) + O_WRONLY|O_CREAT|O_TRUNC,0, #else - if (!do_open(PL_argvoutgv,(char*)SvPVX_const(sv),SvCUR(sv), - PL_inplace!=0,O_WRONLY|O_CREAT|OPEN_EXCL,0666, - NULL)) + O_WRONLY|O_CREAT|OPEN_EXCL,0600, #endif - { + NULL, NULL, 0)) { if (ckWARN_d(WARN_INPLACE)) Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: %s", PL_oldname, Strerror(errno) ); @@ -906,7 +906,7 @@ Perl_nextargv(pTHX_ register GV *gv) if (io && (IoFLAGS(io) & IOf_ARGV) && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0) { - GV * const oldout = (GV*)av_pop(PL_argvout_stack); + GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack)); setdefout(oldout); SvREFCNT_dec(oldout); return NULL; @@ -926,7 +926,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit) if (!gv) gv = PL_argvgv; - if (!gv || SvTYPE(gv) != SVt_PVGV) { + if (!gv || !isGV_with_GP(gv)) { if (not_implicit) SETERRNO(EBADF,SS_IVCHAN); return FALSE; @@ -1012,14 +1012,14 @@ Perl_do_eof(pTHX_ GV *gv) { /* getc and ungetc can stomp on errno */ - const int saverrno = errno; + dSAVE_ERRNO; const int ch = PerlIO_getc(IoIFP(io)); if (ch != EOF) { (void)PerlIO_ungetc(IoIFP(io),ch); - errno = saverrno; + RESTORE_ERRNO; return FALSE; } - errno = saverrno; + RESTORE_ERRNO; } if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) { @@ -1096,12 +1096,10 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence) } int -Perl_mode_from_discipline(pTHX_ SV *discp) +Perl_mode_from_discipline(pTHX_ const char *s, STRLEN len) { int mode = O_BINARY; - if (discp) { - STRLEN len; - const char *s = SvPV_const(discp,len); + if (s) { while (*s) { if (*s == ':') { switch (s[1]) { @@ -1284,7 +1282,7 @@ Perl_my_stat(pTHX) do_fstat_have_io: PL_laststype = OP_STAT; PL_statgv = gv; - sv_setpvn(PL_statname, "", 0); + sv_setpvs(PL_statname, ""); if(io) { if (IoIFP(io)) { return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache)); @@ -1309,16 +1307,16 @@ Perl_my_stat(pTHX) const char *s; STRLEN len; PUTBACK; - if (SvTYPE(sv) == SVt_PVGV) { - gv = (GV*)sv; + if (isGV_with_GP(sv)) { + gv = MUTABLE_GV(sv); goto do_fstat; } - else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { - gv = (GV*)SvRV(sv); + else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) { + gv = MUTABLE_GV(SvRV(sv)); goto do_fstat; } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { - io = (IO*)SvRV(sv); + io = MUTABLE_IO(SvRV(sv)); gv = NULL; goto do_fstat_have_io; } @@ -1365,9 +1363,9 @@ Perl_my_lstat(pTHX) PL_statgv = NULL; sv = POPs; PUTBACK; - if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV && ckWARN(WARN_IO)) { + if (SvROK(sv) && isGV_with_GP(SvRV(sv)) && ckWARN(WARN_IO)) { Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s", - GvENAME((GV*) SvRV(sv))); + GvENAME((const GV *)SvRV(sv))); return (PL_laststatval = -1); } file = SvPV_nolen_const(sv); @@ -1398,7 +1396,7 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, { dVAR; PERL_ARGS_ASSERT_DO_AEXEC5; -#if defined(MACOS_TRADITIONAL) || defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__) +#if defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__) Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system"); #else if (sp > mark) { @@ -1626,8 +1624,8 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) tot = sp - mark; while (++mark <= sp) { GV* gv; - if (SvTYPE(*mark) == SVt_PVGV) { - gv = (GV*)*mark; + if (isGV_with_GP(*mark)) { + gv = MUTABLE_GV(*mark); do_fchmod: if (GvIO(gv) && IoIFP(GvIOp(gv))) { #ifdef HAS_FCHMOD @@ -1642,8 +1640,8 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) tot--; } } - else if (SvROK(*mark) && SvTYPE(SvRV(*mark)) == SVt_PVGV) { - gv = (GV*)SvRV(*mark); + else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) { + gv = MUTABLE_GV(SvRV(*mark)); goto do_fchmod; } else { @@ -1666,8 +1664,8 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) tot = sp - mark; while (++mark <= sp) { GV* gv; - if (SvTYPE(*mark) == SVt_PVGV) { - gv = (GV*)*mark; + if (isGV_with_GP(*mark)) { + gv = MUTABLE_GV(*mark); do_fchown: if (GvIO(gv) && IoIFP(GvIOp(gv))) { #ifdef HAS_FCHOWN @@ -1682,8 +1680,8 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) tot--; } } - else if (SvROK(*mark) && SvTYPE(SvRV(*mark)) == SVt_PVGV) { - gv = (GV*)SvRV(*mark); + else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) { + gv = MUTABLE_GV(SvRV(*mark)); goto do_fchown; } else { @@ -1728,8 +1726,11 @@ nothing in the core. * CRTL's emulation of Unix-style signals and kill() */ while (++mark <= sp) { - I32 proc = SvIV(*mark); + I32 proc; register unsigned long int __vmssts; + if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark))) + Perl_croak(aTHX_ "Can't kill a non-numeric process ID"); + proc = SvIV(*mark); APPLY_TAINT_PROPER(); if (!((__vmssts = sys$delprc(&proc,0)) & 1)) { tot--; @@ -1752,7 +1753,10 @@ nothing in the core. if (val < 0) { val = -val; while (++mark <= sp) { - const I32 proc = SvIV(*mark); + I32 proc; + if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark))) + Perl_croak(aTHX_ "Can't kill a non-numeric process ID"); + proc = SvIV(*mark); APPLY_TAINT_PROPER(); #ifdef HAS_KILLPG if (PerlProc_killpg(proc,val)) /* BSD */ @@ -1764,7 +1768,10 @@ nothing in the core. } else { while (++mark <= sp) { - const I32 proc = SvIV(*mark); + I32 proc; + if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark))) + Perl_croak(aTHX_ "Can't kill a non-numeric process ID"); + proc = SvIV(*mark); APPLY_TAINT_PROPER(); if (PerlProc_kill(proc, val)) tot--; @@ -1838,8 +1845,8 @@ nothing in the core. tot = sp - mark; while (++mark <= sp) { GV* gv; - if (SvTYPE(*mark) == SVt_PVGV) { - gv = (GV*)*mark; + if (isGV_with_GP(*mark)) { + gv = MUTABLE_GV(*mark); do_futimes: if (GvIO(gv) && IoIFP(GvIOp(gv))) { #ifdef HAS_FUTIMES @@ -1855,8 +1862,8 @@ nothing in the core. tot--; } } - else if (SvROK(*mark) && SvTYPE(SvRV(*mark)) == SVt_PVGV) { - gv = (GV*)SvRV(*mark); + else if (SvROK(*mark) && isGV_with_GP(SvRV(*mark))) { + gv = MUTABLE_GV(SvRV(*mark)); goto do_futimes; } else { @@ -1943,13 +1950,9 @@ Perl_cando(pTHX_ Mode_t mode, bool effective, register const Stat_t *statbufp) } #endif /* ! VMS */ -bool -Perl_ingroup(pTHX_ Gid_t testgid, bool effective) +static bool +S_ingroup(pTHX_ Gid_t testgid, bool effective) { -#ifdef MACOS_TRADITIONAL - /* This is simply not correct for AppleShare, but fix it yerself. */ - return TRUE; -#else dVAR; if (testgid == (effective ? PL_egid : PL_gid)) return TRUE; @@ -1974,7 +1977,6 @@ Perl_ingroup(pTHX_ Gid_t testgid, bool effective) #else return FALSE; #endif -#endif } #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) @@ -1984,7 +1986,7 @@ Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp) { dVAR; const key_t key = (key_t)SvNVx(*++mark); - const I32 n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark); + SV *nsv = optype == OP_MSGGET ? NULL : *++mark; const I32 flags = SvIVx(*++mark); PERL_ARGS_ASSERT_DO_IPCGET; @@ -1999,14 +2001,15 @@ Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp) #endif #ifdef HAS_SEM case OP_SEMGET: - return semget(key, n, flags); + return semget(key, (int) SvIV(nsv), flags); #endif #ifdef HAS_SHM case OP_SHMGET: - return shmget(key, n, flags); + return shmget(key, (size_t) SvUV(nsv), flags); #endif #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) default: + /* diag_listed_as: msg%s not implemented */ Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); #endif } @@ -2067,12 +2070,14 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) than guessing about u_?short(_t)? */ } #else + /* diag_listed_as: sem%s not implemented */ Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); #endif break; #endif #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) default: + /* diag_listed_as: shm%s not implemented */ Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); #endif } @@ -2120,6 +2125,7 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) #endif ret = Semctl(id, n, cmd, unsemds); #else + /* diag_listed_as: sem%s not implemented */ Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); #endif } @@ -2161,6 +2167,7 @@ Perl_do_msgsnd(pTHX_ SV **mark, SV **sp) #else PERL_UNUSED_ARG(sp); PERL_UNUSED_ARG(mark); + /* diag_listed_as: msg%s not implemented */ Perl_croak(aTHX_ "msgsnd not implemented"); #endif } @@ -2181,7 +2188,7 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) /* suppress warning when reading into undef var --jhi */ if (! SvOK(mstr)) - sv_setpvn(mstr, "", 0); + sv_setpvs(mstr, ""); msize = SvIVx(*++mark); mtype = (long)SvIVx(*++mark); flags = SvIVx(*++mark); @@ -2202,6 +2209,7 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) #else PERL_UNUSED_ARG(sp); PERL_UNUSED_ARG(mark); + /* diag_listed_as: msg%s not implemented */ Perl_croak(aTHX_ "msgrcv not implemented"); #endif } @@ -2256,6 +2264,7 @@ Perl_do_semop(pTHX_ SV **mark, SV **sp) return result; } #else + /* diag_listed_as: sem%s not implemented */ Perl_croak(aTHX_ "semop not implemented"); #endif } @@ -2290,7 +2299,7 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) char *mbuf; /* suppress warning when reading into undef var (tchrist 3/Mar/00) */ if (! SvOK(mstr)) - sv_setpvn(mstr, "", 0); + sv_setpvs(mstr, ""); SvPV_force_nolen(mstr); mbuf = SvGROW(mstr, (STRLEN)msize+1); @@ -2314,6 +2323,7 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) } return shmdt(shm); #else + /* diag_listed_as: shm%s not implemented */ Perl_croak(aTHX_ "shm I/O not implemented"); #endif } @@ -2355,11 +2365,6 @@ Perl_vms_start_glob fp = Perl_vms_start_glob(aTHX_ tmpglob, io); #else /* !VMS */ -#ifdef MACOS_TRADITIONAL - sv_setpv(tmpcmd, "glob "); - sv_catsv(tmpcmd, tmpglob); - sv_catpv(tmpcmd, " |"); -#else #ifdef DOSISH #ifdef OS2 sv_setpv(tmpcmd, "for a in "); @@ -2391,7 +2396,6 @@ Perl_vms_start_glob #endif #endif /* !CSH */ #endif /* !DOSISH */ -#endif /* MACOS_TRADITIONAL */ (void)do_open(PL_last_in_gv, (char*)SvPVX_const(tmpcmd), SvCUR(tmpcmd), FALSE, O_RDONLY, 0, NULL); fp = IoIFP(io);