/* pp_sys.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * Copyright (c) 1991-2003, 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.
*/
#include "EXTERN.h"
+#define PERL_IN_PP_SYS_C
#include "perl.h"
-/* XXX If this causes problems, set i_unistd=undef in the hint file. */
-#ifdef I_UNISTD
-# include <unistd.h>
+#ifdef I_SHADOW
+/* Shadow password support for solaris - pdo@cs.umd.edu
+ * Not just Solaris: at least HP-UX, IRIX, Linux.
+ * The API is from SysV.
+ *
+ * There are at least two more shadow interfaces,
+ * see the comments in pp_gpwent().
+ *
+ * --jhi */
+# ifdef __hpux__
+/* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
+ * and another MAXINT from "perl.h" <- <sys/param.h>. */
+# undef MAXINT
+# endif
+# include <shadow.h>
+#endif
+
+#ifdef HAS_SYSCALL
+#ifdef __cplusplus
+extern "C" int syscall(unsigned long,...);
+#endif
#endif
#ifdef I_SYS_WAIT
# include <sys/resource.h>
#endif
-/* Put this after #includes because fork and vfork prototypes may
- conflict.
-*/
-#ifndef HAS_VFORK
-# define vfork fork
-#endif
-
-#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
-# include <sys/socket.h>
-# include <netdb.h>
-# ifndef ENOTSOCK
-# ifdef I_NET_ERRNO
-# include <net/errno.h>
-# endif
-# endif
+#ifdef NETWARE
+NETDB_DEFINE_CONTEXT
#endif
#ifdef HAS_SELECT
-#ifdef I_SYS_SELECT
-#include <sys/select.h>
-#endif
+# ifdef I_SYS_SELECT
+# include <sys/select.h>
+# endif
#endif
-#ifdef HOST_NOT_FOUND
+/* XXX Configure test needed.
+ h_errno might not be a simple 'int', especially for multi-threaded
+ applications, see "extern int errno in perl.h". Creating such
+ a test requires taking into account the differences between
+ compiling multithreaded and singlethreaded ($ccflags et al).
+ HOST_NOT_FOUND is typically defined in <netdb.h>.
+*/
+#if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
extern int h_errno;
#endif
# ifdef I_PWD
# include <pwd.h>
# else
- struct passwd *getpwnam _((char *));
- struct passwd *getpwuid _((Uid_t));
+# if !defined(VMS)
+ struct passwd *getpwnam (char *);
+ struct passwd *getpwuid (Uid_t);
+# endif
+# endif
+# ifdef HAS_GETPWENT
+#ifndef getpwent
+ struct passwd *getpwent (void);
+#elif defined (VMS) && defined (my_getpwent)
+ struct passwd *Perl_my_getpwent (void);
+#endif
# endif
- struct passwd *getpwent _((void));
#endif
#ifdef HAS_GROUP
# ifdef I_GRP
# include <grp.h>
# else
- struct group *getgrnam _((char *));
- struct group *getgrgid _((Gid_t));
+ struct group *getgrnam (char *);
+ struct group *getgrgid (Gid_t);
# endif
- struct group *getgrent _((void));
+# ifdef HAS_GETGRENT
+#ifndef getgrent
+ struct group *getgrent (void);
#endif
-
-#ifdef I_UTIME
-#include <utime.h>
-#endif
-#ifdef I_FCNTL
-#include <fcntl.h>
-#endif
-#ifdef I_SYS_FILE
-#include <sys/file.h>
+# endif
#endif
-#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
-static int dooneliner _((char *cmd, char *filename));
+#ifdef I_UTIME
+# if defined(_MSC_VER) || defined(__MINGW32__)
+# include <sys/utime.h>
+# else
+# include <utime.h>
+# endif
#endif
#ifdef HAS_CHSIZE
# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
# undef my_chsize
# endif
-# define my_chsize chsize
+# define my_chsize PerlLIO_chsize
#endif
#ifdef HAS_FLOCK
# include <fcntl.h>
# endif
-# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
+# if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
# define FLOCK fcntl_emulate_flock
# define FCNTL_EMULATE_FLOCK
# else /* no flock() or fcntl(F_SETLK,...) */
# endif /* no flock() or fcntl(F_SETLK,...) */
# ifdef FLOCK
- static int FLOCK _((int, int));
+ static int FLOCK (int, int);
/*
* These are the flock() constants. Since this sytems doesn't have
#endif /* no flock() */
+#define ZBTLEN 10
+static char zero_but_true[ZBTLEN + 1] = "0 but true";
+
+#if defined(I_SYS_ACCESS) && !defined(R_OK)
+# include <sys/access.h>
+#endif
+
+#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
+# 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
+
+/* F_OK unused: if stat() cannot find it... */
+
+#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
+ /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
+# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
+# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
+# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
+#endif
+
+#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
+# ifdef I_SYS_SECURITY
+# include <sys/security.h>
+# endif
+# ifdef ACC_SELF
+ /* HP SecureWare */
+# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
+# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
+# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
+# else
+ /* SCO */
+# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
+# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
+# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
+# endif
+#endif
+
+#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
+ /* AIX */
+# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
+# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
+# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
+#endif
+
+#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \
+ && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
+ || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
+/* The Hard Way. */
+STATIC int
+S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
+{
+ Uid_t ruid = getuid();
+ Uid_t euid = geteuid();
+ Gid_t rgid = getgid();
+ Gid_t egid = getegid();
+ int res;
+
+ LOCK_CRED_MUTEX;
+#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
+ Perl_croak(aTHX_ "switching effective uid is not implemented");
+#else
+#ifdef HAS_SETREUID
+ if (setreuid(euid, ruid))
+#else
+#ifdef HAS_SETRESUID
+ if (setresuid(euid, ruid, (Uid_t)-1))
+#endif
+#endif
+ Perl_croak(aTHX_ "entering effective uid failed");
+#endif
+
+#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
+ Perl_croak(aTHX_ "switching effective gid is not implemented");
+#else
+#ifdef HAS_SETREGID
+ if (setregid(egid, rgid))
+#else
+#ifdef HAS_SETRESGID
+ if (setresgid(egid, rgid, (Gid_t)-1))
+#endif
+#endif
+ Perl_croak(aTHX_ "entering effective gid failed");
+#endif
+
+ res = access(path, mode);
-/* Pushy I/O. */
+#ifdef HAS_SETREUID
+ if (setreuid(ruid, euid))
+#else
+#ifdef HAS_SETRESUID
+ if (setresuid(ruid, euid, (Uid_t)-1))
+#endif
+#endif
+ Perl_croak(aTHX_ "leaving effective uid failed");
+
+#ifdef HAS_SETREGID
+ if (setregid(rgid, egid))
+#else
+#ifdef HAS_SETRESGID
+ if (setresgid(rgid, egid, (Gid_t)-1))
+#endif
+#endif
+ Perl_croak(aTHX_ "leaving effective gid failed");
+ UNLOCK_CRED_MUTEX;
+
+ return res;
+}
+# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
+# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
+# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
+#endif
+
+#if !defined(PERL_EFF_ACCESS_R_OK)
+/* With it or without it: anyway you get a warning: either that
+ it is unused, or it is declared static and never defined.
+ */
+STATIC int
+S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
+{
+ Perl_croak(aTHX_ "switching effective uid is not implemented");
+ /*NOTREACHED*/
+ return -1;
+}
+#endif
PP(pp_backtick)
{
dSP; dTARGET;
PerlIO *fp;
- char *tmps = POPp;
+ STRLEN n_a;
+ char *tmps = POPpx;
+ I32 gimme = GIMME_V;
+ char *mode = "r";
+
TAINT_PROPER("``");
- fp = my_popen(tmps, "r");
+ if (PL_op->op_private & OPpOPEN_IN_RAW)
+ mode = "rb";
+ else if (PL_op->op_private & OPpOPEN_IN_CRLF)
+ mode = "rt";
+ fp = PerlProc_popen(tmps, mode);
if (fp) {
- sv_setpv(TARG, ""); /* note that this preserves previous buffer */
- if (GIMME == G_SCALAR) {
+ char *type = NULL;
+ if (PL_curcop->cop_io) {
+ type = SvPV_nolen(PL_curcop->cop_io);
+ }
+ if (type && *type)
+ PerlIO_apply_layers(aTHX_ fp,mode,type);
+
+ if (gimme == G_VOID) {
+ char tmpbuf[256];
+ while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
+ /*SUPPRESS 530*/
+ ;
+ }
+ 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 {
SV *sv;
for (;;) {
- sv = NEWSV(56, 80);
+ sv = NEWSV(56, 79);
if (sv_gets(sv, fp, 0) == Nullch) {
SvREFCNT_dec(sv);
break;
SvLEN_set(sv, SvCUR(sv)+1);
Renew(SvPVX(sv), SvLEN(sv), char);
}
+ SvTAINTED_on(sv);
}
}
- statusvalue = FIXSTATUS(my_pclose(fp));
+ STATUS_NATIVE_SET(PerlProc_pclose(fp));
+ TAINT; /* "I believe that this is not gratuitous!" */
}
else {
- statusvalue = -1;
- if (GIMME == G_SCALAR)
+ STATUS_NATIVE_SET(-1);
+ if (gimme == G_SCALAR)
RETPUSHUNDEF;
}
PP(pp_glob)
{
OP *result;
+ tryAMAGICunTARGET(iter, -1);
+
+ /* Note that we only ever get here if File::Glob fails to load
+ * without at the same time croaking, for some reason, or if
+ * perl was built with PERL_EXTERNAL_GLOB */
+
ENTER;
- SAVESPTR(last_in_gv); /* We don't want this to be permanent. */
- last_in_gv = (GV*)*stack_sp--;
+#ifndef VMS
+ if (PL_tainting) {
+ /*
+ * The external globbing program may use things we can't control,
+ * so for security reasons we must assume the worst.
+ */
+ TAINT;
+ taint_proper(PL_no_security, "glob");
+ }
+#endif /* !VMS */
+
+ SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
+ PL_last_in_gv = (GV*)*PL_stack_sp--;
- SAVESPTR(rs); /* This is not permanent, either. */
- rs = sv_2mortal(newSVpv("", 1));
+ SAVESPTR(PL_rs); /* This is not permanent, either. */
+ PL_rs = sv_2mortal(newSVpvn("\000", 1));
#ifndef DOSISH
#ifndef CSH
- *SvPVX(rs) = '\n';
+ *SvPVX(PL_rs) = '\n';
#endif /* !CSH */
#endif /* !DOSISH */
return result;
}
-PP(pp_indread)
-{
- last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*stack_sp--)), na), TRUE,SVt_PVIO);
- return do_readline();
-}
-
PP(pp_rcatline)
{
- last_in_gv = cGVOP->op_gv;
+ PL_last_in_gv = cGVOP_gv;
return do_readline();
}
PP(pp_warn)
{
dSP; dMARK;
+ SV *tmpsv;
char *tmps;
+ STRLEN len;
if (SP - MARK != 1) {
dTARGET;
- do_join(TARG, &sv_no, MARK, SP);
- tmps = SvPV(TARG, na);
+ do_join(TARG, &PL_sv_no, MARK, SP);
+ tmpsv = TARG;
SP = MARK + 1;
}
else {
- tmps = SvPV(TOPs, na);
+ tmpsv = TOPs;
}
- if (!tmps || !*tmps) {
- SV *error = GvSV(errgv);
+ tmps = SvPV(tmpsv, len);
+ if (!tmps || !len) {
+ SV *error = ERRSV;
(void)SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
sv_catpv(error, "\t...caught");
- tmps = SvPV(error, na);
+ tmpsv = error;
+ tmps = SvPV(tmpsv, len);
}
- if (!tmps || !*tmps)
- tmps = "Warning: something's wrong";
- warn("%s", tmps);
+ if (!tmps || !len)
+ tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
+
+ Perl_warn(aTHX_ "%"SVf, tmpsv);
RETSETYES;
}
{
dSP; dMARK;
char *tmps;
+ SV *tmpsv;
+ STRLEN len;
+ bool multiarg = 0;
+#ifdef VMS
+ VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
+#endif
if (SP - MARK != 1) {
dTARGET;
- do_join(TARG, &sv_no, MARK, SP);
- tmps = SvPV(TARG, na);
+ do_join(TARG, &PL_sv_no, MARK, SP);
+ tmpsv = TARG;
+ tmps = SvPV(tmpsv, len);
+ multiarg = 1;
SP = MARK + 1;
}
else {
- tmps = SvPV(TOPs, na);
+ tmpsv = TOPs;
+ tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
}
- if (!tmps || !*tmps) {
- SV *error = GvSV(errgv);
+ if (!tmps || !len) {
+ SV *error = ERRSV;
(void)SvUPGRADE(error, SVt_PV);
- if (SvPOK(error) && SvCUR(error))
- sv_catpv(error, "\t...propagated");
- tmps = SvPV(error, na);
+ if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
+ if (!multiarg)
+ SvSetSV(error,tmpsv);
+ else if (sv_isobject(error)) {
+ HV *stash = SvSTASH(SvRV(error));
+ GV *gv = gv_fetchmethod(stash, "PROPAGATE");
+ if (gv) {
+ SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
+ SV *line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
+ EXTEND(SP, 3);
+ PUSHMARK(SP);
+ PUSHs(error);
+ PUSHs(file);
+ PUSHs(line);
+ PUTBACK;
+ call_sv((SV*)GvCV(gv),
+ G_SCALAR|G_EVAL|G_KEEPERR);
+ sv_setsv(error,*PL_stack_sp--);
+ }
+ }
+ DIE(aTHX_ Nullformat);
+ }
+ else {
+ if (SvPOK(error) && SvCUR(error))
+ sv_catpv(error, "\t...propagated");
+ tmpsv = error;
+ tmps = SvPV(tmpsv, len);
+ }
}
- if (!tmps || !*tmps)
- tmps = "Died";
- DIE("%s", tmps);
+ if (!tmps || !len)
+ tmpsv = sv_2mortal(newSVpvn("Died", 4));
+
+ DIE(aTHX_ "%"SVf, tmpsv);
}
/* I/O. */
PP(pp_open)
{
- dSP; dTARGET;
+ dSP;
+ dMARK; dORIGMARK;
+ dTARGET;
GV *gv;
SV *sv;
+ IO *io;
char *tmps;
STRLEN len;
+ MAGIC *mg;
+ bool ok;
- if (MAXARG > 1)
- sv = POPs;
- if (!isGV(TOPs))
- DIE(no_usym, "filehandle");
- if (MAXARG <= 1)
- sv = GvSV(TOPs);
- gv = (GV*)POPs;
+ gv = (GV *)*++MARK;
if (!isGV(gv))
- DIE(no_usym, "filehandle");
- if (GvIOp(gv))
+ DIE(aTHX_ PL_no_usym, "filehandle");
+ if ((io = GvIOp(gv)))
IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
+
+ if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
+ /* Method's args are same as ours ... */
+ /* ... except handle is replaced by the object */
+ *MARK-- = SvTIED_obj((SV*)io, mg);
+ PUSHMARK(MARK);
+ PUTBACK;
+ ENTER;
+ call_method("OPEN", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
+
+ if (MARK < SP) {
+ sv = *++MARK;
+ }
+ else {
+ sv = GvSV(gv);
+ }
+
tmps = SvPV(sv, len);
- if (do_open(gv, tmps, len, FALSE, 0, 0, Nullfp))
- PUSHi( (I32)forkprocess );
- else if (forkprocess == 0) /* we are a new child */
+ ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, MARK+1, (SP-MARK));
+ SP = ORIGMARK;
+ if (ok)
+ PUSHi( (I32)PL_forkprocess );
+ else if (PL_forkprocess == 0) /* we are a new child */
PUSHi(0);
else
RETPUSHUNDEF;
{
dSP;
GV *gv;
+ IO *io;
+ MAGIC *mg;
if (MAXARG == 0)
- gv = defoutgv;
+ gv = PL_defoutgv;
else
gv = (GV*)POPs;
+
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+ PUTBACK;
+ ENTER;
+ call_method("CLOSE", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
EXTEND(SP, 1);
- PUSHs( do_close(gv, TRUE) ? &sv_yes : &sv_no );
+ PUSHs(boolSV(do_close(gv, TRUE)));
RETURN;
}
PP(pp_pipe_op)
{
- dSP;
#ifdef HAS_PIPE
+ dSP;
GV *rgv;
GV *wgv;
register IO *rstio;
goto badexit;
if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
- DIE(no_usym, "filehandle");
+ DIE(aTHX_ PL_no_usym, "filehandle");
rstio = GvIOn(rgv);
wstio = GvIOn(wgv);
if (IoIFP(wstio))
do_close(wgv, FALSE);
- if (pipe(fd) < 0)
+ 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(wstio) = '>';
+ IoTYPE(rstio) = IoTYPE_RDONLY;
+ IoTYPE(wstio) = IoTYPE_WRONLY;
if (!IoIFP(rstio) || !IoOFP(wstio)) {
if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
- else close(fd[0]);
+ else PerlLIO_close(fd[0]);
if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
- else close(fd[1]);
+ else PerlLIO_close(fd[1]);
goto badexit;
}
-
+#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;
badexit:
RETPUSHUNDEF;
#else
- DIE(no_func, "pipe");
+ DIE(aTHX_ PL_no_func, "pipe");
#endif
}
GV *gv;
IO *io;
PerlIO *fp;
+ MAGIC *mg;
+
if (MAXARG < 1)
RETPUSHUNDEF;
gv = (GV*)POPs;
- if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
+
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+ PUTBACK;
+ ENTER;
+ call_method("FILENO", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
+
+ if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
+ /* Can't do this because people seem to do things like
+ defined(fileno($foo)) to check whether $foo is a valid fh.
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
+ */
RETPUSHUNDEF;
+ }
+
PUSHi(PerlIO_fileno(fp));
RETURN;
}
PP(pp_umask)
{
dSP; dTARGET;
- int anum;
-
#ifdef HAS_UMASK
+ Mode_t anum;
+
if (MAXARG < 1) {
- anum = umask(0);
- (void)umask(anum);
+ anum = PerlLIO_umask(0);
+ (void)PerlLIO_umask(anum);
}
else
- anum = umask(POPi);
+ anum = PerlLIO_umask(POPi);
TAINT_PROPER("umask");
XPUSHi(anum);
#else
- DIE(no_func, "Unsupported function umask");
+ /* Only DIE if trying to restrict permissions on `user' (self).
+ * Otherwise it's harmless and more useful to just return undef
+ * since 'group' and 'other' concepts probably don't exist here. */
+ if (MAXARG >= 1 && (POPi & 0700))
+ DIE(aTHX_ "umask not implemented");
+ XPUSHs(&PL_sv_undef);
#endif
RETURN;
}
GV *gv;
IO *io;
PerlIO *fp;
+ MAGIC *mg;
+ SV *discp = Nullsv;
if (MAXARG < 1)
RETPUSHUNDEF;
+ if (MAXARG > 1) {
+ discp = POPs;
+ }
gv = (GV*)POPs;
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+ if (discp)
+ XPUSHs(discp);
+ PUTBACK;
+ ENTER;
+ call_method("BINMODE", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
+
EXTEND(SP, 1);
- if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
- RETPUSHUNDEF;
+ 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;
+ }
-#ifdef DOSISH
-#ifdef atarist
- if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
- RETPUSHYES;
- else
- RETPUSHUNDEF;
-#else
- if (setmode(PerlIO_fileno(fp), OP_BINARY) != -1)
- RETPUSHYES;
- else
- RETPUSHUNDEF;
-#endif
-#else
-#if defined(USEMYBINMODE)
- if (my_binmode(fp,IoTYPE(io)) != NULL)
+ PUTBACK;
+ if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
+ (discp) ? SvPV_nolen(discp) : Nullch)) {
+ SPAGAIN;
RETPUSHYES;
- else
+ }
+ else {
+ SPAGAIN;
RETPUSHUNDEF;
-#else
- RETPUSHYES;
-#endif
-#endif
-
+ }
}
PP(pp_tie)
{
dSP;
+ dMARK;
SV *varsv;
HV* stash;
GV *gv;
- BINOP myop;
SV *sv;
- SV **mark = stack_base + ++*markstack_ptr; /* reuse in entersub */
- I32 markoff = mark - stack_base - 1;
+ I32 markoff = MARK - PL_stack_base;
char *methname;
-
- varsv = mark[0];
- if (SvTYPE(varsv) == SVt_PVHV)
- methname = "TIEHASH";
- else if (SvTYPE(varsv) == SVt_PVAV)
- methname = "TIEARRAY";
- else if (SvTYPE(varsv) == SVt_PVGV)
- methname = "TIEHANDLE";
- else
- methname = "TIESCALAR";
-
- stash = gv_stashsv(mark[1], FALSE);
- if (!stash || !(gv = gv_fetchmethod(stash, methname)) || !GvCV(gv))
- DIE("Can't locate object method \"%s\" via package \"%s\"",
- methname, SvPV(mark[1],na));
-
- Zero(&myop, 1, BINOP);
- myop.op_last = (OP *) &myop;
- myop.op_next = Nullop;
- myop.op_flags = OPf_KNOW|OPf_STACKED;
-
- ENTER;
- SAVESPTR(op);
- op = (OP *) &myop;
- if (perldb && curstash != debstash)
- op->op_private |= OPpENTERSUB_DB;
-
- XPUSHs((SV*)gv);
- PUTBACK;
-
- if (op = pp_entersub())
- runops();
+ int how = PERL_MAGIC_tied;
+ U32 items;
+
+ varsv = *++MARK;
+ switch(SvTYPE(varsv)) {
+ case SVt_PVHV:
+ methname = "TIEHASH";
+ HvEITER((HV *)varsv) = Null(HE *);
+ break;
+ case SVt_PVAV:
+ methname = "TIEARRAY";
+ break;
+ case SVt_PVGV:
+#ifdef GV_UNIQUE_CHECK
+ if (GvUNIQUE((GV*)varsv)) {
+ Perl_croak(aTHX_ "Attempt to tie unique GV");
+ }
+#endif
+ methname = "TIEHANDLE";
+ how = PERL_MAGIC_tiedscalar;
+ /* For tied filehandles, we apply tiedscalar magic to the IO
+ slot of the GP rather than the GV itself. AMS 20010812 */
+ if (!GvIOp(varsv))
+ GvIOp(varsv) = newIO();
+ varsv = (SV *)GvIOp(varsv);
+ break;
+ default:
+ methname = "TIESCALAR";
+ how = PERL_MAGIC_tiedscalar;
+ break;
+ }
+ items = SP - MARK++;
+ if (sv_isobject(*MARK)) {
+ ENTER;
+ PUSHSTACKi(PERLSI_MAGIC);
+ PUSHMARK(SP);
+ EXTEND(SP,(I32)items);
+ while (items--)
+ PUSHs(*MARK++);
+ PUTBACK;
+ call_method(methname, G_SCALAR);
+ }
+ else {
+ /* Not clear why we don't call call_method here too.
+ * perhaps to get different error message ?
+ */
+ stash = gv_stashsv(*MARK, FALSE);
+ if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
+ DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
+ methname, *MARK);
+ }
+ ENTER;
+ PUSHSTACKi(PERLSI_MAGIC);
+ PUSHMARK(SP);
+ EXTEND(SP,(I32)items);
+ while (items--)
+ PUSHs(*MARK++);
+ PUTBACK;
+ call_sv((SV*)GvCV(gv), G_SCALAR);
+ }
SPAGAIN;
sv = TOPs;
+ POPSTACK;
if (sv_isobject(sv)) {
- if (SvTYPE(varsv) == SVt_PVHV || SvTYPE(varsv) == SVt_PVAV) {
- sv_unmagic(varsv, 'P');
- sv_magic(varsv, sv, 'P', Nullch, 0);
- }
- else {
- sv_unmagic(varsv, 'q');
- sv_magic(varsv, sv, 'q', Nullch, 0);
- }
+ sv_unmagic(varsv, how);
+ /* Croak if a self-tie on an aggregate is attempted. */
+ 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, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
}
LEAVE;
- SP = stack_base + markoff;
+ SP = PL_stack_base + markoff;
PUSHs(sv);
RETURN;
}
PP(pp_untie)
{
dSP;
- SV * sv ;
+ MAGIC *mg;
+ SV *sv = POPs;
+ char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
+ ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
- sv = POPs;
+ if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
+ RETPUSHYES;
- if (dowarn) {
- MAGIC * mg ;
- if (SvMAGICAL(sv)) {
- if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
- mg = mg_find(sv, 'P') ;
- else
- mg = mg_find(sv, 'q') ;
-
- if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
- warn("untie attempted while %d inner references still exist",
- SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
+ if ((mg = SvTIED_mg(sv, how))) {
+ SV *obj = SvRV(mg->mg_obj);
+ GV *gv;
+ CV *cv = NULL;
+ if (obj) {
+ if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
+ isGV(gv) && (cv = GvCV(gv))) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)gv, mg));
+ XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
+ PUTBACK;
+ ENTER;
+ call_sv((SV *)cv, G_VOID);
+ LEAVE;
+ SPAGAIN;
+ }
+ else if (ckWARN(WARN_UNTIE)) {
+ if (mg && SvREFCNT(obj) > 1)
+ Perl_warner(aTHX_ packWARN(WARN_UNTIE),
+ "untie attempted while %"UVuf" inner references still exist",
+ (UV)SvREFCNT(obj) - 1 ) ;
+ }
}
+ sv_unmagic(sv, how) ;
}
-
- if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
- sv_unmagic(sv, 'P');
- else
- sv_unmagic(sv, 'q');
RETPUSHYES;
}
PP(pp_tied)
{
dSP;
- SV * sv ;
- MAGIC * mg ;
+ MAGIC *mg;
+ SV *sv = POPs;
+ char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
+ ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
- sv = POPs;
- if (SvMAGICAL(sv)) {
- if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
- mg = mg_find(sv, 'P') ;
- else
- mg = mg_find(sv, 'q') ;
-
- if (mg) {
- PUSHs(sv_2mortal(newSVsv(mg->mg_obj))) ;
- RETURN ;
- }
- }
+ if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
+ RETPUSHUNDEF;
+ if ((mg = SvTIED_mg(sv, how))) {
+ SV *osv = SvTIED_obj(sv, mg);
+ if (osv == mg->mg_obj)
+ osv = sv_mortalcopy(osv);
+ PUSHs(osv);
+ RETURN;
+ }
RETPUSHUNDEF;
}
dPOPPOPssrl;
HV* stash;
GV *gv;
- BINOP myop;
SV *sv;
hv = (HV*)POPs;
- sv = sv_mortalcopy(&sv_no);
+ sv = sv_mortalcopy(&PL_sv_no);
sv_setpv(sv, "AnyDBM_File");
stash = gv_stashsv(sv, FALSE);
- if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")) || !GvCV(gv)) {
+ if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
PUTBACK;
- perl_require_pv("AnyDBM_File.pm");
+ require_pv("AnyDBM_File.pm");
SPAGAIN;
- if (!(gv = gv_fetchmethod(stash, "TIEHASH")) || !GvCV(gv))
- DIE("No dbm on this machine");
+ if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
+ DIE(aTHX_ "No dbm on this machine");
}
- Zero(&myop, 1, BINOP);
- myop.op_last = (OP *) &myop;
- myop.op_next = Nullop;
- myop.op_flags = OPf_KNOW|OPf_STACKED;
-
ENTER;
- SAVESPTR(op);
- op = (OP *) &myop;
- if (perldb && curstash != debstash)
- op->op_private |= OPpENTERSUB_DB;
- PUTBACK;
- pp_pushmark();
+ PUSHMARK(SP);
- EXTEND(sp, 5);
+ EXTEND(SP, 5);
PUSHs(sv);
PUSHs(left);
if (SvIV(right))
- PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
+ PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
else
- PUSHs(sv_2mortal(newSViv(O_RDWR)));
+ PUSHs(sv_2mortal(newSVuv(O_RDWR)));
PUSHs(right);
- PUSHs((SV*)gv);
PUTBACK;
-
- if (op = pp_entersub())
- runops();
+ call_sv((SV*)GvCV(gv), G_SCALAR);
SPAGAIN;
if (!sv_isobject(TOPs)) {
- sp--;
- op = (OP *) &myop;
- PUTBACK;
- pp_pushmark();
-
+ SP--;
+ PUSHMARK(SP);
PUSHs(sv);
PUSHs(left);
- PUSHs(sv_2mortal(newSViv(O_RDONLY)));
+ PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
PUSHs(right);
- PUSHs((SV*)gv);
PUTBACK;
-
- if (op = pp_entersub())
- runops();
+ call_sv((SV*)GvCV(gv), G_SCALAR);
SPAGAIN;
}
- if (sv_isobject(TOPs))
- sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
+ if (sv_isobject(TOPs)) {
+ sv_unmagic((SV *) hv, PERL_MAGIC_tied);
+ sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, Nullch, 0);
+ }
LEAVE;
RETURN;
}
PP(pp_dbmclose)
{
- return pp_untie(ARGS);
+ return pp_untie();
}
PP(pp_sselect)
{
- dSP; dTARGET;
#ifdef HAS_SELECT
+ dSP; dTARGET;
register I32 i;
register I32 j;
register char *s;
register SV *sv;
- double value;
+ NV value;
I32 maxlen = 0;
I32 nfound;
struct timeval timebuf;
struct timeval *tbuf = &timebuf;
I32 growsize;
char *fd_sets[4];
+ STRLEN n_a;
#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
I32 masksize;
I32 offset;
maxlen = j;
}
-#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
-#ifdef __linux__
- growsize = sizeof(fd_set);
-#else
- growsize = maxlen; /* little endians can use vecs directly */
-#endif
-#else
-#ifdef NFDBITS
+/* little endians can use vecs directly */
+#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
+# ifdef NFDBITS
-#ifndef NBBY
-#define NBBY 8
-#endif
+# ifndef NBBY
+# define NBBY 8
+# endif
masksize = NFDBITS / NBBY;
-#else
+# else
masksize = sizeof(long); /* documented int, everyone seems to use long */
-#endif
- growsize = maxlen + (masksize - (maxlen % masksize));
+# endif
Zero(&fd_sets[0], 4, char*);
#endif
+# if SELECT_MIN_BITS > 1
+ /* 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, 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
+ growsize = sizeof(fd_set);
+# endif
+
sv = SP[4];
if (SvOK(sv)) {
value = SvNV(sv);
if (value < 0.0)
value = 0.0;
timebuf.tv_sec = (long)value;
- value -= (double)timebuf.tv_sec;
+ value -= (NV)timebuf.tv_sec;
timebuf.tv_usec = (long)(value * 1000000.0);
}
else
continue;
}
else if (!SvPOK(sv))
- SvPV_force(sv,na); /* force string conversion */
+ SvPV_force(sv,n_a); /* force string conversion */
j = SvLEN(sv);
if (j < growsize) {
Sv_Grow(sv, growsize);
#endif
}
- nfound = select(
+#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];
PUSHi(nfound);
if (GIMME == G_ARRAY && tbuf) {
- value = (double)(timebuf.tv_sec) +
- (double)(timebuf.tv_usec) / 1000000.0;
- PUSHs(sv = sv_mortalcopy(&sv_no));
+ value = (NV)(timebuf.tv_sec) +
+ (NV)(timebuf.tv_usec) / 1000000.0;
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setnv(sv, value);
}
RETURN;
#else
- DIE("select not implemented");
+ DIE(aTHX_ "select not implemented");
#endif
}
void
-setdefout(gv)
-GV *gv;
+Perl_setdefout(pTHX_ GV *gv)
{
if (gv)
(void)SvREFCNT_inc(gv);
- if (defoutgv)
- SvREFCNT_dec(defoutgv);
- defoutgv = gv;
+ if (PL_defoutgv)
+ SvREFCNT_dec(PL_defoutgv);
+ PL_defoutgv = gv;
}
PP(pp_select)
GV *newdefout, *egv;
HV *hv;
- newdefout = (op->op_private > 0) ? ((GV *) POPs) : NULL;
+ newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
- egv = GvEGV(defoutgv);
+ egv = GvEGV(PL_defoutgv);
if (!egv)
- egv = defoutgv;
+ egv = PL_defoutgv;
hv = GvSTASH(egv);
if (! hv)
- XPUSHs(&sv_undef);
+ XPUSHs(&PL_sv_undef);
else {
GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
- if (gvp && *gvp == egv)
- gv_efullname3(TARG, defoutgv, Nullch);
- else
- sv_setsv(TARG, sv_2mortal(newRV((SV*)egv)));
- XPUSHTARG;
+ if (gvp && *gvp == egv) {
+ gv_efullname4(TARG, PL_defoutgv, Nullch, TRUE);
+ XPUSHTARG;
+ }
+ else {
+ XPUSHs(sv_2mortal(newRV((SV*)egv)));
+ }
}
if (newdefout) {
{
dSP; dTARGET;
GV *gv;
+ IO *io = NULL;
+ MAGIC *mg;
- if (MAXARG <= 0)
- gv = stdingv;
+ if (MAXARG == 0)
+ gv = PL_stdingv;
else
gv = (GV*)POPs;
- if (!gv)
- gv = argvgv;
- if (!gv || do_eof(gv)) /* make sure we have fp with something */
+
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
+ I32 gimme = GIMME_V;
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+ PUTBACK;
+ ENTER;
+ call_method("GETC", gimme);
+ LEAVE;
+ SPAGAIN;
+ if (gimme == G_SCALAR)
+ SvSetMagicSV_nosteal(TARG, TOPs);
+ RETURN;
+ }
+ if (!gv || do_eof(gv)) { /* make sure we have fp with something */
+ 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;
sv_setpv(TARG, " ");
*SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
+ if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
+ /* Find out how many bytes the char needs */
+ Size_t len = UTF8SKIP(SvPVX(TARG));
+ if (len > 1) {
+ SvGROW(TARG,len+1);
+ len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
+ SvCUR_set(TARG,1+len);
+ }
+ SvUTF8_on(TARG);
+ }
PUSHTARG;
RETURN;
}
PP(pp_read)
{
- return pp_sysread(ARGS);
+ return pp_sysread();
}
-static OP *
-doform(cv,gv,retop)
-CV *cv;
-GV *gv;
-OP *retop;
+STATIC OP *
+S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
{
- register CONTEXT *cx;
- I32 gimme = GIMME;
- AV* padlist = CvPADLIST(cv);
- SV** svp = AvARRAY(padlist);
+ register PERL_CONTEXT *cx;
+ I32 gimme = GIMME_V;
ENTER;
SAVETMPS;
push_return(retop);
- PUSHBLOCK(cx, CXt_SUB, stack_sp);
+ PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
PUSHFORMAT(cx);
- SAVESPTR(curpad);
- curpad = AvARRAY((AV*)svp[1]);
+ PAD_SET_CUR(CvPADLIST(cv), 1);
setdefout(gv); /* locally select filehandle so $% et al work */
return CvSTART(cv);
CV *cv;
if (MAXARG == 0)
- gv = defoutgv;
+ gv = PL_defoutgv;
else {
gv = (GV*)POPs;
if (!gv)
- gv = defoutgv;
+ gv = PL_defoutgv;
}
EXTEND(SP, 1);
io = GvIO(gv);
fgv = gv;
cv = GvFORM(fgv);
-
if (!cv) {
+ char *name = NULL;
if (fgv) {
SV *tmpsv = sv_newmortal();
- gv_efullname3(tmpsv, fgv, Nullch);
- DIE("Undefined format \"%s\" called",SvPVX(tmpsv));
+ gv_efullname4(tmpsv, fgv, Nullch, FALSE);
+ name = SvPV_nolen(tmpsv);
}
- DIE("Not a format reference");
+ if (name && *name)
+ DIE(aTHX_ "Undefined format \"%s\" called", name);
+ DIE(aTHX_ "Not a format reference");
}
- IoFLAGS(io) &= ~IOf_DIDTOP;
+ if (CvCLONE(cv))
+ cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
- return doform(cv,gv,op->op_next);
+ IoFLAGS(io) &= ~IOf_DIDTOP;
+ return doform(cv,gv,PL_op->op_next);
}
PP(pp_leavewrite)
PerlIO *fp;
SV **newsp;
I32 gimme;
- register CONTEXT *cx;
+ register PERL_CONTEXT *cx;
DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
- (long)IoLINES_LEFT(io), (long)FmLINES(formtarget)));
- if (IoLINES_LEFT(io) < FmLINES(formtarget) &&
- formtarget != toptarget)
+ (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
+ if (!io || !ofp)
+ goto forget_top;
+ if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
+ PL_formtarget != PL_toptarget)
{
GV *fgv;
CV *cv;
if (!IoTOP_GV(io)) {
GV *topgv;
- char tmpbuf[256];
+ SV *topname;
if (!IoTOP_NAME(io)) {
if (!IoFMT_NAME(io))
IoFMT_NAME(io) = savepv(GvNAME(gv));
- sprintf(tmpbuf, "%s_TOP", IoFMT_NAME(io));
- topgv = gv_fetchpv(tmpbuf,FALSE, SVt_PVFM);
+ topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io)));
+ topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
if ((topgv && GvFORM(topgv)) ||
!gv_fetchpv("top",FALSE,SVt_PVFM))
- IoTOP_NAME(io) = savepv(tmpbuf);
+ IoTOP_NAME(io) = savepv(SvPVX(topname));
else
IoTOP_NAME(io) = savepv("top");
}
}
if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
I32 lines = IoLINES_LEFT(io);
- char *s = SvPVX(formtarget);
+ char *s = SvPVX(PL_formtarget);
if (lines <= 0) /* Yow, header didn't even fit!!! */
goto forget_top;
while (lines-- > 0) {
s++;
}
if (s) {
- PerlIO_write(ofp, SvPVX(formtarget), s - SvPVX(formtarget));
- sv_chop(formtarget, s);
- FmLINES(formtarget) -= IoLINES_LEFT(io);
+ STRLEN save = SvCUR(PL_formtarget);
+ SvCUR_set(PL_formtarget, s - SvPVX(PL_formtarget));
+ do_print(PL_formtarget, ofp);
+ SvCUR_set(PL_formtarget, save);
+ sv_chop(PL_formtarget, s);
+ FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
}
}
if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
- PerlIO_write(ofp, SvPVX(formfeed), SvCUR(formfeed));
+ do_print(PL_formfeed, ofp);
IoLINES_LEFT(io) = IoPAGE_LEN(io);
IoPAGE(io)++;
- formtarget = toptarget;
+ PL_formtarget = PL_toptarget;
IoFLAGS(io) |= IOf_DIDTOP;
fgv = IoTOP_GV(io);
if (!fgv)
- DIE("bad top format reference");
+ DIE(aTHX_ "bad top format reference");
cv = GvFORM(fgv);
- if (!cv) {
- SV *tmpsv = sv_newmortal();
- gv_efullname3(tmpsv, fgv, Nullch);
- DIE("Undefined top format \"%s\" called",SvPVX(tmpsv));
+ {
+ char *name = NULL;
+ if (!cv) {
+ SV *sv = sv_newmortal();
+ gv_efullname4(sv, fgv, Nullch, FALSE);
+ name = SvPV_nolen(sv);
+ }
+ if (name && *name)
+ DIE(aTHX_ "Undefined top format \"%s\" called",name);
+ /* why no:
+ else
+ DIE(aTHX_ "Undefined top format called");
+ ?*/
}
- return doform(cv,gv,op);
+ if (CvCLONE(cv))
+ cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+ return doform(cv,gv,PL_op);
}
forget_top:
- POPBLOCK(cx,curpm);
+ POPBLOCK(cx,PL_curpm);
POPFORMAT(cx);
LEAVE;
fp = IoOFP(io);
if (!fp) {
- if (dowarn) {
+ if (ckWARN2(WARN_CLOSED,WARN_IO)) {
if (IoIFP(io))
- warn("Filehandle only opened for input");
- else
- warn("Write on closed filehandle");
+ report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
+ else if (ckWARN(WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
}
- PUSHs(&sv_no);
+ PUSHs(&PL_sv_no);
}
else {
- if ((IoLINES_LEFT(io) -= FmLINES(formtarget)) < 0) {
- if (dowarn)
- warn("page overflow");
+ if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
+ if (ckWARN(WARN_IO))
+ Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
}
- if (!PerlIO_write(ofp, SvPVX(formtarget), SvCUR(formtarget)) ||
- PerlIO_error(fp))
- PUSHs(&sv_no);
+ if (!do_print(PL_formtarget, fp))
+ PUSHs(&PL_sv_no);
else {
- FmLINES(formtarget) = 0;
- SvCUR_set(formtarget, 0);
- *SvEND(formtarget) = '\0';
+ FmLINES(PL_formtarget) = 0;
+ SvCUR_set(PL_formtarget, 0);
+ *SvEND(PL_formtarget) = '\0';
if (IoFLAGS(io) & IOf_FLUSH)
(void)PerlIO_flush(fp);
- PUSHs(&sv_yes);
+ PUSHs(&PL_sv_yes);
}
}
- formtarget = bodytarget;
+ /* bad_ofp: */
+ PL_formtarget = PL_bodytarget;
PUTBACK;
return pop_return();
}
GV *gv;
IO *io;
PerlIO *fp;
- SV *sv = NEWSV(0,0);
+ SV *sv;
+ MAGIC *mg;
- if (op->op_flags & OPf_STACKED)
+ if (PL_op->op_flags & OPf_STACKED)
gv = (GV*)*++MARK;
else
- gv = defoutgv;
- if (!(io = GvIO(gv))) {
- if (dowarn) {
- gv_fullname3(sv, gv, Nullch);
- warn("Filehandle %s never opened", SvPV(sv,na));
+ gv = PL_defoutgv;
+
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
+ if (MARK == ORIGMARK) {
+ MEXTEND(SP, 1);
+ ++MARK;
+ Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
+ ++SP;
}
- SETERRNO(EBADF,RMS$_IFI);
+ PUSHMARK(MARK - 1);
+ *MARK = SvTIED_obj((SV*)io, mg);
+ PUTBACK;
+ ENTER;
+ call_method("PRINTF", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ MARK = ORIGMARK + 1;
+ *MARK = *SP;
+ SP = MARK;
+ RETURN;
+ }
+
+ sv = NEWSV(0,0);
+ if (!(io = GvIO(gv))) {
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
+ SETERRNO(EBADF,RMS_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
- if (dowarn) {
- gv_fullname3(sv, gv, Nullch);
+ if (ckWARN2(WARN_CLOSED,WARN_IO)) {
if (IoIFP(io))
- warn("Filehandle %s opened only for input", SvPV(sv,na));
- else
- warn("printf on closed filehandle %s", SvPV(sv,na));
+ 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 {
-#ifdef USE_LOCALE_NUMERIC
- if (op->op_private & OPpLOCALE)
- SET_NUMERIC_LOCAL();
- else
- SET_NUMERIC_STANDARD();
-#endif
do_sprintf(sv, SP - MARK, MARK + 1);
if (!do_print(sv, fp))
goto just_say_no;
}
SvREFCNT_dec(sv);
SP = ORIGMARK;
- PUSHs(&sv_yes);
+ PUSHs(&PL_sv_yes);
RETURN;
just_say_no:
SvREFCNT_dec(sv);
SP = ORIGMARK;
- PUSHs(&sv_undef);
+ PUSHs(&PL_sv_undef);
RETURN;
}
sv = POPs;
gv = (GV *)POPs;
+ /* Need TIEHANDLE method ? */
+
tmps = SvPV(sv, len);
if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
IoLINES(GvIOp(gv)) = 0;
- PUSHs(&sv_yes);
+ PUSHs(&PL_sv_yes);
}
else {
- PUSHs(&sv_undef);
+ PUSHs(&PL_sv_undef);
}
RETURN;
}
GV *gv;
IO *io;
char *buffer;
- int length;
- int bufsize;
+ SSize_t length;
+ SSize_t count;
+ Sock_size_t bufsize;
SV *bufsv;
STRLEN blen;
+ MAGIC *mg;
+ int fp_utf8;
+ Size_t got = 0;
+ Size_t wanted;
+ bool charstart = FALSE;
+ STRLEN charskip = 0;
+ STRLEN skip = 0;
gv = (GV*)*++MARK;
+ if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
+ && gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
+ SV *sv;
+
+ PUSHMARK(MARK-1);
+ *MARK = SvTIED_obj((SV*)io, mg);
+ ENTER;
+ call_method("READ", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ sv = POPs;
+ SP = ORIGMARK;
+ PUSHs(sv);
+ RETURN;
+ }
+
if (!gv)
goto say_undef;
bufsv = *++MARK;
if (! SvOK(bufsv))
sv_setpvn(bufsv, "", 0);
- buffer = SvPV_force(bufsv, blen);
length = SvIVx(*++MARK);
- if (length < 0)
- DIE("Negative length");
SETERRNO(0,0);
if (MARK < SP)
offset = SvIVx(*++MARK);
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 */
+ SvUTF8_on(bufsv);
+ }
+ else {
+ buffer = SvPV_force(bufsv, blen);
+ }
+ if (length < 0)
+ DIE(aTHX_ "Negative length");
+ wanted = length;
+
+ charstart = TRUE;
+ charskip = 0;
+ skip = 0;
+
#ifdef HAS_SOCKET
- if (op->op_type == OP_RECV) {
- bufsize = sizeof buf;
- buffer = SvGROW(bufsv, length+1);
+ if (PL_op->op_type == OP_RECV) {
+ char namebuf[MAXPATHLEN];
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
+ bufsize = sizeof (struct sockaddr_in);
+#else
+ bufsize = sizeof namebuf;
+#endif
+#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
+ if (bufsize >= 256)
+ bufsize = 255;
+#endif
+ buffer = SvGROW(bufsv, (STRLEN)(length+1));
/* 'offset' means 'flags' here */
- length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
- (struct sockaddr *)buf, &bufsize);
- if (length < 0)
+ count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
+ (struct sockaddr *)namebuf, &bufsize);
+ if (count < 0)
RETPUSHUNDEF;
- SvCUR_set(bufsv, length);
+#ifdef EPOC
+ /* Bogus return without padding */
+ bufsize = sizeof (struct sockaddr_in);
+#endif
+ SvCUR_set(bufsv, count);
*SvEND(bufsv) = '\0';
(void)SvPOK_only(bufsv);
+ if (fp_utf8)
+ SvUTF8_on(bufsv);
SvSETMAGIC(bufsv);
/* This should not be marked tainted if the fp is marked clean */
if (!(IoFLAGS(io) & IOf_UNTAINT))
SvTAINTED_on(bufsv);
SP = ORIGMARK;
- sv_setpvn(TARG, buf, bufsize);
+ sv_setpvn(TARG, namebuf, bufsize);
PUSHs(TARG);
RETURN;
}
#else
- if (op->op_type == OP_RECV)
- DIE(no_sock_func, "recv");
+ if (PL_op->op_type == OP_RECV)
+ DIE(aTHX_ PL_no_sock_func, "recv");
#endif
+ if (DO_UTF8(bufsv)) {
+ /* offset adjust in characters not bytes */
+ blen = sv_len_utf8(bufsv);
+ }
if (offset < 0) {
- if (-offset > blen)
- DIE("Offset outside string");
+ if (-offset > (int)blen)
+ DIE(aTHX_ "Offset outside string");
offset += blen;
}
+ if (DO_UTF8(bufsv)) {
+ /* convert offset-as-chars to offset-as-bytes */
+ offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
+ }
+ more_bytes:
bufsize = SvCUR(bufsv);
- buffer = SvGROW(bufsv, length+offset+1);
+ buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
if (offset > bufsize) { /* Zero any newly allocated space */
Zero(buffer+bufsize, offset-bufsize, char);
}
- if (op->op_type == OP_SYSREAD) {
- length = read(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
+ buffer = buffer + offset;
+
+ if (PL_op->op_type == OP_SYSREAD) {
+#ifdef PERL_SOCK_SYSREAD_IS_RECV
+ if (IoTYPE(io) == IoTYPE_SOCKET) {
+ count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
+ buffer, length, 0);
+ }
+ else
+#endif
+ {
+ count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
+ buffer, length);
+ }
}
else
#ifdef HAS_SOCKET__bad_code_maybe
- if (IoTYPE(io) == 's') {
- bufsize = sizeof buf;
- length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
- (struct sockaddr *)buf, &bufsize);
+ if (IoTYPE(io) == IoTYPE_SOCKET) {
+ char namebuf[MAXPATHLEN];
+#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
+ bufsize = sizeof (struct sockaddr_in);
+#else
+ bufsize = sizeof namebuf;
+#endif
+ count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
+ (struct sockaddr *)namebuf, &bufsize);
}
else
#endif
- length = PerlIO_read(IoIFP(io), buffer+offset, length);
- if (length < 0)
+ {
+ count = PerlIO_read(IoIFP(io), buffer, length);
+ /* PerlIO_read() - like fread() returns 0 on both error and EOF */
+ if (count == 0 && PerlIO_error(IoIFP(io)))
+ count = -1;
+ }
+ if (count < 0) {
+ if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
+ report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
goto say_undef;
- SvCUR_set(bufsv, length+offset);
+ }
+ SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv)));
*SvEND(bufsv) = '\0';
(void)SvPOK_only(bufsv);
+ if (fp_utf8 && !IN_BYTES) {
+ /* Look at utf8 we got back and count the characters */
+ char *bend = buffer + count;
+ while (buffer < bend) {
+ if (charstart) {
+ skip = UTF8SKIP(buffer);
+ charskip = 0;
+ }
+ if (buffer - charskip + skip > bend) {
+ /* partial character - try for rest of it */
+ length = skip - (bend-buffer);
+ offset = bend - SvPVX(bufsv);
+ charstart = FALSE;
+ charskip += count;
+ goto more_bytes;
+ }
+ else {
+ got++;
+ buffer += skip;
+ charstart = TRUE;
+ charskip = 0;
+ }
+ }
+ /* If we have not 'got' the number of _characters_ we 'wanted' get some more
+ provided amount read (count) was what was requested (length)
+ */
+ if (got < wanted && count == length) {
+ length = wanted - got;
+ offset = bend - SvPVX(bufsv);
+ goto more_bytes;
+ }
+ /* return value is character count */
+ count = got;
+ SvUTF8_on(bufsv);
+ }
SvSETMAGIC(bufsv);
/* This should not be marked tainted if the fp is marked clean */
if (!(IoFLAGS(io) & IOf_UNTAINT))
SvTAINTED_on(bufsv);
SP = ORIGMARK;
- PUSHi(length);
+ PUSHi(count);
RETURN;
say_undef:
PP(pp_syswrite)
{
- return pp_send(ARGS);
+ dSP;
+ int items = (SP - PL_stack_base) - TOPMARK;
+ if (items == 2) {
+ SV *sv;
+ EXTEND(SP, 1);
+ sv = sv_2mortal(newSViv(sv_len(*SP)));
+ PUSHs(sv);
+ PUTBACK;
+ }
+ return pp_send();
}
PP(pp_send)
dSP; dMARK; dORIGMARK; dTARGET;
GV *gv;
IO *io;
- int offset;
SV *bufsv;
char *buffer;
- int length;
+ Size_t length;
+ SSize_t retval;
STRLEN blen;
+ MAGIC *mg;
gv = (GV*)*++MARK;
+ if (PL_op->op_type == OP_SYSWRITE
+ && gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
+ SV *sv;
+
+ PUSHMARK(MARK-1);
+ *MARK = SvTIED_obj((SV*)io, mg);
+ ENTER;
+ call_method("WRITE", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ sv = POPs;
+ SP = ORIGMARK;
+ PUSHs(sv);
+ RETURN;
+ }
if (!gv)
goto say_undef;
bufsv = *++MARK;
- buffer = SvPV(bufsv, blen);
- length = SvIVx(*++MARK);
- if (length < 0)
- DIE("Negative length");
+#if Size_t_size > IVSIZE
+ length = (Size_t)SvNVx(*++MARK);
+#else
+ length = (Size_t)SvIVx(*++MARK);
+#endif
+ if ((SSize_t)length < 0)
+ DIE(aTHX_ "Negative length");
SETERRNO(0,0);
io = GvIO(gv);
if (!io || !IoIFP(io)) {
- length = -1;
- if (dowarn) {
- if (op->op_type == OP_SYSWRITE)
- warn("Syswrite on closed filehandle");
- else
- warn("Send on closed socket");
- }
+ retval = -1;
+ if (ckWARN(WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
+ SETERRNO(EBADF,RMS_IFI);
+ goto say_undef;
+ }
+
+ if (PerlIO_isutf8(IoIFP(io))) {
+ buffer = SvPVutf8(bufsv, blen);
}
- else if (op->op_type == OP_SYSWRITE) {
+ else {
+ if (DO_UTF8(bufsv))
+ sv_utf8_downgrade(bufsv, FALSE);
+ buffer = SvPV(bufsv, blen);
+ }
+
+ if (PL_op->op_type == OP_SYSWRITE) {
+ IV offset;
+ if (DO_UTF8(bufsv)) {
+ /* length and offset are in chars */
+ blen = sv_len_utf8(bufsv);
+ }
if (MARK < SP) {
offset = SvIVx(*++MARK);
if (offset < 0) {
- if (-offset > blen)
- DIE("Offset outside string");
+ if (-offset > (IV)blen)
+ DIE(aTHX_ "Offset outside string");
offset += blen;
- } else if (offset >= blen)
- DIE("Offset outside string");
+ } else if (offset >= (IV)blen && blen > 0)
+ DIE(aTHX_ "Offset outside string");
} else
offset = 0;
if (length > blen - offset)
length = blen - offset;
- length = write(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
+ if (DO_UTF8(bufsv)) {
+ buffer = (char*)utf8_hop((U8 *)buffer, offset);
+ length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
+ }
+ else {
+ buffer = buffer+offset;
+ }
+#ifdef PERL_SOCK_SYSWRITE_IS_SEND
+ if (IoTYPE(io) == IoTYPE_SOCKET) {
+ retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
+ buffer, length, 0);
+ }
+ else
+#endif
+ {
+ /* See the note at doio.c:do_print about filesize limits. --jhi */
+ retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
+ buffer, length);
+ }
}
#ifdef HAS_SOCKET
else if (SP > MARK) {
char *sockbuf;
STRLEN mlen;
sockbuf = SvPVx(*++MARK, mlen);
- length = sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
- (struct sockaddr *)sockbuf, mlen);
+ /* length is really flags */
+ retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
+ length, (struct sockaddr *)sockbuf, mlen);
}
else
- length = send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
+ /* length is really flags */
+ retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
#else
else
- DIE(no_sock_func, "send");
+ DIE(aTHX_ PL_no_sock_func, "send");
#endif
- if (length < 0)
+ if (retval < 0)
goto say_undef;
SP = ORIGMARK;
- PUSHi(length);
+ if (DO_UTF8(bufsv))
+ retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
+#if Size_t_size > IVSIZE
+ PUSHn(retval);
+#else
+ PUSHi(retval);
+#endif
RETURN;
say_undef:
PP(pp_recv)
{
- return pp_sysread(ARGS);
+ return pp_sysread();
}
PP(pp_eof)
{
dSP;
GV *gv;
+ IO *io;
+ MAGIC *mg;
- if (MAXARG <= 0)
- gv = last_in_gv;
+ if (MAXARG == 0) {
+ if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
+ IO *io;
+ gv = PL_last_in_gv = GvEGV(PL_argvgv);
+ io = GvIO(gv);
+ if (io && !IoIFP(io)) {
+ if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
+ IoLINES(io) = 0;
+ IoFLAGS(io) &= ~IOf_START;
+ do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp);
+ sv_setpvn(GvSV(gv), "-", 1);
+ SvSETMAGIC(GvSV(gv));
+ }
+ else if (!nextargv(gv))
+ RETPUSHYES;
+ }
+ }
+ else
+ gv = PL_last_in_gv; /* eof */
+ }
else
- gv = last_in_gv = (GV*)POPs;
- PUSHs(!gv || do_eof(gv) ? &sv_yes : &sv_no);
+ gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
+
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+ PUTBACK;
+ ENTER;
+ call_method("EOF", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
+
+ PUSHs(boolSV(!gv || do_eof(gv)));
RETURN;
}
{
dSP; dTARGET;
GV *gv;
+ IO *io;
+ MAGIC *mg;
+
+ if (MAXARG == 0)
+ gv = PL_last_in_gv;
+ else
+ gv = PL_last_in_gv = (GV*)POPs;
+
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+ PUTBACK;
+ ENTER;
+ call_method("TELL", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
- if (MAXARG <= 0)
- gv = last_in_gv;
- else
- gv = last_in_gv = (GV*)POPs;
+#if LSEEKSIZE > IVSIZE
+ PUSHn( do_tell(gv) );
+#else
PUSHi( do_tell(gv) );
+#endif
RETURN;
}
PP(pp_seek)
{
+ return pp_sysseek();
+}
+
+PP(pp_sysseek)
+{
dSP;
GV *gv;
+ IO *io;
int whence = POPi;
- long offset = POPl;
+#if LSEEKSIZE > IVSIZE
+ Off_t offset = (Off_t)SvNVx(POPs);
+#else
+ Off_t offset = (Off_t)SvIVx(POPs);
+#endif
+ MAGIC *mg;
+
+ gv = PL_last_in_gv = (GV*)POPs;
+
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+#if LSEEKSIZE > IVSIZE
+ XPUSHs(sv_2mortal(newSVnv((NV) offset)));
+#else
+ XPUSHs(sv_2mortal(newSViv(offset)));
+#endif
+ XPUSHs(sv_2mortal(newSViv(whence)));
+ PUTBACK;
+ ENTER;
+ call_method("SEEK", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
- gv = last_in_gv = (GV*)POPs;
- PUSHs( do_seek(gv, offset, whence) ? &sv_yes : &sv_no );
+ if (PL_op->op_type == OP_SEEK)
+ PUSHs(boolSV(do_seek(gv, offset, whence)));
+ else {
+ Off_t sought = do_sysseek(gv, offset, whence);
+ if (sought < 0)
+ PUSHs(&PL_sv_undef);
+ else {
+ SV* sv = sought ?
+#if LSEEKSIZE > IVSIZE
+ newSVnv((NV)sought)
+#else
+ newSViv(sought)
+#endif
+ : newSVpvn(zero_but_true, ZBTLEN);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
RETURN;
}
PP(pp_truncate)
{
dSP;
- Off_t len = (Off_t)POPn;
- int result = 1;
- GV *tmpgv;
-
+ /* There seems to be no consensus on the length type of truncate()
+ * and ftruncate(), both off_t and size_t have supporters. In
+ * general one would think that when using large files, off_t is
+ * at least as wide as size_t, so using an off_t should be okay. */
+ /* XXX Configure probe for the length type of *truncate() needed XXX */
+ Off_t len;
+
+#if Off_t_size > IVSIZE
+ len = (Off_t)POPn;
+#else
+ len = (Off_t)POPi;
+#endif
+ /* Checking for length < 0 is problematic as the type might or
+ * might not be signed: if it is not, clever compilers will moan. */
+ /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
SETERRNO(0,0);
#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
- if (op->op_flags & OPf_SPECIAL) {
- tmpgv = gv_fetchpv(POPp,FALSE, SVt_PVIO);
- do_ftruncate:
- if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
+ {
+ 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_gv:
+ if (!GvIO(tmpgv))
+ result = 0;
+ else {
+ PerlIO *fp;
+ io = GvIOp(tmpgv);
+ do_ftruncate_io:
+ TAINT_PROPER("truncate");
+ if (!(fp = IoIFP(io))) {
+ result = 0;
+ }
+ else {
+ PerlIO_flush(fp);
#ifdef HAS_TRUNCATE
- ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
-#else
- my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+ if (ftruncate(PerlIO_fileno(fp), len) < 0)
+#else
+ if (my_chsize(PerlIO_fileno(fp), len) < 0)
#endif
- result = 0;
- }
- else {
- SV *sv = POPs;
- if (SvTYPE(sv) == SVt_PVGV) {
- tmpgv = (GV*)sv; /* *main::FRED for example */
- goto do_ftruncate;
- }
- else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
- tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
- goto do_ftruncate;
+ result = 0;
+ }
+ }
}
+ else {
+ SV *sv = POPs;
+ char *name;
+
+ if (SvTYPE(sv) == SVt_PVGV) {
+ tmpgv = (GV*)sv; /* *main::FRED for example */
+ goto do_ftruncate_gv;
+ }
+ else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
+ tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
+ 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);
+ TAINT_PROPER("truncate");
#ifdef HAS_TRUNCATE
- if (truncate (SvPV (sv, na), len) < 0)
- result = 0;
+ if (truncate(name, len) < 0)
+ result = 0;
#else
- {
- int tmpfd;
+ {
+ int tmpfd;
- if ((tmpfd = open(SvPV (sv, na), O_RDWR)) < 0)
- result = 0;
- else {
- if (my_chsize(tmpfd, len) < 0)
+ if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
result = 0;
- close(tmpfd);
+ else {
+ if (my_chsize(tmpfd, len) < 0)
+ result = 0;
+ PerlLIO_close(tmpfd);
+ }
}
- }
#endif
- }
+ }
- if (result)
- RETPUSHYES;
- if (!errno)
- SETERRNO(EBADF,RMS$_IFI);
- RETPUSHUNDEF;
+ if (result)
+ RETPUSHYES;
+ if (!errno)
+ SETERRNO(EBADF,RMS_IFI);
+ RETPUSHUNDEF;
+ }
#else
- DIE("truncate not implemented");
+ DIE(aTHX_ "truncate not implemented");
#endif
}
PP(pp_fcntl)
{
- return pp_ioctl(ARGS);
+ return pp_ioctl();
}
PP(pp_ioctl)
{
dSP; dTARGET;
SV *argsv = POPs;
- unsigned int func = U_I(POPn);
- int optype = op->op_type;
+ unsigned int func = POPu;
+ int optype = PL_op->op_type;
char *s;
- int retval;
+ IV retval;
GV *gv = (GV*)POPs;
- IO *io = GvIOn(gv);
+ IO *io = gv ? GvIOn(gv) : 0;
if (!io || !argsv || !IoIFP(io)) {
- SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
+ SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
RETPUSHUNDEF;
}
if (SvPOK(argsv) || !SvNIOK(argsv)) {
STRLEN len;
+ STRLEN need;
s = SvPV_force(argsv, len);
- retval = IOCPARM_LEN(func);
- if (len < retval) {
- s = Sv_Grow(argsv, retval+1);
- SvCUR_set(argsv, retval);
+ need = IOCPARM_LEN(func);
+ if (len < need) {
+ s = Sv_Grow(argsv, need + 1);
+ SvCUR_set(argsv, need);
}
s[SvCUR(argsv)] = 17; /* a little sanity check here */
}
else {
retval = SvIV(argsv);
-#ifdef DOSISH
- s = (char*)(long)retval; /* ouch */
-#else
- s = (char*)retval; /* ouch */
-#endif
+ s = INT2PTR(char*,retval); /* ouch */
}
TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
if (optype == OP_IOCTL)
#ifdef HAS_IOCTL
- retval = ioctl(PerlIO_fileno(IoIFP(io)), func, s);
+ retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
#else
- DIE("ioctl is not implemented");
+ 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("fcntl is not implemented");
#endif
if (SvPOK(argsv)) {
if (s[SvCUR(argsv)] != 17)
- DIE("Possible memory corruption: %s overflowed 3rd argument",
- op_name[optype]);
+ DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
+ OP_NAME(PL_op));
s[SvCUR(argsv)] = 0; /* put our null back */
SvSETMAGIC(argsv); /* Assume it has changed */
}
PUSHi(retval);
}
else {
- PUSHp("0 but true", 10);
+ PUSHp(zero_but_true, ZBTLEN);
}
+#endif
RETURN;
}
PP(pp_flock)
{
+#ifdef FLOCK
dSP; dTARGET;
I32 value;
int argtype;
GV *gv;
+ IO *io = NULL;
PerlIO *fp;
-#ifdef FLOCK
argtype = POPi;
- if (MAXARG <= 0)
- gv = last_in_gv;
+ if (MAXARG == 0)
+ gv = PL_last_in_gv;
else
gv = (GV*)POPs;
- if (gv && GvIO(gv))
- fp = IoIFP(GvIOp(gv));
- else
+ if (gv && (io = GvIO(gv)))
+ fp = IoIFP(io);
+ else {
fp = Nullfp;
+ io = NULL;
+ }
if (fp) {
- value = (I32)(FLOCK(PerlIO_fileno(fp), argtype) >= 0);
+ (void)PerlIO_flush(fp);
+ value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
}
- else
+ else {
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
value = 0;
+ SETERRNO(EBADF,RMS_IFI);
+ }
PUSHi(value);
RETURN;
#else
- DIE(no_func, "flock()");
+ DIE(aTHX_ PL_no_func, "flock()");
#endif
}
PP(pp_socket)
{
- dSP;
#ifdef HAS_SOCKET
+ dSP;
GV *gv;
register IO *io;
int protocol = POPi;
int fd;
gv = (GV*)POPs;
-
- if (!gv) {
- SETERRNO(EBADF,LIB$_INVARG);
+ io = gv ? GvIOn(gv) : NULL;
+
+ if (!gv || !io) {
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
+ if (IoIFP(io))
+ do_close(gv, FALSE);
+ SETERRNO(EBADF,LIB_INVARG);
RETPUSHUNDEF;
}
- io = GvIOn(gv);
if (IoIFP(io))
do_close(gv, FALSE);
TAINT_PROPER("socket");
- fd = socket(domain, type, protocol);
+ 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");
- IoTYPE(io) = 's';
+ 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));
if (IoOFP(io)) PerlIO_close(IoOFP(io));
- if (!IoIFP(io) && !IoOFP(io)) close(fd);
+ 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
+
+#ifdef EPOC
+ setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
+#endif
RETPUSHYES;
#else
- DIE(no_sock_func, "socket");
+ DIE(aTHX_ PL_no_sock_func, "socket");
#endif
}
PP(pp_sockpair)
{
+#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
dSP;
-#ifdef HAS_SOCKETPAIR
GV *gv1;
GV *gv2;
register IO *io1;
gv2 = (GV*)POPs;
gv1 = (GV*)POPs;
- if (!gv1 || !gv2)
+ io1 = gv1 ? GvIOn(gv1) : NULL;
+ io2 = gv2 ? GvIOn(gv2) : NULL;
+ if (!gv1 || !gv2 || !io1 || !io2) {
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
+ if (!gv1 || !io1)
+ report_evil_fh(gv1, io1, PL_op->op_type);
+ if (!gv2 || !io2)
+ report_evil_fh(gv1, io2, PL_op->op_type);
+ }
+ if (IoIFP(io1))
+ do_close(gv1, FALSE);
+ if (IoIFP(io2))
+ do_close(gv2, FALSE);
RETPUSHUNDEF;
+ }
- io1 = GvIOn(gv1);
- io2 = GvIOn(gv2);
if (IoIFP(io1))
do_close(gv1, FALSE);
if (IoIFP(io2))
do_close(gv2, FALSE);
TAINT_PROPER("socketpair");
- if (socketpair(domain, type, protocol, fd) < 0)
+ if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
RETPUSHUNDEF;
- IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
- IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
- IoTYPE(io1) = 's';
- IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
- IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
- IoTYPE(io2) = 's';
+ 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"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));
if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
- if (!IoIFP(io1) && !IoOFP(io1)) close(fd[0]);
+ if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
- if (!IoIFP(io2) && !IoOFP(io2)) close(fd[1]);
+ 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
- DIE(no_sock_func, "socketpair");
+ DIE(aTHX_ PL_no_sock_func, "socketpair");
#endif
}
PP(pp_bind)
{
- dSP;
#ifdef HAS_SOCKET
+ dSP;
+#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
+ extern void GETPRIVMODE();
+ extern void GETUSERMODE();
+#endif
SV *addrsv = POPs;
char *addr;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
STRLEN len;
+ int bind_ok = 0;
+#ifdef MPE
+ int mpeprivmode = 0;
+#endif
if (!io || !IoIFP(io))
goto nuts;
addr = SvPV(addrsv, len);
TAINT_PROPER("bind");
- if (bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
+#ifdef MPE /* Deal with MPE bind() peculiarities */
+ if (((struct sockaddr *)addr)->sa_family == AF_INET) {
+ /* The address *MUST* stupidly be zero. */
+ ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
+ /* PRIV mode is required to bind() to ports < 1024. */
+ if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
+ ((struct sockaddr_in *)addr)->sin_port > 0) {
+ GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
+ mpeprivmode = 1;
+ }
+ }
+#endif /* MPE */
+ if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
+ (struct sockaddr *)addr, len) >= 0)
+ bind_ok = 1;
+
+#ifdef MPE /* Switch back to USER mode */
+ if (mpeprivmode)
+ GETUSERMODE();
+#endif /* MPE */
+
+ if (bind_ok)
RETPUSHYES;
else
RETPUSHUNDEF;
nuts:
- if (dowarn)
- warn("bind() on closed fd");
- SETERRNO(EBADF,SS$_IVCHAN);
+ if (ckWARN(WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
+ SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
#else
- DIE(no_sock_func, "bind");
+ DIE(aTHX_ PL_no_sock_func, "bind");
#endif
}
PP(pp_connect)
{
- dSP;
#ifdef HAS_SOCKET
+ dSP;
SV *addrsv = POPs;
char *addr;
GV *gv = (GV*)POPs;
addr = SvPV(addrsv, len);
TAINT_PROPER("connect");
- if (connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
+ if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
RETPUSHYES;
else
RETPUSHUNDEF;
nuts:
- if (dowarn)
- warn("connect() on closed fd");
- SETERRNO(EBADF,SS$_IVCHAN);
+ if (ckWARN(WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
+ SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
#else
- DIE(no_sock_func, "connect");
+ DIE(aTHX_ PL_no_sock_func, "connect");
#endif
}
PP(pp_listen)
{
- dSP;
#ifdef HAS_SOCKET
+ dSP;
int backlog = POPi;
GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
+ register IO *io = gv ? GvIOn(gv) : NULL;
- if (!io || !IoIFP(io))
+ if (!gv || !io || !IoIFP(io))
goto nuts;
- if (listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
+ if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
RETPUSHYES;
else
RETPUSHUNDEF;
nuts:
- if (dowarn)
- warn("listen() on closed fd");
- SETERRNO(EBADF,SS$_IVCHAN);
+ if (ckWARN(WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
+ SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
#else
- DIE(no_sock_func, "listen");
+ DIE(aTHX_ PL_no_sock_func, "listen");
#endif
}
PP(pp_accept)
{
- dSP; dTARGET;
#ifdef HAS_SOCKET
+ dSP; dTARGET;
GV *ngv;
GV *ggv;
register IO *nstio;
register IO *gstio;
struct sockaddr saddr; /* use a struct to avoid alignment problems */
- int len = sizeof saddr;
+ Sock_size_t len = sizeof saddr;
int fd;
ggv = (GV*)POPs;
goto nuts;
nstio = GvIOn(ngv);
- if (IoIFP(nstio))
- do_close(ngv, FALSE);
-
- fd = accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
+ fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
if (fd < 0)
goto badexit;
- IoIFP(nstio) = PerlIO_fdopen(fd, "r");
- IoOFP(nstio) = PerlIO_fdopen(fd, "w");
- IoTYPE(nstio) = 's';
+ if (IoIFP(nstio))
+ do_close(ngv, FALSE);
+ 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 (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
- if (!IoIFP(nstio) && !IoOFP(nstio)) close(fd);
+ 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
+
+#ifdef EPOC
+ len = sizeof saddr; /* EPOC somehow truncates info */
+ setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
+#endif
PUSHp((char *)&saddr, len);
RETURN;
nuts:
- if (dowarn)
- warn("accept() on closed fd");
- SETERRNO(EBADF,SS$_IVCHAN);
+ if (ckWARN(WARN_CLOSED))
+ report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
+ SETERRNO(EBADF,SS_IVCHAN);
badexit:
RETPUSHUNDEF;
#else
- DIE(no_sock_func, "accept");
+ DIE(aTHX_ PL_no_sock_func, "accept");
#endif
}
PP(pp_shutdown)
{
- dSP; dTARGET;
#ifdef HAS_SOCKET
+ dSP; dTARGET;
int how = POPi;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
if (!io || !IoIFP(io))
goto nuts;
- PUSHi( shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
+ PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
RETURN;
nuts:
- if (dowarn)
- warn("shutdown() on closed fd");
- SETERRNO(EBADF,SS$_IVCHAN);
+ if (ckWARN(WARN_CLOSED))
+ report_evil_fh(gv, io, PL_op->op_type);
+ SETERRNO(EBADF,SS_IVCHAN);
RETPUSHUNDEF;
#else
- DIE(no_sock_func, "shutdown");
+ DIE(aTHX_ PL_no_sock_func, "shutdown");
#endif
}
PP(pp_gsockopt)
{
#ifdef HAS_SOCKET
- return pp_ssockopt(ARGS);
+ return pp_ssockopt();
#else
- DIE(no_sock_func, "getsockopt");
+ DIE(aTHX_ PL_no_sock_func, "getsockopt");
#endif
}
PP(pp_ssockopt)
{
- dSP;
#ifdef HAS_SOCKET
- int optype = op->op_type;
+ dSP;
+ int optype = PL_op->op_type;
SV *sv;
int fd;
unsigned int optname;
unsigned int lvl;
GV *gv;
register IO *io;
- int aint;
+ Sock_size_t len;
if (optype == OP_GSOCKOPT)
sv = sv_2mortal(NEWSV(22, 257));
(void)SvPOK_only(sv);
SvCUR_set(sv,256);
*SvEND(sv) ='\0';
- aint = SvCUR(sv);
- if (getsockopt(fd, lvl, optname, SvPVX(sv), &aint) < 0)
+ len = SvCUR(sv);
+ if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
goto nuts2;
- SvCUR_set(sv,aint);
+ SvCUR_set(sv, len);
*SvEND(sv) ='\0';
PUSHs(sv);
break;
case OP_SSOCKOPT: {
- STRLEN len = 0;
- char *buf = 0;
- if (SvPOKp(sv))
- buf = SvPV(sv, len);
- else if (SvOK(sv)) {
+ char *buf;
+ int aint;
+ if (SvPOKp(sv)) {
+ STRLEN l;
+ buf = SvPV(sv, l);
+ len = l;
+ }
+ else {
aint = (int)SvIV(sv);
buf = (char*)&aint;
len = sizeof(int);
}
- if (setsockopt(fd, lvl, optname, buf, (int)len) < 0)
+ if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
goto nuts2;
- PUSHs(&sv_yes);
+ PUSHs(&PL_sv_yes);
}
break;
}
RETURN;
nuts:
- if (dowarn)
- warn("[gs]etsockopt() on closed fd");
- SETERRNO(EBADF,SS$_IVCHAN);
+ if (ckWARN(WARN_CLOSED))
+ report_evil_fh(gv, io, optype);
+ SETERRNO(EBADF,SS_IVCHAN);
nuts2:
RETPUSHUNDEF;
#else
- DIE(no_sock_func, "setsockopt");
+ DIE(aTHX_ PL_no_sock_func, "setsockopt");
#endif
}
PP(pp_getsockname)
{
#ifdef HAS_SOCKET
- return pp_getpeername(ARGS);
+ return pp_getpeername();
#else
- DIE(no_sock_func, "getsockname");
+ DIE(aTHX_ PL_no_sock_func, "getsockname");
#endif
}
PP(pp_getpeername)
{
- dSP;
#ifdef HAS_SOCKET
- int optype = op->op_type;
+ dSP;
+ int optype = PL_op->op_type;
SV *sv;
int fd;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
- int aint;
+ Sock_size_t len;
if (!io || !IoIFP(io))
goto nuts;
sv = sv_2mortal(NEWSV(22, 257));
(void)SvPOK_only(sv);
- SvCUR_set(sv,256);
+ len = 256;
+ SvCUR_set(sv, len);
*SvEND(sv) ='\0';
- aint = SvCUR(sv);
fd = PerlIO_fileno(IoIFP(io));
switch (optype) {
case OP_GETSOCKNAME:
- if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &aint) < 0)
+ if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
goto nuts2;
break;
case OP_GETPEERNAME:
- if (getpeername(fd, (struct sockaddr *)SvPVX(sv), &aint) < 0)
+ if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
goto nuts2;
+#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
+ {
+ static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
+ /* If the call succeeded, make sure we don't have a zeroed port/addr */
+ if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
+ !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
+ sizeof(u_short) + sizeof(struct in_addr))) {
+ goto nuts2;
+ }
+ }
+#endif
break;
}
#ifdef BOGUS_GETNAME_RETURN
/* Interactive Unix, getpeername() and getsockname()
does not return valid namelen */
- if (aint == BOGUS_GETNAME_RETURN)
- aint = sizeof(struct sockaddr);
+ if (len == BOGUS_GETNAME_RETURN)
+ len = sizeof(struct sockaddr);
#endif
- SvCUR_set(sv,aint);
+ SvCUR_set(sv, len);
*SvEND(sv) ='\0';
PUSHs(sv);
RETURN;
nuts:
- if (dowarn)
- warn("get{sock, peer}name() on closed fd");
- SETERRNO(EBADF,SS$_IVCHAN);
+ if (ckWARN(WARN_CLOSED))
+ report_evil_fh(gv, io, optype);
+ SETERRNO(EBADF,SS_IVCHAN);
nuts2:
RETPUSHUNDEF;
#else
- DIE(no_sock_func, "getpeername");
+ DIE(aTHX_ PL_no_sock_func, "getpeername");
#endif
}
PP(pp_lstat)
{
- return pp_stat(ARGS);
+ return pp_stat();
}
PP(pp_stat)
{
dSP;
- GV *tmpgv;
+ GV *gv;
+ I32 gimme;
I32 max = 13;
+ STRLEN n_a;
+
+ if (PL_op->op_flags & OPf_REF) {
+ gv = cGVOP_gv;
+ if (PL_op->op_type == OP_LSTAT) {
+ if (gv != PL_defgv) {
+ if (ckWARN(WARN_IO))
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "lstat() on filehandle %s", GvENAME(gv));
+ } else if (PL_laststype != OP_LSTAT)
+ Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
+ }
- if (op->op_flags & OPf_REF) {
- tmpgv = cGVOP->op_gv;
do_fstat:
- if (tmpgv != defgv) {
- laststype = OP_STAT;
- statgv = tmpgv;
- sv_setpv(statname, "");
- laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
- ? Fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &statcache) : -1);
+ if (gv != PL_defgv) {
+ PL_laststype = OP_STAT;
+ PL_statgv = gv;
+ sv_setpv(PL_statname, "");
+ PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
+ ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
}
- if (laststatval < 0)
+ if (PL_laststatval < 0) {
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
+ report_evil_fh(gv, GvIO(gv), PL_op->op_type);
max = 0;
+ }
}
else {
SV* sv = POPs;
if (SvTYPE(sv) == SVt_PVGV) {
- tmpgv = (GV*)sv;
+ gv = (GV*)sv;
goto do_fstat;
}
else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
- tmpgv = (GV*)SvRV(sv);
+ gv = (GV*)SvRV(sv);
+ if (PL_op->op_type == OP_LSTAT && ckWARN(WARN_IO))
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "lstat() on filehandle %s", GvENAME(gv));
goto do_fstat;
}
- sv_setpv(statname, SvPV(sv,na));
- statgv = Nullgv;
+ sv_setpv(PL_statname, SvPV(sv,n_a));
+ PL_statgv = Nullgv;
#ifdef HAS_LSTAT
- laststype = op->op_type;
- if (op->op_type == OP_LSTAT)
- laststatval = lstat(SvPV(statname, na), &statcache);
+ PL_laststype = PL_op->op_type;
+ if (PL_op->op_type == OP_LSTAT)
+ PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
else
#endif
- laststatval = Stat(SvPV(statname, na), &statcache);
- if (laststatval < 0) {
- if (dowarn && strchr(SvPV(statname, na), '\n'))
- warn(warn_nl, "stat");
+ PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
+ if (PL_laststatval < 0) {
+ if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
+ Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
max = 0;
}
}
- if (GIMME != G_ARRAY) {
- EXTEND(SP, 1);
- if (max)
- RETPUSHYES;
- else
- RETPUSHUNDEF;
+ gimme = GIMME_V;
+ if (gimme != G_ARRAY) {
+ if (gimme != G_VOID)
+ XPUSHs(boolSV(max));
+ RETURN;
}
if (max) {
EXTEND(SP, max);
EXTEND_MORTAL(max);
-
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_dev)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_ino)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_mode)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_nlink)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_uid)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_gid)));
+ PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
+ PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
+ PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
+ PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
+#if Uid_t_size > IVSIZE
+ PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
+#else
+# if Uid_t_sign <= 0
+ PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
+# else
+ PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
+# endif
+#endif
+#if Gid_t_size > IVSIZE
+ PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
+#else
+# if Gid_t_sign <= 0
+ PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
+# else
+ PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
+# endif
+#endif
#ifdef USE_STAT_RDEV
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_rdev)));
+ PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
+#else
+ PUSHs(sv_2mortal(newSVpvn("", 0)));
+#endif
+#if Off_t_size > IVSIZE
+ PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
#else
- PUSHs(sv_2mortal(newSVpv("", 0)));
+ PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
#endif
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_size)));
#ifdef BIG_TIME
- PUSHs(sv_2mortal(newSVnv((U32)statcache.st_atime)));
- PUSHs(sv_2mortal(newSVnv((U32)statcache.st_mtime)));
- PUSHs(sv_2mortal(newSVnv((U32)statcache.st_ctime)));
+ PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
+ PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
+ PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
#else
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_atime)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_mtime)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_ctime)));
+ PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
+ PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
+ PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
#endif
#ifdef USE_STAT_BLOCKS
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_blksize)));
- PUSHs(sv_2mortal(newSViv((I32)statcache.st_blocks)));
+ PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
+ PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
#else
- PUSHs(sv_2mortal(newSVpv("", 0)));
- PUSHs(sv_2mortal(newSVpv("", 0)));
+ PUSHs(sv_2mortal(newSVpvn("", 0)));
+ PUSHs(sv_2mortal(newSVpvn("", 0)));
#endif
}
RETURN;
PP(pp_ftrread)
{
- I32 result = my_stat(ARGS);
+ I32 result;
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 (result == 0)
+ RETPUSHYES;
+ if (result < 0)
+ RETPUSHUNDEF;
+ RETPUSHNO;
+ }
+ else
+ result = my_stat();
+#else
+ result = my_stat();
+#endif
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- if (cando(S_IRUSR, 0, &statcache))
+ if (cando(S_IRUSR, 0, &PL_statcache))
RETPUSHYES;
RETPUSHNO;
}
PP(pp_ftrwrite)
{
- I32 result = my_stat(ARGS);
+ I32 result;
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 (result == 0)
+ RETPUSHYES;
+ if (result < 0)
+ RETPUSHUNDEF;
+ RETPUSHNO;
+ }
+ else
+ result = my_stat();
+#else
+ result = my_stat();
+#endif
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- if (cando(S_IWUSR, 0, &statcache))
+ if (cando(S_IWUSR, 0, &PL_statcache))
RETPUSHYES;
RETPUSHNO;
}
PP(pp_ftrexec)
{
- I32 result = my_stat(ARGS);
+ I32 result;
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 (result == 0)
+ RETPUSHYES;
+ if (result < 0)
+ RETPUSHUNDEF;
+ RETPUSHNO;
+ }
+ else
+ result = my_stat();
+#else
+ result = my_stat();
+#endif
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- if (cando(S_IXUSR, 0, &statcache))
+ if (cando(S_IXUSR, 0, &PL_statcache))
RETPUSHYES;
RETPUSHNO;
}
PP(pp_fteread)
{
- I32 result = my_stat(ARGS);
+ I32 result;
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 (result == 0)
+ RETPUSHYES;
+ if (result < 0)
+ RETPUSHUNDEF;
+ RETPUSHNO;
+ }
+ else
+ result = my_stat();
+#else
+ result = my_stat();
+#endif
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- if (cando(S_IRUSR, 1, &statcache))
+ if (cando(S_IRUSR, 1, &PL_statcache))
RETPUSHYES;
RETPUSHNO;
}
PP(pp_ftewrite)
{
- I32 result = my_stat(ARGS);
+ I32 result;
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 (result == 0)
+ RETPUSHYES;
+ if (result < 0)
+ RETPUSHUNDEF;
+ RETPUSHNO;
+ }
+ else
+ result = my_stat();
+#else
+ result = my_stat();
+#endif
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- if (cando(S_IWUSR, 1, &statcache))
+ if (cando(S_IWUSR, 1, &PL_statcache))
RETPUSHYES;
RETPUSHNO;
}
PP(pp_fteexec)
{
- I32 result = my_stat(ARGS);
+ I32 result;
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 (result == 0)
+ RETPUSHYES;
+ if (result < 0)
+ RETPUSHUNDEF;
+ RETPUSHNO;
+ }
+ else
+ result = my_stat();
+#else
+ result = my_stat();
+#endif
+ SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- if (cando(S_IXUSR, 1, &statcache))
+ if (cando(S_IXUSR, 1, &PL_statcache))
RETPUSHYES;
RETPUSHNO;
}
PP(pp_ftis)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
dSP;
if (result < 0)
RETPUSHUNDEF;
PP(pp_fteowned)
{
- return pp_ftrowned(ARGS);
+ return pp_ftrowned();
}
PP(pp_ftrowned)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
dSP;
if (result < 0)
RETPUSHUNDEF;
- if (statcache.st_uid == (op->op_type == OP_FTEOWNED ? euid : uid) )
+ if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
+ PL_euid : PL_uid) )
RETPUSHYES;
RETPUSHNO;
}
PP(pp_ftzero)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
dSP;
if (result < 0)
RETPUSHUNDEF;
- if (!statcache.st_size)
+ if (PL_statcache.st_size == 0)
RETPUSHYES;
RETPUSHNO;
}
PP(pp_ftsize)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
dSP; dTARGET;
if (result < 0)
RETPUSHUNDEF;
- PUSHi(statcache.st_size);
+#if Off_t_size > IVSIZE
+ PUSHn(PL_statcache.st_size);
+#else
+ PUSHi(PL_statcache.st_size);
+#endif
RETURN;
}
PP(pp_ftmtime)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
dSP; dTARGET;
if (result < 0)
RETPUSHUNDEF;
- PUSHn( ((I32)basetime - (I32)statcache.st_mtime) / 86400.0 );
+ PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
RETURN;
}
PP(pp_ftatime)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
dSP; dTARGET;
if (result < 0)
RETPUSHUNDEF;
- PUSHn( ((I32)basetime - (I32)statcache.st_atime) / 86400.0 );
+ PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
RETURN;
}
PP(pp_ftctime)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
dSP; dTARGET;
if (result < 0)
RETPUSHUNDEF;
- PUSHn( ((I32)basetime - (I32)statcache.st_ctime) / 86400.0 );
+ PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
RETURN;
}
PP(pp_ftsock)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
dSP;
if (result < 0)
RETPUSHUNDEF;
- if (S_ISSOCK(statcache.st_mode))
+ if (S_ISSOCK(PL_statcache.st_mode))
RETPUSHYES;
RETPUSHNO;
}
PP(pp_ftchr)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
dSP;
if (result < 0)
RETPUSHUNDEF;
- if (S_ISCHR(statcache.st_mode))
+ if (S_ISCHR(PL_statcache.st_mode))
RETPUSHYES;
RETPUSHNO;
}
PP(pp_ftblk)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
dSP;
if (result < 0)
RETPUSHUNDEF;
- if (S_ISBLK(statcache.st_mode))
+ if (S_ISBLK(PL_statcache.st_mode))
RETPUSHYES;
RETPUSHNO;
}
PP(pp_ftfile)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
dSP;
if (result < 0)
RETPUSHUNDEF;
- if (S_ISREG(statcache.st_mode))
+ if (S_ISREG(PL_statcache.st_mode))
RETPUSHYES;
RETPUSHNO;
}
PP(pp_ftdir)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
dSP;
if (result < 0)
RETPUSHUNDEF;
- if (S_ISDIR(statcache.st_mode))
+ if (S_ISDIR(PL_statcache.st_mode))
RETPUSHYES;
RETPUSHNO;
}
PP(pp_ftpipe)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
dSP;
if (result < 0)
RETPUSHUNDEF;
- if (S_ISFIFO(statcache.st_mode))
+ if (S_ISFIFO(PL_statcache.st_mode))
RETPUSHYES;
RETPUSHNO;
}
PP(pp_ftlink)
{
- I32 result = my_lstat(ARGS);
+ I32 result = my_lstat();
dSP;
if (result < 0)
RETPUSHUNDEF;
- if (S_ISLNK(statcache.st_mode))
+ if (S_ISLNK(PL_statcache.st_mode))
RETPUSHYES;
RETPUSHNO;
}
{
dSP;
#ifdef S_ISUID
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- if (statcache.st_mode & S_ISUID)
+ if (PL_statcache.st_mode & S_ISUID)
RETPUSHYES;
#endif
RETPUSHNO;
{
dSP;
#ifdef S_ISGID
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- if (statcache.st_mode & S_ISGID)
+ if (PL_statcache.st_mode & S_ISGID)
RETPUSHYES;
#endif
RETPUSHNO;
{
dSP;
#ifdef S_ISVTX
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
- if (statcache.st_mode & S_ISVTX)
+ if (PL_statcache.st_mode & S_ISVTX)
RETPUSHYES;
#endif
RETPUSHNO;
dSP;
int fd;
GV *gv;
- char *tmps;
- if (op->op_flags & OPf_REF) {
- gv = cGVOP->op_gv;
- tmps = "";
- }
+ char *tmps = Nullch;
+ STRLEN n_a;
+
+ if (PL_op->op_flags & OPf_REF)
+ gv = cGVOP_gv;
+ else if (isGV(TOPs))
+ gv = (GV*)POPs;
+ else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
+ gv = (GV*)SvRV(POPs);
else
- gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO);
+ gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
+
if (GvIO(gv) && IoIFP(GvIOp(gv)))
fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
- else if (isDIGIT(*tmps))
+ else if (tmps && isDIGIT(*tmps))
fd = atoi(tmps);
else
RETPUSHUNDEF;
- if (isatty(fd))
+ if (PerlLIO_isatty(fd))
RETPUSHYES;
RETPUSHNO;
}
register IO *io;
register SV *sv;
GV *gv;
+ STRLEN n_a;
+ PerlIO *fp;
- if (op->op_flags & OPf_REF)
- gv = cGVOP->op_gv;
+ if (PL_op->op_flags & OPf_REF)
+ gv = cGVOP_gv;
else if (isGV(TOPs))
gv = (GV*)POPs;
else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
if (gv) {
EXTEND(SP, 1);
- if (gv == defgv) {
- if (statgv)
- io = GvIO(statgv);
+ if (gv == PL_defgv) {
+ if (PL_statgv)
+ io = GvIO(PL_statgv);
else {
- sv = statname;
+ sv = PL_statname;
goto really_filename;
}
}
else {
- statgv = gv;
- laststatval = -1;
- sv_setpv(statname, "");
- io = GvIO(statgv);
+ PL_statgv = gv;
+ PL_laststatval = -1;
+ sv_setpv(PL_statname, "");
+ io = GvIO(PL_statgv);
}
if (io && IoIFP(io)) {
if (! PerlIO_has_base(IoIFP(io)))
- DIE("-T and -B not implemented on filehandles");
- laststatval = Fstat(PerlIO_fileno(IoIFP(io)), &statcache);
- if (laststatval < 0)
+ DIE(aTHX_ "-T and -B not implemented on filehandles");
+ PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
+ if (PL_laststatval < 0)
RETPUSHUNDEF;
- if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */
- if (op->op_type == OP_FTTEXT)
+ if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
+ if (PL_op->op_type == OP_FTTEXT)
RETPUSHNO;
else
RETPUSHYES;
+ }
if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
i = PerlIO_getc(IoIFP(io));
if (i != EOF)
len = 512;
}
else {
- if (dowarn)
- warn("Test on unopened file <%s>",
- GvENAME(cGVOP->op_gv));
- SETERRNO(EBADF,RMS$_IFI);
+ if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
+ gv = cGVOP_gv;
+ report_evil_fh(gv, GvIO(gv), PL_op->op_type);
+ }
+ SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
}
}
else {
sv = POPs;
really_filename:
- statgv = Nullgv;
- laststatval = -1;
- sv_setpv(statname, SvPV(sv, na));
-#ifdef HAS_OPEN3
- i = open(SvPV(sv, na), O_RDONLY, 0);
-#else
- i = open(SvPV(sv, na), 0);
-#endif
- if (i < 0) {
- if (dowarn && strchr(SvPV(sv, na), '\n'))
- warn(warn_nl, "open");
+ PL_statgv = Nullgv;
+ PL_laststatval = -1;
+ 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'))
+ Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
RETPUSHUNDEF;
}
- laststatval = Fstat(i, &statcache);
- if (laststatval < 0)
+ PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
+ if (PL_laststatval < 0) {
+ (void)PerlIO_close(fp);
RETPUSHUNDEF;
- len = read(i, tbuf, 512);
- (void)close(i);
+ }
+ PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
+ len = PerlIO_read(fp, tbuf, sizeof(tbuf));
+ (void)PerlIO_close(fp);
if (len <= 0) {
- if (S_ISDIR(statcache.st_mode) && op->op_type == OP_FTTEXT)
+ if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
RETPUSHNO; /* special case NFS directories */
RETPUSHYES; /* null file is anything */
}
/* now scan s to look for textiness */
/* XXX ASCII dependent code */
+#if defined(DOSISH) || defined(USEMYBINMODE)
+ /* ignore trailing ^Z on short files */
+ if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
+ --len;
+#endif
+
for (i = 0; i < len; i++, s++) {
if (!*s) { /* null never allowed in text */
odd += len;
break;
}
- else if (*s & 128)
+#ifdef EBCDIC
+ else if (!(isPRINT(*s) || isSPACE(*s)))
+ odd++;
+#else
+ else if (*s & 128) {
+#ifdef USE_LOCALE
+ if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
+ continue;
+#endif
+ /* utf8 characters don't count as odd */
+ if (UTF8_IS_START(*s)) {
+ int ulen = UTF8SKIP(s);
+ if (ulen < len - i) {
+ int j;
+ for (j = 1; j < ulen; j++) {
+ if (!UTF8_IS_CONTINUATION(s[j]))
+ goto not_utf8;
+ }
+ --ulen; /* loop does extra increment */
+ s += ulen;
+ i += ulen;
+ continue;
+ }
+ }
+ not_utf8:
odd++;
+ }
else if (*s < 32 &&
*s != '\n' && *s != '\r' && *s != '\b' &&
*s != '\t' && *s != '\f' && *s != 27)
odd++;
+#endif
}
- if ((odd * 3 > len) == (op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
+ if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
RETPUSHNO;
else
RETPUSHYES;
PP(pp_ftbinary)
{
- return pp_fttext(ARGS);
+ return pp_fttext();
}
/* File calls. */
dSP; dTARGET;
char *tmps;
SV **svp;
+ STRLEN n_a;
- if (MAXARG < 1)
- tmps = Nullch;
+ if( MAXARG == 1 )
+ tmps = POPpx;
else
- tmps = POPp;
- if (!tmps || !*tmps) {
- svp = hv_fetch(GvHVn(envgv), "HOME", 4, FALSE);
- if (svp)
- tmps = SvPV(*svp, na);
- }
- if (!tmps || !*tmps) {
- svp = hv_fetch(GvHVn(envgv), "LOGDIR", 6, FALSE);
- if (svp)
- tmps = SvPV(*svp, na);
+ tmps = 0;
+
+ if( !tmps || !*tmps ) {
+ if ( (svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE))
+ || (svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE))
+#ifdef VMS
+ || (svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE))
+#endif
+ )
+ {
+ if( MAXARG == 1 )
+ deprecate("chdir('') or chdir(undef) as chdir()");
+ tmps = SvPV(*svp, n_a);
+ }
+ else {
+ PUSHi(0);
+ TAINT_PROPER("chdir");
+ RETURN;
+ }
}
+
TAINT_PROPER("chdir");
- PUSHi( chdir(tmps) >= 0 );
+ PUSHi( PerlDir_chdir(tmps) >= 0 );
#ifdef VMS
/* Clear the DEFAULT element of ENV so we'll get the new value
* in the future. */
- hv_delete(GvHVn(envgv),"DEFAULT",7,G_DISCARD);
+ hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
#endif
RETURN;
}
PP(pp_chown)
{
- dSP; dMARK; dTARGET;
- I32 value;
#ifdef HAS_CHOWN
- value = (I32)apply(op->op_type, MARK, SP);
+ dSP; dMARK; dTARGET;
+ I32 value = (I32)apply(PL_op->op_type, MARK, SP);
+
SP = MARK;
PUSHi(value);
RETURN;
#else
- DIE(no_func, "Unsupported function chown");
+ DIE(aTHX_ PL_no_func, "chown");
#endif
}
PP(pp_chroot)
{
- dSP; dTARGET;
- char *tmps;
#ifdef HAS_CHROOT
- tmps = POPp;
+ dSP; dTARGET;
+ STRLEN n_a;
+ char *tmps = POPpx;
TAINT_PROPER("chroot");
PUSHi( chroot(tmps) >= 0 );
RETURN;
#else
- DIE(no_func, "chroot");
+ DIE(aTHX_ PL_no_func, "chroot");
#endif
}
{
dSP; dMARK; dTARGET;
I32 value;
- value = (I32)apply(op->op_type, MARK, SP);
+ value = (I32)apply(PL_op->op_type, MARK, SP);
SP = MARK;
PUSHi(value);
RETURN;
{
dSP; dMARK; dTARGET;
I32 value;
- value = (I32)apply(op->op_type, MARK, SP);
+ value = (I32)apply(PL_op->op_type, MARK, SP);
SP = MARK;
PUSHi(value);
RETURN;
{
dSP; dMARK; dTARGET;
I32 value;
- value = (I32)apply(op->op_type, MARK, SP);
+ value = (I32)apply(PL_op->op_type, MARK, SP);
SP = MARK;
PUSHi(value);
RETURN;
{
dSP; dTARGET;
int anum;
+ STRLEN n_a;
- char *tmps2 = POPp;
- char *tmps = SvPV(TOPs, na);
+ char *tmps2 = POPpx;
+ char *tmps = SvPV(TOPs, n_a);
TAINT_PROPER("rename");
#ifdef HAS_RENAME
- anum = rename(tmps, tmps2);
+ anum = PerlLIO_rename(tmps, tmps2);
#else
- if (!(anum = Stat(tmps, &statbuf))) {
+ if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
if (same_dirent(tmps2, tmps)) /* can always rename to same name */
anum = 1;
else {
- if (euid || Stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
+ if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
(void)UNLINK(tmps2);
if (!(anum = link(tmps, tmps2)))
anum = UNLINK(tmps);
PP(pp_link)
{
- dSP; dTARGET;
#ifdef HAS_LINK
- char *tmps2 = POPp;
- char *tmps = SvPV(TOPs, na);
+ dSP; dTARGET;
+ STRLEN n_a;
+ char *tmps2 = POPpx;
+ char *tmps = SvPV(TOPs, n_a);
TAINT_PROPER("link");
- SETi( link(tmps, tmps2) >= 0 );
+ SETi( PerlLIO_link(tmps, tmps2) >= 0 );
+ RETURN;
#else
- DIE(no_func, "Unsupported function link");
+ DIE(aTHX_ PL_no_func, "link");
#endif
- RETURN;
}
PP(pp_symlink)
{
- dSP; dTARGET;
#ifdef HAS_SYMLINK
- char *tmps2 = POPp;
- char *tmps = SvPV(TOPs, na);
+ dSP; dTARGET;
+ STRLEN n_a;
+ char *tmps2 = POPpx;
+ char *tmps = SvPV(TOPs, n_a);
TAINT_PROPER("symlink");
SETi( symlink(tmps, tmps2) >= 0 );
RETURN;
#else
- DIE(no_func, "symlink");
+ DIE(aTHX_ PL_no_func, "symlink");
#endif
}
PP(pp_readlink)
{
- dSP; dTARGET;
+ dSP;
#ifdef HAS_SYMLINK
+ dTARGET;
char *tmps;
+ char buf[MAXPATHLEN];
int len;
- tmps = POPp;
- len = readlink(tmps, buf, sizeof buf);
+ STRLEN n_a;
+
+#ifndef INCOMPLETE_TAINTS
+ TAINT;
+#endif
+ tmps = POPpx;
+ len = readlink(tmps, buf, sizeof(buf) - 1);
EXTEND(SP, 1);
if (len < 0)
RETPUSHUNDEF;
}
#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
-static int
-dooneliner(cmd, filename)
-char *cmd;
-char *filename;
+STATIC int
+S_dooneliner(pTHX_ char *cmd, char *filename)
{
- char mybuf[8192];
- char *s,
- *save_filename = filename;
- int anum = 1;
+ char *save_filename = filename;
+ char *cmdline;
+ char *s;
PerlIO *myfp;
+ int anum = 1;
- strcpy(mybuf, cmd);
- strcat(mybuf, " ");
- for (s = mybuf+strlen(mybuf); *filename; ) {
+ New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
+ strcpy(cmdline, cmd);
+ strcat(cmdline, " ");
+ for (s = cmdline + strlen(cmdline); *filename; ) {
*s++ = '\\';
*s++ = *filename++;
}
strcpy(s, " 2>&1");
- myfp = my_popen(mybuf, "r");
+ myfp = PerlProc_popen(cmdline, "r");
+ Safefree(cmdline);
+
if (myfp) {
- *mybuf = '\0';
- /* Need to save/restore 'rs' ?? */
+ SV *tmpsv = sv_newmortal();
+ /* Need to save/restore 'PL_rs' ?? */
s = sv_gets(tmpsv, myfp, 0);
- (void)my_pclose(myfp);
+ (void)PerlProc_pclose(myfp);
if (s != Nullch) {
- for (errno = 1; errno < sys_nerr; errno++) {
+ int e;
+ for (e = 1;
#ifdef HAS_SYS_ERRLIST
- if (instr(mybuf, sys_errlist[errno])) /* you don't see this */
- return 0;
+ e <= sys_nerr
+#endif
+ ; e++)
+ {
+ /* you don't see this */
+ char *errmsg =
+#ifdef HAS_SYS_ERRLIST
+ sys_errlist[e]
#else
- char *errmsg; /* especially if it isn't there */
-
- if (instr(mybuf,
- (errmsg = strerror(errno)) ? errmsg : "NoErRoR"))
+ strerror(e)
+#endif
+ ;
+ if (!errmsg)
+ break;
+ if (instr(s, errmsg)) {
+ SETERRNO(e,0);
return 0;
-#endif
+ }
}
SETERRNO(0,0);
#ifndef EACCES
#define EACCES EPERM
#endif
- if (instr(mybuf, "cannot make"))
- SETERRNO(EEXIST,RMS$_FEX);
- else if (instr(mybuf, "existing file"))
- SETERRNO(EEXIST,RMS$_FEX);
- else if (instr(mybuf, "ile exists"))
- SETERRNO(EEXIST,RMS$_FEX);
- else if (instr(mybuf, "non-exist"))
- SETERRNO(ENOENT,RMS$_FNF);
- else if (instr(mybuf, "does not exist"))
- SETERRNO(ENOENT,RMS$_FNF);
- else if (instr(mybuf, "not empty"))
- SETERRNO(EBUSY,SS$_DEVOFFLINE);
- else if (instr(mybuf, "cannot access"))
- SETERRNO(EACCES,RMS$_PRV);
+ if (instr(s, "cannot make"))
+ SETERRNO(EEXIST,RMS_FEX);
+ else if (instr(s, "existing file"))
+ SETERRNO(EEXIST,RMS_FEX);
+ else if (instr(s, "ile exists"))
+ SETERRNO(EEXIST,RMS_FEX);
+ else if (instr(s, "non-exist"))
+ SETERRNO(ENOENT,RMS_FNF);
+ else if (instr(s, "does not exist"))
+ SETERRNO(ENOENT,RMS_FNF);
+ else if (instr(s, "not empty"))
+ SETERRNO(EBUSY,SS_DEVOFFLINE);
+ else if (instr(s, "cannot access"))
+ SETERRNO(EACCES,RMS_PRV);
else
- SETERRNO(EPERM,RMS$_PRV);
+ SETERRNO(EPERM,RMS_PRV);
return 0;
}
else { /* some mkdirs return no failure indication */
- anum = (Stat(save_filename, &statbuf) >= 0);
- if (op->op_type == OP_RMDIR)
+ anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
+ if (PL_op->op_type == OP_RMDIR)
anum = !anum;
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;
- int mode = POPi;
+ int mode;
#ifndef HAS_MKDIR
int oldumask;
#endif
- char *tmps = SvPV(TOPs, na);
+ STRLEN len;
+ char *tmps;
+ bool copy = FALSE;
+
+ if (MAXARG > 1)
+ mode = POPi;
+ else
+ mode = 0777;
+
+ TRIMSLASHES(tmps,len,copy);
TAINT_PROPER("mkdir");
#ifdef HAS_MKDIR
- SETi( mkdir(tmps, mode) >= 0 );
+ SETi( PerlDir_mkdir(tmps, mode) >= 0 );
#else
SETi( dooneliner("mkdir", tmps) );
- oldumask = umask(0);
- umask(oldumask);
- chmod(tmps, (mode & ~oldumask) & 0777);
+ oldumask = PerlLIO_umask(0);
+ PerlLIO_umask(oldumask);
+ PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
#endif
+ if (copy)
+ Safefree(tmps);
RETURN;
}
PP(pp_rmdir)
{
dSP; dTARGET;
+ STRLEN len;
char *tmps;
+ bool copy = FALSE;
- tmps = POPp;
+ TRIMSLASHES(tmps,len,copy);
TAINT_PROPER("rmdir");
#ifdef HAS_RMDIR
- XPUSHi( rmdir(tmps) >= 0 );
+ SETi( PerlDir_rmdir(tmps) >= 0 );
#else
- XPUSHi( dooneliner("rmdir", tmps) );
+ SETi( dooneliner("rmdir", tmps) );
#endif
+ if (copy)
+ Safefree(tmps);
RETURN;
}
PP(pp_open_dir)
{
- dSP;
#if defined(Direntry_t) && defined(HAS_READDIR)
- char *dirname = POPp;
+ dSP;
+ STRLEN n_a;
+ char *dirname = POPpx;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
goto nope;
if (IoDIRP(io))
- closedir(IoDIRP(io));
- if (!(IoDIRP(io) = opendir(dirname)))
+ PerlDir_close(IoDIRP(io));
+ if (!(IoDIRP(io) = PerlDir_open(dirname)))
goto nope;
RETPUSHYES;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_DIR);
+ SETERRNO(EBADF,RMS_DIR);
RETPUSHUNDEF;
#else
- DIE(no_dir_func, "opendir");
+ DIE(aTHX_ PL_no_dir_func, "opendir");
#endif
}
PP(pp_readdir)
{
- dSP;
#if defined(Direntry_t) && defined(HAS_READDIR)
-#ifndef I_DIRENT
- Direntry_t *readdir _((DIR *));
+ dSP;
+#if !defined(I_DIRENT) && !defined(VMS)
+ Direntry_t *readdir (DIR *);
#endif
register Direntry_t *dp;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
+ SV *sv;
if (!io || !IoDIRP(io))
goto nope;
if (GIMME == G_ARRAY) {
/*SUPPRESS 560*/
- while (dp = (Direntry_t *)readdir(IoDIRP(io))) {
+ while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
#ifdef DIRNAMLEN
- XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
+ sv = newSVpvn(dp->d_name, dp->d_namlen);
#else
- XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
+ sv = newSVpv(dp->d_name, 0);
#endif
+#ifndef INCOMPLETE_TAINTS
+ if (!(IoFLAGS(io) & IOf_UNTAINT))
+ SvTAINTED_on(sv);
+#endif
+ XPUSHs(sv_2mortal(sv));
}
}
else {
- if (!(dp = (Direntry_t *)readdir(IoDIRP(io))))
+ if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
goto nope;
#ifdef DIRNAMLEN
- XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
+ sv = newSVpvn(dp->d_name, dp->d_namlen);
#else
- XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
+ sv = newSVpv(dp->d_name, 0);
+#endif
+#ifndef INCOMPLETE_TAINTS
+ if (!(IoFLAGS(io) & IOf_UNTAINT))
+ SvTAINTED_on(sv);
#endif
+ XPUSHs(sv_2mortal(sv));
}
RETURN;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_ISI);
+ SETERRNO(EBADF,RMS_ISI);
if (GIMME == G_ARRAY)
RETURN;
else
RETPUSHUNDEF;
#else
- DIE(no_dir_func, "readdir");
+ DIE(aTHX_ PL_no_dir_func, "readdir");
#endif
}
PP(pp_telldir)
{
- dSP; dTARGET;
#if defined(HAS_TELLDIR) || defined(telldir)
-#if !defined(telldir) && !defined(HAS_TELLDIR_PROTOTYPE)
- long telldir _((DIR *));
-#endif
+ dSP; dTARGET;
+ /* XXX does _anyone_ need this? --AD 2/20/1998 */
+ /* XXX netbsd still seemed to.
+ XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
+ --JHI 1999-Feb-02 */
+# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
+ long telldir (DIR *);
+# endif
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
if (!io || !IoDIRP(io))
goto nope;
- PUSHi( telldir(IoDIRP(io)) );
+ PUSHi( PerlDir_tell(IoDIRP(io)) );
RETURN;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_ISI);
+ SETERRNO(EBADF,RMS_ISI);
RETPUSHUNDEF;
#else
- DIE(no_dir_func, "telldir");
+ DIE(aTHX_ PL_no_dir_func, "telldir");
#endif
}
PP(pp_seekdir)
{
- dSP;
#if defined(HAS_SEEKDIR) || defined(seekdir)
+ dSP;
long along = POPl;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
if (!io || !IoDIRP(io))
goto nope;
- (void)seekdir(IoDIRP(io), along);
+ (void)PerlDir_seek(IoDIRP(io), along);
RETPUSHYES;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_ISI);
+ SETERRNO(EBADF,RMS_ISI);
RETPUSHUNDEF;
#else
- DIE(no_dir_func, "seekdir");
+ DIE(aTHX_ PL_no_dir_func, "seekdir");
#endif
}
PP(pp_rewinddir)
{
- dSP;
#if defined(HAS_REWINDDIR) || defined(rewinddir)
+ dSP;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
if (!io || !IoDIRP(io))
goto nope;
- (void)rewinddir(IoDIRP(io));
+ (void)PerlDir_rewind(IoDIRP(io));
RETPUSHYES;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_ISI);
+ SETERRNO(EBADF,RMS_ISI);
RETPUSHUNDEF;
#else
- DIE(no_dir_func, "rewinddir");
+ DIE(aTHX_ PL_no_dir_func, "rewinddir");
#endif
}
PP(pp_closedir)
{
- dSP;
#if defined(Direntry_t) && defined(HAS_READDIR)
+ dSP;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
goto nope;
#ifdef VOID_CLOSEDIR
- closedir(IoDIRP(io));
+ PerlDir_close(IoDIRP(io));
#else
- if (closedir(IoDIRP(io)) < 0) {
+ if (PerlDir_close(IoDIRP(io)) < 0) {
IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
goto nope;
}
RETPUSHYES;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,RMS_IFI);
RETPUSHUNDEF;
#else
- DIE(no_dir_func, "closedir");
+ DIE(aTHX_ PL_no_dir_func, "closedir");
#endif
}
PP(pp_fork)
{
+#ifdef HAS_FORK
dSP; dTARGET;
- int childpid;
+ Pid_t childpid;
GV *tmpgv;
EXTEND(SP, 1);
-#ifdef HAS_FORK
- childpid = fork();
+ PERL_FLUSHALL_FOR_CHILD;
+ childpid = PerlProc_fork();
if (childpid < 0)
RETSETUNDEF;
if (!childpid) {
/*SUPPRESS 560*/
- if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
- sv_setiv(GvSV(tmpgv), (I32)getpid());
- hv_clear(pidstatus); /* no kids, so don't wait for 'em */
+ if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) {
+ SvREADONLY_off(GvSV(tmpgv));
+ 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);
RETURN;
#else
- DIE(no_func, "Unsupported function fork");
+# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
+ dSP; dTARGET;
+ Pid_t childpid;
+
+ EXTEND(SP, 1);
+ PERL_FLUSHALL_FOR_CHILD;
+ childpid = PerlProc_fork();
+ if (childpid == -1)
+ RETSETUNDEF;
+ PUSHi(childpid);
+ RETURN;
+# else
+ DIE(aTHX_ PL_no_func, "fork");
+# endif
#endif
}
PP(pp_wait)
{
+#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
dSP; dTARGET;
- int childpid;
+ Pid_t childpid;
int argflags;
- I32 value;
- EXTEND(SP, 1);
-#ifdef HAS_WAIT
- childpid = wait(&argflags);
- if (childpid > 0)
- pidgone(childpid, argflags);
- value = (I32)childpid;
- statusvalue = FIXSTATUS(argflags);
- PUSHi(value);
+ 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();
+ }
+ }
+# 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);
+# else
+ STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
+# endif
+ XPUSHi(childpid);
RETURN;
#else
- DIE(no_func, "Unsupported function wait");
+ DIE(aTHX_ PL_no_func, "wait");
#endif
}
PP(pp_waitpid)
{
+#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
dSP; dTARGET;
- int childpid;
+ Pid_t childpid;
int optype;
int argflags;
- I32 value;
-#ifdef HAS_WAIT
optype = POPi;
childpid = TOPi;
- childpid = wait4pid(childpid, &argflags, optype);
- value = (I32)childpid;
- statusvalue = FIXSTATUS(argflags);
- SETi(value);
+ 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();
+ }
+ }
+# 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);
+# else
+ STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
+# endif
+ SETi(childpid);
RETURN;
#else
- DIE(no_func, "Unsupported function wait");
+ DIE(aTHX_ PL_no_func, "waitpid");
#endif
}
{
dSP; dMARK; dORIGMARK; dTARGET;
I32 value;
- int childpid;
+ STRLEN n_a;
int result;
- int status;
- Sigsave_t ihand,qhand; /* place to save signals during system() */
-
-#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
- if (SP - MARK == 1) {
- if (tainting) {
- char *junk = SvPV(TOPs, na);
- TAINT_ENV();
- TAINT_PROPER("system");
+ I32 did_pipes = 0;
+
+ if (PL_tainting) {
+ TAINT_ENV();
+ while (++MARK <= SP) {
+ (void)SvPV_nolen(*MARK); /* stringify for taint check */
+ if (PL_tainted)
+ break;
}
+ MARK = ORIGMARK;
+ TAINT_PROPER("system");
}
- while ((childpid = vfork()) == -1) {
- if (errno != EAGAIN) {
- value = -1;
+ PERL_FLUSHALL_FOR_CHILD;
+#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
+ {
+ Pid_t childpid;
+ int pp[2];
+
+ if (PerlProc_pipe(pp) >= 0)
+ did_pipes = 1;
+ while ((childpid = PerlProc_fork()) == -1) {
+ if (errno != EAGAIN) {
+ value = -1;
+ SP = ORIGMARK;
+ PUSHi(value);
+ if (did_pipes) {
+ PerlLIO_close(pp[0]);
+ PerlLIO_close(pp[1]);
+ }
+ RETURN;
+ }
+ sleep(5);
+ }
+ if (childpid > 0) {
+ Sigsave_t ihand,qhand; /* place to save signals during system() */
+ int status;
+
+ if (did_pipes)
+ PerlLIO_close(pp[1]);
+#ifndef PERL_MICRO
+ rsignal_save(SIGINT, SIG_IGN, &ihand);
+ rsignal_save(SIGQUIT, SIG_IGN, &qhand);
+#endif
+ do {
+ result = wait4pid(childpid, &status, 0);
+ } while (result == -1 && errno == EINTR);
+#ifndef PERL_MICRO
+ (void)rsignal_restore(SIGINT, &ihand);
+ (void)rsignal_restore(SIGQUIT, &qhand);
+#endif
+ STATUS_NATIVE_SET(result == -1 ? -1 : status);
+ do_execfree(); /* free any memory child malloced on fork */
SP = ORIGMARK;
- PUSHi(value);
+ if (did_pipes) {
+ int errkid;
+ int n = 0, n1;
+
+ while (n < sizeof(int)) {
+ n1 = PerlLIO_read(pp[0],
+ (void*)(((char*)&errkid)+n),
+ (sizeof(int)) - n);
+ if (n1 <= 0)
+ break;
+ n += n1;
+ }
+ PerlLIO_close(pp[0]);
+ if (n) { /* Error */
+ if (n != sizeof(int))
+ DIE(aTHX_ "panic: kid popen errno read");
+ errno = errkid; /* Propagate errno from kid */
+ STATUS_CURRENT = -1;
+ }
+ }
+ PUSHi(STATUS_CURRENT);
RETURN;
}
- sleep(5);
- }
- if (childpid > 0) {
- rsignal_save(SIGINT, SIG_IGN, &ihand);
- rsignal_save(SIGQUIT, SIG_IGN, &qhand);
- do {
- result = wait4pid(childpid, &status, 0);
- } while (result == -1 && errno == EINTR);
- (void)rsignal_restore(SIGINT, &ihand);
- (void)rsignal_restore(SIGQUIT, &qhand);
- statusvalue = FIXSTATUS(status);
- if (result < 0)
- value = -1;
+ if (did_pipes) {
+ PerlLIO_close(pp[0]);
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+#endif
+ }
+ if (PL_op->op_flags & OPf_STACKED) {
+ SV *really = *++MARK;
+ value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
+ }
+ else if (SP - MARK != 1)
+ value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
else {
- value = (I32)((unsigned int)status & 0xffff);
+ value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
}
- do_execfree(); /* free any memory child malloced on vfork */
- SP = ORIGMARK;
- PUSHi(value);
- RETURN;
+ PerlProc__exit(-1);
}
- if (op->op_flags & OPf_STACKED) {
- SV *really = *++MARK;
- value = (I32)do_aexec(really, MARK, SP);
- }
- else if (SP - MARK != 1)
- value = (I32)do_aexec(Nullsv, MARK, SP);
- else {
- value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
- }
- _exit(-1);
#else /* ! FORK or VMS or OS/2 */
- if (op->op_flags & OPf_STACKED) {
+ PL_statusvalue = 0;
+ 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), na));
+ value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
}
- statusvalue = FIXSTATUS(value);
+ if (PL_statusvalue == -1) /* hint that value must be returned as is */
+ result = 1;
+ STATUS_NATIVE_SET(value);
do_execfree();
SP = ORIGMARK;
- PUSHi(value);
+ PUSHi(result ? value : STATUS_CURRENT);
#endif /* !FORK or VMS */
RETURN;
}
{
dSP; dMARK; dORIGMARK; dTARGET;
I32 value;
+ STRLEN n_a;
- if (op->op_flags & OPf_STACKED) {
+ if (PL_tainting) {
+ TAINT_ENV();
+ while (++MARK <= SP) {
+ (void)SvPV_nolen(*MARK); /* stringify for taint check */
+ if (PL_tainted)
+ break;
+ }
+ MARK = ORIGMARK;
+ TAINT_PROPER("exec");
+ }
+ PERL_FLUSHALL_FOR_CHILD;
+ if (PL_op->op_flags & OPf_STACKED) {
SV *really = *++MARK;
value = (I32)do_aexec(really, MARK, SP);
}
#ifdef VMS
value = (I32)vms_do_aexec(Nullsv, MARK, SP);
#else
+# ifdef __OPEN_VM
+ {
+ (void ) do_aspawn(Nullsv, MARK, SP);
+ value = 0;
+ }
+# else
value = (I32)do_aexec(Nullsv, MARK, SP);
+# endif
#endif
else {
- if (tainting) {
- char *junk = SvPV(*SP, na);
- TAINT_ENV();
- TAINT_PROPER("exec");
- }
#ifdef VMS
- value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), na));
+ value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
#else
- value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
+# ifdef __OPEN_VM
+ (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
+ value = 0;
+# else
+ value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
+# endif
#endif
}
+
SP = ORIGMARK;
PUSHi(value);
RETURN;
PP(pp_kill)
{
+#ifdef HAS_KILL
dSP; dMARK; dTARGET;
I32 value;
-#ifdef HAS_KILL
- value = (I32)apply(op->op_type, MARK, SP);
+ value = (I32)apply(PL_op->op_type, MARK, SP);
SP = MARK;
PUSHi(value);
RETURN;
#else
- DIE(no_func, "Unsupported function kill");
+ DIE(aTHX_ PL_no_func, "kill");
#endif
}
{
#ifdef HAS_GETPPID
dSP; dTARGET;
+# ifdef THREADS_HAVE_PIDS
+ XPUSHi( PL_ppid );
+# else
XPUSHi( getppid() );
+# endif
RETURN;
#else
- DIE(no_func, "getppid");
+ DIE(aTHX_ PL_no_func, "getppid");
#endif
}
{
#ifdef HAS_GETPGRP
dSP; dTARGET;
- int pid;
- I32 value;
+ Pid_t pid;
+ Pid_t pgrp;
if (MAXARG < 1)
pid = 0;
else
pid = SvIVx(POPs);
#ifdef BSD_GETPGRP
- value = (I32)BSD_GETPGRP(pid);
+ pgrp = (I32)BSD_GETPGRP(pid);
#else
- if (pid != 0)
- DIE("POSIX getpgrp can't take an argument");
- value = (I32)getpgrp();
+ if (pid != 0 && pid != PerlProc_getpid())
+ DIE(aTHX_ "POSIX getpgrp can't take an argument");
+ pgrp = getpgrp();
#endif
- XPUSHi(value);
+ XPUSHi(pgrp);
RETURN;
#else
- DIE(no_func, "getpgrp()");
+ DIE(aTHX_ PL_no_func, "getpgrp()");
#endif
}
{
#ifdef HAS_SETPGRP
dSP; dTARGET;
- int pgrp;
- int pid;
+ Pid_t pgrp;
+ Pid_t pid;
if (MAXARG < 2) {
pgrp = 0;
pid = 0;
#ifdef BSD_SETPGRP
SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
#else
- if ((pgrp != 0) || (pid != 0)) {
- DIE("POSIX setpgrp can't take an argument");
+ if ((pgrp != 0 && pgrp != PerlProc_getpid())
+ || (pid != 0 && pid != PerlProc_getpid()))
+ {
+ DIE(aTHX_ "setpgrp can't take arguments");
}
SETi( setpgrp() >= 0 );
#endif /* USE_BSDPGRP */
RETURN;
#else
- DIE(no_func, "setpgrp()");
+ DIE(aTHX_ PL_no_func, "setpgrp()");
#endif
}
PP(pp_getpriority)
{
- dSP; dTARGET;
- int which;
- int who;
#ifdef HAS_GETPRIORITY
- who = POPi;
- which = TOPi;
+ dSP; dTARGET;
+ int who = POPi;
+ int which = TOPi;
SETi( getpriority(which, who) );
RETURN;
#else
- DIE(no_func, "getpriority()");
+ DIE(aTHX_ PL_no_func, "getpriority()");
#endif
}
PP(pp_setpriority)
{
- dSP; dTARGET;
- int which;
- int who;
- int niceval;
#ifdef HAS_SETPRIORITY
- niceval = POPi;
- who = POPi;
- which = TOPi;
+ dSP; dTARGET;
+ int niceval = POPi;
+ int who = POPi;
+ int which = TOPi;
TAINT_PROPER("setpriority");
SETi( setpriority(which, who, niceval) >= 0 );
RETURN;
#else
- DIE(no_func, "setpriority()");
+ DIE(aTHX_ PL_no_func, "setpriority()");
#endif
}
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.
-*/
-
-#ifndef HZ
-# ifdef CLK_TCK
-# define HZ CLK_TCK
-# else
-# define HZ 60
-# endif
-#endif
-
PP(pp_tms)
{
+#ifdef HAS_TIMES
dSP;
-
-#ifndef HAS_TIMES
- DIE("times not implemented");
-#else
EXTEND(SP, 4);
-
#ifndef VMS
- (void)times(×buf);
+ (void)PerlProc_times(&PL_timesbuf);
#else
- (void)times((tbuffer_t *)×buf); /* time.h uses different name for */
- /* struct tms, though same data */
- /* is returned. */
+ (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
+ /* struct tms, though same data */
+ /* is returned. */
#endif
- PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ)));
+ PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
if (GIMME == G_ARRAY) {
- PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_stime)/HZ)));
- PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cutime)/HZ)));
- PUSHs(sv_2mortal(newSVnv(((double)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
+ DIE(aTHX_ "times not implemented");
#endif /* HAS_TIMES */
}
PP(pp_localtime)
{
- return pp_gmtime(ARGS);
+ return pp_gmtime();
}
PP(pp_gmtime)
when = (Time_t)SvIVx(POPs);
#endif
- if (op->op_type == OP_LOCALTIME)
+ if (PL_op->op_type == OP_LOCALTIME)
tmbuf = localtime(&when);
else
tmbuf = gmtime(&when);
- EXTEND(SP, 9);
- EXTEND_MORTAL(9);
if (GIMME != G_ARRAY) {
- dTARGET;
- char mybuf[30];
+ SV *tsv;
+ EXTEND(SP, 1);
+ EXTEND_MORTAL(1);
if (!tmbuf)
RETPUSHUNDEF;
- sprintf(mybuf, "%s %s %2d %02d:%02d:%02d %d",
- dayname[tmbuf->tm_wday],
- monname[tmbuf->tm_mon],
- tmbuf->tm_mday,
- tmbuf->tm_hour,
- tmbuf->tm_min,
- tmbuf->tm_sec,
- tmbuf->tm_year + 1900);
- PUSHp(mybuf, strlen(mybuf));
+ tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
+ dayname[tmbuf->tm_wday],
+ monname[tmbuf->tm_mon],
+ tmbuf->tm_mday,
+ tmbuf->tm_hour,
+ tmbuf->tm_min,
+ tmbuf->tm_sec,
+ tmbuf->tm_year + 1900);
+ PUSHs(sv_2mortal(tsv));
}
else if (tmbuf) {
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
- PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
+ EXTEND(SP, 9);
+ EXTEND_MORTAL(9);
+ PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
+ PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
+ PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
+ PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
+ PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
+ PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
+ PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
+ PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
+ PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
}
RETURN;
}
PP(pp_alarm)
{
+#ifdef HAS_ALARM
dSP; dTARGET;
int anum;
-#ifdef HAS_ALARM
anum = POPi;
anum = alarm((unsigned int)anum);
EXTEND(SP, 1);
if (anum < 0)
RETPUSHUNDEF;
- PUSHi((I32)anum);
+ PUSHi(anum);
RETURN;
#else
- DIE(no_func, "Unsupported function alarm");
+ DIE(aTHX_ PL_no_func, "alarm");
#endif
}
(void)time(&lasttime);
if (MAXARG < 1)
- Pause();
+ PerlProc_pause();
else {
duration = POPi;
- sleep((unsigned int)duration);
+ PerlProc_sleep((unsigned int)duration);
}
(void)time(&when);
XPUSHi(when - lasttime);
PP(pp_shmget)
{
- return pp_semget(ARGS);
+ return pp_semget();
}
PP(pp_shmctl)
{
- return pp_semctl(ARGS);
+ return pp_semctl();
}
PP(pp_shmread)
{
- return pp_shmwrite(ARGS);
+ return pp_shmwrite();
}
PP(pp_shmwrite)
{
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
dSP; dMARK; dTARGET;
- I32 value = (I32)(do_shmio(op->op_type, MARK, SP) >= 0);
+ I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
SP = MARK;
PUSHi(value);
RETURN;
#else
- return pp_semget(ARGS);
+ return pp_semget();
#endif
}
PP(pp_msgget)
{
- return pp_semget(ARGS);
+ return pp_semget();
}
PP(pp_msgctl)
{
- return pp_semctl(ARGS);
+ return pp_semctl();
}
PP(pp_msgsnd)
PUSHi(value);
RETURN;
#else
- return pp_semget(ARGS);
+ return pp_semget();
#endif
}
PUSHi(value);
RETURN;
#else
- return pp_semget(ARGS);
+ return pp_semget();
#endif
}
{
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
dSP; dMARK; dTARGET;
- int anum = do_ipcget(op->op_type, MARK, SP);
+ int anum = do_ipcget(PL_op->op_type, MARK, SP);
SP = MARK;
if (anum == -1)
RETPUSHUNDEF;
PUSHi(anum);
RETURN;
#else
- DIE("System V IPC is not implemented on this machine");
+ DIE(aTHX_ "System V IPC is not implemented on this machine");
#endif
}
{
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
dSP; dMARK; dTARGET;
- int anum = do_ipcctl(op->op_type, MARK, SP);
+ int anum = do_ipcctl(PL_op->op_type, MARK, SP);
SP = MARK;
if (anum == -1)
RETSETUNDEF;
PUSHi(anum);
}
else {
- PUSHp("0 but true",10);
+ PUSHp(zero_but_true, ZBTLEN);
}
RETURN;
#else
- return pp_semget(ARGS);
+ return pp_semget();
#endif
}
PUSHi(value);
RETURN;
#else
- return pp_semget(ARGS);
+ return pp_semget();
#endif
}
PP(pp_ghbyname)
{
-#ifdef HAS_SOCKET
- return pp_ghostent(ARGS);
+#ifdef HAS_GETHOSTBYNAME
+ return pp_ghostent();
#else
- DIE(no_sock_func, "gethostbyname");
+ DIE(aTHX_ PL_no_sock_func, "gethostbyname");
#endif
}
PP(pp_ghbyaddr)
{
-#ifdef HAS_SOCKET
- return pp_ghostent(ARGS);
+#ifdef HAS_GETHOSTBYADDR
+ return pp_ghostent();
#else
- DIE(no_sock_func, "gethostbyaddr");
+ DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
#endif
}
PP(pp_ghostent)
{
+#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
dSP;
-#ifdef HAS_SOCKET
- I32 which = op->op_type;
+ I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
- struct hostent *gethostbyname();
- struct hostent *gethostbyaddr();
-#ifdef HAS_GETHOSTENT
- struct hostent *gethostent();
+#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
+ struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
+ struct hostent *gethostbyname(Netdb_name_t);
+ struct hostent *gethostent(void);
#endif
struct hostent *hent;
unsigned long len;
+ STRLEN n_a;
EXTEND(SP, 10);
if (which == OP_GHBYNAME) {
- hent = gethostbyname(POPp);
+#ifdef HAS_GETHOSTBYNAME
+ char* name = POPpbytex;
+ hent = PerlSock_gethostbyname(name);
+#else
+ DIE(aTHX_ PL_no_sock_func, "gethostbyname");
+#endif
}
else if (which == OP_GHBYADDR) {
+#ifdef HAS_GETHOSTBYADDR
int addrtype = POPi;
SV *addrsv = POPs;
STRLEN addrlen;
- char *addr = SvPV(addrsv, addrlen);
+ Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
- hent = gethostbyaddr(addr, addrlen, addrtype);
+ hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
+#else
+ DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
+#endif
}
else
#ifdef HAS_GETHOSTENT
- hent = gethostent();
+ hent = PerlSock_gethostent();
#else
- DIE("gethostent not implemented");
+ DIE(aTHX_ PL_no_sock_func, "gethostent");
#endif
#ifdef HOST_NOT_FOUND
- if (!hent)
- statusvalue = FIXSTATUS(h_errno);
+ if (!hent) {
+#ifdef USE_REENTRANT_API
+# ifdef USE_GETHOSTENT_ERRNO
+ h_errno = PL_reentrant_buffer->_gethostent_errno;
+# endif
+#endif
+ STATUS_NATIVE_SET(h_errno);
+ }
#endif
if (GIMME != G_ARRAY) {
}
if (hent) {
- PUSHs(sv = sv_mortalcopy(&sv_no));
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setpv(sv, (char*)hent->h_name);
- PUSHs(sv = sv_mortalcopy(&sv_no));
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
for (elem = hent->h_aliases; elem && *elem; elem++) {
sv_catpv(sv, *elem);
if (elem[1])
sv_catpvn(sv, " ", 1);
}
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)hent->h_addrtype);
- PUSHs(sv = sv_mortalcopy(&sv_no));
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setiv(sv, (IV)hent->h_addrtype);
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
len = hent->h_length;
- sv_setiv(sv, (I32)len);
+ sv_setiv(sv, (IV)len);
#ifdef h_addr
for (elem = hent->h_addr_list; elem && *elem; elem++) {
- XPUSHs(sv = sv_mortalcopy(&sv_no));
+ XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setpvn(sv, *elem, len);
}
#else
- PUSHs(sv = sv_mortalcopy(&sv_no));
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
if (hent->h_addr)
sv_setpvn(sv, hent->h_addr, len);
#endif /* h_addr */
}
RETURN;
#else
- DIE(no_sock_func, "gethostent");
+ DIE(aTHX_ PL_no_sock_func, "gethostent");
#endif
}
PP(pp_gnbyname)
{
-#ifdef HAS_SOCKET
- return pp_gnetent(ARGS);
+#ifdef HAS_GETNETBYNAME
+ return pp_gnetent();
#else
- DIE(no_sock_func, "getnetbyname");
+ DIE(aTHX_ PL_no_sock_func, "getnetbyname");
#endif
}
PP(pp_gnbyaddr)
{
-#ifdef HAS_SOCKET
- return pp_gnetent(ARGS);
+#ifdef HAS_GETNETBYADDR
+ return pp_gnetent();
#else
- DIE(no_sock_func, "getnetbyaddr");
+ DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
#endif
}
PP(pp_gnetent)
{
+#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
dSP;
-#ifdef HAS_SOCKET
- I32 which = op->op_type;
+ I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
- struct netent *getnetbyname();
- struct netent *getnetbyaddr();
- struct netent *getnetent();
+#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
+ struct netent *getnetbyaddr(Netdb_net_t, int);
+ struct netent *getnetbyname(Netdb_name_t);
+ struct netent *getnetent(void);
+#endif
struct netent *nent;
+ STRLEN n_a;
- if (which == OP_GNBYNAME)
- nent = getnetbyname(POPp);
+ if (which == OP_GNBYNAME){
+#ifdef HAS_GETNETBYNAME
+ char *name = POPpbytex;
+ nent = PerlSock_getnetbyname(name);
+#else
+ DIE(aTHX_ PL_no_sock_func, "getnetbyname");
+#endif
+ }
else if (which == OP_GNBYADDR) {
+#ifdef HAS_GETNETBYADDR
int addrtype = POPi;
- unsigned long addr = U_L(POPn);
- nent = getnetbyaddr((long)addr, addrtype);
+ Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
+ nent = PerlSock_getnetbyaddr(addr, addrtype);
+#else
+ DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
+#endif
}
else
- nent = getnetent();
+#ifdef HAS_GETNETENT
+ nent = PerlSock_getnetent();
+#else
+ DIE(aTHX_ PL_no_sock_func, "getnetent");
+#endif
+
+#ifdef HOST_NOT_FOUND
+ if (!nent) {
+#ifdef USE_REENTRANT_API
+# ifdef USE_GETNETENT_ERRNO
+ h_errno = PL_reentrant_buffer->_getnetent_errno;
+# endif
+#endif
+ STATUS_NATIVE_SET(h_errno);
+ }
+#endif
EXTEND(SP, 4);
if (GIMME != G_ARRAY) {
PUSHs(sv = sv_newmortal());
if (nent) {
if (which == OP_GNBYNAME)
- sv_setiv(sv, (I32)nent->n_net);
+ sv_setiv(sv, (IV)nent->n_net);
else
sv_setpv(sv, nent->n_name);
}
}
if (nent) {
- PUSHs(sv = sv_mortalcopy(&sv_no));
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setpv(sv, nent->n_name);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- for (elem = nent->n_aliases; *elem; elem++) {
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ for (elem = nent->n_aliases; elem && *elem; elem++) {
sv_catpv(sv, *elem);
if (elem[1])
sv_catpvn(sv, " ", 1);
}
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)nent->n_addrtype);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)nent->n_net);
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setiv(sv, (IV)nent->n_addrtype);
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setiv(sv, (IV)nent->n_net);
}
RETURN;
#else
- DIE(no_sock_func, "getnetent");
+ DIE(aTHX_ PL_no_sock_func, "getnetent");
#endif
}
PP(pp_gpbyname)
{
-#ifdef HAS_SOCKET
- return pp_gprotoent(ARGS);
+#ifdef HAS_GETPROTOBYNAME
+ return pp_gprotoent();
#else
- DIE(no_sock_func, "getprotobyname");
+ DIE(aTHX_ PL_no_sock_func, "getprotobyname");
#endif
}
PP(pp_gpbynumber)
{
-#ifdef HAS_SOCKET
- return pp_gprotoent(ARGS);
+#ifdef HAS_GETPROTOBYNUMBER
+ return pp_gprotoent();
#else
- DIE(no_sock_func, "getprotobynumber");
+ DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
#endif
}
PP(pp_gprotoent)
{
+#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
dSP;
-#ifdef HAS_SOCKET
- I32 which = op->op_type;
+ I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
- struct protoent *getprotobyname();
- struct protoent *getprotobynumber();
- struct protoent *getprotoent();
+#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
+ struct protoent *getprotobyname(Netdb_name_t);
+ struct protoent *getprotobynumber(int);
+ struct protoent *getprotoent(void);
+#endif
struct protoent *pent;
+ STRLEN n_a;
- if (which == OP_GPBYNAME)
- pent = getprotobyname(POPp);
- else if (which == OP_GPBYNUMBER)
- pent = getprotobynumber(POPi);
+ if (which == OP_GPBYNAME) {
+#ifdef HAS_GETPROTOBYNAME
+ char* name = POPpbytex;
+ pent = PerlSock_getprotobyname(name);
+#else
+ DIE(aTHX_ PL_no_sock_func, "getprotobyname");
+#endif
+ }
+ else if (which == OP_GPBYNUMBER) {
+#ifdef HAS_GETPROTOBYNUMBER
+ int number = POPi;
+ pent = PerlSock_getprotobynumber(number);
+#else
+ DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
+#endif
+ }
else
- pent = getprotoent();
+#ifdef HAS_GETPROTOENT
+ pent = PerlSock_getprotoent();
+#else
+ DIE(aTHX_ PL_no_sock_func, "getprotoent");
+#endif
EXTEND(SP, 3);
if (GIMME != G_ARRAY) {
PUSHs(sv = sv_newmortal());
if (pent) {
if (which == OP_GPBYNAME)
- sv_setiv(sv, (I32)pent->p_proto);
+ sv_setiv(sv, (IV)pent->p_proto);
else
sv_setpv(sv, pent->p_name);
}
}
if (pent) {
- PUSHs(sv = sv_mortalcopy(&sv_no));
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setpv(sv, pent->p_name);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- for (elem = pent->p_aliases; *elem; elem++) {
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ for (elem = pent->p_aliases; elem && *elem; elem++) {
sv_catpv(sv, *elem);
if (elem[1])
sv_catpvn(sv, " ", 1);
}
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)pent->p_proto);
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setiv(sv, (IV)pent->p_proto);
}
RETURN;
#else
- DIE(no_sock_func, "getprotoent");
+ DIE(aTHX_ PL_no_sock_func, "getprotoent");
#endif
}
PP(pp_gsbyname)
{
-#ifdef HAS_SOCKET
- return pp_gservent(ARGS);
+#ifdef HAS_GETSERVBYNAME
+ return pp_gservent();
#else
- DIE(no_sock_func, "getservbyname");
+ DIE(aTHX_ PL_no_sock_func, "getservbyname");
#endif
}
PP(pp_gsbyport)
{
-#ifdef HAS_SOCKET
- return pp_gservent(ARGS);
+#ifdef HAS_GETSERVBYPORT
+ return pp_gservent();
#else
- DIE(no_sock_func, "getservbyport");
+ DIE(aTHX_ PL_no_sock_func, "getservbyport");
#endif
}
PP(pp_gservent)
{
+#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
dSP;
-#ifdef HAS_SOCKET
- I32 which = op->op_type;
+ I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
- struct servent *getservbyname();
- struct servent *getservbynumber();
- struct servent *getservent();
+#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
+ struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
+ struct servent *getservbyport(int, Netdb_name_t);
+ struct servent *getservent(void);
+#endif
struct servent *sent;
+ STRLEN n_a;
if (which == OP_GSBYNAME) {
- char *proto = POPp;
- char *name = POPp;
+#ifdef HAS_GETSERVBYNAME
+ char *proto = POPpbytex;
+ char *name = POPpbytex;
if (proto && !*proto)
proto = Nullch;
- sent = getservbyname(name, proto);
+ sent = PerlSock_getservbyname(name, proto);
+#else
+ DIE(aTHX_ PL_no_sock_func, "getservbyname");
+#endif
}
else if (which == OP_GSBYPORT) {
- char *proto = POPp;
- unsigned short port = POPu;
+#ifdef HAS_GETSERVBYPORT
+ char *proto = POPpbytex;
+ unsigned short port = (unsigned short)POPu;
+
+ if (proto && !*proto)
+ proto = Nullch;
#ifdef HAS_HTONS
- port = htons(port);
+ port = PerlSock_htons(port);
+#endif
+ sent = PerlSock_getservbyport(port, proto);
+#else
+ DIE(aTHX_ PL_no_sock_func, "getservbyport");
#endif
- sent = getservbyport(port, proto);
}
else
- sent = getservent();
+#ifdef HAS_GETSERVENT
+ sent = PerlSock_getservent();
+#else
+ DIE(aTHX_ PL_no_sock_func, "getservent");
+#endif
EXTEND(SP, 4);
if (GIMME != G_ARRAY) {
if (sent) {
if (which == OP_GSBYNAME) {
#ifdef HAS_NTOHS
- sv_setiv(sv, (I32)ntohs(sent->s_port));
+ sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
#else
- sv_setiv(sv, (I32)(sent->s_port));
+ sv_setiv(sv, (IV)(sent->s_port));
#endif
}
else
}
if (sent) {
- PUSHs(sv = sv_mortalcopy(&sv_no));
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setpv(sv, sent->s_name);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- for (elem = sent->s_aliases; *elem; elem++) {
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ for (elem = sent->s_aliases; elem && *elem; elem++) {
sv_catpv(sv, *elem);
if (elem[1])
sv_catpvn(sv, " ", 1);
}
- PUSHs(sv = sv_mortalcopy(&sv_no));
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
#ifdef HAS_NTOHS
- sv_setiv(sv, (I32)ntohs(sent->s_port));
+ sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
#else
- sv_setiv(sv, (I32)(sent->s_port));
+ sv_setiv(sv, (IV)(sent->s_port));
#endif
- PUSHs(sv = sv_mortalcopy(&sv_no));
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setpv(sv, sent->s_proto);
}
RETURN;
#else
- DIE(no_sock_func, "getservent");
+ DIE(aTHX_ PL_no_sock_func, "getservent");
#endif
}
PP(pp_shostent)
{
+#ifdef HAS_SETHOSTENT
dSP;
-#ifdef HAS_SOCKET
- sethostent(TOPi);
+ PerlSock_sethostent(TOPi);
RETSETYES;
#else
- DIE(no_sock_func, "sethostent");
+ DIE(aTHX_ PL_no_sock_func, "sethostent");
#endif
}
PP(pp_snetent)
{
+#ifdef HAS_SETNETENT
dSP;
-#ifdef HAS_SOCKET
- setnetent(TOPi);
+ PerlSock_setnetent(TOPi);
RETSETYES;
#else
- DIE(no_sock_func, "setnetent");
+ DIE(aTHX_ PL_no_sock_func, "setnetent");
#endif
}
PP(pp_sprotoent)
{
+#ifdef HAS_SETPROTOENT
dSP;
-#ifdef HAS_SOCKET
- setprotoent(TOPi);
+ PerlSock_setprotoent(TOPi);
RETSETYES;
#else
- DIE(no_sock_func, "setprotoent");
+ DIE(aTHX_ PL_no_sock_func, "setprotoent");
#endif
}
PP(pp_sservent)
{
+#ifdef HAS_SETSERVENT
dSP;
-#ifdef HAS_SOCKET
- setservent(TOPi);
+ PerlSock_setservent(TOPi);
RETSETYES;
#else
- DIE(no_sock_func, "setservent");
+ DIE(aTHX_ PL_no_sock_func, "setservent");
#endif
}
PP(pp_ehostent)
{
+#ifdef HAS_ENDHOSTENT
dSP;
-#ifdef HAS_SOCKET
- endhostent();
- EXTEND(sp,1);
+ PerlSock_endhostent();
+ EXTEND(SP,1);
RETPUSHYES;
#else
- DIE(no_sock_func, "endhostent");
+ DIE(aTHX_ PL_no_sock_func, "endhostent");
#endif
}
PP(pp_enetent)
{
+#ifdef HAS_ENDNETENT
dSP;
-#ifdef HAS_SOCKET
- endnetent();
- EXTEND(sp,1);
+ PerlSock_endnetent();
+ EXTEND(SP,1);
RETPUSHYES;
#else
- DIE(no_sock_func, "endnetent");
+ DIE(aTHX_ PL_no_sock_func, "endnetent");
#endif
}
PP(pp_eprotoent)
{
+#ifdef HAS_ENDPROTOENT
dSP;
-#ifdef HAS_SOCKET
- endprotoent();
- EXTEND(sp,1);
+ PerlSock_endprotoent();
+ EXTEND(SP,1);
RETPUSHYES;
#else
- DIE(no_sock_func, "endprotoent");
+ DIE(aTHX_ PL_no_sock_func, "endprotoent");
#endif
}
PP(pp_eservent)
{
+#ifdef HAS_ENDSERVENT
dSP;
-#ifdef HAS_SOCKET
- endservent();
- EXTEND(sp,1);
+ PerlSock_endservent();
+ EXTEND(SP,1);
RETPUSHYES;
#else
- DIE(no_sock_func, "endservent");
+ DIE(aTHX_ PL_no_sock_func, "endservent");
#endif
}
PP(pp_gpwnam)
{
#ifdef HAS_PASSWD
- return pp_gpwent(ARGS);
+ return pp_gpwent();
#else
- DIE(no_func, "getpwnam");
+ DIE(aTHX_ PL_no_func, "getpwnam");
#endif
}
PP(pp_gpwuid)
{
#ifdef HAS_PASSWD
- return pp_gpwent(ARGS);
+ return pp_gpwent();
#else
- DIE(no_func, "getpwuid");
+ DIE(aTHX_ PL_no_func, "getpwuid");
#endif
}
PP(pp_gpwent)
{
- dSP;
#ifdef HAS_PASSWD
- I32 which = op->op_type;
+ dSP;
+ I32 which = PL_op->op_type;
register SV *sv;
- struct passwd *pwent;
+ STRLEN n_a;
+ struct passwd *pwent = NULL;
+ /*
+ * We currently support only the SysV getsp* shadow password interface.
+ * The interface is declared in <shadow.h> and often one needs to link
+ * with -lsecurity or some such.
+ * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
+ * (and SCO?)
+ *
+ * AIX getpwnam() is clever enough to return the encrypted password
+ * only if the caller (euid?) is root.
+ *
+ * There are at least two other shadow password APIs. Many platforms
+ * seem to contain more than one interface for accessing the shadow
+ * password databases, possibly for compatibility reasons.
+ * The getsp*() is by far he simplest one, the other two interfaces
+ * are much more complicated, but also very similar to each other.
+ *
+ * <sys/types.h>
+ * <sys/security.h>
+ * <prot.h>
+ * struct pr_passwd *getprpw*();
+ * The password is in
+ * char getprpw*(...).ufld.fd_encrypt[]
+ * Mention HAS_GETPRPWNAM here so that Configure probes for it.
+ *
+ * <sys/types.h>
+ * <sys/security.h>
+ * <prot.h>
+ * struct es_passwd *getespw*();
+ * The password is in
+ * char *(getespw*(...).ufld.fd_encrypt)
+ * Mention HAS_GETESPWNAM here so that Configure probes for it.
+ *
+ * Mention I_PROT here so that Configure probes for it.
+ *
+ * In HP-UX for getprpw*() the manual page claims that one should include
+ * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
+ * if one includes <shadow.h> as that includes <hpsecurity.h>,
+ * and pp_sys.c already includes <shadow.h> if there is such.
+ *
+ * Note that <sys/security.h> is already probed for, but currently
+ * it is only included in special cases.
+ *
+ * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
+ * be preferred interface, even though also the getprpw*() interface
+ * is available) one needs to link with -lsecurity -ldb -laud -lm.
+ * One also needs to call set_auth_parameters() in main() before
+ * doing anything else, whether one is using getespw*() or getprpw*().
+ *
+ * Note that accessing the shadow databases can be magnitudes
+ * slower than accessing the standard databases.
+ *
+ * --jhi
+ */
- if (which == OP_GPWNAM)
- pwent = getpwnam(POPp);
- else if (which == OP_GPWUID)
- pwent = getpwuid(POPi);
- else
- pwent = (struct passwd *)getpwent();
+ switch (which) {
+ case OP_GPWNAM:
+ {
+ char* name = POPpbytex;
+ pwent = getpwnam(name);
+ }
+ break;
+ case OP_GPWUID:
+ {
+ Uid_t uid = POPi;
+ pwent = getpwuid(uid);
+ }
+ break;
+ 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
+ break;
+ }
EXTEND(SP, 10);
if (GIMME != G_ARRAY) {
PUSHs(sv = sv_newmortal());
if (pwent) {
if (which == OP_GPWNAM)
- sv_setiv(sv, (I32)pwent->pw_uid);
+# if Uid_t_sign <= 0
+ sv_setiv(sv, (IV)pwent->pw_uid);
+# else
+ sv_setuv(sv, (UV)pwent->pw_uid);
+# endif
else
sv_setpv(sv, pwent->pw_name);
}
}
if (pwent) {
- PUSHs(sv = sv_mortalcopy(&sv_no));
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setpv(sv, pwent->pw_name);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setpv(sv, pwent->pw_passwd);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)pwent->pw_uid);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)pwent->pw_gid);
- PUSHs(sv = sv_mortalcopy(&sv_no));
-#ifdef PWCHANGE
- sv_setiv(sv, (I32)pwent->pw_change);
-#else
-#ifdef PWQUOTA
- sv_setiv(sv, (I32)pwent->pw_quota);
-#else
-#ifdef PWAGE
+
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ SvPOK_off(sv);
+ /* If we have getspnam(), we try to dig up the shadow
+ * password. If we are underprivileged, the shadow
+ * interface will set the errno to EACCES or similar,
+ * and return a null pointer. If this happens, we will
+ * use the dummy password (usually "*" or "x") from the
+ * standard password database.
+ *
+ * In theory we could skip the shadow call completely
+ * if euid != 0 but in practice we cannot know which
+ * security measures are guarding the shadow databases
+ * on a random platform.
+ *
+ * Resist the urge to use additional shadow interfaces.
+ * Divert the urge to writing an extension instead.
+ *
+ * --jhi */
+# ifdef HAS_GETSPNAM
+ {
+ struct spwd *spwent;
+ int saverrno; /* Save and restore errno so that
+ * underprivileged attempts seem
+ * to have never made the unsccessful
+ * attempt to retrieve the shadow password. */
+
+ saverrno = errno;
+ spwent = getspnam(pwent->pw_name);
+ errno = saverrno;
+ if (spwent && spwent->sp_pwdp)
+ sv_setpv(sv, spwent->sp_pwdp);
+ }
+# endif
+# ifdef PWPASSWD
+ if (!SvPOK(sv)) /* Use the standard password, then. */
+ sv_setpv(sv, pwent->pw_passwd);
+# endif
+
+# ifndef INCOMPLETE_TAINTS
+ /* passwd is tainted because user himself can diddle with it.
+ * admittedly not much and in a very limited way, but nevertheless. */
+ SvTAINTED_on(sv);
+# endif
+
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+# if Uid_t_sign <= 0
+ sv_setiv(sv, (IV)pwent->pw_uid);
+# else
+ sv_setuv(sv, (UV)pwent->pw_uid);
+# endif
+
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+# if Uid_t_sign <= 0
+ sv_setiv(sv, (IV)pwent->pw_gid);
+# else
+ sv_setuv(sv, (UV)pwent->pw_gid);
+# endif
+ /* pw_change, pw_quota, and pw_age are mutually exclusive--
+ * because of the poor interface of the Perl getpw*(),
+ * not because there's some standard/convention saying so.
+ * A better interface would have been to return a hash,
+ * but we are accursed by our history, alas. --jhi. */
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+# ifdef PWCHANGE
+ sv_setiv(sv, (IV)pwent->pw_change);
+# else
+# ifdef PWQUOTA
+ sv_setiv(sv, (IV)pwent->pw_quota);
+# else
+# ifdef PWAGE
sv_setpv(sv, pwent->pw_age);
-#endif
-#endif
-#endif
- PUSHs(sv = sv_mortalcopy(&sv_no));
-#ifdef PWCLASS
+# endif
+# endif
+# endif
+
+ /* pw_class and pw_comment are mutually exclusive--.
+ * see the above note for pw_change, pw_quota, and pw_age. */
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+# ifdef PWCLASS
sv_setpv(sv, pwent->pw_class);
-#else
-#ifdef PWCOMMENT
+# else
+# ifdef PWCOMMENT
sv_setpv(sv, pwent->pw_comment);
-#endif
-#endif
- PUSHs(sv = sv_mortalcopy(&sv_no));
+# endif
+# endif
+
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+# ifdef PWGECOS
sv_setpv(sv, pwent->pw_gecos);
- PUSHs(sv = sv_mortalcopy(&sv_no));
+# endif
+# ifndef INCOMPLETE_TAINTS
+ /* pw_gecos is tainted because user himself can diddle with it. */
+ SvTAINTED_on(sv);
+# endif
+
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setpv(sv, pwent->pw_dir);
- PUSHs(sv = sv_mortalcopy(&sv_no));
+
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setpv(sv, pwent->pw_shell);
-#ifdef PWEXPIRE
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)pwent->pw_expire);
-#endif
+# ifndef INCOMPLETE_TAINTS
+ /* pw_shell is tainted because user himself can diddle with it. */
+ SvTAINTED_on(sv);
+# endif
+
+# ifdef PWEXPIRE
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setiv(sv, (IV)pwent->pw_expire);
+# endif
}
RETURN;
#else
- DIE(no_func, "getpwent");
+ DIE(aTHX_ PL_no_func, "getpwent");
#endif
}
PP(pp_spwent)
{
+#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
dSP;
-#ifdef HAS_PASSWD
setpwent();
RETPUSHYES;
#else
- DIE(no_func, "setpwent");
+ DIE(aTHX_ PL_no_func, "setpwent");
#endif
}
PP(pp_epwent)
{
+#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
dSP;
-#ifdef HAS_PASSWD
endpwent();
RETPUSHYES;
#else
- DIE(no_func, "endpwent");
+ DIE(aTHX_ PL_no_func, "endpwent");
#endif
}
PP(pp_ggrnam)
{
#ifdef HAS_GROUP
- return pp_ggrent(ARGS);
+ return pp_ggrent();
#else
- DIE(no_func, "getgrnam");
+ DIE(aTHX_ PL_no_func, "getgrnam");
#endif
}
PP(pp_ggrgid)
{
#ifdef HAS_GROUP
- return pp_ggrent(ARGS);
+ return pp_ggrent();
#else
- DIE(no_func, "getgrgid");
+ DIE(aTHX_ PL_no_func, "getgrgid");
#endif
}
PP(pp_ggrent)
{
- dSP;
#ifdef HAS_GROUP
- I32 which = op->op_type;
+ dSP;
+ I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
struct group *grent;
+ STRLEN n_a;
- if (which == OP_GGRNAM)
- grent = (struct group *)getgrnam(POPp);
- else if (which == OP_GGRGID)
- grent = (struct group *)getgrgid(POPi);
+ if (which == OP_GGRNAM) {
+ char* name = POPpbytex;
+ grent = (struct group *)getgrnam(name);
+ }
+ else if (which == OP_GGRGID) {
+ Gid_t gid = POPi;
+ grent = (struct group *)getgrgid(gid);
+ }
else
+#ifdef HAS_GETGRENT
grent = (struct group *)getgrent();
+#else
+ DIE(aTHX_ PL_no_func, "getgrent");
+#endif
EXTEND(SP, 4);
if (GIMME != G_ARRAY) {
PUSHs(sv = sv_newmortal());
if (grent) {
if (which == OP_GGRNAM)
- sv_setiv(sv, (I32)grent->gr_gid);
+ sv_setiv(sv, (IV)grent->gr_gid);
else
sv_setpv(sv, grent->gr_name);
}
}
if (grent) {
- PUSHs(sv = sv_mortalcopy(&sv_no));
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setpv(sv, grent->gr_name);
- PUSHs(sv = sv_mortalcopy(&sv_no));
+
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+#ifdef GRPASSWD
sv_setpv(sv, grent->gr_passwd);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)grent->gr_gid);
- PUSHs(sv = sv_mortalcopy(&sv_no));
- for (elem = grent->gr_mem; *elem; elem++) {
+#endif
+
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setiv(sv, (IV)grent->gr_gid);
+
+#if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ /* In UNICOS/mk (_CRAYMPP) the multithreading
+ * versions (getgrnam_r, getgrgid_r)
+ * seem to return an illegal pointer
+ * as the group members list, gr_mem.
+ * getgrent() doesn't even have a _r version
+ * but the gr_mem is poisonous anyway.
+ * So yes, you cannot get the list of group
+ * members if building multithreaded in UNICOS/mk. */
+ for (elem = grent->gr_mem; elem && *elem; elem++) {
sv_catpv(sv, *elem);
if (elem[1])
sv_catpvn(sv, " ", 1);
}
+#endif
}
RETURN;
#else
- DIE(no_func, "getgrent");
+ DIE(aTHX_ PL_no_func, "getgrent");
#endif
}
PP(pp_sgrent)
{
+#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
dSP;
-#ifdef HAS_GROUP
setgrent();
RETPUSHYES;
#else
- DIE(no_func, "setgrent");
+ DIE(aTHX_ PL_no_func, "setgrent");
#endif
}
PP(pp_egrent)
{
+#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
dSP;
-#ifdef HAS_GROUP
endgrent();
RETPUSHYES;
#else
- DIE(no_func, "endgrent");
+ DIE(aTHX_ PL_no_func, "endgrent");
#endif
}
PP(pp_getlogin)
{
- dSP; dTARGET;
#ifdef HAS_GETLOGIN
+ dSP; dTARGET;
char *tmps;
EXTEND(SP, 1);
- if (!(tmps = getlogin()))
+ if (!(tmps = PerlProc_getlogin()))
RETPUSHUNDEF;
PUSHp(tmps, strlen(tmps));
RETURN;
#else
- DIE(no_func, "getlogin");
+ DIE(aTHX_ PL_no_func, "getlogin");
#endif
}
unsigned long a[20];
register I32 i = 0;
I32 retval = -1;
- MAGIC *mg;
+ STRLEN n_a;
- if (tainting) {
+ if (PL_tainting) {
while (++MARK <= SP) {
if (SvTAINTED(*MARK)) {
TAINT;
while (++MARK <= SP) {
if (SvNIOK(*MARK) || !i)
a[i++] = SvIV(*MARK);
- else if (*MARK == &sv_undef)
+ else if (*MARK == &PL_sv_undef)
a[i++] = 0;
- else
- a[i++] = (unsigned long)SvPV_force(*MARK, na);
+ else
+ a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
if (i > 15)
break;
}
switch (items) {
default:
- DIE("Too many args to syscall");
+ DIE(aTHX_ "Too many args to syscall");
case 0:
- DIE("Too few args to syscall");
+ DIE(aTHX_ "Too few args to syscall");
case 1:
retval = syscall(a[0]);
break;
PUSHi(retval);
RETURN;
#else
- DIE(no_func, "syscall");
+ DIE(aTHX_ PL_no_func, "syscall");
#endif
}
#ifdef FCNTL_EMULATE_FLOCK
-
+
/* XXX Emulate flock() with fcntl().
What's really needed is a good file locking module.
*/
static int
-fcntl_emulate_flock(fd, operation)
-int fd;
-int operation;
+fcntl_emulate_flock(int fd, int operation)
{
struct flock flock;
-
+
switch (operation & ~LOCK_NB) {
case LOCK_SH:
flock.l_type = F_RDLCK;
return -1;
}
flock.l_whence = SEEK_SET;
- flock.l_start = flock.l_len = 0L;
-
+ flock.l_start = flock.l_len = (Off_t)0;
+
return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
}
# endif
static int
-lockf_emulate_flock (fd, operation)
-int fd;
-int operation;
+lockf_emulate_flock(int fd, int operation)
{
int i;
+ int save_errno;
+ Off_t pos;
+
+ /* flock locks entire file so for lockf we need to do the same */
+ save_errno = errno;
+ pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
+ if (pos > 0) /* is seekable and needs to be repositioned */
+ if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
+ pos = -1; /* seek failed, so don't seek back afterwards */
+ errno = save_errno;
+
switch (operation) {
/* LOCK_SH - get a shared lock */
errno = EINVAL;
break;
}
+
+ if (pos > 0) /* need to restore position of the handle */
+ PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
+
return (i);
}