X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/fe13d51d6409065a0214793b416a2eb3fe209949..1a711748856db57545e4462189a7d8ae47c8d12a:/doio.c diff --git a/doio.c b/doio.c index 7be7af1..cecc574 100644 --- a/doio.c +++ b/doio.c @@ -214,7 +214,8 @@ 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) : savepvs (""); + name = (SvOK(*svp) || SvGMAGICAL(*svp)) ? + savesvpv (*svp) : savepvs (""); SAVEFREEPV(name); } else { @@ -758,14 +759,13 @@ Perl_nextargv(pTHX_ register GV *gv) fileuid = PL_statbuf.st_uid; filegid = PL_statbuf.st_gid; if (!S_ISREG(PL_filemode)) { - if (ckWARN_d(WARN_INPLACE)) - Perl_warner(aTHX_ packWARN(WARN_INPLACE), - "Can't do inplace edit: %s is not a regular file", - PL_oldname ); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), + "Can't do inplace edit: %s is not a regular file", + PL_oldname ); do_close(gv,FALSE); continue; } - if (*PL_inplace) { + if (*PL_inplace && strNE(PL_inplace, "*")) { const char *star = strchr(PL_inplace, '*'); if (star) { const char *begin = PL_inplace; @@ -790,10 +790,9 @@ Perl_nextargv(pTHX_ register GV *gv) #endif ) { - if (ckWARN_d(WARN_INPLACE)) - Perl_warner(aTHX_ packWARN(WARN_INPLACE), - "Can't do inplace edit: %"SVf" would not be unique", - SVfARG(sv)); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), + "Can't do inplace edit: %"SVf" would not be unique", + SVfARG(sv)); do_close(gv,FALSE); continue; } @@ -801,10 +800,9 @@ Perl_nextargv(pTHX_ register GV *gv) #ifdef HAS_RENAME #if !defined(DOSISH) && !defined(__CYGWIN__) && !defined(EPOC) if (PerlLIO_rename(PL_oldname,SvPVX_const(sv)) < 0) { - if (ckWARN_d(WARN_INPLACE)) - Perl_warner(aTHX_ packWARN(WARN_INPLACE), - "Can't rename %s to %"SVf": %s, skipping file", - PL_oldname, SVfARG(sv), Strerror(errno)); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), + "Can't rename %s to %"SVf": %s, skipping file", + PL_oldname, SVfARG(sv), Strerror(errno)); do_close(gv,FALSE); continue; } @@ -817,10 +815,9 @@ Perl_nextargv(pTHX_ register GV *gv) #else (void)UNLINK(SvPVX_const(sv)); if (link(PL_oldname,SvPVX_const(sv)) < 0) { - if (ckWARN_d(WARN_INPLACE)) - Perl_warner(aTHX_ packWARN(WARN_INPLACE), - "Can't rename %s to %"SVf": %s, skipping file", - PL_oldname, SVfARG(sv), Strerror(errno) ); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), + "Can't rename %s to %"SVf": %s, skipping file", + PL_oldname, SVfARG(sv), Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -831,10 +828,9 @@ Perl_nextargv(pTHX_ register GV *gv) #if !defined(DOSISH) && !defined(AMIGAOS) # ifndef VMS /* Don't delete; use automatic file versioning */ if (UNLINK(PL_oldname) < 0) { - if (ckWARN_d(WARN_INPLACE)) - Perl_warner(aTHX_ packWARN(WARN_INPLACE), - "Can't remove %s: %s, skipping file", - PL_oldname, Strerror(errno) ); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), + "Can't remove %s: %s, skipping file", + PL_oldname, Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -854,9 +850,8 @@ Perl_nextargv(pTHX_ register GV *gv) 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) ); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: %s", + PL_oldname, Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -934,8 +929,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit) io = GvIO(gv); if (!io) { /* never opened */ if (not_implicit) { - if (ckWARN(WARN_UNOPENED)) /* no check for closed here */ - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); } return FALSE; @@ -1001,8 +995,8 @@ Perl_do_eof(pTHX_ GV *gv) if (!io) return TRUE; - else if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO)) - report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY); + else if (IoTYPE(io) == IoTYPE_WRONLY) + report_wrongway_fh(gv, '>'); while (IoIFP(io)) { if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */ @@ -1040,20 +1034,19 @@ Off_t Perl_do_tell(pTHX_ GV *gv) { dVAR; - register IO *io = NULL; + IO *const io = GvIO(gv); register PerlIO *fp; PERL_ARGS_ASSERT_DO_TELL; - if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) { + if (io && (fp = IoIFP(io))) { #ifdef ULTRIX_STDIO_BOTCH if (PerlIO_eof(fp)) (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */ #endif return PerlIO_tell(fp); } - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); return (Off_t)-1; } @@ -1062,18 +1055,17 @@ bool Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence) { dVAR; - register IO *io = NULL; + IO *const io = GvIO(gv); register PerlIO *fp; - if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) { + if (io && (fp = IoIFP(io))) { #ifdef ULTRIX_STDIO_BOTCH if (PerlIO_eof(fp)) (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */ #endif return PerlIO_seek(fp, pos, whence) >= 0; } - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); return FALSE; } @@ -1082,15 +1074,14 @@ Off_t Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence) { dVAR; - register IO *io = NULL; + IO *const io = GvIO(gv); register PerlIO *fp; PERL_ARGS_ASSERT_DO_SYSSEEK; - if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) + if (io && (fp = IoIFP(io))) return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence); - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); return (Off_t)-1; } @@ -1233,6 +1224,9 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) tmpbuf = bytes_to_utf8((const U8*) tmps, &len); tmps = (char *) tmpbuf; } + else if (ckWARN_d(WARN_UTF8)) { + (void) check_utf8_print((const U8*) tmps, len); + } } else if (DO_UTF8(sv)) { STRLEN tmplen = len; @@ -1245,10 +1239,13 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) } else { assert((char *)result == tmps); - if (ckWARN_d(WARN_UTF8)) { - Perl_warner(aTHX_ packWARN(WARN_UTF8), - "Wide character in print"); - } + Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), + "Wide character in %s", + PL_op ? OP_DESC(PL_op) : "print" + ); + /* Could also check that isn't one of the things to avoid + * in utf8 by using check_utf8_print(), but not doing so, + * since the stream isn't a UTF8 stream */ } } /* To detect whether the process is about to overstep its @@ -1265,7 +1262,7 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) } I32 -Perl_my_stat(pTHX) +Perl_my_stat_flags(pTHX_ const U32 flags) { dVAR; dSP; @@ -1289,13 +1286,11 @@ Perl_my_stat(pTHX) } else if (IoDIRP(io)) { return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache)); } else { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); return (PL_laststatval = -1); } } else { - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) - report_evil_fh(gv, io, PL_op->op_type); + report_evil_fh(gv); return (PL_laststatval = -1); } } @@ -1321,7 +1316,7 @@ Perl_my_stat(pTHX) goto do_fstat_have_io; } - s = SvPV_const(sv, len); + s = SvPV_flags_const(sv, len, flags); PL_statgv = NULL; sv_setpvn(PL_statname, s, len); s = SvPVX_const(PL_statname); /* s now NUL-terminated */ @@ -1335,7 +1330,7 @@ Perl_my_stat(pTHX) I32 -Perl_my_lstat(pTHX) +Perl_my_lstat_flags(pTHX_ const U32 flags) { dVAR; static const char no_prev_lstat[] = "The stat preceding -l _ wasn't an lstat"; @@ -1368,7 +1363,7 @@ Perl_my_lstat(pTHX) GvENAME((const GV *)SvRV(sv))); return (PL_laststatval = -1); } - file = SvPV_nolen_const(sv); + file = SvPV_flags_const_nolen(sv, flags); sv_setpv(PL_statname,file); PL_laststatval = PerlLIO_lstat(file,&PL_statcache); if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(file, '\n')) @@ -1726,8 +1721,12 @@ 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; + SvGETMAGIC(*mark); + if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark))) + Perl_croak(aTHX_ "Can't kill a non-numeric process ID"); + proc = SvIV_nomg(*mark); APPLY_TAINT_PROPER(); if (!((__vmssts = sys$delprc(&proc,0)) & 1)) { tot--; @@ -1744,13 +1743,18 @@ nothing in the core. } } } + PERL_ASYNC_CHECK(); break; } #endif if (val < 0) { val = -val; while (++mark <= sp) { - const I32 proc = SvIV(*mark); + I32 proc; + SvGETMAGIC(*mark); + if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark))) + Perl_croak(aTHX_ "Can't kill a non-numeric process ID"); + proc = SvIV_nomg(*mark); APPLY_TAINT_PROPER(); #ifdef HAS_KILLPG if (PerlProc_killpg(proc,val)) /* BSD */ @@ -1762,12 +1766,17 @@ nothing in the core. } else { while (++mark <= sp) { - const I32 proc = SvIV(*mark); + I32 proc; + SvGETMAGIC(*mark); + if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark))) + Perl_croak(aTHX_ "Can't kill a non-numeric process ID"); + proc = SvIV_nomg(*mark); APPLY_TAINT_PROPER(); if (PerlProc_kill(proc, val)) tot--; } } + PERL_ASYNC_CHECK(); break; #endif case OP_UNLINK: @@ -1896,7 +1905,7 @@ Perl_cando(pTHX_ Mode_t mode, bool effective, register const Stat_t *statbufp) /* [Comments and code from Len Reed] * MS-DOS "user" is similar to UNIX's "superuser," but can't write * to write-protected files. The execute permission bit is set - * by the Miscrosoft C library stat() function for the following: + * by the Microsoft C library stat() function for the following: * .exe files * .com files * .bat files @@ -1917,7 +1926,11 @@ Perl_cando(pTHX_ Mode_t mode, bool effective, register const Stat_t *statbufp) return (mode & statbufp->st_mode) ? TRUE : FALSE; #else /* ! DOSISH */ +# ifdef __CYGWIN__ + if (ingroup(544,effective)) { /* member of Administrators */ +# else if ((effective ? PL_euid : PL_uid) == 0) { /* root is special */ +# endif if (mode == S_IXUSR) { if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) return TRUE;