/* pp_sys.c
*
- * Copyright (c) 1991-1997, Larry Wall
+ * Copyright (c) 1991-2000, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
#include "EXTERN.h"
+#define PERL_IN_PP_SYS_C
#include "perl.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. --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
+
/* XXX If this causes problems, set i_unistd=undef in the hint file. */
#ifdef I_UNISTD
# include <unistd.h>
#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
# include <sys/socket.h>
+# if defined(USE_SOCKS) && defined(I_SOCKS)
+# include <socks.h>
+# endif
# ifdef I_NETDB
# include <netdb.h>
# endif
compiling multithreaded and singlethreaded ($ccflags et al).
HOST_NOT_FOUND is typically defined in <netdb.h>.
*/
-#if defined(HOST_NOT_FOUND) && !defined(h_errno)
+#if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
extern int h_errno;
#endif
# ifdef I_PWD
# include <pwd.h>
# else
- struct passwd *getpwnam _((char *));
- struct passwd *getpwuid _((Uid_t));
+ struct passwd *getpwnam (char *);
+ struct passwd *getpwuid (Uid_t);
# endif
# ifdef HAS_GETPWENT
- struct passwd *getpwent _((void));
+ struct passwd *getpwent (void);
# endif
#endif
# 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
# ifdef HAS_GETGRENT
- struct group *getgrent _((void));
+ struct group *getgrent (void);
# endif
#endif
# include <utime.h>
# endif
#endif
-#ifdef I_FCNTL
-#include <fcntl.h>
-#endif
-#ifdef I_SYS_FILE
-#include <sys/file.h>
-#endif
/* Put this after #includes because fork and vfork prototypes may conflict. */
#ifndef HAS_VFORK
# define vfork fork
#endif
-/* Put this after #includes because <unistd.h> defines _XOPEN_*. */
-#ifndef Sock_size_t
-# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
-# define Sock_size_t Size_t
-# else
-# define Sock_size_t int
-# endif
-#endif
-
-#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
-static int dooneliner _((char *cmd, char *filename));
-#endif
-
#ifdef HAS_CHSIZE
# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
# undef my_chsize
# 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
# include <sys/access.h>
#endif
+#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
+# define FD_CLOEXEC 1 /* NeXT needs this */
+#endif
+
#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
#undef PERL_EFF_ACCESS_W_OK
#undef PERL_EFF_ACCESS_X_OK
# if defined(I_SYS_SECURITY)
# include <sys/security.h>
# endif
- /* XXX Configure test needed for eaccess */
# ifdef ACC_SELF
/* HP SecureWare */
# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
|| defined(HAS_SETREGID) || defined(HAS_SETRESGID))
/* The Hard Way. */
STATIC int
-emulate_eaccess (const char* path, int mode) {
+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;
- MUTEX_LOCK(&PL_cred_mutex);
+ LOCK_CRED_MUTEX;
#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
- croak("switching effective uid is not implemented");
+ Perl_croak(aTHX_ "switching effective uid is not implemented");
#else
#ifdef HAS_SETREUID
if (setreuid(euid, ruid))
if (setresuid(euid, ruid, (Uid_t)-1))
#endif
#endif
- croak("entering effective uid failed");
+ Perl_croak(aTHX_ "entering effective uid failed");
#endif
#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
- croak("switching effective gid is not implemented");
+ Perl_croak(aTHX_ "switching effective gid is not implemented");
#else
#ifdef HAS_SETREGID
if (setregid(egid, rgid))
if (setresgid(egid, rgid, (Gid_t)-1))
#endif
#endif
- croak("entering effective gid failed");
+ Perl_croak(aTHX_ "entering effective gid failed");
#endif
res = access(path, mode);
if (setresuid(ruid, euid, (Uid_t)-1))
#endif
#endif
- croak("leaving effective uid failed");
+ Perl_croak(aTHX_ "leaving effective uid failed");
#ifdef HAS_SETREGID
if (setregid(rgid, egid))
if (setresgid(rgid, egid, (Gid_t)-1))
#endif
#endif
- croak("leaving effective gid failed");
- MUTEX_UNLOCK(&PL_cred_mutex);
+ Perl_croak(aTHX_ "leaving effective gid failed");
+ UNLOCK_CRED_MUTEX;
return res;
}
#if !defined(PERL_EFF_ACCESS_R_OK)
STATIC int
-emulate_eaccess (const char* path, int mode) {
- croak("switching effective uid is not implemented");
+S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
+{
+ Perl_croak(aTHX_ "switching effective uid is not implemented");
/*NOTREACHED*/
return -1;
}
STRLEN n_a;
char *tmps = POPpx;
I32 gimme = GIMME_V;
+ char *mode = "r";
TAINT_PROPER("``");
- fp = PerlProc_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) {
if (gimme == G_VOID) {
char tmpbuf[256];
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;
#ifndef VMS
PL_last_in_gv = (GV*)*PL_stack_sp--;
SAVESPTR(PL_rs); /* This is not permanent, either. */
- PL_rs = sv_2mortal(newSVpv("", 1));
+ PL_rs = sv_2mortal(newSVpvn("\000", 1));
#ifndef DOSISH
#ifndef CSH
*SvPVX(PL_rs) = '\n';
PP(pp_rcatline)
{
- PL_last_in_gv = cGVOP->op_gv;
+ PL_last_in_gv = cGVOP_gv;
return do_readline();
}
PP(pp_warn)
{
djSP; dMARK;
+ SV *tmpsv;
char *tmps;
- STRLEN n_a;
+ STRLEN len;
if (SP - MARK != 1) {
dTARGET;
do_join(TARG, &PL_sv_no, MARK, SP);
- tmps = SvPV(TARG, n_a);
+ tmpsv = TARG;
SP = MARK + 1;
}
else {
- tmps = SvPV(TOPs, n_a);
+ tmpsv = TOPs;
}
- if (!tmps || !*tmps) {
+ 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, n_a);
+ 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;
}
{
djSP; dMARK;
char *tmps;
- SV *tmpsv = Nullsv;
- char *pat = "%s";
- STRLEN n_a;
+ SV *tmpsv;
+ STRLEN len;
+ bool multiarg = 0;
if (SP - MARK != 1) {
dTARGET;
do_join(TARG, &PL_sv_no, MARK, SP);
- tmps = SvPV(TARG, n_a);
+ tmpsv = TARG;
+ tmps = SvPV(tmpsv, len);
+ multiarg = 1;
SP = MARK + 1;
}
else {
tmpsv = TOPs;
- tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, n_a);
+ tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
}
- if (!tmps || !*tmps) {
+ if (!tmps || !len) {
SV *error = ERRSV;
(void)SvUPGRADE(error, SVt_PV);
- if(tmpsv ? SvROK(tmpsv) : SvROK(error)) {
- if(tmpsv)
+ if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
+ if (!multiarg)
SvSetSV(error,tmpsv);
- else if(sv_isobject(error)) {
+ else if (sv_isobject(error)) {
HV *stash = SvSTASH(SvRV(error));
GV *gv = gv_fetchmethod(stash, "PROPAGATE");
if (gv) {
- SV *file = sv_2mortal(newSVsv(GvSV(PL_curcop->cop_filegv)));
- SV *line = sv_2mortal(newSViv(PL_curcop->cop_line));
+ 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;
- perl_call_sv((SV*)GvCV(gv),
- G_SCALAR|G_EVAL|G_KEEPERR);
+ call_sv((SV*)GvCV(gv),
+ G_SCALAR|G_EVAL|G_KEEPERR);
sv_setsv(error,*PL_stack_sp--);
}
}
- pat = Nullch;
+ DIE(aTHX_ Nullch);
}
else {
if (SvPOK(error) && SvCUR(error))
sv_catpv(error, "\t...propagated");
- tmps = SvPV(error, n_a);
+ tmpsv = error;
+ tmps = SvPV(tmpsv, len);
}
}
- if (!tmps || !*tmps)
- tmps = "Died";
- DIE(pat, tmps);
+ if (!tmps || !len)
+ tmpsv = sv_2mortal(newSVpvn("Died", 4));
+
+ DIE(aTHX_ "%"SVf, tmpsv);
}
/* I/O. */
djSP; dTARGET;
GV *gv;
SV *sv;
+ SV *name;
+ I32 have_name = 0;
char *tmps;
STRLEN len;
+ MAGIC *mg;
+ if (MAXARG > 2) {
+ name = POPs;
+ have_name = 1;
+ }
if (MAXARG > 1)
sv = POPs;
if (!isGV(TOPs))
- DIE(PL_no_usym, "filehandle");
+ DIE(aTHX_ PL_no_usym, "filehandle");
if (MAXARG <= 1)
sv = GvSV(TOPs);
gv = (GV*)POPs;
if (!isGV(gv))
- DIE(PL_no_usym, "filehandle");
+ DIE(aTHX_ PL_no_usym, "filehandle");
if (GvIOp(gv))
IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
+
+ if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)gv, mg));
+ XPUSHs(sv);
+ if (have_name)
+ XPUSHs(name);
+ PUTBACK;
+ ENTER;
+ call_method("OPEN", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
+
tmps = SvPV(sv, len);
- if (do_open(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp))
+ if (do_open9(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, name, have_name))
PUSHi( (I32)PL_forkprocess );
else if (PL_forkprocess == 0) /* we are a new child */
PUSHi(0);
else
gv = (GV*)POPs;
- if (mg = SvTIED_mg((SV*)gv, 'q')) {
+ if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
PUTBACK;
ENTER;
- perl_call_method("CLOSE", G_SCALAR);
+ call_method("CLOSE", G_SCALAR);
LEAVE;
SPAGAIN;
RETURN;
goto badexit;
if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
- DIE(PL_no_usym, "filehandle");
+ DIE(aTHX_ PL_no_usym, "filehandle");
rstio = GvIOn(rgv);
wstio = GvIOn(wgv);
badexit:
RETPUSHUNDEF;
#else
- DIE(PL_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 && (mg = SvTIED_mg((SV*)gv, 'q'))) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)gv, mg));
+ PUTBACK;
+ ENTER;
+ call_method("FILENO", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
+
if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
RETPUSHUNDEF;
PUSHi(PerlIO_fileno(fp));
PP(pp_umask)
{
djSP; dTARGET;
- int anum;
+ Mode_t anum;
#ifdef HAS_UMASK
if (MAXARG < 1) {
* 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("umask not implemented");
+ 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;
+ gv = (GV*)POPs;
+
+ if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)gv, 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 (do_binmode(fp,IoTYPE(io),TRUE))
+ if (do_binmode(fp,IoTYPE(io),mode_from_discipline(discp)))
RETPUSHYES;
else
RETPUSHUNDEF;
}
-
PP(pp_tie)
{
djSP;
while (items--)
PUSHs(*MARK++);
PUTBACK;
- perl_call_method(methname, G_SCALAR);
+ call_method(methname, G_SCALAR);
}
else {
- /* Not clear why we don't call perl_call_method here too.
+ /* 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("Can't locate object method \"%s\" via package \"%s\"",
+ DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"",
methname, SvPV(*MARK,n_a));
}
ENTER;
while (items--)
PUSHs(*MARK++);
PUTBACK;
- perl_call_sv((SV*)GvCV(gv), G_SCALAR);
+ call_sv((SV*)GvCV(gv), G_SCALAR);
}
SPAGAIN;
if (ckWARN(WARN_UNTIE)) {
MAGIC * mg ;
- if (mg = SvTIED_mg(sv, how)) {
+ if ((mg = SvTIED_mg(sv, how))) {
if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
- warner(WARN_UNTIE,
- "untie attempted while %lu inner references still exist",
- (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
+ Perl_warner(aTHX_ WARN_UNTIE,
+ "untie attempted while %"UVuf" inner references still exist",
+ (UV)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
}
}
char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
MAGIC *mg;
- if (mg = SvTIED_mg(sv, how)) {
+ if ((mg = SvTIED_mg(sv, how))) {
SV *osv = SvTIED_obj(sv, mg);
if (osv == mg->mg_obj)
osv = sv_mortalcopy(osv);
stash = gv_stashsv(sv, FALSE);
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")))
- DIE("No dbm on this machine");
+ DIE(aTHX_ "No dbm on this machine");
}
ENTER;
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);
PUTBACK;
- perl_call_sv((SV*)GvCV(gv), G_SCALAR);
+ call_sv((SV*)GvCV(gv), G_SCALAR);
SPAGAIN;
if (!sv_isobject(TOPs)) {
PUSHMARK(SP);
PUSHs(sv);
PUSHs(left);
- PUSHs(sv_2mortal(newSViv(O_RDONLY)));
+ PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
PUSHs(right);
PUTBACK;
- perl_call_sv((SV*)GvCV(gv), G_SCALAR);
+ call_sv((SV*)GvCV(gv), G_SCALAR);
SPAGAIN;
}
PP(pp_dbmclose)
{
- return pp_untie(ARGS);
+ return pp_untie();
}
PP(pp_sselect)
register I32 j;
register char *s;
register SV *sv;
- double value;
+ NV value;
I32 maxlen = 0;
I32 nfound;
struct timeval timebuf;
/* If SELECT_MIN_BITS is greater than one we most probably will want
* to align the sizes with SELECT_MIN_BITS/8 because for example
* in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
- * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
+ * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
* on (sets/tests/clears bits) is 32 bits. */
growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
# else
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
PUSHi(nfound);
if (GIMME == G_ARRAY && tbuf) {
- value = (double)(timebuf.tv_sec) +
- (double)(timebuf.tv_usec) / 1000000.0;
+ 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)
+Perl_setdefout(pTHX_ GV *gv)
{
dTHR;
if (gv)
GV *gv;
MAGIC *mg;
- if (MAXARG <= 0)
+ if (MAXARG == 0)
gv = PL_stdingv;
else
gv = (GV*)POPs;
- if (!gv)
- gv = PL_argvgv;
- if (mg = SvTIED_mg((SV*)gv, 'q')) {
+ if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
I32 gimme = GIMME_V;
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)gv, mg));
PUTBACK;
ENTER;
- perl_call_method("GETC", gimme);
+ call_method("GETC", gimme);
LEAVE;
SPAGAIN;
if (gimme == G_SCALAR)
PP(pp_read)
{
- return pp_sysread(ARGS);
+ return pp_sysread();
}
STATIC OP *
-doform(CV *cv, GV *gv, OP *retop)
+S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
{
dTHR;
register PERL_CONTEXT *cx;
SAVETMPS;
push_return(retop);
- PUSHBLOCK(cx, CXt_SUB, PL_stack_sp);
+ PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
PUSHFORMAT(cx);
- SAVESPTR(PL_curpad);
+ SAVEVPTR(PL_curpad);
PL_curpad = AvARRAY((AV*)svp[1]);
setdefout(gv); /* locally select filehandle so $% et al work */
if (fgv) {
SV *tmpsv = sv_newmortal();
gv_efullname3(tmpsv, fgv, Nullch);
- DIE("Undefined format \"%s\" called",SvPVX(tmpsv));
+ DIE(aTHX_ "Undefined format \"%s\" called",SvPVX(tmpsv));
}
- DIE("Not a format reference");
+ DIE(aTHX_ "Not a format reference");
}
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
if (!IoTOP_NAME(io)) {
if (!IoFMT_NAME(io))
IoFMT_NAME(io) = savepv(GvNAME(gv));
- topname = sv_2mortal(newSVpvf("%s_TOP", IoFMT_NAME(io)));
+ 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))
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));
+ DIE(aTHX_ "Undefined top format \"%s\" called",SvPVX(tmpsv));
}
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
fp = IoOFP(io);
if (!fp) {
if (ckWARN2(WARN_CLOSED,WARN_IO)) {
- if (IoIFP(io))
- warner(WARN_IO, "Filehandle only opened for input");
+ if (IoIFP(io)) {
+ SV* sv = sv_newmortal();
+ gv_efullname3(sv, gv, Nullch);
+ Perl_warner(aTHX_ WARN_IO,
+ "Filehandle %s opened only for input",
+ SvPV_nolen(sv));
+ }
else if (ckWARN(WARN_CLOSED))
- warner(WARN_CLOSED, "Write on closed filehandle");
+ report_closed_fh(gv, io, "write", "filehandle");
}
PUSHs(&PL_sv_no);
}
else {
if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
if (ckWARN(WARN_IO))
- warner(WARN_IO, "page overflow");
+ Perl_warner(aTHX_ WARN_IO, "page overflow");
}
if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
PerlIO_error(fp))
else
gv = PL_defoutgv;
- if (mg = SvTIED_mg((SV*)gv, 'q')) {
+ if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
if (MARK == ORIGMARK) {
MEXTEND(SP, 1);
++MARK;
*MARK = SvTIED_obj((SV*)gv, mg);
PUTBACK;
ENTER;
- perl_call_method("PRINTF", G_SCALAR);
+ call_method("PRINTF", G_SCALAR);
LEAVE;
SPAGAIN;
MARK = ORIGMARK + 1;
sv = NEWSV(0,0);
if (!(io = GvIO(gv))) {
if (ckWARN(WARN_UNOPENED)) {
- gv_fullname3(sv, gv, Nullch);
- warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a));
+ gv_efullname3(sv, gv, Nullch);
+ Perl_warner(aTHX_ WARN_UNOPENED,
+ "Filehandle %s never opened", SvPV(sv,n_a));
}
SETERRNO(EBADF,RMS$_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
if (ckWARN2(WARN_CLOSED,WARN_IO)) {
- gv_fullname3(sv, gv, Nullch);
- if (IoIFP(io))
- warner(WARN_IO, "Filehandle %s opened only for input",
- SvPV(sv,n_a));
+ if (IoIFP(io)) {
+ gv_efullname3(sv, gv, Nullch);
+ Perl_warner(aTHX_ WARN_IO,
+ "Filehandle %s opened only for input",
+ SvPV(sv,n_a));
+ }
else if (ckWARN(WARN_CLOSED))
- warner(WARN_CLOSED, "printf on closed filehandle %s",
- SvPV(sv,n_a));
+ report_closed_fh(gv, io, "printf", "filehandle");
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
}
else {
-#ifdef USE_LOCALE_NUMERIC
- if (PL_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;
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;
PUSHMARK(MARK-1);
*MARK = SvTIED_obj((SV*)gv, mg);
ENTER;
- perl_call_method("READ", G_SCALAR);
+ call_method("READ", G_SCALAR);
LEAVE;
SPAGAIN;
sv = POPs;
buffer = SvPV_force(bufsv, blen);
length = SvIVx(*++MARK);
if (length < 0)
- DIE("Negative length");
+ DIE(aTHX_ "Negative length");
SETERRNO(0,0);
if (MARK < SP)
offset = SvIVx(*++MARK);
#else
bufsize = sizeof namebuf;
#endif
+#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
+ if (bufsize >= 256)
+ bufsize = 255;
+#endif
+#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
+ if (bufsize >= 256)
+ bufsize = 255;
+#endif
buffer = SvGROW(bufsv, length+1);
/* 'offset' means 'flags' here */
length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
}
#else
if (PL_op->op_type == OP_RECV)
- DIE(PL_no_sock_func, "recv");
+ DIE(aTHX_ PL_no_sock_func, "recv");
#endif
if (offset < 0) {
if (-offset > blen)
- DIE("Offset outside string");
+ DIE(aTHX_ "Offset outside string");
offset += blen;
}
bufsize = SvCUR(bufsv);
if (length == 0 && PerlIO_error(IoIFP(io)))
length = -1;
}
- if (length < 0)
+ if (length < 0) {
+ if ((IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout()
+ || IoIFP(io) == PerlIO_stderr()) && ckWARN(WARN_IO))
+ {
+ SV* sv = sv_newmortal();
+ gv_efullname3(sv, gv, Nullch);
+ Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
+ SvPV_nolen(sv));
+ }
goto say_undef;
+ }
SvCUR_set(bufsv, length+offset);
*SvEND(bufsv) = '\0';
(void)SvPOK_only(bufsv);
PUSHs(sv);
PUTBACK;
}
- return pp_send(ARGS);
+ return pp_send();
}
PP(pp_send)
djSP; dMARK; dORIGMARK; dTARGET;
GV *gv;
IO *io;
- int offset;
SV *bufsv;
char *buffer;
- int length;
+ Size_t length;
+ SSize_t retval;
+ IV offset;
STRLEN blen;
MAGIC *mg;
PUSHMARK(MARK-1);
*MARK = SvTIED_obj((SV*)gv, mg);
ENTER;
- perl_call_method("WRITE", G_SCALAR);
+ call_method("WRITE", G_SCALAR);
LEAVE;
SPAGAIN;
sv = POPs;
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;
+ retval = -1;
if (ckWARN(WARN_CLOSED)) {
if (PL_op->op_type == OP_SYSWRITE)
- warner(WARN_CLOSED, "Syswrite on closed filehandle");
+ report_closed_fh(gv, io, "syswrite", "filehandle");
else
- warner(WARN_CLOSED, "Send on closed socket");
+ report_closed_fh(gv, io, "send", "socket");
}
}
else if (PL_op->op_type == OP_SYSWRITE) {
offset = SvIVx(*++MARK);
if (offset < 0) {
if (-offset > blen)
- DIE("Offset outside string");
+ DIE(aTHX_ "Offset outside string");
offset += blen;
} else if (offset >= blen && blen > 0)
- DIE("Offset outside string");
+ DIE(aTHX_ "Offset outside string");
} else
offset = 0;
if (length > blen - offset)
length = blen - offset;
#ifdef PERL_SOCK_SYSWRITE_IS_SEND
if (IoTYPE(io) == 's') {
- length = PerlSock_send(PerlIO_fileno(IoIFP(io)),
+ retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
buffer+offset, length, 0);
}
else
#endif
{
- length = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
+ /* See the note at doio.c:do_print about filesize limits. --jhi */
+ retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
buffer+offset, length);
}
}
char *sockbuf;
STRLEN mlen;
sockbuf = SvPVx(*++MARK, mlen);
- length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
- (struct sockaddr *)sockbuf, mlen);
+ retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
+ length, (struct sockaddr *)sockbuf, mlen);
}
else
- length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
+ retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
#else
else
- DIE(PL_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 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)
{
djSP;
GV *gv;
+ MAGIC *mg;
- if (MAXARG <= 0)
- gv = PL_last_in_gv;
+ if (MAXARG == 0) {
+ if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
+ IO *io;
+ gv = PL_last_in_gv = 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 = PL_last_in_gv = (GV*)POPs;
+ gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
+
+ if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)gv, mg));
+ PUTBACK;
+ ENTER;
+ call_method("EOF", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
+
PUSHs(boolSV(!gv || do_eof(gv)));
RETURN;
}
PP(pp_tell)
{
djSP; dTARGET;
- GV *gv;
+ GV *gv;
+ MAGIC *mg;
- if (MAXARG <= 0)
+ if (MAXARG == 0)
gv = PL_last_in_gv;
else
gv = PL_last_in_gv = (GV*)POPs;
+
+ if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)gv, mg));
+ PUTBACK;
+ ENTER;
+ call_method("TELL", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
+
+#if LSEEKSIZE > IVSIZE
+ PUSHn( do_tell(gv) );
+#else
PUSHi( do_tell(gv) );
+#endif
RETURN;
}
PP(pp_seek)
{
- return pp_sysseek(ARGS);
+ return pp_sysseek();
}
PP(pp_sysseek)
djSP;
GV *gv;
int whence = POPi;
- Off_t 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 && (mg = SvTIED_mg((SV*)gv, 'q'))) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)gv, mg));
+#if LSEEKSIZE > IVSIZE
+ XPUSHs(sv_2mortal(newSVnv((NV) offset)));
+#else
+ XPUSHs(sv_2mortal(newSViv(offset)));
+#endif
+ XPUSHs(sv_2mortal(newSViv(whence)));
+ PUTBACK;
+ ENTER;
+ call_method("SEEK", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
+
if (PL_op->op_type == OP_SEEK)
PUSHs(boolSV(do_seek(gv, offset, whence)));
else {
- Off_t n = do_sysseek(gv, offset, whence);
- PUSHs((n < 0) ? &PL_sv_undef
- : sv_2mortal(n ? newSViv((IV)n)
- : newSVpv(zero_but_true, ZBTLEN)));
+ 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)
{
djSP;
- Off_t len = (Off_t)POPn;
+ /* 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;
int result = 1;
GV *tmpgv;
STRLEN n_a;
+#if Size_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 (PL_op->op_flags & OPf_SPECIAL) {
tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
do_ftruncate:
TAINT_PROPER("truncate");
- if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
+ if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
+ result = 0;
+ else {
+ PerlIO_flush(IoIFP(GvIOp(tmpgv)));
#ifdef HAS_TRUNCATE
- ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+ if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
#else
- my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+ if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
#endif
- result = 0;
+ result = 0;
+ }
}
else {
SV *sv = POPs;
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)
}
else {
retval = SvIV(argsv);
- s = (char*)retval; /* ouch */
+ s = INT2PTR(char*,retval); /* ouch */
}
TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
#ifdef HAS_IOCTL
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
retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
#endif
#else
- DIE("fcntl is not implemented");
+ DIE(aTHX_ "fcntl is not implemented");
#endif
if (SvPOK(argsv)) {
if (s[SvCUR(argsv)] != 17)
- DIE("Possible memory corruption: %s overflowed 3rd argument",
+ DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
PL_op_name[optype]);
s[SvCUR(argsv)] = 0; /* put our null back */
SvSETMAGIC(argsv); /* Assume it has changed */
#ifdef FLOCK
argtype = POPi;
- if (MAXARG <= 0)
+ if (MAXARG == 0)
gv = PL_last_in_gv;
else
gv = (GV*)POPs;
(void)PerlIO_flush(fp);
value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
}
- else
+ else {
value = 0;
+ SETERRNO(EBADF,RMS$_IFI);
+ if (ckWARN(WARN_CLOSED))
+ report_closed_fh(gv, GvIO(gv), "flock", "filehandle");
+ }
PUSHi(value);
RETURN;
#else
- DIE(PL_no_func, "flock()");
+ DIE(aTHX_ PL_no_func, "flock()");
#endif
}
if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
RETPUSHUNDEF;
}
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
+#endif
RETPUSHYES;
#else
- DIE(PL_no_sock_func, "socket");
+ DIE(aTHX_ PL_no_sock_func, "socket");
#endif
}
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(PL_no_sock_func, "socketpair");
+ DIE(aTHX_ PL_no_sock_func, "socketpair");
#endif
}
nuts:
if (ckWARN(WARN_CLOSED))
- warner(WARN_CLOSED, "bind() on closed fd");
+ report_closed_fh(gv, io, "bind", "socket");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
- DIE(PL_no_sock_func, "bind");
+ DIE(aTHX_ PL_no_sock_func, "bind");
#endif
}
nuts:
if (ckWARN(WARN_CLOSED))
- warner(WARN_CLOSED, "connect() on closed fd");
+ report_closed_fh(gv, io, "connect", "socket");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
- DIE(PL_no_sock_func, "connect");
+ DIE(aTHX_ PL_no_sock_func, "connect");
#endif
}
nuts:
if (ckWARN(WARN_CLOSED))
- warner(WARN_CLOSED, "listen() on closed fd");
+ report_closed_fh(gv, io, "listen", "socket");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
- DIE(PL_no_sock_func, "listen");
+ DIE(aTHX_ PL_no_sock_func, "listen");
#endif
}
if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
goto badexit;
}
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
+#endif
PUSHp((char *)&saddr, len);
RETURN;
nuts:
if (ckWARN(WARN_CLOSED))
- warner(WARN_CLOSED, "accept() on closed fd");
+ report_closed_fh(ggv, ggv ? GvIO(ggv) : 0, "accept", "socket");
SETERRNO(EBADF,SS$_IVCHAN);
badexit:
RETPUSHUNDEF;
#else
- DIE(PL_no_sock_func, "accept");
+ DIE(aTHX_ PL_no_sock_func, "accept");
#endif
}
nuts:
if (ckWARN(WARN_CLOSED))
- warner(WARN_CLOSED, "shutdown() on closed fd");
+ report_closed_fh(gv, io, "shutdown", "socket");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
- DIE(PL_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(PL_no_sock_func, "getsockopt");
+ DIE(aTHX_ PL_no_sock_func, "getsockopt");
#endif
}
nuts:
if (ckWARN(WARN_CLOSED))
- warner(WARN_CLOSED, "[gs]etsockopt() on closed fd");
+ report_closed_fh(gv, io,
+ optype == OP_GSOCKOPT ? "getsockopt" : "setsockopt",
+ "socket");
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
#else
- DIE(PL_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(PL_no_sock_func, "getsockname");
+ DIE(aTHX_ PL_no_sock_func, "getsockname");
#endif
}
nuts:
if (ckWARN(WARN_CLOSED))
- warner(WARN_CLOSED, "get{sock, peer}name() on closed fd");
+ report_closed_fh(gv, io,
+ optype == OP_GETSOCKNAME ? "getsockname"
+ : "getpeername",
+ "socket");
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
#else
- DIE(PL_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)
STRLEN n_a;
if (PL_op->op_flags & OPf_REF) {
- tmpgv = cGVOP->op_gv;
+ tmpgv = cGVOP_gv;
do_fstat:
if (tmpgv != PL_defgv) {
PL_laststype = OP_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'))
- warner(WARN_NEWLINE, PL_warn_nl, "stat");
+ Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
max = 0;
}
}
if (max) {
EXTEND(SP, max);
EXTEND_MORTAL(max);
- PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_dev)));
- PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ino)));
- PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mode)));
- PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_nlink)));
- PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_uid)));
- PUSHs(sv_2mortal(newSViv((I32)PL_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)PL_statcache.st_rdev)));
+ PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
#else
- PUSHs(sv_2mortal(newSVpv("", 0)));
+ PUSHs(sv_2mortal(newSVpvn("", 0)));
+#endif
+#if Off_t_size > IVSIZE
+ PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
+#else
+ PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
#endif
- PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_size)));
#ifdef BIG_TIME
- PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_atime)));
- PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_mtime)));
- PUSHs(sv_2mortal(newSVnv((U32)PL_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)PL_statcache.st_atime)));
- PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mtime)));
- PUSHs(sv_2mortal(newSViv((I32)PL_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)PL_statcache.st_blksize)));
- PUSHs(sv_2mortal(newSViv((I32)PL_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;
RETPUSHNO;
}
else
- result = my_stat(ARGS);
+ result = my_stat();
#else
- result = my_stat(ARGS);
+ result = my_stat();
#endif
SPAGAIN;
if (result < 0)
RETPUSHNO;
}
else
- result = my_stat(ARGS);
+ result = my_stat();
#else
- result = my_stat(ARGS);
+ result = my_stat();
#endif
SPAGAIN;
if (result < 0)
RETPUSHNO;
}
else
- result = my_stat(ARGS);
+ result = my_stat();
#else
- result = my_stat(ARGS);
+ result = my_stat();
#endif
SPAGAIN;
if (result < 0)
RETPUSHNO;
}
else
- result = my_stat(ARGS);
+ result = my_stat();
#else
- result = my_stat(ARGS);
+ result = my_stat();
#endif
SPAGAIN;
if (result < 0)
RETPUSHNO;
}
else
- result = my_stat(ARGS);
+ result = my_stat();
#else
- result = my_stat(ARGS);
+ result = my_stat();
#endif
SPAGAIN;
if (result < 0)
RETPUSHNO;
}
else
- result = my_stat(ARGS);
+ result = my_stat();
#else
- result = my_stat(ARGS);
+ result = my_stat();
#endif
SPAGAIN;
if (result < 0)
PP(pp_ftis)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
djSP;
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();
djSP;
if (result < 0)
RETPUSHUNDEF;
- if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? PL_euid : PL_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();
djSP;
if (result < 0)
RETPUSHUNDEF;
- if (!PL_statcache.st_size)
+ if (PL_statcache.st_size == 0)
RETPUSHYES;
RETPUSHNO;
}
PP(pp_ftsize)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
djSP; dTARGET;
if (result < 0)
RETPUSHUNDEF;
+#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();
djSP; dTARGET;
if (result < 0)
RETPUSHUNDEF;
- PUSHn( ((I32)PL_basetime - (I32)PL_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();
djSP; dTARGET;
if (result < 0)
RETPUSHUNDEF;
- PUSHn( ((I32)PL_basetime - (I32)PL_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();
djSP; dTARGET;
if (result < 0)
RETPUSHUNDEF;
- PUSHn( ((I32)PL_basetime - (I32)PL_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();
djSP;
if (result < 0)
RETPUSHUNDEF;
PP(pp_ftchr)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
djSP;
if (result < 0)
RETPUSHUNDEF;
PP(pp_ftblk)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
djSP;
if (result < 0)
RETPUSHUNDEF;
PP(pp_ftfile)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
djSP;
if (result < 0)
RETPUSHUNDEF;
PP(pp_ftdir)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
djSP;
if (result < 0)
RETPUSHUNDEF;
PP(pp_ftpipe)
{
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
djSP;
if (result < 0)
RETPUSHUNDEF;
PP(pp_ftlink)
{
- I32 result = my_lstat(ARGS);
+ I32 result = my_lstat();
djSP;
if (result < 0)
RETPUSHUNDEF;
{
djSP;
#ifdef S_ISUID
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
{
djSP;
#ifdef S_ISGID
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
{
djSP;
#ifdef S_ISVTX
- I32 result = my_stat(ARGS);
+ I32 result = my_stat();
SPAGAIN;
if (result < 0)
RETPUSHUNDEF;
STRLEN n_a;
if (PL_op->op_flags & OPf_REF)
- gv = cGVOP->op_gv;
+ gv = cGVOP_gv;
else if (isGV(TOPs))
gv = (GV*)POPs;
else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
register SV *sv;
GV *gv;
STRLEN n_a;
+ PerlIO *fp;
if (PL_op->op_flags & OPf_REF)
- gv = cGVOP->op_gv;
+ gv = cGVOP_gv;
else if (isGV(TOPs))
gv = (GV*)POPs;
else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
}
if (io && IoIFP(io)) {
if (! PerlIO_has_base(IoIFP(io)))
- DIE("-T and -B not implemented on filehandles");
+ DIE(aTHX_ "-T and -B not implemented on filehandles");
PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
if (PL_laststatval < 0)
RETPUSHUNDEF;
len = 512;
}
else {
- if (ckWARN(WARN_UNOPENED))
- warner(WARN_UNOPENED, "Test on unopened file <%s>",
- GvENAME(cGVOP->op_gv));
+ if (ckWARN(WARN_UNOPENED)) {
+ gv = cGVOP_gv;
+ Perl_warner(aTHX_ WARN_UNOPENED, "Test on unopened file <%s>",
+ GvENAME(gv));
+ }
SETERRNO(EBADF,RMS$_IFI);
RETPUSHUNDEF;
}
PL_statgv = Nullgv;
PL_laststatval = -1;
sv_setpv(PL_statname, SvPV(sv, n_a));
-#ifdef HAS_OPEN3
- i = PerlLIO_open3(SvPV(sv, n_a), O_RDONLY, 0);
-#else
- i = PerlLIO_open(SvPV(sv, n_a), 0);
-#endif
- if (i < 0) {
+ if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
- warner(WARN_NEWLINE, PL_warn_nl, "open");
+ Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
RETPUSHUNDEF;
}
- PL_laststatval = PerlLIO_fstat(i, &PL_statcache);
- if (PL_laststatval < 0)
+ PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
+ if (PL_laststatval < 0) {
+ (void)PerlIO_close(fp);
RETPUSHUNDEF;
- len = PerlLIO_read(i, tbuf, 512);
- (void)PerlLIO_close(i);
+ }
+ do_binmode(fp, '<', O_BINARY);
+ len = PerlIO_read(fp, tbuf, sizeof(tbuf));
+ (void)PerlIO_close(fp);
if (len <= 0) {
if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
RETPUSHNO; /* special case NFS directories */
/* 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;
else if (!(isPRINT(*s) || isSPACE(*s)))
odd++;
#else
- else if (*s & 128)
+ else if (*s & 128) {
+#ifdef USE_LOCALE
+ if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s))
+ continue;
+#endif
+ /* utf8 characters don't count as odd */
+ if (*s & 0x40) {
+ int ulen = UTF8SKIP(s);
+ if (ulen < len - i) {
+ int j;
+ for (j = 1; j < ulen; j++) {
+ if ((s[j] & 0xc0) != 0x80)
+ 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)
PP(pp_ftbinary)
{
- return pp_fttext(ARGS);
+ return pp_fttext();
}
/* File calls. */
PUSHi(value);
RETURN;
#else
- DIE(PL_no_func, "Unsupported function chown");
+ DIE(aTHX_ PL_no_func, "Unsupported function chown");
#endif
}
PUSHi( chroot(tmps) >= 0 );
RETURN;
#else
- DIE(PL_no_func, "chroot");
+ DIE(aTHX_ PL_no_func, "chroot");
#endif
}
char *tmps2 = POPpx;
char *tmps = SvPV(TOPs, n_a);
TAINT_PROPER("link");
- SETi( link(tmps, tmps2) >= 0 );
+ SETi( PerlLIO_link(tmps, tmps2) >= 0 );
#else
- DIE(PL_no_func, "Unsupported function link");
+ DIE(aTHX_ PL_no_func, "Unsupported function link");
#endif
RETURN;
}
SETi( symlink(tmps, tmps2) >= 0 );
RETURN;
#else
- DIE(PL_no_func, "symlink");
+ DIE(aTHX_ PL_no_func, "symlink");
#endif
}
}
#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 *save_filename = filename;
char *cmdline;
PP(pp_mkdir)
{
djSP; dTARGET;
- int mode = POPi;
+ int mode;
#ifndef HAS_MKDIR
int oldumask;
#endif
STRLEN n_a;
- char *tmps = SvPV(TOPs, n_a);
+ char *tmps;
+
+ if (MAXARG > 1)
+ mode = POPi;
+ else
+ mode = 0777;
+
+ tmps = SvPV(TOPs, n_a);
TAINT_PROPER("mkdir");
#ifdef HAS_MKDIR
SETERRNO(EBADF,RMS$_DIR);
RETPUSHUNDEF;
#else
- DIE(PL_no_dir_func, "opendir");
+ DIE(aTHX_ PL_no_dir_func, "opendir");
#endif
}
djSP;
#if defined(Direntry_t) && defined(HAS_READDIR)
#ifndef I_DIRENT
- Direntry_t *readdir _((DIR *));
+ Direntry_t *readdir (DIR *);
#endif
register Direntry_t *dp;
GV *gv = (GV*)POPs;
if (GIMME == G_ARRAY) {
/*SUPPRESS 560*/
- while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
+ while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
#ifdef DIRNAMLEN
- sv = newSVpv(dp->d_name, dp->d_namlen);
+ sv = newSVpvn(dp->d_name, dp->d_namlen);
#else
sv = newSVpv(dp->d_name, 0);
#endif
#ifndef INCOMPLETE_TAINTS
- SvTAINTED_on(sv);
+ if (!(IoFLAGS(io) & IOf_UNTAINT))
+ SvTAINTED_on(sv);
#endif
XPUSHs(sv_2mortal(sv));
}
if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
goto nope;
#ifdef DIRNAMLEN
- sv = newSVpv(dp->d_name, dp->d_namlen);
+ sv = newSVpvn(dp->d_name, dp->d_namlen);
#else
sv = newSVpv(dp->d_name, 0);
#endif
#ifndef INCOMPLETE_TAINTS
- SvTAINTED_on(sv);
+ if (!(IoFLAGS(io) & IOf_UNTAINT))
+ SvTAINTED_on(sv);
#endif
XPUSHs(sv_2mortal(sv));
}
else
RETPUSHUNDEF;
#else
- DIE(PL_no_dir_func, "readdir");
+ DIE(aTHX_ PL_no_dir_func, "readdir");
#endif
}
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 *));
+ long telldir (DIR *);
# endif
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
SETERRNO(EBADF,RMS$_ISI);
RETPUSHUNDEF;
#else
- DIE(PL_no_dir_func, "telldir");
+ DIE(aTHX_ PL_no_dir_func, "telldir");
#endif
}
SETERRNO(EBADF,RMS$_ISI);
RETPUSHUNDEF;
#else
- DIE(PL_no_dir_func, "seekdir");
+ DIE(aTHX_ PL_no_dir_func, "seekdir");
#endif
}
SETERRNO(EBADF,RMS$_ISI);
RETPUSHUNDEF;
#else
- DIE(PL_no_dir_func, "rewinddir");
+ DIE(aTHX_ PL_no_dir_func, "rewinddir");
#endif
}
SETERRNO(EBADF,RMS$_IFI);
RETPUSHUNDEF;
#else
- DIE(PL_no_dir_func, "closedir");
+ DIE(aTHX_ PL_no_dir_func, "closedir");
#endif
}
{
#ifdef HAS_FORK
djSP; dTARGET;
- int childpid;
+ Pid_t childpid;
GV *tmpgv;
EXTEND(SP, 1);
+ PERL_FLUSHALL_FOR_CHILD;
childpid = fork();
if (childpid < 0)
RETSETUNDEF;
if (!childpid) {
/*SUPPRESS 560*/
- if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
- sv_setiv(GvSV(tmpgv), (IV)getpid());
+ if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
+ sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
}
PUSHi(childpid);
RETURN;
#else
- DIE(PL_no_func, "Unsupported function fork");
+# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
+ djSP; 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, "Unsupported function fork");
+# endif
#endif
}
PP(pp_wait)
{
-#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
+#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
djSP; dTARGET;
- int childpid;
+ Pid_t childpid;
int argflags;
childpid = wait4pid(-1, &argflags, 0);
XPUSHi(childpid);
RETURN;
#else
- DIE(PL_no_func, "Unsupported function wait");
+ DIE(aTHX_ PL_no_func, "Unsupported function wait");
#endif
}
PP(pp_waitpid)
{
-#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
+#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
djSP; dTARGET;
- int childpid;
+ Pid_t childpid;
int optype;
int argflags;
SETi(childpid);
RETURN;
#else
- DIE(PL_no_func, "Unsupported function waitpid");
+ DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
#endif
}
{
djSP; dMARK; dORIGMARK; dTARGET;
I32 value;
- int childpid;
+ Pid_t childpid;
int result;
int status;
Sigsave_t ihand,qhand; /* place to save signals during system() */
STRLEN n_a;
+ I32 did_pipes = 0;
+ int pp[2];
if (SP - MARK == 1) {
if (PL_tainting) {
TAINT_PROPER("system");
}
}
-#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
+ PERL_FLUSHALL_FOR_CHILD;
+#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__)
+ if (PerlProc_pipe(pp) >= 0)
+ did_pipes = 1;
while ((childpid = vfork()) == -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) {
+ if (did_pipes)
+ PerlLIO_close(pp[1]);
rsignal_save(SIGINT, SIG_IGN, &ihand);
rsignal_save(SIGQUIT, SIG_IGN, &qhand);
do {
STATUS_NATIVE_SET(result == -1 ? -1 : status);
do_execfree(); /* free any memory child malloced on vfork */
SP = ORIGMARK;
+ 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;
}
+ 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_aexec(really, MARK, SP);
+ value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
}
else if (SP - MARK != 1)
- value = (I32)do_aexec(Nullsv, MARK, SP);
+ value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
else {
- value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
+ value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
}
PerlProc__exit(-1);
#else /* ! FORK or VMS or OS/2 */
I32 value;
STRLEN n_a;
+ PERL_FLUSHALL_FOR_CHILD;
if (PL_op->op_flags & OPf_STACKED) {
SV *really = *++MARK;
value = (I32)do_aexec(really, MARK, SP);
# endif
#endif
}
+
+#if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
+ if (value >= 0)
+ my_exit(value);
+#endif
+
SP = ORIGMARK;
PUSHi(value);
RETURN;
PUSHi(value);
RETURN;
#else
- DIE(PL_no_func, "Unsupported function kill");
+ DIE(aTHX_ PL_no_func, "Unsupported function kill");
#endif
}
XPUSHi( getppid() );
RETURN;
#else
- DIE(PL_no_func, "getppid");
+ DIE(aTHX_ PL_no_func, "getppid");
#endif
}
{
#ifdef HAS_GETPGRP
djSP; 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 && pid != getpid())
- 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(PL_no_func, "getpgrp()");
+ DIE(aTHX_ PL_no_func, "getpgrp()");
#endif
}
{
#ifdef HAS_SETPGRP
djSP; 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 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
- 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(PL_no_func, "setpgrp()");
+ DIE(aTHX_ PL_no_func, "setpgrp()");
#endif
}
SETi( getpriority(which, who) );
RETURN;
#else
- DIE(PL_no_func, "getpriority()");
+ DIE(aTHX_ PL_no_func, "getpriority()");
#endif
}
SETi( setpriority(which, who, niceval) >= 0 );
RETURN;
#else
- DIE(PL_no_func, "setpriority()");
+ DIE(aTHX_ PL_no_func, "setpriority()");
#endif
}
djSP;
#ifndef HAS_TIMES
- DIE("times not implemented");
+ DIE(aTHX_ "times not implemented");
#else
EXTEND(SP, 4);
/* is returned. */
#endif
- PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_utime)/HZ)));
+ PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
if (GIMME == G_ARRAY) {
- PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_stime)/HZ)));
- PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cutime)/HZ)));
- PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cstime)/HZ)));
+ PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
+ PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
+ PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
}
RETURN;
#endif /* HAS_TIMES */
PP(pp_localtime)
{
- return pp_gmtime(ARGS);
+ return pp_gmtime();
}
PP(pp_gmtime)
EXTEND(SP, 9);
EXTEND_MORTAL(9);
if (GIMME != G_ARRAY) {
- dTARGET;
SV *tsv;
if (!tmbuf)
RETPUSHUNDEF;
- tsv = newSVpvf("%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);
+ 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)));
+ 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;
}
EXTEND(SP, 1);
if (anum < 0)
RETPUSHUNDEF;
- PUSHi((I32)anum);
+ PUSHi(anum);
RETURN;
#else
- DIE(PL_no_func, "Unsupported function alarm");
+ DIE(aTHX_ PL_no_func, "Unsupported function alarm");
#endif
}
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)
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
}
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
}
}
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_GETHOSTBYNAME
- return pp_ghostent(ARGS);
+ return pp_ghostent();
#else
- DIE(PL_no_sock_func, "gethostbyname");
+ DIE(aTHX_ PL_no_sock_func, "gethostbyname");
#endif
}
PP(pp_ghbyaddr)
{
#ifdef HAS_GETHOSTBYADDR
- return pp_ghostent(ARGS);
+ return pp_ghostent();
#else
- DIE(PL_no_sock_func, "gethostbyaddr");
+ DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
#endif
}
#ifdef HAS_GETHOSTBYNAME
hent = PerlSock_gethostbyname(POPpx);
#else
- DIE(PL_no_sock_func, "gethostbyname");
+ DIE(aTHX_ PL_no_sock_func, "gethostbyname");
#endif
else if (which == OP_GHBYADDR) {
#ifdef HAS_GETHOSTBYADDR
hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
#else
- DIE(PL_no_sock_func, "gethostbyaddr");
+ DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
#endif
}
else
#ifdef HAS_GETHOSTENT
hent = PerlSock_gethostent();
#else
- DIE(PL_no_sock_func, "gethostent");
+ DIE(aTHX_ PL_no_sock_func, "gethostent");
#endif
#ifdef HOST_NOT_FOUND
}
RETURN;
#else
- DIE(PL_no_sock_func, "gethostent");
+ DIE(aTHX_ PL_no_sock_func, "gethostent");
#endif
}
PP(pp_gnbyname)
{
#ifdef HAS_GETNETBYNAME
- return pp_gnetent(ARGS);
+ return pp_gnetent();
#else
- DIE(PL_no_sock_func, "getnetbyname");
+ DIE(aTHX_ PL_no_sock_func, "getnetbyname");
#endif
}
PP(pp_gnbyaddr)
{
#ifdef HAS_GETNETBYADDR
- return pp_gnetent(ARGS);
+ return pp_gnetent();
#else
- DIE(PL_no_sock_func, "getnetbyaddr");
+ DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
#endif
}
#ifdef HAS_GETNETBYNAME
nent = PerlSock_getnetbyname(POPpx);
#else
- DIE(PL_no_sock_func, "getnetbyname");
+ DIE(aTHX_ PL_no_sock_func, "getnetbyname");
#endif
else if (which == OP_GNBYADDR) {
#ifdef HAS_GETNETBYADDR
Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
nent = PerlSock_getnetbyaddr(addr, addrtype);
#else
- DIE(PL_no_sock_func, "getnetbyaddr");
+ DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
#endif
}
else
#ifdef HAS_GETNETENT
nent = PerlSock_getnetent();
#else
- DIE(PL_no_sock_func, "getnetent");
+ DIE(aTHX_ PL_no_sock_func, "getnetent");
#endif
EXTEND(SP, 4);
RETURN;
#else
- DIE(PL_no_sock_func, "getnetent");
+ DIE(aTHX_ PL_no_sock_func, "getnetent");
#endif
}
PP(pp_gpbyname)
{
#ifdef HAS_GETPROTOBYNAME
- return pp_gprotoent(ARGS);
+ return pp_gprotoent();
#else
- DIE(PL_no_sock_func, "getprotobyname");
+ DIE(aTHX_ PL_no_sock_func, "getprotobyname");
#endif
}
PP(pp_gpbynumber)
{
#ifdef HAS_GETPROTOBYNUMBER
- return pp_gprotoent(ARGS);
+ return pp_gprotoent();
#else
- DIE(PL_no_sock_func, "getprotobynumber");
+ DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
#endif
}
#ifdef HAS_GETPROTOBYNAME
pent = PerlSock_getprotobyname(POPpx);
#else
- DIE(PL_no_sock_func, "getprotobyname");
+ DIE(aTHX_ PL_no_sock_func, "getprotobyname");
#endif
else if (which == OP_GPBYNUMBER)
#ifdef HAS_GETPROTOBYNUMBER
pent = PerlSock_getprotobynumber(POPi);
#else
- DIE(PL_no_sock_func, "getprotobynumber");
+ DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
#endif
else
#ifdef HAS_GETPROTOENT
pent = PerlSock_getprotoent();
#else
- DIE(PL_no_sock_func, "getprotoent");
+ DIE(aTHX_ PL_no_sock_func, "getprotoent");
#endif
EXTEND(SP, 3);
RETURN;
#else
- DIE(PL_no_sock_func, "getprotoent");
+ DIE(aTHX_ PL_no_sock_func, "getprotoent");
#endif
}
PP(pp_gsbyname)
{
#ifdef HAS_GETSERVBYNAME
- return pp_gservent(ARGS);
+ return pp_gservent();
#else
- DIE(PL_no_sock_func, "getservbyname");
+ DIE(aTHX_ PL_no_sock_func, "getservbyname");
#endif
}
PP(pp_gsbyport)
{
#ifdef HAS_GETSERVBYPORT
- return pp_gservent(ARGS);
+ return pp_gservent();
#else
- DIE(PL_no_sock_func, "getservbyport");
+ DIE(aTHX_ PL_no_sock_func, "getservbyport");
#endif
}
sent = PerlSock_getservbyname(name, proto);
#else
- DIE(PL_no_sock_func, "getservbyname");
+ DIE(aTHX_ PL_no_sock_func, "getservbyname");
#endif
}
else if (which == OP_GSBYPORT) {
#endif
sent = PerlSock_getservbyport(port, proto);
#else
- DIE(PL_no_sock_func, "getservbyport");
+ DIE(aTHX_ PL_no_sock_func, "getservbyport");
#endif
}
else
#ifdef HAS_GETSERVENT
sent = PerlSock_getservent();
#else
- DIE(PL_no_sock_func, "getservent");
+ DIE(aTHX_ PL_no_sock_func, "getservent");
#endif
EXTEND(SP, 4);
RETURN;
#else
- DIE(PL_no_sock_func, "getservent");
+ DIE(aTHX_ PL_no_sock_func, "getservent");
#endif
}
PerlSock_sethostent(TOPi);
RETSETYES;
#else
- DIE(PL_no_sock_func, "sethostent");
+ DIE(aTHX_ PL_no_sock_func, "sethostent");
#endif
}
PerlSock_setnetent(TOPi);
RETSETYES;
#else
- DIE(PL_no_sock_func, "setnetent");
+ DIE(aTHX_ PL_no_sock_func, "setnetent");
#endif
}
PerlSock_setprotoent(TOPi);
RETSETYES;
#else
- DIE(PL_no_sock_func, "setprotoent");
+ DIE(aTHX_ PL_no_sock_func, "setprotoent");
#endif
}
PerlSock_setservent(TOPi);
RETSETYES;
#else
- DIE(PL_no_sock_func, "setservent");
+ DIE(aTHX_ PL_no_sock_func, "setservent");
#endif
}
EXTEND(SP,1);
RETPUSHYES;
#else
- DIE(PL_no_sock_func, "endhostent");
+ DIE(aTHX_ PL_no_sock_func, "endhostent");
#endif
}
EXTEND(SP,1);
RETPUSHYES;
#else
- DIE(PL_no_sock_func, "endnetent");
+ DIE(aTHX_ PL_no_sock_func, "endnetent");
#endif
}
EXTEND(SP,1);
RETPUSHYES;
#else
- DIE(PL_no_sock_func, "endprotoent");
+ DIE(aTHX_ PL_no_sock_func, "endprotoent");
#endif
}
EXTEND(SP,1);
RETPUSHYES;
#else
- DIE(PL_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(PL_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(PL_no_func, "getpwuid");
+ DIE(aTHX_ PL_no_func, "getpwuid");
#endif
}
PP(pp_gpwent)
{
djSP;
-#if defined(HAS_PASSWD) && defined(HAS_GETPWENT)
+#ifdef HAS_PASSWD
I32 which = PL_op->op_type;
register SV *sv;
- struct passwd *pwent;
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 tby 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[AUTH_MAX_CIPHERTEXT_LENGTH]
+ *
+ * <sys/types.h>
+ * <sys/security.h>
+ * <prot.h>
+ * struct es_passwd *getespw*();
+ * The password is in
+ * char *(getespw*(...).ufld.fd_encrypt)
+ *
+ * XXX Configure test needed for getprpwnam XXX
+ * XXX Configure test needed for getespwnam XXX
+ *
+ * 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.
+ *
+ * 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.
+ *
+ * --jhi
+ */
+# ifdef HAS_GETSPNAM
+ struct spwd *spwent = NULL;
+# endif
- if (which == OP_GPWNAM)
- pwent = getpwnam(POPpx);
- else if (which == OP_GPWUID)
- pwent = getpwuid(POPi);
- else
- pwent = (struct passwd *)getpwent();
+ switch (which) {
+ case OP_GPWNAM:
+ pwent = getpwnam(POPpx);
+ break;
+ case OP_GPWUID:
+ pwent = getpwuid((Uid_t)POPi);
+ break;
+ case OP_GPWENT:
+# ifdef HAS_GETPWENT
+ pwent = getpwent();
+# 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)
+# 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);
}
sv_setpv(sv, pwent->pw_name);
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
-#ifdef PWPASSWD
+# ifdef HAS_GETSPNAM
+ spwent = getspnam(pwent->pw_name);
+ if (spwent)
+ sv_setpv(sv, spwent->sp_pwdp);
+ else
+ sv_setpv(sv, pwent->pw_passwd);
+# else
sv_setpv(sv, pwent->pw_passwd);
-#endif
+# endif
+# ifndef INCOMPLETE_TAINTS
+ /* passwd is tainted because user himself can diddle with it. */
+ 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. */
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
-#ifdef PWCHANGE
+# ifdef PWCHANGE
sv_setiv(sv, (IV)pwent->pw_change);
-#else
-# ifdef PWQUOTA
- sv_setiv(sv, (IV)pwent->pw_quota);
# else
-# ifdef PWAGE
+# ifdef PWQUOTA
+ sv_setiv(sv, (IV)pwent->pw_quota);
+# else
+# ifdef PWAGE
sv_setpv(sv, pwent->pw_age);
+# endif
# endif
# endif
-#endif
/* pw_class and pw_comment are mutually exclusive. */
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
-#ifdef PWCLASS
+# ifdef PWCLASS
sv_setpv(sv, pwent->pw_class);
-#else
-# ifdef PWCOMMENT
+# else
+# ifdef PWCOMMENT
sv_setpv(sv, pwent->pw_comment);
+# endif
# endif
-#endif
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
-#ifdef PWGECOS
+# ifdef PWGECOS
sv_setpv(sv, pwent->pw_gecos);
-#endif
-#ifndef INCOMPLETE_TAINTS
+# endif
+# ifndef INCOMPLETE_TAINTS
/* pw_gecos is tainted because user himself can diddle with it. */
SvTAINTED_on(sv);
-#endif
+# endif
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setpv(sv, pwent->pw_dir);
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setpv(sv, pwent->pw_shell);
+# ifndef INCOMPLETE_TAINTS
+ /* pw_shell is tainted because user himself can diddle with it. */
+ SvTAINTED_on(sv);
+# endif
-#ifdef PWEXPIRE
+# ifdef PWEXPIRE
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setiv(sv, (IV)pwent->pw_expire);
-#endif
+# endif
}
RETURN;
#else
- DIE(PL_no_func, "getpwent");
+ DIE(aTHX_ PL_no_func, "getpwent");
#endif
}
PP(pp_spwent)
{
djSP;
-#if defined(HAS_PASSWD) && defined(HAS_SETPWENT) && !defined(CYGWIN32)
+#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
setpwent();
RETPUSHYES;
#else
- DIE(PL_no_func, "setpwent");
+ DIE(aTHX_ PL_no_func, "setpwent");
#endif
}
endpwent();
RETPUSHYES;
#else
- DIE(PL_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(PL_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(PL_no_func, "getgrgid");
+ DIE(aTHX_ PL_no_func, "getgrgid");
#endif
}
PP(pp_ggrent)
{
djSP;
-#if defined(HAS_GROUP) && defined(HAS_GETGRENT)
+#ifdef HAS_GROUP
I32 which = PL_op->op_type;
register char **elem;
register SV *sv;
else if (which == OP_GGRGID)
grent = (struct group *)getgrgid(POPi);
else
+#ifdef HAS_GETGRENT
grent = (struct group *)getgrent();
+#else
+ DIE(aTHX_ PL_no_func, "getgrent");
+#endif
EXTEND(SP, 4);
if (GIMME != G_ARRAY) {
RETURN;
#else
- DIE(PL_no_func, "getgrent");
+ DIE(aTHX_ PL_no_func, "getgrent");
#endif
}
setgrent();
RETPUSHYES;
#else
- DIE(PL_no_func, "setgrent");
+ DIE(aTHX_ PL_no_func, "setgrent");
#endif
}
endgrent();
RETPUSHYES;
#else
- DIE(PL_no_func, "endgrent");
+ DIE(aTHX_ PL_no_func, "endgrent");
#endif
}
PUSHp(tmps, strlen(tmps));
RETURN;
#else
- DIE(PL_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 (PL_tainting) {
}
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(PL_no_func, "syscall");
+ DIE(aTHX_ PL_no_func, "syscall");
#endif
}
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;