/* pp_sys.c
*
- * Copyright (c) 1991-2003, Larry Wall
+ * Copyright (C) 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
tmpsv = TOPs;
}
tmps = SvPV(tmpsv, len);
- if (!tmps || !len) {
+ if ((!tmps || !len) && PL_errgv) {
SV *error = ERRSV;
(void)SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
PUTBACK;
if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
(discp) ? SvPV_nolen(discp) : Nullch)) {
+ if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
+ if (!PerlIO_binmode(aTHX_ IoOFP(io),IoTYPE(io),
+ mode_from_discipline(discp),
+ (discp) ? SvPV_nolen(discp) : Nullch)) {
+ SPAGAIN;
+ RETPUSHUNDEF;
+ }
+ }
SPAGAIN;
RETPUSHYES;
}
RETPUSHYES;
if ((mg = SvTIED_mg(sv, how))) {
- SV *obj = SvRV(mg->mg_obj);
+ SV *obj = SvRV(SvTIED_obj(sv, mg));
GV *gv;
CV *cv = NULL;
if (obj) {
(UV)SvREFCNT(obj) - 1 ) ;
}
}
- sv_unmagic(sv, how) ;
}
+ sv_unmagic(sv, how) ;
RETPUSHYES;
}
Zero(&fd_sets[0], 4, char*);
#endif
-# if SELECT_MIN_BITS > 1
+# if SELECT_MIN_BITS == 1
+ growsize = sizeof(fd_set);
+# else
+# if defined(__GLIBC__) && defined(__FD_SETSIZE)
+# undef SELECT_MIN_BITS
+# define SELECT_MIN_BITS __FD_SETSIZE
+# endif
/* 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];
#endif
}
+#ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
+ /* Can't make just the (void*) conditional because that would be
+ * cpp #if within cpp macro, and not all compilers like that. */
+ nfound = PerlSock_select(
+ maxlen * 8,
+ (Select_fd_set_t) fd_sets[1],
+ (Select_fd_set_t) fd_sets[2],
+ (Select_fd_set_t) fd_sets[3],
+ (void*) tbuf); /* Workaround for compiler bug. */
+#else
nfound = PerlSock_select(
maxlen * 8,
(Select_fd_set_t) fd_sets[1],
(Select_fd_set_t) fd_sets[2],
(Select_fd_set_t) fd_sets[3],
-#ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
- (void*) /* Workaround for a compiler bug. */
-#endif
tbuf);
+#endif
for (i = 1; i <= 3; i++) {
if (fd_sets[i]) {
sv = SP[i];
}
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 */
+ /* UTF-8 may not have been set if they are all low bytes */
SvUTF8_on(bufsv);
}
else {
buffer = SvPVutf8(bufsv, blen);
}
else {
- if (DO_UTF8(bufsv))
- sv_utf8_downgrade(bufsv, FALSE);
- buffer = SvPV(bufsv, blen);
+ if (DO_UTF8(bufsv)) {
+ /* Not modifying source SV, so making a temporary copy. */
+ bufsv = sv_2mortal(newSVsv(bufsv));
+ sv_utf8_downgrade(bufsv, FALSE);
+ }
+ buffer = SvPV(bufsv, blen);
}
if (PL_op->op_type == OP_SYSWRITE) {
#else
retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
#endif
+#endif
+#if defined(HAS_IOCTL) || defined(HAS_FCNTL)
if (SvPOK(argsv)) {
if (s[SvCUR(argsv)] != 17)
DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
GV *ggv;
register IO *nstio;
register IO *gstio;
- struct sockaddr saddr; /* use a struct to avoid alignment problems */
- Sock_size_t len = sizeof saddr;
+ char namebuf[MAXPATHLEN];
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
+ Sock_size_t len = sizeof (struct sockaddr_in);
+#else
+ Sock_size_t len = sizeof namebuf;
+#endif
int fd;
ggv = (GV*)POPs;
goto nuts;
nstio = GvIOn(ngv);
- fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
+ fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
if (fd < 0)
goto badexit;
if (IoIFP(nstio))
#endif
#ifdef EPOC
- len = sizeof saddr; /* EPOC somehow truncates info */
+ len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
#endif
+#ifdef __SCO_VERSION__
+ len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
+#endif
- PUSHp((char *)&saddr, len);
+ PUSHp(namebuf, len);
RETURN;
nuts:
dSP;
#if defined(HAS_ACCESS) && defined(R_OK)
STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = access(TOPpx, R_OK);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ result = access(POPpx, R_OK);
if (result == 0)
RETPUSHYES;
if (result < 0)
dSP;
#if defined(HAS_ACCESS) && defined(W_OK)
STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = access(TOPpx, W_OK);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ result = access(POPpx, W_OK);
if (result == 0)
RETPUSHYES;
if (result < 0)
dSP;
#if defined(HAS_ACCESS) && defined(X_OK)
STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = access(TOPpx, X_OK);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ result = access(POPpx, X_OK);
if (result == 0)
RETPUSHYES;
if (result < 0)
dSP;
#ifdef PERL_EFF_ACCESS_R_OK
STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = PERL_EFF_ACCESS_R_OK(TOPpx);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ result = PERL_EFF_ACCESS_R_OK(POPpx);
if (result == 0)
RETPUSHYES;
if (result < 0)
dSP;
#ifdef PERL_EFF_ACCESS_W_OK
STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = PERL_EFF_ACCESS_W_OK(TOPpx);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ result = PERL_EFF_ACCESS_W_OK(POPpx);
if (result == 0)
RETPUSHYES;
if (result < 0)
dSP;
#ifdef PERL_EFF_ACCESS_X_OK
STRLEN n_a;
- if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
- result = PERL_EFF_ACCESS_X_OK(TOPpx);
+ if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
+ result = PERL_EFF_ACCESS_X_OK(POPpx);
if (result == 0)
RETPUSHYES;
if (result < 0)
dSP; dTARGET;
if (result < 0)
RETPUSHUNDEF;
- PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
+ PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
RETURN;
}
dSP; dTARGET;
if (result < 0)
RETPUSHUNDEF;
- PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
+ PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
RETURN;
}
dSP; dTARGET;
if (result < 0)
RETPUSHUNDEF;
- PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
+ PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
RETURN;
}
PL_laststype = OP_STAT;
sv_setpv(PL_statname, SvPV(sv, n_a));
if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
- if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
+ if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
RETPUSHUNDEF;
}
PP(pp_readdir)
{
-#if defined(Direntry_t) && defined(HAS_READDIR)
- dSP;
+#if !defined(Direntry_t) || !defined(HAS_READDIR)
+ DIE(aTHX_ PL_no_dir_func, "readdir");
+#else
#if !defined(I_DIRENT) && !defined(VMS)
Direntry_t *readdir (DIR *);
#endif
+ dSP;
+
+ SV *sv;
+ I32 gimme = GIMME;
+ GV *gv = (GV *)POPs;
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 *)PerlDir_read(IoDIRP(io)))) {
+ do {
+ dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
+ if (!dp)
+ break;
#ifdef DIRNAMLEN
- sv = newSVpvn(dp->d_name, dp->d_namlen);
+ sv = newSVpvn(dp->d_name, dp->d_namlen);
#else
- sv = 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 *)PerlDir_read(IoDIRP(io))))
- goto nope;
-#ifdef DIRNAMLEN
- sv = newSVpvn(dp->d_name, dp->d_namlen);
-#else
- sv = newSVpv(dp->d_name, 0);
-#endif
-#ifndef INCOMPLETE_TAINTS
- if (!(IoFLAGS(io) & IOf_UNTAINT))
- SvTAINTED_on(sv);
+ if (!(IoFLAGS(io) & IOf_UNTAINT))
+ SvTAINTED_on(sv);
#endif
- XPUSHs(sv_2mortal(sv));
+ XPUSHs(sv_2mortal(sv));
}
+ while (gimme == G_ARRAY);
+
+ if (!dp && gimme != G_ARRAY)
+ goto nope;
+
RETURN;
nope:
RETURN;
else
RETPUSHUNDEF;
-#else
- DIE(aTHX_ PL_no_dir_func, "readdir");
#endif
}
result = 0;
if (PL_op->op_flags & OPf_STACKED) {
SV *really = *++MARK;
-# ifdef WIN32
+# if defined(WIN32) || defined(OS2)
value = (I32)do_aspawn(really, MARK, SP);
# else
value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
# endif
}
else if (SP - MARK != 1) {
-# ifdef WIN32
+# if defined(WIN32) || defined(OS2)
value = (I32)do_aspawn(Nullsv, MARK, SP);
# else
value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
}
RETURN;
#else
+# ifdef PERL_MICRO
+ dSP;
+ PUSHs(sv_2mortal(newSVnv((NV)0.0)));
+ EXTEND(SP, 4);
+ if (GIMME == G_ARRAY) {
+ PUSHs(sv_2mortal(newSVnv((NV)0.0)));
+ PUSHs(sv_2mortal(newSVnv((NV)0.0)));
+ PUSHs(sv_2mortal(newSVnv((NV)0.0)));
+ }
+ RETURN;
+# else
DIE(aTHX_ "times not implemented");
+# endif
#endif /* HAS_TIMES */
}
* 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
+ * There are at least three 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
* char *(getespw*(...).ufld.fd_encrypt)
* Mention HAS_GETESPWNAM here so that Configure probes for it.
*
+ * <userpw.h> (AIX)
+ * struct userpw *getuserpw();
+ * The password is in
+ * char *(getuserpw(...)).spw_upw_passwd
+ * (but the de facto standard getpwnam() should work okay)
+ *
* Mention I_PROT here so that Configure probes for it.
*
* In HP-UX for getprpw*() the manual page claims that one should include
* --jhi
*/
+# if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
+ /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
+ * the pw_comment is left uninitialized. */
+ PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
+# endif
+
switch (which) {
case OP_GPWNAM:
{
* Divert the urge to writing an extension instead.
*
* --jhi */
-# ifdef HAS_GETSPNAM
+ /* Some AIX setups falsely(?) detect some getspnam(), which
+ * has a different API than the Solaris/IRIX one. */
+# if defined(HAS_GETSPNAM) && !defined(_AIX)
{
struct spwd *spwent;
int saverrno; /* Save and restore errno so that
https://perl5.git.perl.org / perl5.git / blobdiff