/* 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.
tmpsv = TOPs;
}
tmps = SvPV(tmpsv, len);
- if (!tmps || !len) {
+ if ((!tmps || !len) && PL_errgv) {
SV *error = ERRSV;
(void)SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
#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];
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);
#else
retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
#endif
+#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",
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;
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)
}
#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-1] == '/' && 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;
}
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);
projects / p5sagit/p5-mst-13.2.git / blobdiff