X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=f4b08a61ccbbb1f3068fac2b4c881ec6eef971eb;hb=be3c0a43e1e6b1244032726df02a3ab450a3c4be;hp=89c39fa81996b3c67f7840aceb5197953026e37b;hpb=0dd95eb270db2cdad9a8acda96ac3a3aab8775c2;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 89c39fa..f4b08a6 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, ...) { @@ -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. @@ -2459,9 +2520,11 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) goto hard_way; # endif result = PerlProc_waitpid(pid,statusp,flags); + goto finish; #endif #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); + goto finish; #endif #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) hard_way: @@ -2476,6 +2539,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) } } #endif + finish: if (result < 0 && errno == EINTR) { PERL_ASYNC_CHECK(); } @@ -3731,6 +3795,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 @@ -3893,13 +3959,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); @@ -3964,4 +4032,250 @@ Perl_new_vstring(pTHX_ char *s, SV *sv) return s; } +#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); + unsigned short port; + int got; + + memset (&addresses, 0, sizeof (addresses)); + i = 1; + do { + 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 (PerlSock_bind (sockets[i], (struct sockaddr *) &addresses[i], + sizeof (struct sockaddr_in)) + == -1) + goto tidy_up_and_fail; + } while (i--); + + /* Now have 2 UDP sockets. Find out which port each is connected to, and + for each connect the other socket to it. */ + i = 1; + do { + 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 (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i], + sizeof (struct sockaddr_in)) == -1) + goto tidy_up_and_fail; + } while (i--); + + /* Now we have 2 sockets connected to each other. I don't trust some other + process not to have already sent a packet to us (by random) so send + a packet from each to the other. */ + i = 1; + do { + /* I'm going to send my own port number. As a short. + (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 = PerlLIO_write (sockets[i], &port, sizeof(port)); + if (got != sizeof(port)) { + if (got == -1) + goto tidy_up_and_fail; + goto abort_tidy_up_and_fail; + } + } while (i--); + + /* Packets sent. I don't trust them to have arrived though. + (As I understand it Solaris TCP stack is multithreaded. Non-blocking + connect to localhost will use a second kernel thread. In 2.6 the + first thread running the connect() returns before the second completes, + so EINPROGRESS> In 2.7 the improved stack is faster and connect() + returns 0. Poor programs have tripped up. One poor program's authors' + had a 50-1 reverse stock split. Not sure how connected these were.) + So I don't trust someone not to have an unpredictable UDP stack. + */ + + { + struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */ + int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0]; + fd_set rset; + + FD_ZERO (&rset); + FD_SET (sockets[0], &rset); + FD_SET (sockets[1], &rset); + + 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. */ + if (got == -1) + goto tidy_up_and_fail; + goto abort_tidy_up_and_fail; + } + } + + /* And the paranoia department even now doesn't trust it to have arrive + (hence MSG_DONTWAIT). Or that what arrives was sent by us. */ + { + struct sockaddr_in readfrom; + unsigned short buffer[2]; + + i = 1; + do { +#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, + (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] != (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 + || readfrom.sin_port != addresses[!i].sin_port) + goto abort_tidy_up_and_fail; + } while (i--); + } + /* My caller (my_socketpair) has validated that this is non-NULL */ + fd[0] = sockets[0]; + fd[1] = sockets[1]; + /* I hereby declare this connection open. May God bless all who cross + her. */ + return 0; + + abort_tidy_up_and_fail: + errno = ECONNABORTED; + tidy_up_and_fail: + { + int save_errno = errno; + if (sockets[0] != -1) + PerlLIO_close (sockets[0]); + if (sockets[1] != -1) + PerlLIO_close (sockets[1]); + errno = save_errno; + return -1; + } +} + +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 (or UDP). */ + dTHX; + int listener = -1; + int connector = -1; + int acceptor = -1; + struct sockaddr_in listen_addr; + struct sockaddr_in connect_addr; + Sock_size_t size; + + if (protocol +#ifdef AF_UNIX + || family != AF_UNIX +#endif + ) { + errno = EAFNOSUPPORT; + return -1; + } + if (!fd) { + errno = EINVAL; + return -1; + } + +#ifdef EMULATE_SOCKETPAIR_UDP + if (type == SOCK_DGRAM) + return S_socketpair_udp (fd); +#endif + + 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 (PerlSock_bind (listener, (struct sockaddr *) &listen_addr, sizeof (listen_addr)) + == -1) + goto tidy_up_and_fail; + if (PerlSock_listen(listener, 1) == -1) + goto tidy_up_and_fail; + + 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 (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 (PerlSock_connect(connector, (struct sockaddr *) &connect_addr, + sizeof (connect_addr)) == -1) + goto tidy_up_and_fail; + + size = sizeof (listen_addr); + 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; + PerlLIO_close (listener); + /* Now check we are talking to ourself by matching port and host on the + two sockets. */ + 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 + || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr + || listen_addr.sin_port != connect_addr.sin_port) { + goto abort_tidy_up_and_fail; + } + fd[0] = connector; + fd[1] = acceptor; + return 0; + + abort_tidy_up_and_fail: + errno = ECONNABORTED; /* I hope this is portable and appropriate. */ + tidy_up_and_fail: + { + int save_errno = errno; + if (listener != -1) + PerlLIO_close (listener); + if (connector != -1) + PerlLIO_close (connector); + if (acceptor != -1) + 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