X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=303bfa449f86743a071d02c86aa9318478c7ebf8;hb=e25f343da3028177c9933244078147e9eb57a1c3;hp=09af1de710db91985413b5ce9345635bfd476678;hpb=02fc2eeebe0e138f51e361717ee5d2258b2c13d0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 09af1de..303bfa4 100644 --- a/util.c +++ b/util.c @@ -1,6 +1,6 @@ /* util.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (c) 1991-2002, 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. @@ -30,6 +30,12 @@ # include #endif +#ifdef HAS_SELECT +# ifdef I_SYS_SELECT +# include +# endif +#endif + #define FLUSH #ifdef LEAKTEST @@ -482,6 +488,8 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit If FBMcf_TAIL, the table is created as if the string has a trailing \n. */ /* +=head1 Miscellaneous Functions + =for apidoc fbm_compile Analyses the string in order to make fast searches on it using fbm_instr() @@ -871,6 +879,8 @@ Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) /* copy a string to a safe spot */ /* +=head1 Memory Management + =for apidoc savepv Copy a string to a safe spot. This does not use an SV. @@ -881,10 +891,11 @@ Copy a string to a safe spot. This does not use an SV. char * Perl_savepv(pTHX_ const char *sv) { - register char *newaddr; - - New(902,newaddr,strlen(sv)+1,char); - (void)strcpy(newaddr,sv); + register char *newaddr = Nullch; + if (sv) { + New(902,newaddr,strlen(sv)+1,char); + (void)strcpy(newaddr,sv); + } return newaddr; } @@ -894,7 +905,8 @@ Perl_savepv(pTHX_ const char *sv) =for apidoc savepvn Copy a string to a safe spot. The C indicates number of bytes to -copy. This does not use an SV. +copy. If pointer is NULL allocate space for a string of size specified. +This does not use an SV. =cut */ @@ -905,11 +917,38 @@ Perl_savepvn(pTHX_ const char *sv, register I32 len) register char *newaddr; New(903,newaddr,len+1,char); - Copy(sv,newaddr,len,char); /* might not be null terminated */ - newaddr[len] = '\0'; /* is now */ + /* Give a meaning to NULL pointer mainly for the use in sv_magic() */ + if (sv) { + Copy(sv,newaddr,len,char); /* might not be null terminated */ + newaddr[len] = '\0'; /* is now */ + } + else { + Zero(newaddr,len+1,char); + } return newaddr; } +/* +=for apidoc savesharedpv + +Copy a string to a safe spot in memory shared between threads. +This does not use an SV. + +=cut +*/ +char * +Perl_savesharedpv(pTHX_ const char *sv) +{ + register char *newaddr = Nullch; + if (sv) { + newaddr = PerlMemShared_malloc(strlen(sv)+1); + (void)strcpy(newaddr,sv); + } + return newaddr; +} + + + /* the SV for Perl_form() and mess() is not kept in an arena */ STATIC SV * @@ -948,6 +987,26 @@ Perl_form_nocontext(const char* pat, ...) } #endif /* PERL_IMPLICIT_CONTEXT */ +/* +=head1 Miscellaneous Functions +=for apidoc form + +Takes a sprintf-style format pattern and conventional +(non-SV) arguments and returns the formatted string. + + (char *) Perl_form(pTHX_ const char* pat, ...) + +can be used any place a string (char *) is required: + + char * s = Perl_form("%d.%d",major,minor); + +Uses a single private buffer so if you want to format several strings you +must explicitly copy the earlier strings away (and free the copies when you +are done). + +=cut +*/ + char * Perl_form(pTHX_ const char* pat, ...) { @@ -1045,7 +1104,7 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) if (CopLINE(cop)) Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, - CopFILE(cop), (IV)CopLINE(cop)); + OutCopFILE(cop), (IV)CopLINE(cop)); if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) { bool line_mode = (RsSIMPLE(PL_rs) && SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n'); @@ -1260,6 +1319,8 @@ Perl_croak_nocontext(const char *pat, ...) #endif /* PERL_IMPLICIT_CONTEXT */ /* +=head1 Warning and Dieing + =for apidoc croak This is the XSUB-writer's interface to Perl's C function. @@ -1295,6 +1356,8 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) CV *cv; SV *msv; STRLEN msglen; + IO *io; + MAGIC *mg; msv = vmess(pat, args); message = SvPV(msv, msglen); @@ -1327,6 +1390,20 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) return; } } + + /* if STDERR is tied, use it instead */ + if (PL_stderrgv && (io = GvIOp(PL_stderrgv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { + dSP; ENTER; + PUSHMARK(SP); + XPUSHs(SvTIED_obj((SV*)io, mg)); + XPUSHs(sv_2mortal(newSVpvn(message, msglen))); + PUTBACK; + call_method("PRINT", G_SCALAR); + LEAVE; + return; + } + { PerlIO *serr = Perl_error_log; @@ -3432,30 +3509,32 @@ Perl_ebcdic_control(pTHX_ int ch) } #endif -/* XXX struct tm on some systems (SunOS4/BSD) contains extra (non POSIX) - * fields for which we don't have Configure support yet: - * char *tm_zone; -- abbreviation of timezone name - * long tm_gmtoff; -- offset from GMT in seconds - * To workaround core dumps from the uninitialised tm_zone we get the +/* To workaround core dumps from the uninitialised tm_zone we get the * system to give us a reasonable struct to copy. This fix means that * strftime uses the tm_zone and tm_gmtoff values returned by * localtime(time()). That should give the desired result most of the * time. But probably not always! * - * This is a temporary workaround to be removed once Configure - * support is added and NETaa14816 is considered in full. - * It does not address tzname aspects of NETaa14816. + * This does not address tzname aspects of NETaa14816. + * */ + #ifdef HAS_GNULIBC # ifndef STRUCT_TM_HASZONE # define STRUCT_TM_HASZONE # endif #endif +#ifdef STRUCT_TM_HASZONE /* Backward compat */ +# ifndef HAS_TM_TM_ZONE +# define HAS_TM_TM_ZONE +# endif +#endif + void Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ { -#ifdef STRUCT_TM_HASZONE +#ifdef HAS_TM_TM_ZONE Time_t now; (void)time(&now); Copy(localtime(&now), ptm, 1, struct tm); @@ -3734,6 +3813,8 @@ return FALSE (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) /* +=head1 Miscellaneous Functions + =for apidoc getcwd_sv Fill the sv with current working directory @@ -3896,13 +3977,15 @@ Perl_getcwd_sv(pTHX_ register SV *sv) } /* +=head1 SV Manipulation Functions + =for apidoc new_vstring Returns a pointer to the next character after the parsed vstring, as well as updating the passed in sv. - * + Function must be called like - + sv = NEWSV(92,5); s = new_vstring(s,sv); @@ -3931,35 +4014,39 @@ Perl_new_vstring(pTHX_ char *s, SV *sv) for (;;) { rev = 0; { - /* this is atoi() that tolerates underscores */ - char *end = pos; - UV mult = 1; - if ( *(s-1) == '_') { - mult = 10; - } - while (--end >= s) { - UV orev; - orev = rev; - rev += (*end - '0') * mult; - mult *= 10; - if (orev > rev && ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ WARN_OVERFLOW, - "Integer overflow in decimal number"); - } + /* this is atoi() that tolerates underscores */ + char *end = pos; + UV mult = 1; + if ( *(s-1) == '_') { + mult = 10; + } + while (--end >= s) { + UV orev; + orev = rev; + rev += (*end - '0') * mult; + mult *= 10; + if (orev > rev && ckWARN_d(WARN_OVERFLOW)) + Perl_warner(aTHX_ WARN_OVERFLOW, + "Integer overflow in decimal number"); + } } +#ifdef EBCDIC + if (rev > 0x7FFFFFFF) + Perl_croak(aTHX "In EBCDIC the v-string components cannot exceed 2147483647"); +#endif /* Append native character for the rev point */ tmpend = uvchr_to_utf8(tmpbuf, rev); sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev))) - SvUTF8_on(sv); + SvUTF8_on(sv); if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1])) - s = ++pos; + s = ++pos; else { - s = pos; - break; + s = pos; + break; } while (isDIGIT(*pos) ) - pos++; + pos++; } SvPOK_on(sv); SvREADONLY_on(sv); @@ -3967,28 +4054,33 @@ Perl_new_vstring(pTHX_ char *s, SV *sv) return s; } -#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) +#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) +# define EMULATE_SOCKETPAIR_UDP +#endif + +#ifdef EMULATE_SOCKETPAIR_UDP static int S_socketpair_udp (int fd[2]) { + dTHX; /* Fake a datagram socketpair using UDP to localhost. */ int sockets[2] = {-1, -1}; struct sockaddr_in addresses[2]; int i; Sock_size_t size = sizeof (struct sockaddr_in); - short port; + unsigned short port; int got; memset (&addresses, 0, sizeof (addresses)); i = 1; do { - sockets[i] = socket (AF_INET, SOCK_DGRAM, 0); + sockets[i] = PerlSock_socket (AF_INET, SOCK_DGRAM, PF_INET); if (sockets[i] == -1) goto tidy_up_and_fail; addresses[i].sin_family = AF_INET; addresses[i].sin_addr.s_addr = htonl (INADDR_LOOPBACK); addresses[i].sin_port = 0; /* kernel choses port. */ - if (bind (sockets[i], (struct sockaddr *) &addresses[i], + if (PerlSock_bind (sockets[i], (struct sockaddr *) &addresses[i], sizeof (struct sockaddr_in)) == -1) goto tidy_up_and_fail; @@ -3998,13 +4090,13 @@ S_socketpair_udp (int fd[2]) { for each connect the other socket to it. */ i = 1; do { - if (getsockname (sockets[i], (struct sockaddr *) &addresses[i], &size) + if (PerlSock_getsockname (sockets[i], (struct sockaddr *) &addresses[i], &size) == -1) goto tidy_up_and_fail; if (size != sizeof (struct sockaddr_in)) goto abort_tidy_up_and_fail; /* !1 is 0, !0 is 1 */ - if (connect(sockets[!i], (struct sockaddr *) &addresses[i], + if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i], sizeof (struct sockaddr_in)) == -1) goto tidy_up_and_fail; } while (i--); @@ -4018,7 +4110,7 @@ S_socketpair_udp (int fd[2]) { (Who knows if someone somewhere has sin_port as a bitfield and needs this routine. (I'm assuming crays have socketpair)) */ port = addresses[i].sin_port; - got = write (sockets[i], &port, sizeof(port)); + got = PerlLIO_write (sockets[i], &port, sizeof(port)); if (got != sizeof(port)) { if (got == -1) goto tidy_up_and_fail; @@ -4045,7 +4137,7 @@ S_socketpair_udp (int fd[2]) { FD_SET (sockets[0], &rset); FD_SET (sockets[1], &rset); - got = select (max + 1, &rset, NULL, NULL, &waitfor); + got = PerlSock_select (max + 1, &rset, NULL, NULL, &waitfor); if (got != 2 || !FD_ISSET (sockets[0], &rset) || !FD_ISSET (sockets[1], &rset)) { /* I hope this is portable and appropriate. */ @@ -4059,24 +4151,26 @@ S_socketpair_udp (int fd[2]) { (hence MSG_DONTWAIT). Or that what arrives was sent by us. */ { struct sockaddr_in readfrom; - short buffer[2]; + unsigned short buffer[2]; i = 1; do { - got = recvfrom (sockets[i], (char *) &buffer, sizeof(buffer), #ifdef MSG_DONTWAIT + got = PerlSock_recvfrom (sockets[i], (char *) &buffer, sizeof(buffer), MSG_DONTWAIT, + (struct sockaddr *) &readfrom, &size); #else + got = PerlSock_recvfrom (sockets[i], (char *) &buffer, sizeof(buffer), 0, -#endif (struct sockaddr *) &readfrom, &size); +#endif if (got == -1) goto tidy_up_and_fail; if (got != sizeof(port) || size != sizeof (struct sockaddr_in) /* Check other socket sent us its port. */ - || buffer[0] != addresses[!i].sin_port + || buffer[0] != (unsigned short) addresses[!i].sin_port /* Check kernel says we got the datagram from that socket. */ || readfrom.sin_family != addresses[!i].sin_family || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr @@ -4097,9 +4191,9 @@ S_socketpair_udp (int fd[2]) { { int save_errno = errno; if (sockets[0] != -1) - close (sockets[0]); + PerlLIO_close (sockets[0]); if (sockets[1] != -1) - close (sockets[1]); + PerlLIO_close (sockets[1]); errno = save_errno; return -1; } @@ -4108,7 +4202,8 @@ S_socketpair_udp (int fd[2]) { int Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { /* Stevens says that family must be AF_LOCAL, protocol 0. - I'm going to enforce that, then ignore it, and use TCP. */ + I'm going to enforce that, then ignore it, and use TCP (or UDP). */ + dTHX; int listener = -1; int connector = -1; int acceptor = -1; @@ -4116,52 +4211,60 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { struct sockaddr_in connect_addr; Sock_size_t size; - if (protocol || family != AF_UNIX) { + if (protocol +#ifdef AF_UNIX + || family != AF_UNIX +#endif + ) { errno = EAFNOSUPPORT; return -1; } - if (!fd) - return EINVAL; + if (!fd) { + errno = EINVAL; + return -1; + } +#ifdef EMULATE_SOCKETPAIR_UDP if (type == SOCK_DGRAM) return S_socketpair_udp (fd); +#endif - listener = socket (AF_INET, type, 0); + listener = PerlSock_socket (AF_INET, type, 0); if (listener == -1) return -1; memset (&listen_addr, 0, sizeof (listen_addr)); listen_addr.sin_family = AF_INET; listen_addr.sin_addr.s_addr = htonl (INADDR_LOOPBACK); listen_addr.sin_port = 0; /* kernel choses port. */ - if (bind (listener, (struct sockaddr *) &listen_addr, sizeof (listen_addr)) + if (PerlSock_bind (listener, (struct sockaddr *) &listen_addr, sizeof (listen_addr)) == -1) goto tidy_up_and_fail; - if (listen(listener, 1) == -1) + if (PerlSock_listen(listener, 1) == -1) goto tidy_up_and_fail; - connector = socket (AF_INET, type, 0); + connector = PerlSock_socket (AF_INET, type, 0); if (connector == -1) goto tidy_up_and_fail; /* We want to find out the port number to connect to. */ size = sizeof (connect_addr); - if (getsockname (listener, (struct sockaddr *) &connect_addr, &size) == -1) + if (PerlSock_getsockname (listener, (struct sockaddr *) &connect_addr, &size) == -1) goto tidy_up_and_fail; if (size != sizeof (connect_addr)) goto abort_tidy_up_and_fail; - if (connect(connector, (struct sockaddr *) &connect_addr, + if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr, sizeof (connect_addr)) == -1) goto tidy_up_and_fail; size = sizeof (listen_addr); - acceptor = accept (listener, (struct sockaddr *) &listen_addr, &size); + acceptor = PerlSock_accept (listener, (struct sockaddr *) &listen_addr, &size); if (acceptor == -1) goto tidy_up_and_fail; if (size != sizeof (listen_addr)) goto abort_tidy_up_and_fail; - close (listener); + PerlLIO_close (listener); /* Now check we are talking to ourself by matching port and host on the two sockets. */ - if (getsockname (connector, (struct sockaddr *) &connect_addr, &size) == -1) + if (PerlSock_getsockname (connector, (struct sockaddr *) &connect_addr, &size) == -1) goto tidy_up_and_fail; if (size != sizeof (connect_addr) || listen_addr.sin_family != connect_addr.sin_family @@ -4179,13 +4282,71 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { { int save_errno = errno; if (listener != -1) - close (listener); + PerlLIO_close (listener); if (connector != -1) - close (connector); + PerlLIO_close (connector); if (acceptor != -1) - close (acceptor); + PerlLIO_close (acceptor); errno = save_errno; return -1; } } #endif /* !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) */ +#ifdef HAS_SOCKETPAIR +/* In any case have a stub so that there's code corresponding + * to the my_socketpair in global.sym. */ +int +Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { + return socketpair(family, type, protocol, fd); +} +#endif + +/* + +=for apidoc sv_nosharing + +Dummy routine which "shares" an SV when there is no sharing module present. +Exists to avoid test for a NULL function pointer and because it could potentially warn under +some level of strict-ness. + +=cut +*/ + +void +Perl_sv_nosharing(pTHX_ SV *sv) +{ +} + +/* +=for apidoc sv_nolocking + +Dummy routine which "locks" an SV when there is no locking module present. +Exists to avoid test for a NULL function pointer and because it could potentially warn under +some level of strict-ness. + +=cut +*/ + +void +Perl_sv_nolocking(pTHX_ SV *sv) +{ +} + + +/* +=for apidoc sv_nounlocking + +Dummy routine which "unlocks" an SV when there is no locking module present. +Exists to avoid test for a NULL function pointer and because it could potentially warn under +some level of strict-ness. + +=cut +*/ + +void +Perl_sv_nounlocking(pTHX_ SV *sv) +{ +} + + +