# define FD_CLOEXEC 1 /* NeXT needs this */
#endif
+#include "reentr.h"
+
#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
#undef PERL_EFF_ACCESS_W_OK
#undef PERL_EFF_ACCESS_X_OK
;
}
else if (gimme == G_SCALAR) {
+ SV *oldrs = PL_rs;
+ PL_rs = &PL_sv_undef;
sv_setpv(TARG, ""); /* note that this preserves previous buffer */
while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
/*SUPPRESS 530*/
;
+ PL_rs = oldrs;
XPUSHs(TARG);
SvTAINTED_on(TARG);
}
}
else {
tmpsv = TOPs;
- tmps = (SvROK(tmpsv) && PL_in_eval) ? Nullch : SvPV(tmpsv, len);
+ tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
}
if (!tmps || !len) {
SV *error = ERRSV;
if (PerlProc_pipe(fd) < 0)
goto badexit;
- IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
- IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
+ IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPESOCK_MODE);
+ IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPESOCK_MODE);
+ IoOFP(rstio) = IoIFP(rstio);
IoIFP(wstio) = IoOFP(wstio);
IoTYPE(rstio) = IoTYPE_RDONLY;
IoTYPE(wstio) = IoTYPE_WRONLY;
if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
+ SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
sv_unmagic(varsv, how);
/* Croak if a self-tie on an aggregate is attempted. */
if (varsv == SvRV(sv) &&
- (SvTYPE(sv) == SVt_PVAV ||
- SvTYPE(sv) == SVt_PVHV))
+ (SvTYPE(varsv) == SVt_PVAV ||
+ SvTYPE(varsv) == SVt_PVHV))
Perl_croak(aTHX_
"Self-ties of arrays and hashes are not supported");
- sv_magic(varsv, sv, how, Nullch, 0);
+ sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
}
LEAVE;
SP = PL_stack_base + markoff;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)
&& (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY)))
report_evil_fh(gv, io, PL_op->op_type);
+ SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
TAINT;
{
register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
- AV* padlist = CvPADLIST(cv);
- SV** svp = AvARRAY(padlist);
ENTER;
SAVETMPS;
push_return(retop);
PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
PUSHFORMAT(cx);
- SAVEVPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)svp[1]);
+ PAD_SET_CUR(CvPADLIST(cv), 1);
setdefout(gv); /* locally select filehandle so $% et al work */
return CvSTART(cv);
if (!(io = GvIO(gv))) {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,RMS_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
else if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
}
- SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
+ SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
goto just_say_no;
}
else {
else
offset = 0;
io = GvIO(gv);
- if (!io || !IoIFP(io))
+ if (!io || !IoIFP(io)) {
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
+ SETERRNO(EBADF,RMS_IFI);
goto say_undef;
+ }
if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
buffer = SvPVutf8_force(bufsv, blen);
/* UTF8 may not have been set if they are all low bytes */
retval = -1;
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
+ SETERRNO(EBADF,RMS_IFI);
goto say_undef;
}
/* XXX Configure probe for the length type of *truncate() needed XXX */
Off_t len;
-#if Size_t_size > IVSIZE
+#if Off_t_size > IVSIZE
len = (Off_t)POPn;
#else
len = (Off_t)POPi;
if (result)
RETPUSHYES;
if (!errno)
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
#else
if (!io || !argsv || !IoIFP(io)) {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
+ SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
RETPUSHUNDEF;
}
DIE(aTHX_ "ioctl is not implemented");
#endif
else
-#ifdef HAS_FCNTL
+#ifndef HAS_FCNTL
+ DIE(aTHX_ "fcntl is not implemented");
+#else
#if defined(OS2) && defined(__EMX__)
retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
#else
retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
#endif
-#else
- DIE(aTHX_ "fcntl is not implemented");
-#endif
if (SvPOK(argsv)) {
if (s[SvCUR(argsv)] != 17)
else {
PUSHp(zero_but_true, ZBTLEN);
}
+#endif
RETURN;
}
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
value = 0;
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,RMS_IFI);
}
PUSHi(value);
RETURN;
report_evil_fh(gv, io, PL_op->op_type);
if (IoIFP(io))
do_close(gv, FALSE);
- SETERRNO(EBADF,LIB$_INVARG);
+ SETERRNO(EBADF,LIB_INVARG);
RETPUSHUNDEF;
}
fd = PerlSock_socket(domain, type, protocol);
if (fd < 0)
RETPUSHUNDEF;
- IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
- IoOFP(io) = PerlIO_fdopen(fd, "w");
+ IoIFP(io) = PerlIO_fdopen(fd, "r"PIPESOCK_MODE); /* stdio gets confused about sockets */
+ IoOFP(io) = PerlIO_fdopen(fd, "w"PIPESOCK_MODE);
IoTYPE(io) = IoTYPE_SOCKET;
if (!IoIFP(io) || !IoOFP(io)) {
if (IoIFP(io)) PerlIO_close(IoIFP(io));
TAINT_PROPER("socketpair");
if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
RETPUSHUNDEF;
- IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
- IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
+ IoIFP(io1) = PerlIO_fdopen(fd[0], "r"PIPESOCK_MODE);
+ IoOFP(io1) = PerlIO_fdopen(fd[0], "w"PIPESOCK_MODE);
IoTYPE(io1) = IoTYPE_SOCKET;
- IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
- IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
+ IoIFP(io2) = PerlIO_fdopen(fd[1], "r"PIPESOCK_MODE);
+ IoOFP(io2) = PerlIO_fdopen(fd[1], "w"PIPESOCK_MODE);
IoTYPE(io2) = IoTYPE_SOCKET;
if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "bind");
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "connect");
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "listen");
goto badexit;
if (IoIFP(nstio))
do_close(ngv, FALSE);
- IoIFP(nstio) = PerlIO_fdopen(fd, "r");
+ IoIFP(nstio) = PerlIO_fdopen(fd, "r"PIPESOCK_MODE);
/* FIXME: we dup(fd) here so that refcounting of fd's does not inhibit
fclose of IoOFP's FILE * - and hence leak memory.
Special treatment of _this_ case of IoIFP != IoOFP seems wrong.
*/
- IoOFP(nstio) = PerlIO_fdopen(fd2 = PerlLIO_dup(fd), "w");
+ IoOFP(nstio) = PerlIO_fdopen(fd2 = PerlLIO_dup(fd), "w"PIPESOCK_MODE);
IoTYPE(nstio) = IoTYPE_SOCKET;
if (!IoIFP(nstio) || !IoOFP(nstio)) {
if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,SS_IVCHAN);
badexit:
RETPUSHUNDEF;
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "shutdown");
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, optype);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,SS_IVCHAN);
nuts2:
RETPUSHUNDEF;
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, optype);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,SS_IVCHAN);
nuts2:
RETPUSHUNDEF;
gv = cGVOP_gv;
report_evil_fh(gv, GvIO(gv), PL_op->op_type);
}
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
}
#define EACCES EPERM
#endif
if (instr(s, "cannot make"))
- SETERRNO(EEXIST,RMS$_FEX);
+ SETERRNO(EEXIST,RMS_FEX);
else if (instr(s, "existing file"))
- SETERRNO(EEXIST,RMS$_FEX);
+ SETERRNO(EEXIST,RMS_FEX);
else if (instr(s, "ile exists"))
- SETERRNO(EEXIST,RMS$_FEX);
+ SETERRNO(EEXIST,RMS_FEX);
else if (instr(s, "non-exist"))
- SETERRNO(ENOENT,RMS$_FNF);
+ SETERRNO(ENOENT,RMS_FNF);
else if (instr(s, "does not exist"))
- SETERRNO(ENOENT,RMS$_FNF);
+ SETERRNO(ENOENT,RMS_FNF);
else if (instr(s, "not empty"))
- SETERRNO(EBUSY,SS$_DEVOFFLINE);
+ SETERRNO(EBUSY,SS_DEVOFFLINE);
else if (instr(s, "cannot access"))
- SETERRNO(EACCES,RMS$_PRV);
+ SETERRNO(EACCES,RMS_PRV);
else
- SETERRNO(EPERM,RMS$_PRV);
+ SETERRNO(EPERM,RMS_PRV);
return 0;
}
else { /* some mkdirs return no failure indication */
if (anum)
SETERRNO(0,0);
else
- SETERRNO(EACCES,RMS$_PRV); /* a guess */
+ SETERRNO(EACCES,RMS_PRV); /* a guess */
}
return anum;
}
* -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
* (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
if (len > 1 && tmps[len-1] == '/') {
- while (tmps[len] == '/' && len > 1)
+ while (tmps[len-1] == '/' && len > 1)
len--;
tmps = savepvn(tmps, len);
copy = TRUE;
RETPUSHYES;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_DIR);
+ SETERRNO(EBADF,RMS_DIR);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "opendir");
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_ISI);
+ SETERRNO(EBADF,RMS_ISI);
if (GIMME == G_ARRAY)
RETURN;
else
RETURN;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_ISI);
+ SETERRNO(EBADF,RMS_ISI);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "telldir");
RETPUSHYES;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_ISI);
+ SETERRNO(EBADF,RMS_ISI);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "seekdir");
RETPUSHYES;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_ISI);
+ SETERRNO(EBADF,RMS_ISI);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "rewinddir");
RETPUSHYES;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "closedir");
sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
SvREADONLY_on(GvSV(tmpgv));
}
+#ifdef THREADS_HAVE_PIDS
+ PL_ppid = (IV)getppid();
+#endif
hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
}
PUSHi(childpid);
break;
}
MARK = ORIGMARK;
- /* XXX Remove warning at end of deprecation cycle --RD 2002-02 */
- if (SP - MARK == 1) {
- TAINT_PROPER("system");
- }
- else if (ckWARN2(WARN_TAINT, WARN_DEPRECATED)) {
- Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED),
- "Use of tainted arguments in %s is deprecated", "system");
- }
+ TAINT_PROPER("system");
}
PERL_FLUSHALL_FOR_CHILD;
#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
result = 0;
if (PL_op->op_flags & OPf_STACKED) {
SV *really = *++MARK;
+# ifdef WIN32
+ value = (I32)do_aspawn(really, MARK, SP);
+# else
value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
+# endif
}
- else if (SP - MARK != 1)
+ else if (SP - MARK != 1) {
+# ifdef WIN32
+ value = (I32)do_aspawn(Nullsv, MARK, SP);
+# else
value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
+# endif
+ }
else {
value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
}
break;
}
MARK = ORIGMARK;
- /* XXX Remove warning at end of deprecation cycle --RD 2002-02 */
- if (SP - MARK == 1) {
- TAINT_PROPER("exec");
- }
- else if (ckWARN2(WARN_TAINT, WARN_DEPRECATED)) {
- Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED),
- "Use of tainted arguments in %s is deprecated", "exec");
- }
+ TAINT_PROPER("exec");
}
PERL_FLUSHALL_FOR_CHILD;
if (PL_op->op_flags & OPf_STACKED) {
{
#ifdef HAS_GETPPID
dSP; dTARGET;
+# ifdef THREADS_HAVE_PIDS
+ XPUSHi( PL_ppid );
+# else
XPUSHi( getppid() );
+# endif
RETURN;
#else
DIE(aTHX_ PL_no_func, "getppid");
RETURN;
}
-/* XXX The POSIX name is CLK_TCK; it is to be preferred
- to HZ. Probably. For now, assume that if the system
- defines HZ, it does so correctly. (Will this break
- on VMS?)
- Probably we ought to use _sysconf(_SC_CLK_TCK), if
- it's supported. --AD 9/96.
-*/
-
-#ifdef __BEOS__
-# define HZ 1000000
-#endif
-
-#ifndef HZ
-# ifdef CLK_TCK
-# define HZ CLK_TCK
-# else
-# define HZ 60
-# endif
-#endif
-
PP(pp_tms)
{
#ifdef HAS_TIMES
/* is returned. */
#endif
- PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
+ PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
if (GIMME == G_ARRAY) {
- PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
- PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
- PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
+ PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
+ PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
+ PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
}
RETURN;
#else
case OP_GPWENT:
# ifdef HAS_GETPWENT
pwent = getpwent();
+#ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
+ if (pwent) pwent = getpwnam(pwent->pw_name);
+#endif
# else
DIE(aTHX_ PL_no_func, "getpwent");
# endif
projects / p5sagit/p5-mst-13.2.git / blobdiff