X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=6ed8e0a35070e68ca93e8c3f6260235042865e9f;hb=7a9e22343ee2c409475baf99c2f838dc7fc1f7b8;hp=e44ab1c76f44a34798c1e9df6b2f6b6b02b7e1a7;hpb=12bcd1a617c74d6ebf1dc3711b6a85be696dc9bb;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index e44ab1c..6ed8e0a 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -80,7 +80,11 @@ extern int h_errno; # 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 @@ -92,7 +96,9 @@ extern int h_errno; struct group *getgrgid (Gid_t); # endif # ifdef HAS_GETGRENT +#ifndef getgrent struct group *getgrent (void); +#endif # endif #endif @@ -852,7 +858,7 @@ PP(pp_untie) } 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 ) ; } @@ -984,18 +990,7 @@ PP(pp_sselect) } /* little endians can use vecs directly */ -#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 -# 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 -# else +#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 # ifdef NFDBITS # ifndef NBBY @@ -1006,10 +1001,20 @@ PP(pp_sselect) # else masksize = sizeof(long); /* documented int, everyone seems to use long */ # endif - growsize = maxlen + (masksize - (maxlen % masksize)); 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); @@ -1158,7 +1163,8 @@ PP(pp_getc) RETURN; } if (!gv || do_eof(gv)) { /* make sure we have fp with something */ - if (ckWARN2(WARN_UNOPENED,WARN_CLOSED) && IoTYPE(io) != IoTYPE_WRONLY) + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED) + && (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))) report_evil_fh(gv, io, PL_op->op_type); RETPUSHUNDEF; } @@ -1357,10 +1363,10 @@ PP(pp_leavewrite) 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)) @@ -1371,7 +1377,7 @@ PP(pp_leavewrite) 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); @@ -1443,10 +1449,10 @@ PP(pp_prtf) 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)) @@ -1578,7 +1584,7 @@ PP(pp_sysread) #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; @@ -1680,10 +1686,10 @@ PP(pp_sysread) 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; @@ -2731,7 +2737,7 @@ PP(pp_stat) 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"); @@ -2760,7 +2766,7 @@ PP(pp_stat) 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; } @@ -2775,7 +2781,7 @@ PP(pp_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_ WARN_NEWLINE, PL_warn_nl, "stat"); + Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); max = 0; } } @@ -3321,7 +3327,7 @@ PP(pp_fttext) 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); @@ -3422,7 +3428,7 @@ PP(pp_chdir) ) { if( MAXARG == 1 ) - deprecate_old("chdir('') or chdir(undef) as chdir()"); + deprecate("chdir('') or chdir(undef) as chdir()"); tmps = SvPV(*svp, n_a); } else { @@ -4618,21 +4624,23 @@ PP(pp_ghostent) register char **elem; register SV *sv; #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */ - struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int); - struct hostent *PerlSock_gethostbyname(Netdb_name_t); - struct hostent *PerlSock_gethostent(void); + 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) + 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; @@ -4653,8 +4661,14 @@ PP(pp_ghostent) #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) { @@ -4727,19 +4741,21 @@ PP(pp_gnetent) register char **elem; register SV *sv; #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */ - struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int); - struct netent *PerlSock_getnetbyname(Netdb_name_t); - struct netent *PerlSock_getnetent(void); + 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) + 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; @@ -4756,6 +4772,17 @@ PP(pp_gnetent) 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()); @@ -4815,25 +4842,29 @@ PP(pp_gprotoent) register char **elem; register SV *sv; #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */ - struct protoent *PerlSock_getprotobyname(Netdb_name_t); - struct protoent *PerlSock_getprotobynumber(int); - struct protoent *PerlSock_getprotoent(void); + 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) + 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(); @@ -4898,9 +4929,9 @@ PP(pp_gservent) register char **elem; register SV *sv; #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */ - struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t); - struct servent *PerlSock_getservbyport(int, Netdb_name_t); - struct servent *PerlSock_getservent(void); + 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; @@ -5154,10 +5185,16 @@ PP(pp_gpwent) 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 @@ -5354,10 +5391,14 @@ PP(pp_ggrent) 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(); @@ -5389,12 +5430,22 @@ PP(pp_ggrent) 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;