# 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
#endif
struct group *getgrgid (Gid_t);
# endif
# ifdef HAS_GETGRENT
+#ifndef getgrent
struct group *getgrent (void);
+#endif
# endif
#endif
}
else if (ckWARN(WARN_UNTIE)) {
if (mg && SvREFCNT(obj) > 1)
- Perl_warner(aTHX_ WARN_UNTIE,
+ Perl_warner(aTHX_ packWARN(WARN_UNTIE),
"untie attempted while %"UVuf" inner references still exist",
(UV)SvREFCNT(obj) - 1 ) ;
}
name = SvPV_nolen(sv);
}
if (name && *name)
- Perl_warner(aTHX_ WARN_IO,
+ Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle %s opened only for input", name);
else
- Perl_warner(aTHX_ WARN_IO,
+ Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle opened only for input");
}
else if (ckWARN(WARN_CLOSED))
else {
if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
if (ckWARN(WARN_IO))
- Perl_warner(aTHX_ WARN_IO, "page overflow");
+ Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
}
if (!do_print(PL_formtarget, fp))
PUSHs(&PL_sv_no);
name = SvPV_nolen(sv);
}
if (name && *name)
- Perl_warner(aTHX_ WARN_IO,
+ Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle %s opened only for input", name);
else
- Perl_warner(aTHX_ WARN_IO,
+ Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle opened only for input");
}
else if (ckWARN(WARN_CLOSED))
#ifdef HAS_SOCKET
if (PL_op->op_type == OP_RECV) {
char namebuf[MAXPATHLEN];
-#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
bufsize = sizeof (struct sockaddr_in);
#else
bufsize = sizeof namebuf;
name = SvPV_nolen(sv);
}
if (name && *name)
- Perl_warner(aTHX_ WARN_IO,
+ Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle %s opened only for output", name);
else
- Perl_warner(aTHX_ WARN_IO,
+ Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle opened only for output");
}
goto say_undef;
if (PL_op->op_type == OP_LSTAT) {
if (gv != PL_defgv) {
if (ckWARN(WARN_IO))
- Perl_warner(aTHX_ 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");
else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
gv = (GV*)SvRV(sv);
if (PL_op->op_type == OP_LSTAT && ckWARN(WARN_IO))
- Perl_warner(aTHX_ WARN_IO,
+ Perl_warner(aTHX_ packWARN(WARN_IO),
"lstat() on filehandle %s", GvENAME(gv));
goto do_fstat;
}
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_ WARN_NEWLINE, PL_warn_nl, "stat");
+ Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
max = 0;
}
}
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_ WARN_NEWLINE, PL_warn_nl, "open");
+ Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
RETPUSHUNDEF;
}
PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
)
{
if( MAXARG == 1 )
- deprecate_old("chdir('') or chdir(undef) as chdir()");
+ deprecate("chdir('') or chdir(undef) as chdir()");
tmps = SvPV(*svp, n_a);
}
else {
dSP;
STRLEN n_a;
char *dirname = POPpx;
- GV *gv = (GV*)POPs;
- register IO *io = GvIOn(gv);
+ char *dscp = NULL;
+ GV *gv;
+ register IO *io;
+ bool want_utf8 = FALSE;
+
+ if (MAXARG == 3)
+ dscp = POPpx;
+
+ gv = (GV*)POPs;
+ io = GvIOn(gv);
if (!io)
goto nope;
+ if (dscp) {
+ if (*dscp == ':') {
+ if (strnEQ(dscp + 1, "utf8", 4))
+ want_utf8 = TRUE;
+ else
+ Perl_croak(aTHX_ "Unknown discipline '%s'", dscp);
+ }
+ else
+ Perl_croak(aTHX_ "Unknown discipline '%s'", dscp);
+ }
+
if (IoDIRP(io))
PerlDir_close(IoDIRP(io));
if (!(IoDIRP(io) = PerlDir_open(dirname)))
goto nope;
+ if (want_utf8)
+ IoFLAGS(io) |= IOf_DIR_UTF8;
+
RETPUSHYES;
nope:
if (!errno)
if (!(IoFLAGS(io) & IOf_UNTAINT))
SvTAINTED_on(sv);
#endif
+ if (IoFLAGS(io) & IOf_DIR_UTF8 && !IN_BYTES)
+ SvUTF8_on(sv);
XPUSHs(sv_2mortal(sv));
}
}
if (!(IoFLAGS(io) & IOf_UNTAINT))
SvTAINTED_on(sv);
#endif
+ if (IoFLAGS(io) & IOf_DIR_UTF8)
+ sv_utf8_upgrade(sv);
XPUSHs(sv_2mortal(sv));
}
RETURN;
STRLEN n_a;
EXTEND(SP, 10);
- if (which == OP_GHBYNAME)
+ if (which == OP_GHBYNAME) {
#ifdef HAS_GETHOSTBYNAME
- hent = PerlSock_gethostbyname(POPpbytex);
+ 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;
#endif
#ifdef HOST_NOT_FOUND
- if (!hent)
- STATUS_NATIVE_SET(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) {
struct netent *nent;
STRLEN n_a;
- if (which == OP_GNBYNAME)
+ if (which == OP_GNBYNAME){
#ifdef HAS_GETNETBYNAME
- nent = PerlSock_getnetbyname(POPpbytex);
+ 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;
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());
struct protoent *pent;
STRLEN n_a;
- if (which == OP_GPBYNAME)
+ if (which == OP_GPBYNAME) {
#ifdef HAS_GETPROTOBYNAME
- pent = PerlSock_getprotobyname(POPpbytex);
+ char* name = POPpbytex;
+ pent = PerlSock_getprotobyname(name);
#else
DIE(aTHX_ PL_no_sock_func, "getprotobyname");
#endif
- else if (which == OP_GPBYNUMBER)
+ }
+ else if (which == OP_GPBYNUMBER) {
#ifdef HAS_GETPROTOBYNUMBER
- pent = PerlSock_getprotobynumber(POPi);
+ int number = POPi;
+ pent = PerlSock_getprotobynumber(number);
#else
- DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
+ DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
#endif
+ }
else
#ifdef HAS_GETPROTOENT
pent = PerlSock_getprotoent();
switch (which) {
case OP_GPWNAM:
- pwent = getpwnam(POPpbytex);
- break;
+ {
+ char* name = POPpbytex;
+ pwent = getpwnam(name);
+ }
+ break;
case OP_GPWUID:
- pwent = getpwuid((Uid_t)POPi);
+ {
+ Uid_t uid = POPi;
+ pwent = getpwuid(uid);
+ }
break;
case OP_GPWENT:
# ifdef HAS_GETPWENT
struct group *grent;
STRLEN n_a;
- if (which == OP_GGRNAM)
- grent = (struct group *)getgrnam(POPpbytex);
- 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();
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;
projects / p5sagit/p5-mst-13.2.git / blobdiff