X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/cf2093f6405d08be483e037b6052608c46952a75..d308986b5b369caa1602a636a5e2ecfa149dfc89:/doio.c diff --git a/doio.c b/doio.c index 47d70cd..0463af8 100644 --- a/doio.c +++ b/doio.c @@ -134,14 +134,14 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, else result = PerlIO_close(IoIFP(io)); if (result == EOF && fd > PL_maxsysfd) - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "Warning: unable to close filehandle %s properly.\n", GvENAME(gv)); IoOFP(io) = IoIFP(io) = Nullfp; } if (as_raw) { -#if defined(O_LARGEFILE) +#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE) rawmode |= O_LARGEFILE; #endif @@ -183,28 +183,29 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } } else { - char *myname; - char *type = name; - char *otype = name; + char *type; + char *oname = name; STRLEN tlen; - STRLEN otlen = len; + STRLEN olen = len; char mode[3]; /* stdio file mode ("r\0" or "r+\0") */ int dodup; + type = savepvn(name, len); + tlen = len; + SAVEFREEPV(type); if (num_svs) { - type = name; - name = SvPV(svs, tlen) ; - len = (I32)tlen; + STRLEN l; + name = SvPV(svs, l) ; + len = (I32)l; + name = savepvn(name, len); + SAVEFREEPV(name); } - - tlen = otlen; - myname = savepvn(name, len); - SAVEFREEPV(myname); - name = myname; - if (!num_svs) + else { while (tlen && isSPACE(type[tlen-1])) type[--tlen] = '\0'; - + name = type; + len = tlen; + } mode[0] = mode[1] = mode[2] = '\0'; IoTYPE(io) = *type; if (*type == '+' && tlen > 1 && type[tlen-1] != '|') { /* scary */ @@ -216,12 +217,14 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (*type == '|') { if (num_svs && (tlen != 2 || type[1] != '-')) { unknown_desr: - Perl_croak(aTHX_ "Unknown open() mode '%.*s'", otlen, otype); + Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname); } /*SUPPRESS 530*/ - for (type++; isSPACE(*type); type++) ; - if (!num_svs) + for (type++, tlen--; isSPACE(*type); type++, tlen--) ; + if (!num_svs) { name = type; + len = tlen; + } if (*name == '\0') { /* command is missing 19990114 */ dTHR; if (ckWARN(WARN_PIPE)) @@ -232,11 +235,11 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (strNE(name,"-") || num_svs) TAINT_ENV(); TAINT_PROPER("piped open"); - if (name[strlen(name)-1] == '|') { + if (name[len-1] == '|') { dTHR; - name[strlen(name)-1] = '\0' ; + name[--len] = '\0' ; if (ckWARN(WARN_PIPE)) - Perl_warner(aTHX_ WARN_PIPE, "Can't do bidirectional pipe"); + Perl_warner(aTHX_ WARN_PIPE, "Can't open bidirectional pipe"); } fp = PerlProc_popen(name,"w"); writing = 1; @@ -282,7 +285,19 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, goto say_false; } if (IoIFP(thatio)) { - fd = PerlIO_fileno(IoIFP(thatio)); + PerlIO *fp = IoIFP(thatio); + /* Flush stdio buffer before dup. --mjd + * Unfortunately SEEK_CURing 0 seems to + * be optimized away on most platforms; + * only Solaris and Linux seem to flush + * on that. --jhi */ + PerlIO_seek(fp, 0, SEEK_CUR); + /* On the other hand, do all platforms + * take gracefully to flushing a read-only + * filehandle? Perhaps we should do + * fsetpos(src)+fgetpos(dst)? --nik */ + PerlIO_flush(fp); + fd = PerlIO_fileno(fp); if (IoTYPE(thatio) == 's') IoTYPE(io) = 's'; } @@ -296,7 +311,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (!(fp = PerlIO_fdopen(fd,mode))) { if (dodup) PerlLIO_close(fd); - } + } } } else { @@ -413,7 +428,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } } if (fd != PerlIO_fileno(fp)) { - int pid; + Pid_t pid; SV *sv; PerlLIO_dup2(PerlIO_fileno(fp), fd); @@ -440,6 +455,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } #endif IoIFP(io) = fp; + IoFLAGS(io) &= ~IOf_NOLINE; if (writing) { dTHR; if (IoTYPE(io) == 's' @@ -472,9 +488,18 @@ Perl_nextargv(pTHX_ register GV *gv) #endif Uid_t fileuid; Gid_t filegid; + IO *io = GvIOp(gv); if (!PL_argvoutgv) PL_argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO); + if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) { + IoFLAGS(io) &= ~IOf_START; + if (PL_inplace) { + if (!PL_argvout_stack) + PL_argvout_stack = newAV(); + av_push(PL_argvout_stack, SvREFCNT_inc(PL_defoutgv)); + } + } if (PL_filemode & (S_ISUID|S_ISGID)) { PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv))); /* chmod must follow last write */ #ifdef HAS_FCHMOD @@ -548,7 +573,7 @@ Perl_nextargv(pTHX_ register GV *gv) } #endif #ifdef HAS_RENAME -#ifndef DOSISH +#if !defined(DOSISH) && !defined(__CYGWIN__) if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) { if (ckWARN_d(WARN_INPLACE)) Perl_warner(aTHX_ WARN_INPLACE, @@ -598,11 +623,12 @@ Perl_nextargv(pTHX_ register GV *gv) SETERRNO(0,0); /* in case sprintf set errno */ #ifdef VMS if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0, - O_WRONLY|O_CREAT|O_TRUNC,0,Nullfp)) { + O_WRONLY|O_CREAT|O_TRUNC,0,Nullfp)) #else if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0, - O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) { + O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) #endif + { if (ckWARN_d(WARN_INPLACE)) Perl_warner(aTHX_ WARN_INPLACE, "Can't do inplace edit on %s: %s", PL_oldname, Strerror(errno) ); @@ -638,15 +664,25 @@ Perl_nextargv(pTHX_ register GV *gv) if (!S_ISREG(PL_statbuf.st_mode)) Perl_warner(aTHX_ WARN_INPLACE, "Can't do inplace edit: %s is not a regular file", - PL_oldname ); + PL_oldname); else - Perl_warner(aTHX_ WARN_INPLACE, "Can't open %s: %s\n", + Perl_warner(aTHX_ WARN_INPLACE, "Can't open %s: %s", PL_oldname, Strerror(errno)); } } } + if (io && (IoFLAGS(io) & IOf_ARGV)) + IoFLAGS(io) |= IOf_START; if (PL_inplace) { (void)do_close(PL_argvoutgv,FALSE); + if (io && (IoFLAGS(io) & IOf_ARGV) + && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0) + { + GV *oldout = (GV*)av_pop(PL_argvout_stack); + setdefout(oldout); + SvREFCNT_dec(oldout); + return Nullfp; + } setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO)); } return Nullfp; @@ -873,7 +909,7 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence) Perl_warner(aTHX_ WARN_UNOPENED, "sysseek() on unopened file"); } SETERRNO(EBADF,RMS$_IFI); - return -1L; + return (Off_t)-1; } int @@ -994,24 +1030,17 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) { dTHR; if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } return TRUE; case SVt_IV: if (SvIOK(sv)) { if (SvGMAGICAL(sv)) mg_get(sv); -#ifdef IV_IS_QUAD if (SvIsUV(sv)) - PerlIO_printf(fp, "%" PERL_PRIu64, (UV)SvUVX(sv)); + PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv)); else - PerlIO_printf(fp, "%" PERL_PRId64, (IV)SvIVX(sv)); -#else - if (SvIsUV(sv)) - PerlIO_printf(fp, "%lu", (unsigned long)SvUVX(sv)); - else - PerlIO_printf(fp, "%ld", (long)SvIVX(sv)); -#endif + PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv)); return !PerlIO_error(fp); } /* FALL THROUGH */ @@ -1019,6 +1048,12 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) tmps = SvPV(sv, len); break; } + /* To detect whether the process is about to overstep its + * filesize limit we would need getrlimit(). We could then + * also transparently raise the limit with setrlimit() -- + * but only until the system hard limit/the filesystem limit, + * at which we would get EPERM. Note that when using buffered + * io the write failure can be delayed until the flush/close. --jhi */ if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp))) return FALSE; return !PerlIO_error(fp); @@ -1033,7 +1068,7 @@ Perl_my_stat(pTHX) if (PL_op->op_flags & OPf_REF) { EXTEND(SP,1); - tmpgv = cGVOP->op_gv; + tmpgv = cGVOP_gv; do_fstat: io = GvIO(tmpgv); if (io && IoIFP(io)) { @@ -1086,7 +1121,7 @@ Perl_my_lstat(pTHX) STRLEN n_a; if (PL_op->op_flags & OPf_REF) { EXTEND(SP,1); - if (cGVOP->op_gv == PL_defgv) { + if (cGVOP_gv == PL_defgv) { if (PL_laststype != OP_LSTAT) Perl_croak(aTHX_ "The stat preceding -l _ wasn't an lstat"); return PL_laststatval; @@ -1115,6 +1150,9 @@ bool Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, int fd, int do_report) { +#ifdef MACOS_TRADITIONAL + Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system"); +#else register char **a; char *tmps; STRLEN n_a; @@ -1147,6 +1185,7 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, } } do_execfree(); +#endif return FALSE; } @@ -1163,7 +1202,7 @@ Perl_do_execfree(pTHX) } } -#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) +#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) bool Perl_do_exec(pTHX_ char *cmd) @@ -1218,7 +1257,7 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) goto doshell; - for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ + for (s = cmd; *s && isALNUM(*s); s++) ; /* catch VAR=val gizmo */ if (*s == '=') goto doshell; @@ -1487,8 +1526,10 @@ nothing in the core. /* Do the permissions allow some operation? Assumes statcache already set. */ #ifndef VMS /* VMS' cando is in vms.c */ -I32 -Perl_cando(pTHX_ I32 bit, I32 effective, register struct stat *statbufp) +bool +Perl_cando(pTHX_ Mode_t mode, Uid_t effective, register Stat_t *statbufp) +/* Note: we use `effective' both for uids and gids. + * Here we are betting on Uid_t being equal or wider than Gid_t. */ { #ifdef DOSISH /* [Comments and code from Len Reed] @@ -1512,11 +1553,11 @@ Perl_cando(pTHX_ I32 bit, I32 effective, register struct stat *statbufp) /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat * too so it will actually look into the files for magic numbers */ - return (bit & statbufp->st_mode) ? TRUE : FALSE; + return (mode & statbufp->st_mode) ? TRUE : FALSE; #else /* ! DOSISH */ if ((effective ? PL_euid : PL_uid) == 0) { /* root is special */ - if (bit == S_IXUSR) { + if (mode == S_IXUSR) { if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) return TRUE; } @@ -1525,23 +1566,27 @@ Perl_cando(pTHX_ I32 bit, I32 effective, register struct stat *statbufp) return FALSE; } if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) { - if (statbufp->st_mode & bit) + if (statbufp->st_mode & mode) return TRUE; /* ok as "user" */ } - else if (ingroup((I32)statbufp->st_gid,effective)) { - if (statbufp->st_mode & bit >> 3) + else if (ingroup(statbufp->st_gid,effective)) { + if (statbufp->st_mode & mode >> 3) return TRUE; /* ok as "group" */ } - else if (statbufp->st_mode & bit >> 6) + else if (statbufp->st_mode & mode >> 6) return TRUE; /* ok as "other" */ return FALSE; #endif /* ! DOSISH */ } #endif /* ! VMS */ -I32 -Perl_ingroup(pTHX_ I32 testgid, I32 effective) +bool +Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective) { +#ifdef MACOS_TRADITIONAL + /* This is simply not correct for AppleShare, but fix it yerself. */ + return TRUE; +#else if (testgid == (effective ? PL_egid : PL_gid)) return TRUE; #ifdef HAS_GETGROUPS @@ -1559,6 +1604,7 @@ Perl_ingroup(pTHX_ I32 testgid, I32 effective) } #endif return FALSE; +#endif } #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) @@ -1676,7 +1722,7 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) else { IV i = SvIV(astr); - a = (char *)i; /* ouch */ + a = INT2PTR(char *,i); /* ouch */ } SETERRNO(0,0); switch (optype)