/* pp_sys.c
*
- * Copyright (c) 1991-1999, Larry Wall
+ * Copyright (c) 1991-2000, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
compiling multithreaded and singlethreaded ($ccflags et al).
HOST_NOT_FOUND is typically defined in <netdb.h>.
*/
-#if defined(HOST_NOT_FOUND) && !defined(h_errno)
+#if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
extern int h_errno;
#endif
# include <utime.h>
# endif
#endif
-#ifdef I_FCNTL
-#include <fcntl.h>
-#endif
-#ifdef I_SYS_FILE
-#include <sys/file.h>
-#endif
/* Put this after #includes because fork and vfork prototypes may conflict. */
#ifndef HAS_VFORK
# define vfork fork
#endif
-/* Put this after #includes because <unistd.h> defines _XOPEN_*. */
-#ifndef Sock_size_t
-# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
-# define Sock_size_t Size_t
-# else
-# define Sock_size_t int
-# endif
-#endif
-
#ifdef HAS_CHSIZE
# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
# undef my_chsize
Gid_t egid = getegid();
int res;
- MUTEX_LOCK(&PL_cred_mutex);
+ LOCK_CRED_MUTEX;
#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
Perl_croak(aTHX_ "switching effective uid is not implemented");
#else
#endif
#endif
Perl_croak(aTHX_ "leaving effective gid failed");
- MUTEX_UNLOCK(&PL_cred_mutex);
+ UNLOCK_CRED_MUTEX;
return res;
}
if (!tmps || !len)
tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
- Perl_warn(aTHX_ "%_", tmpsv);
+ Perl_warn(aTHX_ "%"SVf, tmpsv);
RETSETYES;
}
if (!tmps || !len)
tmpsv = sv_2mortal(newSVpvn("Died", 4));
- DIE(aTHX_ "%_", tmpsv);
+ DIE(aTHX_ "%"SVf, tmpsv);
}
/* I/O. */
/* If SELECT_MIN_BITS is greater than one we most probably will want
* to align the sizes with SELECT_MIN_BITS/8 because for example
* in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
- * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
+ * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
* on (sets/tests/clears bits) is 32 bits. */
growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
# else
gv = PL_stdingv;
else
gv = (GV*)POPs;
- if (!gv)
- gv = PL_argvgv;
if (mg = SvTIED_mg((SV*)gv, 'q')) {
I32 gimme = GIMME_V;
fp = IoOFP(io);
if (!fp) {
if (ckWARN2(WARN_CLOSED,WARN_IO)) {
- SV* sv = sv_newmortal();
- gv_efullname3(sv, gv, Nullch);
- if (IoIFP(io))
+ if (IoIFP(io)) {
+ SV* sv = sv_newmortal();
+ gv_efullname3(sv, gv, Nullch);
Perl_warner(aTHX_ WARN_IO,
"Filehandle %s opened only for input",
SvPV_nolen(sv));
+ }
else if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED,
- "Write on closed filehandle %s", SvPV_nolen(sv));
+ report_closed_fh(gv, io, "write", "filehandle");
}
PUSHs(&PL_sv_no);
}
}
else if (!(fp = IoOFP(io))) {
if (ckWARN2(WARN_CLOSED,WARN_IO)) {
- gv_efullname3(sv, gv, Nullch);
- if (IoIFP(io))
+ if (IoIFP(io)) {
+ gv_efullname3(sv, gv, Nullch);
Perl_warner(aTHX_ WARN_IO,
"Filehandle %s opened only for input",
SvPV(sv,n_a));
+ }
else if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED,
- "printf on closed filehandle %s", SvPV(sv,n_a));
+ report_closed_fh(gv, io, "printf", "filehandle");
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
length = -1;
if (ckWARN(WARN_CLOSED)) {
if (PL_op->op_type == OP_SYSWRITE)
- Perl_warner(aTHX_ WARN_CLOSED, "Syswrite on closed filehandle");
+ report_closed_fh(gv, io, "syswrite", "filehandle");
else
- Perl_warner(aTHX_ WARN_CLOSED, "Send on closed socket");
+ report_closed_fh(gv, io, "send", "socket");
}
}
else if (PL_op->op_type == OP_SYSWRITE) {
if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
+#if LSEEKSIZE > IVSIZE
+ XPUSHs(sv_2mortal(newSVnv((NV) offset)));
+#else
XPUSHs(sv_2mortal(newSViv((IV) offset)));
+#endif
XPUSHs(sv_2mortal(newSViv((IV) whence)));
PUTBACK;
ENTER;
tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
do_ftruncate:
TAINT_PROPER("truncate");
- if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
+ if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
+ result = 0;
+ else {
+ PerlIO_flush(IoIFP(GvIOp(tmpgv)));
#ifdef HAS_TRUNCATE
- ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+ if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
#else
- my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+ if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
#endif
- result = 0;
+ result = 0;
+ }
}
else {
SV *sv = POPs;
(void)PerlIO_flush(fp);
value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
}
- else
+ else {
value = 0;
+ SETERRNO(EBADF,RMS$_IFI);
+ if (ckWARN(WARN_CLOSED))
+ report_closed_fh(gv, GvIO(gv), "flock", "filehandle");
+ }
PUSHi(value);
RETURN;
#else
if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
RETPUSHUNDEF;
}
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
+#endif
RETPUSHYES;
#else
if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
RETPUSHUNDEF;
}
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
+ fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
+#endif
RETPUSHYES;
#else
nuts:
if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED, "bind() on closed fd");
+ report_closed_fh(gv, io, "bind", "socket");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
nuts:
if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED, "connect() on closed fd");
+ report_closed_fh(gv, io, "connect", "socket");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
nuts:
if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED, "listen() on closed fd");
+ report_closed_fh(gv, io, "listen", "socket");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
goto badexit;
}
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
+#endif
PUSHp((char *)&saddr, len);
RETURN;
nuts:
if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED, "accept() on closed fd");
+ report_closed_fh(ggv, ggv ? GvIO(ggv) : 0, "accept", "socket");
SETERRNO(EBADF,SS$_IVCHAN);
badexit:
nuts:
if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED, "shutdown() on closed fd");
+ report_closed_fh(gv, io, "shutdown", "socket");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
nuts:
if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED, "[gs]etsockopt() on closed fd");
+ report_closed_fh(gv, io,
+ optype == OP_GSOCKOPT ? "getsockopt" : "setsockopt",
+ "socket");
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
nuts:
if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED, "get{sock, peer}name() on closed fd");
+ report_closed_fh(gv, io,
+ optype == OP_GETSOCKNAME ? "getsockname"
+ : "getpeername",
+ "socket");
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
PP(pp_mkdir)
{
djSP; dTARGET;
- int mode = POPi;
+ int mode;
#ifndef HAS_MKDIR
int oldumask;
#endif
STRLEN n_a;
- char *tmps = SvPV(TOPs, n_a);
+ char *tmps;
+
+ if (MAXARG > 1)
+ mode = POPi;
+ else
+ mode = 0777;
+
+ tmps = SvPV(TOPs, n_a);
TAINT_PROPER("mkdir");
#ifdef HAS_MKDIR
PP(pp_gpwent)
{
djSP;
-#if defined(HAS_PASSWD) && defined(HAS_GETPWENT)
+#ifdef HAS_PASSWD
I32 which = PL_op->op_type;
register SV *sv;
struct passwd *pwent;
else if (which == OP_GPWUID)
pwent = getpwuid(POPi);
else
+#ifdef HAS_GETPWENT
pwent = (struct passwd *)getpwent();
+#else
+ DIE(aTHX_ PL_no_func, "getpwent");
+#endif
#ifdef HAS_GETSPNAM
if (which == OP_GPWNAM) {
PP(pp_ggrent)
{
djSP;
-#if defined(HAS_GROUP) && defined(HAS_GETGRENT)
+#ifdef HAS_GROUP
I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
else if (which == OP_GGRGID)
grent = (struct group *)getgrgid(POPi);
else
+#ifdef HAS_GETGRENT
grent = (struct group *)getgrent();
+#else
+ DIE(aTHX_ PL_no_func, "getgrent");
+#endif
EXTEND(SP, 4);
if (GIMME != G_ARRAY) {