if (result == EOF && old_fd > PL_maxsysfd) {
/* Why is this not Perl_warn*() call ? */
PerlIO_printf(Perl_error_log,
- "Warning: unable to close filehandle %"HEKf" properly.\n",
+ "Warning: unable to close filehandle %" HEKf
+ " properly.\n",
HEKfARG(GvENAME_HEK(gv))
);
}
Perl_croak(aTHX_ "panic: sysopen with multiple args, num_svs=%ld",
(long) num_svs);
}
- return do_open_raw(gv, oname, len, rawmode, rawperm);
+ return do_open_raw(gv, oname, len, rawmode, rawperm, NULL);
}
return do_open6(gv, oname, len, supplied_fp, svp, num_svs);
}
bool
Perl_do_open_raw(pTHX_ GV *gv, const char *oname, STRLEN len,
- int rawmode, int rawperm)
+ int rawmode, int rawperm, Stat_t *statbufp)
{
PerlIO *saveifp;
PerlIO *saveofp;
fp = PerlIO_openn(aTHX_ NULL, mode, -1, rawmode, rawperm, NULL, 1, &namesv);
}
return openn_cleanup(gv, io, fp, mode, oname, saveifp, saveofp, savefd,
- savetype, writing, 0, NULL);
+ savetype, writing, 0, NULL, statbufp);
}
bool
else {
PerlIO *that_fp = NULL;
int wanted_fd;
+ UV uv;
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));
wanted_fd = SvUV(*svp);
num_svs = 0;
}
- else if (isDIGIT(*type)) {
- wanted_fd = grok_atou(type, NULL);
+ else if (isDIGIT(*type)
+ && grok_atoUV(type, &uv, NULL)
+ && uv <= INT_MAX
+ ) {
+ wanted_fd = (int)uv;
}
else {
const IO* thatio;
else if (IoTYPE(thatio) == IoTYPE_SOCKET)
IoTYPE(io) = IoTYPE_SOCKET;
}
- else
- wanted_fd = -1;
+ else {
+ SETERRNO(EBADF, RMS_IFI);
+ fp = NULL;
+ goto say_false;
+ }
}
if (!num_svs)
type = NULL;
say_false:
return openn_cleanup(gv, io, fp, mode, oname, saveifp, saveofp, savefd,
- savetype, writing, was_fdopen, type);
+ savetype, writing, was_fdopen, type, NULL);
}
/* Yes, this is ugly, but it's private, and I don't see a cleaner way to
static bool
S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
PerlIO *saveifp, PerlIO *saveofp, int savefd, char savetype,
- int writing, bool was_fdopen, const char *type)
+ int writing, bool was_fdopen, const char *type, Stat_t *statbufp)
{
int fd;
+ Stat_t statbuf;
PERL_ARGS_ASSERT_OPENN_CLEANUP;
if ((IoTYPE(io) == IoTYPE_RDONLY) &&
(fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle STD%s reopened as %"HEKf
+ "Filehandle STD%s reopened as %" HEKf
" only for input",
((fp == PerlIO_stdout()) ? "OUT" : "ERR"),
HEKfARG(GvENAME_HEK(gv)));
}
else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) {
Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle STDIN reopened as %"HEKf" only for output",
+ "Filehandle STDIN reopened as %" HEKf " only for output",
HEKfARG(GvENAME_HEK(gv))
);
}
* otherwise unless we "know" the type probe for socket-ness.
*/
if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) {
- if (PerlLIO_fstat(fd,&PL_statbuf) < 0) {
+ if (PerlLIO_fstat(fd,&statbuf) < 0) {
/* If PerlIO claims to have fd we had better be able to fstat() it. */
(void) PerlIO_close(fp);
goto say_false;
}
#ifndef PERL_MICRO
- if (S_ISSOCK(PL_statbuf.st_mode))
+ if (S_ISSOCK(statbuf.st_mode))
IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */
#ifdef HAS_SOCKET
else if (
- !(PL_statbuf.st_mode & S_IFMT)
+ !(statbuf.st_mode & S_IFMT)
&& IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */
&& IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */
) { /* on OS's that return 0 on fstat()ed pipe */
int ofd = PerlIO_fileno(fp);
int dupfd = ofd >= 0 ? PerlLIO_dup(ofd) : -1;
#if defined(HAS_FCNTL) && defined(F_SETFD)
- /* Assume if we have F_SETFD we have F_GETFD */
- int coe = ofd >= 0 ? fcntl(ofd, F_GETFD) : -1;
- if (coe < 0) {
+ /* Assume if we have F_SETFD we have F_GETFD. */
+ /* Get a copy of all the fd flags. */
+ int fd_flags = ofd >= 0 ? fcntl(ofd, F_GETFD) : -1;
+ if (fd_flags < 0) {
if (dupfd >= 0)
PerlLIO_close(dupfd);
goto say_false;
PerlIO_close(fp);
PerlLIO_dup2(dupfd, ofd);
#if defined(HAS_FCNTL) && defined(F_SETFD)
- /* The dup trick has lost close-on-exec on ofd */
- fcntl(ofd,F_SETFD, coe);
+ /* The dup trick has lost close-on-exec on ofd,
+ * and possibly any other flags, so restore them. */
+ if (fcntl(ofd,F_SETFD, fd_flags) < 0) {
+ if (dupfd >= 0)
+ PerlLIO_close(dupfd);
+ goto say_false;
+ }
#endif
PerlLIO_close(dupfd);
}
PerlIO_clearerr(fp);
fd = PerlIO_fileno(fp);
}
-#if defined(HAS_FCNTL) && defined(F_SETFD)
- if (fd >= 0) {
- if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) {
- PerlLIO_close(fd);
- goto say_false;
- }
+#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
+ if (fd >= 0 && fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) {
+ PerlLIO_close(fd);
+ goto say_false;
}
#endif
IoIFP(io) = fp;
IoFLAGS(io) &= ~IOf_NOLINE;
if (writing) {
if (IoTYPE(io) == IoTYPE_SOCKET
- || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(PL_statbuf.st_mode)) ) {
+ || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(statbuf.st_mode)) ) {
char *s = mode;
if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC)
s++;
else
IoOFP(io) = fp;
}
+ if (statbufp)
+ *statbufp = statbuf;
+
return TRUE;
-say_false:
+ say_false:
IoIFP(io) = saveifp;
IoOFP(io) = saveofp;
IoTYPE(io) = savetype;
Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
{
IO * const io = GvIOp(gv);
+ SV *const old_out_name = PL_inplace ? newSVsv(GvSV(gv)) : NULL;
PERL_ARGS_ASSERT_NEXTARGV;
+ if (old_out_name)
+ SAVEFREESV(old_out_name);
+
if (!PL_argvoutgv)
PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
- if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) {
+ if (io && (IoFLAGS(io) & (IOf_ARGV|IOf_START)) == (IOf_ARGV|IOf_START)) {
IoFLAGS(io) &= ~IOf_START;
if (PL_inplace) {
assert(PL_defoutgv);
}
}
else {
+ Stat_t statbuf;
+ {
+ IO * const io = GvIOp(PL_argvoutgv);
+ if (io && IoIFP(io) && old_out_name && !io_close(io, PL_argvoutgv, FALSE, FALSE)) {
+ Perl_croak(aTHX_ "Failed to close in-place edit file %"
+ SVf ": %s\n", old_out_name, Strerror(errno));
+ }
+ }
/* This very long block ends with return IoIFP(GvIOp(gv));
Both this block and the block above fall through on open
failure to the warning code, and then the while loop above tries
the next entry. */
- if (do_open_raw(gv, PL_oldname, oldlen, O_RDONLY, 0)) {
+ if (do_open_raw(gv, PL_oldname, oldlen, O_RDONLY, 0, &statbuf)) {
#ifndef FLEXFILENAMES
int filedev;
int fileino;
return IoIFP(GvIOp(gv));
}
#ifndef FLEXFILENAMES
- filedev = PL_statbuf.st_dev;
- fileino = PL_statbuf.st_ino;
+ filedev = statbuf.st_dev;
+ fileino = statbuf.st_ino;
#endif
- PL_filemode = PL_statbuf.st_mode;
- fileuid = PL_statbuf.st_uid;
- filegid = PL_statbuf.st_gid;
+ PL_filemode = statbuf.st_mode;
+ fileuid = statbuf.st_uid;
+ filegid = statbuf.st_gid;
if (!S_ISREG(PL_filemode)) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
"Can't do inplace edit: %s is not a regular file",
const char *star = strchr(PL_inplace, '*');
if (star) {
const char *begin = PL_inplace;
- sv_setpvs(sv, "");
+ SvPVCLEAR(sv);
do {
sv_catpvn(sv, begin, star - begin);
sv_catpvn(sv, PL_oldname, oldlen);
sv_catpv(sv,PL_inplace);
}
#ifndef FLEXFILENAMES
- if ((PerlLIO_stat(SvPVX_const(sv),&PL_statbuf) >= 0
- && PL_statbuf.st_dev == filedev
- && PL_statbuf.st_ino == fileino)
+ if ((PerlLIO_stat(SvPVX_const(sv),&statbuf) >= 0
+ && statbuf.st_dev == filedev
+ && statbuf.st_ino == fileino)
#ifdef DJGPP
|| ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0)
#endif
)
{
Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
- "Can't do inplace edit: %"SVf" would not be unique",
+ "Can't do inplace edit: %"
+ SVf " would not be unique",
SVfARG(sv));
do_close(gv,FALSE);
continue;
#if !defined(DOSISH) && !defined(__CYGWIN__)
if (PerlLIO_rename(PL_oldname,SvPVX_const(sv)) < 0) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
- "Can't rename %s to %"SVf": %s, skipping file",
- PL_oldname, SVfARG(sv), Strerror(errno));
+ "Can't rename %s to %" SVf
+ ": %s, skipping file",
+ PL_oldname, SVfARG(sv),
+ Strerror(errno));
do_close(gv,FALSE);
continue;
}
do_close(gv,FALSE);
(void)PerlLIO_unlink(SvPVX_const(sv));
(void)PerlLIO_rename(PL_oldname,SvPVX_const(sv));
- do_open_raw(gv, SvPVX_const(sv), SvCUR(sv), O_RDONLY, 0);
+ do_open_raw(gv, SvPVX_const(sv), SvCUR(sv), O_RDONLY, 0, NULL);
#endif /* DOSISH */
#else
(void)UNLINK(SvPVX_const(sv));
if (link(PL_oldname,SvPVX_const(sv)) < 0) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
- "Can't rename %s to %"SVf": %s, skipping file",
+ "Can't rename %s to %" SVf ": %s, skipping file",
PL_oldname, SVfARG(sv), Strerror(errno) );
do_close(gv,FALSE);
continue;
#endif
}
else {
-#if !defined(DOSISH) && !defined(AMIGAOS)
+#if !defined(DOSISH) && !defined(__amigaos4__)
# ifndef VMS /* Don't delete; use automatic file versioning */
if (UNLINK(PL_oldname) < 0) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
if (!Perl_do_open_raw(aTHX_ PL_argvoutgv, SvPVX_const(sv),
SvCUR(sv),
#ifdef VMS
- O_WRONLY|O_CREAT|O_TRUNC, 0
+ O_WRONLY|O_CREAT|O_TRUNC, 0,
#else
- O_WRONLY|O_CREAT|OPEN_EXCL, 0600
+ O_WRONLY|O_CREAT|OPEN_EXCL, 0600,
#endif
- )) {
+ NULL)) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: %s",
PL_oldname, Strerror(errno) );
do_close(gv,FALSE);
setdefout(PL_argvoutgv);
PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
if (PL_lastfd >= 0) {
- (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
+ (void)PerlLIO_fstat(PL_lastfd,&statbuf);
#ifdef HAS_FCHMOD
(void)fchmod(PL_lastfd,PL_filemode);
#else
(void)PerlLIO_chmod(PL_oldname,PL_filemode);
#endif
- if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
+ if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) {
/* XXX silently ignore failures */
#ifdef HAS_FCHOWN
PERL_UNUSED_RESULT(fchown(PL_lastfd,fileuid,filegid));
if (ckWARN_d(WARN_INPLACE)) {
const int eno = errno;
- if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0
- && !S_ISREG(PL_statbuf.st_mode)) {
+ Stat_t statbuf;
+ if (PerlLIO_stat(PL_oldname, &statbuf) >= 0
+ && !S_ISREG(statbuf.st_mode)) {
Perl_warner(aTHX_ packWARN(WARN_INPLACE),
"Can't do inplace edit: %s is not a regular file",
PL_oldname);
if (io && (IoFLAGS(io) & IOf_ARGV))
IoFLAGS(io) |= IOf_START;
if (PL_inplace) {
- (void)do_close(PL_argvoutgv,FALSE);
+ if (old_out_name) {
+ IO * const io = GvIOp(PL_argvoutgv);
+ if (io && IoIFP(io) && !io_close(io, PL_argvoutgv, FALSE, FALSE)) {
+ Perl_croak(aTHX_ "Failed to close in-place edit file %" SVf ": %s\n",
+ old_out_name, Strerror(errno));
+ }
+ }
+ else {
+ /* maybe this is no longer wanted */
+ (void)do_close(PL_argvoutgv,FALSE);
+ }
if (io && (IoFLAGS(io) & IOf_ARGV)
&& PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
{
}
return FALSE;
}
- retval = io_close(io, not_implicit);
+ retval = io_close(io, NULL, not_implicit, FALSE);
if (not_implicit) {
IoLINES(io) = 0;
IoPAGE(io) = 0;
}
bool
-Perl_io_close(pTHX_ IO *io, bool not_implicit)
+Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail)
{
bool retval = FALSE;
}
}
IoOFP(io) = IoIFP(io) = NULL;
+
+ if (warn_on_fail && !retval) {
+ if (gv)
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
+ "Warning: unable to close filehandle %"
+ HEKf " properly: %" SVf,
+ HEKfARG(GvNAME_HEK(gv)),
+ SVfARG(get_sv("!",GV_ADD)));
+ else
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
+ "Warning: unable to close filehandle "
+ "properly: %" SVf,
+ SVfARG(get_sv("!",GV_ADD)));
+ }
}
else if (not_implicit) {
SETERRNO(EBADF,SS_IVCHAN);
if (io && (fp = IoIFP(io))) {
int fd = PerlIO_fileno(fp);
- if (fd >= 0) {
+ if (fd < 0 || (whence == SEEK_SET && pos < 0)) {
+ SETERRNO(EINVAL,LIB_INVARG);
+ return -1;
+ } else {
return PerlLIO_lseek(fd, pos, whence);
}
}
}
else {
const char *end;
-fail_discipline:
+ fail_discipline:
end = strchr(s+1, ':');
if (!end)
end = s+len;
if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) {
assert(!SvGMAGICAL(sv));
if (SvIsUV(sv))
- PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv));
+ PerlIO_printf(fp, "%" UVuf, (UV)SvUVX(sv));
else
- PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv));
+ PerlIO_printf(fp, "%" IVdf, (IV)SvIVX(sv));
return !PerlIO_error(fp);
}
else {
do_fstat_have_io:
PL_laststype = OP_STAT;
PL_statgv = gv ? gv : (GV *)io;
- sv_setpvs(PL_statname, "");
+ SvPVCLEAR(PL_statname);
if (io) {
if (IoIFP(io)) {
int fd = PerlIO_fileno(IoIFP(io));
if (ckWARN(WARN_IO)) {
/* diag_listed_as: Use of -l on filehandle%s */
Perl_warner(aTHX_ packWARN(WARN_IO),
- "Use of -l on filehandle %"HEKf,
+ "Use of -l on filehandle %" HEKf,
HEKfARG(GvENAME_HEK(cGVOP_gv)));
}
return -1;
else
/* diag_listed_as: Use of -l on filehandle%s */
Perl_warner(aTHX_ packWARN(WARN_IO),
- "Use of -l on filehandle %"HEKf,
+ "Use of -l on filehandle %" HEKf,
HEKfARG(GvENAME_HEK((const GV *)
(SvROK(sv) ? SvRV(sv) : sv))));
}
{
const int e = errno;
PERL_ARGS_ASSERT_EXEC_FAILED;
+
if (ckWARN(WARN_EXEC))
- Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
- cmd, Strerror(e));
+ Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
+ cmd, Strerror(e));
if (do_report) {
/* XXX silently ignore failures */
PERL_UNUSED_RESULT(PerlLIO_write(fd, (void*)&e, sizeof(int)));
(really && *tmps != '/')) /* will execvp use PATH? */
TAINT_ENV(); /* testing IFS here is overkill, probably */
PERL_FPU_PRE_EXEC
- if (really && *tmps)
- PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv));
- else
- PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
+ if (really && *tmps) {
+ PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv));
+ } else {
+ PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
+ }
PERL_FPU_POST_EXEC
S_exec_failed(aTHX_ (really ? tmps : PL_Argv[0]), fd, do_report);
}
{
char flags[PERL_FLAGS_MAX];
if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
- strnEQ(cmd+PL_cshlen," -c",3)) {
+ strEQs(cmd+PL_cshlen," -c")) {
my_strlcpy(flags, "-c", PERL_FLAGS_MAX);
s = cmd+PL_cshlen+3;
if (*s == 'f') {
if (*cmd == '.' && isSPACE(cmd[1]))
goto doshell;
- if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
+ if (strEQs(cmd,"exec") && isSPACE(cmd[4]))
goto doshell;
s = cmd;
}
doshell:
PERL_FPU_PRE_EXEC
- PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL);
+ PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL);
PERL_FPU_POST_EXEC
S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
Safefree(buf);
*a = NULL;
if (PL_Argv[0]) {
PERL_FPU_PRE_EXEC
- PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
+ PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
PERL_FPU_POST_EXEC
if (errno == ENOEXEC) { /* for system V NIH syndrome */
do_execfree();
#endif /* OS2 || WIN32 */
-#ifdef VMS
-#include <starlet.h> /* for sys$delprc */
-#endif
-
I32
Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
{
len -= 3;
}
if ((val = whichsig_pvn(s, len)) < 0)
- Perl_croak(aTHX_ "Unrecognized signal name \"%"SVf"\"", SVfARG(*mark));
+ Perl_croak(aTHX_ "Unrecognized signal name \"%" SVf "\"",
+ SVfARG(*mark));
}
else
{
}
APPLY_TAINT_PROPER();
tot = sp - mark;
-#ifdef VMS
- /* kill() doesn't do process groups (job trees?) under VMS */
- if (val == SIGKILL) {
- /* Use native sys$delprc() to insure that target process is
- * deleted; supervisor-mode images don't pay attention to
- * CRTL's emulation of Unix-style signals and kill()
- */
- while (++mark <= sp) {
- I32 proc;
- 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--;
- switch (__vmssts) {
- case SS$_NONEXPR:
- case SS$_NOSUCHNODE:
- SETERRNO(ESRCH,__vmssts);
- break;
- case SS$_NOPRIV:
- SETERRNO(EPERM,__vmssts);
- break;
- default:
- SETERRNO(EVMSERR,__vmssts);
- }
- }
- }
- PERL_ASYNC_CHECK();
- break;
- }
-#endif
+
while (++mark <= sp) {
Pid_t proc;
SvGETMAGIC(*mark);
}
else if (PL_unsafe) {
if (UNLINK(s))
+ {
tot--;
+ }
+#if defined(__amigaos4__) && defined(NEWLIB)
+ else
+ {
+ /* Under AmigaOS4 unlink only 'fails' if the
+ * filename is invalid. It may not remove the file
+ * if it's locked, so check if it's still around. */
+ if ((access(s,F_OK) != -1))
+ {
+ tot--;
+ }
+ }
+#endif
}
else { /* don't let root wipe out directories without -U */
- if (PerlLIO_lstat(s,&PL_statbuf) < 0)
- tot--;
- else if (S_ISDIR(PL_statbuf.st_mode)) {
+ Stat_t statbuf;
+ if (PerlLIO_lstat(s, &statbuf) < 0)
tot--;
+ else if (S_ISDIR(statbuf.st_mode)) {
SETERRNO(EISDIR, SS_NOPRIV);
+ tot--;
}
else {
if (UNLINK(s))
- tot--;
+ {
+ tot--;
+ }
+#if defined(__amigaos4__) && defined(NEWLIB)
+ else
+ {
+ /* Under AmigaOS4 unlink only 'fails' if the filename is invalid */
+ /* It may not remove the file if it's Locked, so check if it's still */
+ /* arround */
+ if((access(s,F_OK) != -1))
+ {
+ tot--;
+ }
+ }
+#endif
}
}
}
#undef APPLY_TAINT_PROPER
}
-/* Do the permissions allow some operation? Assumes statcache already set. */
+/* Do the permissions in *statbufp allow some operation? */
#ifndef VMS /* VMS' cando is in vms.c */
bool
Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *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 (mode & statbufp->st_mode) ? TRUE : FALSE;
+ return cBOOL(mode & statbufp->st_mode);
#else /* ! DOSISH */
# ifdef __CYGWIN__
if (msize < 0)
Perl_croak(aTHX_ "Arg too short for msgsnd");
SETERRNO(0,0);
- return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
+ if (id >= 0 && flags >= 0) {
+ return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
+ } else {
+ SETERRNO(EINVAL,LIB_INVARG);
+ return -1;
+ }
#else
PERL_UNUSED_ARG(sp);
PERL_UNUSED_ARG(mark);
/* suppress warning when reading into undef var --jhi */
if (! SvOK(mstr))
- sv_setpvs(mstr, "");
+ SvPVCLEAR(mstr);
msize = SvIVx(*++mark);
mtype = (long)SvIVx(*++mark);
flags = SvIVx(*++mark);
mbuf = SvGROW(mstr, sizeof(long)+msize+1);
SETERRNO(0,0);
- ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
+ if (id >= 0 && msize >= 0 && flags >= 0) {
+ ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
+ } else {
+ SETERRNO(EINVAL,LIB_INVARG);
+ ret = -1;
+ }
if (ret >= 0) {
SvCUR_set(mstr, sizeof(long)+ret);
*SvEND(mstr) = '\0';
SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */
return -1;
}
- shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
+ if (id >= 0) {
+ shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
+ } else {
+ SETERRNO(EINVAL,LIB_INVARG);
+ return -1;
+ }
if (shm == (char *)-1) /* I hate System V IPC, I really do */
return -1;
if (optype == OP_SHMREAD) {
SvGETMAGIC(mstr);
SvUPGRADE(mstr, SVt_PV);
if (! SvOK(mstr))
- sv_setpvs(mstr, "");
+ SvPVCLEAR(mstr);
SvPOK_only(mstr);
mbuf = SvGROW(mstr, (STRLEN)msize+1);
Function called by C<do_readline> to spawn a glob (or do the glob inside
perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
-this glob starter is only used by miniperl during the build process.
-Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up.
+this glob starter is only used by miniperl during the build process,
+or when PERL_EXTERNAL_GLOB is defined.
+Moving it away shrinks F<pp_hot.c>; shrinking F<pp_hot.c> helps speed perl up.
=cut
*/
#endif /* !CSH */
#endif /* !DOSISH */
{
- GV * const envgv = gv_fetchpvs("ENV", 0, SVt_PVHV);
- SV ** const home = hv_fetchs(GvHV(envgv), "HOME", 0);
- SV ** const path = hv_fetchs(GvHV(envgv), "PATH", 0);
- if (home && *home) SvGETMAGIC(*home);
- if (path && *path) SvGETMAGIC(*path);
- save_hash(gv_fetchpvs("ENV", 0, SVt_PVHV));
- if (home && *home) SvSETMAGIC(*home);
- if (path && *path) SvSETMAGIC(*path);
+ SV ** const svp = hv_fetchs(GvHVn(PL_envgv), "LS_COLORS", 0);
+ if (svp && *svp)
+ save_helem_flags(GvHV(PL_envgv),
+ newSVpvs_flags("LS_COLORS", SVs_TEMP), svp,
+ SAVEf_SETMAGIC);
}
(void)do_open6(PL_last_in_gv, SvPVX_const(tmpcmd), SvCUR(tmpcmd),
NULL, NULL, 0);
}
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff