/* pp_sys.c
*
- * Copyright (c) 1991-2002, Larry Wall
+ * Copyright (C) 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 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.
# 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 {
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;
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;
}
char *methname;
int how = PERL_MAGIC_tied;
U32 items;
- STRLEN n_a;
varsv = *++MARK;
switch(SvTYPE(varsv)) {
*/
stash = gv_stashsv(*MARK, FALSE);
if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
- DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"",
- methname, SvPV(*MARK,n_a));
+ DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
+ methname, *MARK);
}
ENTER;
PUSHSTACKi(PERLSI_MAGIC);
if (sv_isobject(sv)) {
sv_unmagic(varsv, how);
/* Croak if a self-tie on an aggregate is attempted. */
- if (varsv == SvRV(sv) && how == PERL_MAGIC_tied)
+ if (varsv == SvRV(sv) &&
+ (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;
#endif
}
+#ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
+ /* Can't make just the (void*) conditional because that would be
+ * cpp #if within cpp macro, and not all compilers like that. */
+ nfound = PerlSock_select(
+ maxlen * 8,
+ (Select_fd_set_t) fd_sets[1],
+ (Select_fd_set_t) fd_sets[2],
+ (Select_fd_set_t) fd_sets[3],
+ (void*) tbuf); /* Workaround for compiler bug. */
+#else
nfound = PerlSock_select(
maxlen * 8,
(Select_fd_set_t) fd_sets[1],
(Select_fd_set_t) fd_sets[2],
(Select_fd_set_t) fd_sets[3],
tbuf);
+#endif
for (i = 1; i <= 3; i++) {
if (fd_sets[i]) {
sv = SP[i];
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);
fp = IoOFP(io);
if (!fp) {
if (ckWARN2(WARN_CLOSED,WARN_IO)) {
- if (IoIFP(io)) {
- /* integrate with report_evil_fh()? */
- char *name = NULL;
- if (isGV(gv)) {
- SV* sv = sv_newmortal();
- gv_efullname4(sv, gv, Nullch, FALSE);
- name = SvPV_nolen(sv);
- }
- if (name && *name)
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle %s opened only for input", name);
- else
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle opened only for input");
- }
+ if (IoIFP(io))
+ report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
else if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
}
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))) {
if (ckWARN2(WARN_CLOSED,WARN_IO)) {
- /* integrate with report_evil_fh()? */
- if (IoIFP(io)) {
- char *name = NULL;
- if (isGV(gv)) {
- gv_efullname4(sv, gv, Nullch, FALSE);
- name = SvPV_nolen(sv);
- }
- if (name && *name)
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle %s opened only for input", name);
- else
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle opened only for input");
- }
+ if (IoIFP(io))
+ report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
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 */
}
if (count < 0) {
if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
- {
- /* integrate with report_evil_fh()? */
- char *name = NULL;
- if (isGV(gv)) {
- SV* sv = sv_newmortal();
- gv_efullname4(sv, gv, Nullch, FALSE);
- name = SvPV_nolen(sv);
- }
- if (name && *name)
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle %s opened only for output", name);
- else
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle opened only for output");
- }
+ report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
goto say_undef;
}
SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv)));
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;
STRLEN n_a;
int result = 1;
GV *tmpgv;
-
+ IO *io;
+
if (PL_op->op_flags & OPf_SPECIAL) {
tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
- do_ftruncate:
- TAINT_PROPER("truncate");
- if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
- result = 0;
+ do_ftruncate_gv:
+ if (!GvIO(tmpgv))
+ result = 0;
else {
- PerlIO_flush(IoIFP(GvIOp(tmpgv)));
+ PerlIO *fp;
+ io = GvIOp(tmpgv);
+ do_ftruncate_io:
+ TAINT_PROPER("truncate");
+ if (!(fp = IoIFP(io))) {
+ result = 0;
+ }
+ else {
+ PerlIO_flush(fp);
#ifdef HAS_TRUNCATE
- if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+ if (ftruncate(PerlIO_fileno(fp), len) < 0)
#else
- if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+ if (my_chsize(PerlIO_fileno(fp), len) < 0)
#endif
- result = 0;
+ result = 0;
+ }
}
}
else {
if (SvTYPE(sv) == SVt_PVGV) {
tmpgv = (GV*)sv; /* *main::FRED for example */
- goto do_ftruncate;
+ goto do_ftruncate_gv;
}
else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
- goto do_ftruncate;
+ goto do_ftruncate_gv;
+ }
+ else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
+ io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
+ goto do_ftruncate_io;
}
name = SvPV(sv, n_a);
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 defined(HAS_IOCTL) || defined(HAS_FCNTL)
if (SvPOK(argsv)) {
if (s[SvCUR(argsv)] != 17)
DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
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");
struct sockaddr saddr; /* use a struct to avoid alignment problems */
Sock_size_t len = sizeof saddr;
int fd;
- int fd2;
ggv = (GV*)POPs;
ngv = (GV*)POPs;
goto badexit;
if (IoIFP(nstio))
do_close(ngv, FALSE);
- IoIFP(nstio) = PerlIO_fdopen(fd, "r");
- /* 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");
+ IoIFP(nstio) = PerlIO_fdopen(fd, "r"PIPESOCK_MODE);
+ IoOFP(nstio) = PerlIO_fdopen(fd, "w"PIPESOCK_MODE);
IoTYPE(nstio) = IoTYPE_SOCKET;
if (!IoIFP(nstio) || !IoOFP(nstio)) {
if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
}
#if defined(HAS_FCNTL) && defined(F_SETFD)
fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
- fcntl(fd2, F_SETFD, fd2 > PL_maxsysfd); /* ensure close-on-exec */
#endif
#ifdef EPOC
len = sizeof saddr; /* EPOC somehow truncates info */
setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
#endif
+#ifdef __SCO_VERSION__
+ len = sizeof saddr; /* OpenUNIX 8 somehow truncates info */
+#endif
PUSHp((char *)&saddr, len);
RETURN;
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;
PUSHs(sv_2mortal(newSVpvn("", 0)));
#endif
#if Off_t_size > IVSIZE
- PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
+ PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
#else
PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
#endif
dSP;
#if defined(HAS_ACCESS) && defined(R_OK)
STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = access(TOPpx, R_OK);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ result = access(POPpx, R_OK);
if (result == 0)
RETPUSHYES;
if (result < 0)
dSP;
#if defined(HAS_ACCESS) && defined(W_OK)
STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = access(TOPpx, W_OK);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ result = access(POPpx, W_OK);
if (result == 0)
RETPUSHYES;
if (result < 0)
dSP;
#if defined(HAS_ACCESS) && defined(X_OK)
STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = access(TOPpx, X_OK);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ result = access(POPpx, X_OK);
if (result == 0)
RETPUSHYES;
if (result < 0)
dSP;
#ifdef PERL_EFF_ACCESS_R_OK
STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = PERL_EFF_ACCESS_R_OK(TOPpx);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ result = PERL_EFF_ACCESS_R_OK(POPpx);
if (result == 0)
RETPUSHYES;
if (result < 0)
dSP;
#ifdef PERL_EFF_ACCESS_W_OK
STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = PERL_EFF_ACCESS_W_OK(TOPpx);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ result = PERL_EFF_ACCESS_W_OK(POPpx);
if (result == 0)
RETPUSHYES;
if (result < 0)
dSP;
#ifdef PERL_EFF_ACCESS_X_OK
STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = PERL_EFF_ACCESS_X_OK(TOPpx);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ result = PERL_EFF_ACCESS_X_OK(POPpx);
if (result == 0)
RETPUSHYES;
if (result < 0)
gv = cGVOP_gv;
report_evil_fh(gv, GvIO(gv), PL_op->op_type);
}
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
}
PL_laststype = OP_STAT;
sv_setpv(PL_statname, SvPV(sv, n_a));
if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
- if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
+ if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
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;
}
}
#endif
+/* This macro removes trailing slashes from a directory name.
+ * Different operating and file systems take differently to
+ * trailing slashes. According to POSIX 1003.1 1996 Edition
+ * any number of trailing slashes should be allowed.
+ * Thusly we snip them away so that even non-conforming
+ * systems are happy.
+ * We should probably do this "filtering" for all
+ * the functions that expect (potentially) directory names:
+ * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
+ * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
+
+#define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV(TOPs, (len)); \
+ if ((len) > 1 && (tmps)[(len)-1] == '/') { \
+ do { \
+ (len)--; \
+ } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
+ (tmps) = savepvn((tmps), (len)); \
+ (copy) = TRUE; \
+ }
+
PP(pp_mkdir)
{
dSP; dTARGET;
else
mode = 0777;
- tmps = SvPV(TOPs, len);
- /* Different operating and file systems take differently to
- * trailing slashes. According to POSIX 1003.1 1996 Edition
- * any number of trailing slashes should be allowed.
- * Thusly we snip them away so that even non-conforming
- * systems are happy. */
- /* We should probably do this "filtering" for all
- * the functions that expect (potentially) directory names:
- * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
- * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
- if (len > 1 && tmps[len-1] == '/') {
- while (tmps[len] == '/' && len > 1)
- len--;
- tmps = savepvn(tmps, len);
- copy = TRUE;
- }
+ TRIMSLASHES(tmps,len,copy);
TAINT_PROPER("mkdir");
#ifdef HAS_MKDIR
PP(pp_rmdir)
{
dSP; dTARGET;
+ STRLEN len;
char *tmps;
- STRLEN n_a;
+ bool copy = FALSE;
- tmps = POPpx;
+ TRIMSLASHES(tmps,len,copy);
TAINT_PROPER("rmdir");
#ifdef HAS_RMDIR
- XPUSHi( PerlDir_rmdir(tmps) >= 0 );
+ SETi( PerlDir_rmdir(tmps) >= 0 );
#else
- XPUSHi( dooneliner("rmdir", tmps) );
+ SETi( dooneliner("rmdir", tmps) );
#endif
+ if (copy)
+ Safefree(tmps);
RETURN;
}
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);
Pid_t childpid;
int argflags;
-#ifdef PERL_OLD_SIGNALS
- childpid = wait4pid(-1, &argflags, 0);
-#else
- while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && errno == EINTR) {
- PERL_ASYNC_CHECK();
+ if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+ childpid = wait4pid(-1, &argflags, 0);
+ else {
+ while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
+ errno == EINTR) {
+ PERL_ASYNC_CHECK();
+ }
}
-#endif
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
/* 0 and -1 are both error returns (the former applies to WNOHANG case) */
STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
optype = POPi;
childpid = TOPi;
-#ifdef PERL_OLD_SIGNALS
- childpid = wait4pid(childpid, &argflags, optype);
-#else
- while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && errno == EINTR) {
- PERL_ASYNC_CHECK();
+ if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+ childpid = wait4pid(childpid, &argflags, optype);
+ else {
+ while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 &&
+ errno == EINTR) {
+ PERL_ASYNC_CHECK();
+ }
}
-#endif
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
/* 0 and -1 are both error returns (the former applies to WNOHANG case) */
STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
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;
+# if defined(WIN32) || defined(OS2)
+ 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) {
+# if defined(WIN32) || defined(OS2)
+ 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
char *proto = POPpbytex;
unsigned short port = (unsigned short)POPu;
+ if (proto && !*proto)
+ proto = Nullch;
+
#ifdef HAS_HTONS
port = PerlSock_htons(port);
#endif
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
https://perl5.git.perl.org / perl5.git / blobdiff