diff --git a/Artistic b/Artistic new file mode 100644 index 0000000..5f22124 --- /dev/null +++ b/Artistic @@ -0,0 +1,131 @@ + + + + + The "Artistic License" + + Preamble + +The intent of this document is to state the conditions under which a +Package may be copied, such that the Copyright Holder maintains some +semblance of artistic control over the development of the package, +while giving the users of the package the right to use and distribute +the Package in a more-or-less customary fashion, plus the right to make +reasonable modifications. + +Definitions: + + "Package" refers to the collection of files distributed by the + Copyright Holder, and derivatives of that collection of files + created through textual modification. + + "Standard Version" refers to such a Package if it has not been + modified, or has been modified in accordance with the wishes + of the Copyright Holder as specified below. + + "Copyright Holder" is whoever is named in the copyright or + copyrights for the package. + + "You" is you, if you're thinking about copying or distributing + this Package. + + "Reasonable copying fee" is whatever you can justify on the + basis of media cost, duplication charges, time of people involved, + and so on. (You will not be required to justify it to the + Copyright Holder, but only to the computing community at large + as a market that must bear the fee.) + + "Freely Available" means that no fee is charged for the item + itself, though there may be fees involved in handling the item. + It also means that recipients of the item may redistribute it + under the same conditions they received it. + +1. You may make and give away verbatim copies of the source form of the +Standard Version of this Package without restriction, provided that you +duplicate all of the original copyright notices and associated disclaimers. + +2. You may apply bug fixes, portability fixes and other modifications +derived from the Public Domain or from the Copyright Holder. A Package +modified in such a way shall still be considered the Standard Version. + +3. You may otherwise modify your copy of this Package in any way, provided +that you insert a prominent notice in each changed file stating how and +when you changed that file, and provided that you do at least ONE of the +following: + + a) place your modifications in the Public Domain or otherwise make them + Freely Available, such as by posting said modifications to Usenet or + an equivalent medium, or placing the modifications on a major archive + site such as uunet.uu.net, or by allowing the Copyright Holder to include + your modifications in the Standard Version of the Package. + + b) use the modified Package only within your corporation or organization. + + c) rename any non-standard executables so the names do not conflict + with standard executables, which must also be provided, and provide + a separate manual page for each non-standard executable that clearly + documents how it differs from the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +4. You may distribute the programs of this Package in object code or +executable form, provided that you do at least ONE of the following: + + a) distribute a Standard Version of the executables and library files, + together with instructions (in the manual page or equivalent) on where + to get the Standard Version. + + b) accompany the distribution with the machine-readable source of + the Package with your modifications. + + c) give non-standard executables non-standard names, and clearly + document the differences in manual pages (or equivalent), together + with instructions on where to get the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +5. You may charge a reasonable copying fee for any distribution of this +Package. You may charge any fee you choose for support of this +Package. You may not charge a fee for this Package itself. However, +you may distribute this Package in aggregate with other (possibly +commercial) programs as part of a larger (possibly commercial) software +distribution provided that you do not advertise this Package as a +product of your own. You may embed this Package's interpreter within +an executable of yours (by linking); this shall be construed as a mere +form of aggregation, provided that the complete Standard Version of the +interpreter is so embedded. + +6. The scripts and library files supplied as input to or produced as +output from the programs of this Package do not automatically fall +under the copyright of this Package, but belong to whoever generated +them, and may be sold commercially, and may be aggregated with this +Package. If such scripts or library files are aggregated with this +Package via the so-called "undump" or "unexec" methods of producing a +binary executable image, then distribution of such an image shall +neither be construed as a distribution of this Package nor shall it +fall under the restrictions of Paragraphs 3 and 4, provided that you do +not represent such an executable image as a Standard Version of this +Package. + +7. C subroutines (or comparably compiled subroutines in other +languages) supplied by you and linked into this Package in order to +emulate subroutines and variables of the language defined by this +Package shall not be considered part of this Package, but are the +equivalent of input as in Paragraph 6, provided these subroutines do +not change the language in any way that would cause it to fail the +regression tests for the language. + +8. Aggregation of this Package with a commercial distribution is always +permitted provided that the use of this Package is embedded; that is, +when no overt attempt is made to make this Package's interfaces visible +to the end user of the commercial distribution. Such use shall not be +construed as a distribution of this Package. + +9. The name of the Copyright Holder may not be used to endorse or promote +products derived from this software without specific prior written permission. + +10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED +WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + + The End diff --git a/Changes b/Changes new file mode 100644 index 0000000..921caaa --- /dev/null +++ b/Changes @@ -0,0 +1,241 @@ +Revision history for Socket + +2.027 2018-01-12 16:58:47 + [BUGFIXES] + * Reimplement croak_sv (securely) for older perls (RT124063) + +2.026 2018-01-11 23:15:28 + [CHANGES] + * Add TCP_USER_TIMEOUT (RT123253) + + [BUGFIXES] + * Fix printf format specifier for STRLEN/sizeof (RT124044) + * Recognise %Config key for HAS_GAI_STRERROR (RT124044) + * Remove unused and insecure implementation of croak_sv (RT122830) + +2.025 2018-01-09 15:12:51 + [CHANGES] + * Add IPPROTO_ICMPV6 + + [BUGFIXES] + * Fix for C++11 compilers - require a space either side of + string-pasting macros (thanks Karl Williamson) + * Fix for machines lacking HAS_SOCKADDR_IN6 (RT116913) (thanks ilmari) + * Print to STDERR on test failures (RT123436) (thanks ilmari) + +2.024 2016/08/11 13:49:48 + [BUGFIXES] + * Restore back-compat to pre-2.011 behaviour on undefined port + numbers to pack_sockaddr_in(6?) - silently accept undef as zero + (RT116699) + * Warn if pack_sockaddr_un is truncating an overly long path + (mitigates but does not resolve RT116819) + +2.023 2016/08/02 14:50:50 + [CHANGES] + * Add more socket(7), ip(7) and ipv6(7) socket options from Linux + + [BUGFIXES] + * Fix skip count for abstract AF_UNIX path tests when not running on + Linux + +2.022 2016/08/01 16:02:48 + [CHANGES] + * Throw exceptions if pack/unpack sockaddr functions are passed + undefined arguments (RT116624) + + [BUGFIXES] + * Fix coverty complaint (RT111707) + +2.021 2015/11/18 17:09:13 + [CHANGES] + * Add constants for TCP fastopen (RT105155) + + [BUGFIXES] + * Respect HAS_GETHOSTBYNAME before calling gethostbyname() (RT105947) + * Fixes for inet_pton() fallback on Win32 (RT107058) + * Fix for INET_ADDRSTRLEN on AmigaOS (really!) (RT106797) + * Provide gai_strerror() fallback on platforms that lack one + (RT76091) + +2.020 2015/06/24 14:45:25 + [CHANGES] + * Provide more IPPROTO constants - IGMP, GRE, ESP, AH, SCTP + + [BUGFIXES] + * Provide an SvPVx_nolen wrapper for older perls (<5.8.8) that lack + it (RT104120) + +2.019 2015/04/29 17:05:33 + [BUGFIXES] + * Provide emulations of inet_ntop/inet_pton on MSWin32 by using + WSAStringToAddress/WSAAddressToString + +2.018 2015/02/12 13:42:41 + [BUGFIXES] + * Fix for "addr is not a string" test to use SvPOKp() before 5.18 + +2.017 2015/02/10 12:05:14 + [CHANGES] + * Added some more SO_* constants defined on Linux (thanks + Ronald van Dorp) + + [BUGFIXES] + * Remember to SvGETMAGIC in getnameinfo() (RT79557) + * Quiet some compiler warnings (RT101495, RT100736) + * Fix "Attempt to free unreferenced scalar" warnings (RT78626, et.al.) + +2.016 2014/10/08 21:53:10 + [BUGFIXES] + * Wrap configure tests in a {} block in case of C99-deficient + compilers (RT99363) + * #include so that NULL definitely exists (RT98248) + * Need to pass NI_NUMERICSERV during unit tests for some OSes not to + error (VMS) (RT98217) + +2.015 2014/08/15 23:27:07 + [BUGFIXES] + * Test multiple possibnle portnum->name lookups in case /etc/services + lacks one (RT96874) + * Stronger kill in unit-test for cygwin (RT97773) + * Don't try to assert the result of getnameinfo() to match + gethostbyaddr() or getservbyport() (RT77248) + * Ensure that 'socktype' hint is always passed to getaddrinfo during + unit-testing (RT96274) + * Fix regexp borrowed from Regexp::Common::net (RT96274) + +2.014 2014/06/01 00:09:13 + [BUGFIXES] + * Make sure to (UV)-cast arguments sprintf'ed with UVf + * Use STRUCT_OFFSET() instead of plain C99 offsetof() (RT96036) + * Fix the regexp used to filter for numeric IP addresses in + fake_getaddrinfo() (RT95758) + * Protect against getprotobyname() not being available (RT90217) + +2.013 2013/10/28 00:49:43 + [BUGFIXES] + * Unit-test bugfixes for VMS (RT89766): + + Need to pass protocol => IPPROTO_TCP to avoid SCTP as well + + Perform AI_NUMERICHOST test against non-"localhost" + + May have to set NI_NUMERICSERV flag if it fails without + (thanks Craig A. Berry) + +2.012 2013/09/03 13:20:09 + [CHANGES] + * is not needed on WinCE (RT87389) + * "#undef interface" to avoid issues from Windows' (RT87389) + +2013/07/28 +2.011 CHANGES: + * Handle FreeBSD (or other platforms) returning shorter AF_UNIX + sockaddr structures due to embedded sun_len (RT86613) + (thanks Maxime Soulé; MAXS) + +2013/06/24 +2.010 CHANGES: + * Wrap some IPTOS_* constants, which may come from + * Probe for and optionally include + * Defeat C compilers' attempts to optimise away configure-time probes + for functions that are never called + +2013/01/18 +2.009 CHANGES: + * Fix building in core by skipping check_for() as it doesn't work + there (RT82760) + +2012/12/27 +2.008 CHANGES: + * Fix uninitialised memory read (RT82119) + +2012/12/16 +2.007 CHANGES: + * Test %Config keys for definedness, not mere existence (RT79854) + * Fix missing argument in sprintf in Socket.xs (from perl.git + 5d6dfea82e1c4b6, RT82007) + +2012/08/19 +2.006 CHANGES: + * Fix AF_INET6 test skip counts in t/sockaddr.t (RT79071) + * Define mPUSHs() as it's lacking before 5.10.1 + +2012/08/16 +2.005 CHANGES: + * Have unpack_sockaddr_in{,6} return just the IP address in scalar + context + * Guard against incorrect length scalars being passed in to inet_ntop + (RT78890) + +2012/08/15 +2.004 BUGFIXES: + * Put skip() arguments the right way around in t/ip_mreq.t (RT78986) + +2012/08/15 + ** Do not use; see 2.004 ** +2.003 CHANGES: + * Added IPV6_JOIN_GROUP and IPV6_LEAVE_GROUP + * Added constants and functions required for IP multicast source + group membership + * Added TCP_NOPUSH,NOOPT,CONNECTIONTIMEOUT,INIT_CWND,SACK_ENABLE + (RT78626) + +2012/06/06 +2.002 CHANGES: + * Wrap Linux's SOCK_NONBLOCK and SOCK_CLOEXEC constants + * Added sockopt constants and structure handling functions for IPv4 + multicast (also with thanks to Christian Walde for help on MSWin32) + +2012/03/27 +2.001 CHANGES: + * Apply (modified) patch from ppisar@redhat.com to fix memory + addressing bug with Zero() - RT76067 + * Document that inet_pton() doesn't work on hostnames, only textual + addresses - RT76010 + * Ignore any existing-but-undefined hints hash members to + getaddrinfo() + +2012/03/10 +2.000 CHANGES: + * Apply (modified) patch from rurban to fix memory overflow bug with + sockaddr_un() - RT75623 + * Increase to three-digit version suffix in new major version + +2012/02/21 +1.99 CHANGES: + * Better implementation of inet_pton() that sets correct size (RT 75074) + * Added SO_DOMAIN + * More robust unit tests of address-mangling functions + +1.98 CHANGES: + * Detect presence of sockaddr_in6 and ipv6_mreq; conditionally build + pack/unpack functions on this + * Back-compatibility improvements for older perls, back as far as + 5.6.1 (thanks Zefram) + * Fix for picky compilers or platforms on which size_t doesn't + printf() correctly by %d + * Suppress some harmless compile-time warnings about unused variables + +1.97 CHANGES: + * Rewritten Makefile.PL configure-time logic to use only core's + ExtUtils::CBuilder rather than CPAN's ExtUtils::CChecker + * Fix implementation of synthesized newSVpvn_flags() to also work on + threaded 5.10.0 + * Set INSTALLDIRS=perl on perl before 5.11; required as it's + replacing a core module + +1.96 CHANGES: + * Fix Socket.t to use ok() instead of is() where required - RT73039 + * Complete rewrite of module docs; list all the constants and + functions, updated SYNOPSIS + * Added convenient Exporter tag :addrinfo for all the gai/gni-related + symbols + * Provide static synthesized newSVpvn_flags() replacement for older + Perls + * Implement getnameinfo() NIx_NOHOST and NIx_NOSERV extension flags + +1.95 CHANGES: + * Implement the remaining AI_*, EAI_* and NI_* constants from + Socket::GetAddrInfo + * Declare configure-time dependency on ExtUtils::Constants 0.23 for + when building out of core + * Initial attempt at dual-life extraction from bleadperl + diff --git a/Copying b/Copying new file mode 100644 index 0000000..32a696f --- /dev/null +++ b/Copying @@ -0,0 +1,251 @@ + + GNU GENERAL PUBLIC LICENSE + Version 1, February 1989 + + Copyright (C) 1989 Free Software Foundation, Inc. + 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The license agreements of most software companies try to keep users +at the mercy of those companies. By contrast, our General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. The +General Public License applies to the Free Software Foundation's +software and to any other program whose authors commit to using it. +You can use it for your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Specifically, the General Public License is designed to make +sure that you have the freedom to give away or sell copies of free +software, that you receive source code or can get it if you want it, +that you can change the software or use pieces of it in new free +programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of a such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must tell them their rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any program or other work which +contains a notice placed by the copyright holder saying it may be +distributed under the terms of this General Public License. The +"Program", below, refers to any such program or work, and a "work based +on the Program" means either the Program or any work containing the +Program or a portion of it, either verbatim or with modifications. Each +licensee is addressed as "you". + + 1. You may copy and distribute verbatim copies of the Program's source +code as you receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice and +disclaimer of warranty; keep intact all the notices that refer to this +General Public License and to the absence of any warranty; and give any +other recipients of the Program a copy of this General Public License +along with the Program. You may charge a fee for the physical act of +transferring a copy. + + 2. You may modify your copy or copies of the Program or any portion of +it, and copy and distribute such modifications under the terms of Paragraph +1 above, provided that you also do the following: + + a) cause the modified files to carry prominent notices stating that + you changed the files and the date of any change; and + + b) cause the whole of any work that you distribute or publish, that + in whole or in part contains the Program or any part thereof, either + with or without modifications, to be licensed at no charge to all + third parties under the terms of this General Public License (except + that you may choose to grant warranty protection to some or all + third parties, at your option). + + c) If the modified program normally reads commands interactively when + run, you must cause it, when started running for such interactive use + in the simplest and most usual way, to print or display an + announcement including an appropriate copyright notice and a notice + that there is no warranty (or else, saying that you provide a + warranty) and that users may redistribute the program under these + conditions, and telling the user how to view a copy of this General + Public License. + + d) You may charge a fee for the physical act of transferring a + copy, and you may at your option offer warranty protection in + exchange for a fee. + +Mere aggregation of another independent work with the Program (or its +derivative) on a volume of a storage or distribution medium does not bring +the other work under the scope of these terms. + + 3. You may copy and distribute the Program (or a portion or derivative of +it, under Paragraph 2) in object code or executable form under the terms of +Paragraphs 1 and 2 above provided that you also do one of the following: + + a) accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of + Paragraphs 1 and 2 above; or, + + b) accompany it with a written offer, valid for at least three + years, to give any third party free (except for a nominal charge + for the cost of distribution) a complete machine-readable copy of the + corresponding source code, to be distributed under the terms of + Paragraphs 1 and 2 above; or, + + c) accompany it with the information you received as to where the + corresponding source code may be obtained. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form alone.) + +Source code for a work means the preferred form of the work for making +modifications to it. For an executable file, complete source code means +all the source code for all modules it contains; but, as a special +exception, it need not include source code for modules which are standard +libraries that accompany the operating system on which the executable +file runs, or for standard header files or definitions files that +accompany that operating system. + + 4. You may not copy, modify, sublicense, distribute or transfer the +Program except as expressly provided under this General Public License. +Any attempt otherwise to copy, modify, sublicense, distribute or transfer +the Program is void, and will automatically terminate your rights to use +the Program under this License. However, parties who have received +copies, or rights to use copies, from you under this General Public +License will not have their licenses terminated so long as such parties +remain in full compliance. + + 5. By copying, distributing or modifying the Program (or any work based +on the Program) you indicate your acceptance of this license to do so, +and all its terms and conditions. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the original +licensor to copy, distribute or modify the Program subject to these +terms and conditions. You may not impose any further restrictions on the +recipients' exercise of the rights granted herein. + + 7. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of the license which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +the license, you may choose any version ever published by the Free Software +Foundation. + + 8. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to humanity, the best way to achieve this is to make it +free software which everyone can redistribute and change under these +terms. + + To do so, attach the following notices to the program. It is safest to +attach them to the start of each source file to most effectively convey +the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19xx name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type 'show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type 'show c' for details. + +The hypothetical commands 'show w' and 'show c' should show the +appropriate parts of the General Public License. Of course, the +commands you use may be called something other than 'show w' and 'show +c'; they could even be mouse-clicks or menu items--whatever suits your +program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + program 'Gnomovision' (a program to direct compilers to make passes + at assemblers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..998431b --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +This code was extracted from the Perl 5 core at perl 5.15.5. + +The original licence reads as follows: +----- + +This program is free software; you can redistribute it and/or modify +it under the terms of either: + + a) the GNU General Public License as published by the Free + Software Foundation; either version 1, or (at your option) any + later version, or + + b) the "Artistic License" which comes with this Kit. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either +the GNU General Public License or the Artistic License for more details. + +You should have received a copy of the Artistic License with this +Kit, in the file named "Artistic". If not, I'll be glad to provide one. + +You should also have received a copy of the GNU General Public License +along with this program in the file named "Copying". If not, write to the +Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA or visit their web page on the internet at +http://www.gnu.org/copyleft/gpl.html. + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..965b426 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,19 @@ +Artistic +Changes +Copying +LICENSE +Makefile.PL +MANIFEST +MANIFEST.SKIP +Socket.pm +Socket.xs +t/getaddrinfo.t +t/getnameinfo.t +t/ip_mreq.t +t/ipv6_mreq.t +t/sockaddr.t +t/Socket.t +t/socketpair.t +typemap +META.yml Module YAML meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..8a23b00 --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,12 @@ +\.bzr/ +\.bzrignore +blib/ +const-.*\.inc +Makefile$ +MYMETA\..* +pm_to_blib +Socket-.*\.tar\.gz +.*\.bak +.*\.bs +.*\.c +.*\.o diff --git a/META.json b/META.json new file mode 100644 index 0000000..2701a78 --- /dev/null +++ b/META.json @@ -0,0 +1,43 @@ +{ + "abstract" : "networking constants and support functions", + "author" : [ + "unknown" + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : 2 + }, + "name" : "Socket", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "configure" : { + "requires" : { + "ExtUtils::CBuilder" : "0", + "ExtUtils::Constant" : "0.23" + } + }, + "runtime" : { + "requires" : { + "perl" : "5.006001" + } + } + }, + "release_status" : "stable", + "version" : "2.027", + "x_serialization_backend" : "JSON::PP version 2.94" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..7cbfa04 --- /dev/null +++ b/META.yml @@ -0,0 +1,24 @@ +--- +abstract: 'networking constants and support functions' +author: + - unknown +build_requires: + ExtUtils::MakeMaker: '0' +configure_requires: + ExtUtils::CBuilder: '0' + ExtUtils::Constant: '0.23' +dynamic_config: 1 +generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Socket +no_index: + directory: + - t + - inc +requires: + perl: '5.006001' +version: '2.027' +x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..5eab380 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,292 @@ +#!perl +use strict; +use warnings; + +use ExtUtils::MakeMaker; +use ExtUtils::Constant 0.23 'WriteConstants'; +use Config; + +my @DEFINES; + +my $cb; +my $seq = 0; +sub check_for +{ + my %args = @_; + return if $ENV{PERL_CORE}; + return if defined $args{confkey} and defined $Config{$args{confkey}}; + + require ExtUtils::CBuilder; + $cb ||= ExtUtils::CBuilder->new( quiet => 1 ); + + my $main = $args{main} || ""; + my $header = $args{header} || ""; + + print "Checking $args{define}...\n"; + + my $file_base = "test-$seq"; $seq++; + + my $file_source = "$file_base.c"; + + { + open( my $file_source_fh, ">", $file_source ) or die "Cannot write $file_source - $!"; + print $file_source_fh <<"EOF"; +#include +#include +#ifdef WIN32 +# include +# include +#else +# include +# include +# include +# include +#endif +$header +int main(int argc, char *argv[]) + { + (void)argc; + (void)argv; + { $main } + return 0; + } +EOF + } + + my $file_obj = eval { $cb->compile( source => $file_source ) }; + unlink $file_source; + + return 0 unless defined $file_obj; + + my $file_exe = eval { $cb->link_executable( objects => $file_obj ) }; + unlink $file_obj; + + return 0 unless defined $file_exe; + + # Don't need to try running it + unlink $file_exe; + + push @DEFINES, $args{define}; +} + +sub check_for_func +{ + my %args = @_; + my $func = delete $args{func}; + check_for( %args, main => "void *p = &$func; if(p == NULL) return 1;" ); +} + +my %defines = ( + # -Dfoo func() $Config{key} + HAS_GETADDRINFO => [ "getaddrinfo", "d_getaddrinfo" ], + HAS_GETNAMEINFO => [ "getnameinfo", "d_getnameinfo" ], + HAS_GAI_STRERROR => [ "gai_strerror", "d_gai_strerror" ], + HAS_INET_ATON => [ "inet_aton", "d_inetaton" ], + HAS_INETNTOP => [ "inet_ntop", "d_inetntop" ], + HAS_INETPTON => [ "inet_pton", "d_inetpton" ], +); + +foreach my $define ( sort keys %defines ) { + my ( $func, $key ) = @{$defines{$define}}; + check_for_func( + confkey => $key, + define => $define, + func => $func + ); +} + +check_for( + confkey => "d_sockaddr_sa_len", + define => "HAS_SOCKADDR_SA_LEN", + main => "struct sockaddr sa; sa.sa_len = 0;" +); + +check_for( + confkey => "d_sockaddr_in6", + define => "HAS_SOCKADDR_IN6", + main => "struct sockaddr_in6 sin6; sin6.sin6_family = AF_INET6;" +); + +check_for( + confkey => "d_sin6_scope_id", + define => "HAS_SIN6_SCOPE_ID", + main => "struct sockaddr_in6 sin6; sin6.sin6_scope_id = 0;" +); + +check_for( + confkey => "d_ip_mreq", + define => "HAS_IP_MREQ", + main => "struct ip_mreq mreq; mreq.imr_multiaddr.s_addr = INADDR_ANY;" +); + +check_for( + confkey => "d_ip_mreq_source", + define => "HAS_IP_MREQ_SOURCE", + main => "struct ip_mreq_source mreq; mreq.imr_multiaddr.s_addr = INADDR_ANY;" +); + +check_for( + confkey => "d_ipv6_mreq", + define => "HAS_IPV6_MREQ", + main => "struct ipv6_mreq mreq; mreq.ipv6mr_interface = 0;" +); + +# TODO: Needs adding to perl5 core before importing dual-life again +check_for( + confkey => "i_netinet_ip", + define => "I_NETINET_IP", + header => "#include ", +); + +my %makefile_args; + +# Since we're providing a later version of a core module, before 5.12 the +# @INC order is wrong so we'll have to go in perl rather than site dirs +$makefile_args{INSTALLDIRS} = "perl" if $] < 5.012; + +WriteMakefile( + NAME => 'Socket', + VERSION_FROM => 'Socket.pm', + # ABSTRACT_FROM gets confused by C + ABSTRACT => 'networking constants and support functions', + ($Config{libs} =~ /(-lsocks\S*)/ ? (LIBS => [ "$1" ] ) : ()), + XSPROTOARG => '-noprototypes', # XXX remove later? + realclean => {FILES=> 'const-c.inc const-xs.inc'}, + DEFINE => join( " ", map { "-D$_" } @DEFINES ), + CONFIGURE_REQUIRES => { + 'ExtUtils::CBuilder' => 0, + 'ExtUtils::Constant' => '0.23', + }, + MIN_PERL_VERSION => '5.006001', + LICENSE => 'perl', + %makefile_args, +); +my @names = ( + qw( + AF_802 AF_AAL AF_APPLETALK AF_CCITT AF_CHAOS AF_CTF AF_DATAKIT + AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK AF_INET AF_INET6 + AF_ISO AF_KEY AF_LAST AF_LAT AF_LINK AF_MAX AF_NBS AF_NIT AF_NS AF_OSI + AF_OSINET AF_PUP AF_ROUTE AF_SNA AF_UNIX AF_UNSPEC AF_USER AF_WAN + AF_X25 + + AI_ADDRCONFIG AI_ALL AI_CANONIDN AI_CANONNAME AI_IDN + AI_IDN_ALLOW_UNASSIGNED AI_IDN_USE_STD3_ASCII_RULES AI_NUMERICHOST + AI_NUMERICSERV AI_PASSIVE AI_V4MAPPED + + EAI_ADDRFAMILY EAI_AGAIN EAI_BADFLAGS EAI_BADHINTS EAI_FAIL EAI_FAMILY + EAI_NODATA EAI_NONAME EAI_PROTOCOL EAI_SERVICE EAI_SOCKTYPE EAI_SYSTEM + + IOV_MAX + + IP_ADD_MEMBERSHIP IP_ADD_SOURCE_MEMBERSHIP IP_BIND_ADDRESS_NO_PORT + IP_DROP_MEMBERSHIP IP_DROP_SOURCE_MEMBERSHIP IP_FREEBIND IP_HDRINCL + IP_MULTICAST_ALL IP_MULTICAST_IF IP_MULTICAST_LOOP IP_MULTICAST_TTL + IP_MTU IP_MTU_DISCOVER IP_NODEFRAG IP_OPTIONS IP_RECVERR IP_RECVOPTS + IP_RECVRETOPTS IP_RETOPTS IP_TOS IP_TRANSPARENT IP_TTL + + IP_PMTUDISC_DO IP_PMTUDISC_DONT IP_PMTUDISC_PROBE IP_PMTUDISC_WANT + + IPTOS_LOWDELAY IPTOS_THROUGHPUT IPTOS_RELIABILITY IPTOS_MINCOST + + IPV6_ADDRFROM IPV6_ADD_MEMBERSHIP IPV6_DROP_MEMBERSHIP IPV6_JOIN_GROUP + IPV6_LEAVE_GROUP IPV6_MTU IPV6_MTU_DISCOVER IPV6_MULTICAST_HOPS + IPV6_MULTICAST_IF IPV6_MULTICAST_LOOP IPV6_RECVERR IPV6_ROUTER_ALERT + IPV6_UNICAST_HOPS IPV6_V6ONLY + + MSG_BCAST MSG_BTAG MSG_CTLFLAGS MSG_CTLIGNORE MSG_DONTWAIT MSG_EOF + MSG_EOR MSG_ERRQUEUE MSG_ETAG MSG_FASTOPEN MSG_FIN MSG_MAXIOVLEN + MSG_MCAST MSG_NOSIGNAL MSG_RST MSG_SYN MSG_TRUNC MSG_URG MSG_WAITALL + MSG_WIRE + + NI_DGRAM NI_IDN NI_IDN_ALLOW_UNASSIGNED NI_IDN_USE_STD3_ASCII_RULES + NI_NAMEREQD NI_NOFQDN NI_NUMERICHOST NI_NUMERICSERV + + PF_802 PF_AAL PF_APPLETALK PF_CCITT PF_CHAOS PF_CTF PF_DATAKIT + PF_DECnet PF_DLI PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_INET6 + PF_ISO PF_KEY PF_LAST PF_LAT PF_LINK PF_MAX PF_NBS PF_NIT PF_NS PF_OSI + PF_OSINET PF_PUP PF_ROUTE PF_SNA PF_UNIX PF_UNSPEC PF_USER PF_WAN + PF_X25 + + SCM_CONNECT SCM_CREDENTIALS SCM_CREDS SCM_TIMESTAMP + + SOCK_DGRAM SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM + SOCK_NONBLOCK SOCK_CLOEXEC + + SOL_SOCKET + + SOMAXCONN + + SO_ACCEPTCONN SO_ATTACH_FILTER SO_BACKLOG SO_BINDTODEVICE SO_BROADCAST + SO_BSDCOMPAT SO_BUSY_POLL SO_CHAMELEON SO_DEBUG SO_DETACH_FILTER + SO_DGRAM_ERRIND SO_DOMAIN SO_DONTLINGER SO_DONTROUTE SO_ERROR SO_FAMILY + SO_KEEPALIVE SO_LINGER SO_LOCK_FILTER SO_MARK SO_OOBINLINE SO_PASSCRED + SO_PASSIFNAME SO_PEEK_OFF SO_PEERCRED SO_PRIORITY SO_PROTOCOL + SO_PROTOTYPE SO_RCVBUF SO_RCVBUFFORCE SO_RCVLOWAT SO_RCVTIMEO + SO_REUSEADDR SO_REUSEPORT SO_RXQ_OVFL SO_SECURITY_AUTHENTICATION + SO_SECURITY_ENCRYPTION_NETWORK SO_SECURITY_ENCRYPTION_TRANSPORT + SO_SNDBUF SO_SNDBUFFORCE SO_SNDLOWAT SO_SNDTIMEO SO_STATE SO_TIMESTAMP + SO_TYPE SO_USELOOPBACK SO_XOPEN SO_XSE + + TCP_CONGESTION TCP_CONNECTIONTIMEOUT TCP_CORK TCP_DEFER_ACCEPT + TCP_FASTOPEN TCP_INFO TCP_INIT_CWND TCP_KEEPALIVE TCP_KEEPCNT + TCP_KEEPIDLE TCP_KEEPINTVL TCP_LINGER2 TCP_MAXRT TCP_MAXSEG + TCP_MD5SIG TCP_NODELAY TCP_NOOPT TCP_NOPUSH TCP_QUICKACK + TCP_SACK_ENABLE TCP_STDURG TCP_SYNCNT TCP_USER_TIMEOUT + TCP_WINDOW_CLAMP + + UIO_MAXIOV + ), + {name=>"IPPROTO_IP", type=>"IV", default=>["IV", 0]}, + {name=>"IPPROTO_IPV6", type=>"IV", default=>["IV", 41]}, + {name=>"IPPROTO_RAW", type=>"IV", default=>["IV", 255]}, + {name=>"IPPROTO_ICMP", type=>"IV", default=>["IV", 1]}, + {name=>"IPPROTO_IGMP", type=>"IV", default=>["IV", 2]}, + {name=>"IPPROTO_TCP", type=>"IV", default=>["IV", 6]}, + {name=>"IPPROTO_UDP", type=>"IV", default=>["IV", 17]}, + {name=>"IPPROTO_GRE", type=>"IV", default=>["IV", 47]}, + {name=>"IPPROTO_ESP", type=>"IV", default=>["IV", 50]}, + {name=>"IPPROTO_AH", type=>"IV", default=>["IV", 51]}, + {name=>"IPPROTO_ICMPV6", type=>"IV", default=>["IV", 58]}, + {name=>"IPPROTO_SCTP", type=>"IV", default=>["IV", 132]}, + {name=>"SHUT_RD", type=>"IV", default=>["IV", "0"]}, + {name=>"SHUT_WR", type=>"IV", default=>["IV", "1"]}, + {name=>"SHUT_RDWR", type=>"IV", default=>["IV", "2"]}, +); + +push @names, { + name => $_, + type => "IV", + macro => [ "#if defined($_) || defined(HAS_$_) /* might be an enum */\n", + "#endif\n" ] +} foreach qw (MSG_CTRUNC MSG_DONTROUTE MSG_OOB MSG_PEEK MSG_PROXY SCM_RIGHTS); + +push @names, { + name => $_, + type => "SV", + pre => "struct in_addr ip_address; ip_address.s_addr = htonl($_);", + value => "newSVpvn_flags((char *)&ip_address,sizeof(ip_address), SVs_TEMP)", +} foreach qw(INADDR_ANY INADDR_LOOPBACK INADDR_NONE INADDR_BROADCAST); + +push @names, { + name => $_, + type => "SV", + macro => [ "#ifdef ${_}_INIT\n", + "#endif\n" ], + pre => "struct in6_addr ip6_address = ${_}_INIT;", + value => "newSVpvn_flags((char *)&ip6_address,sizeof(ip6_address), SVs_TEMP)", +} foreach qw(IN6ADDR_ANY IN6ADDR_LOOPBACK); + +# Work around an old Perl core bug that affects ExtUtils::Constants on +# pre-5.8.2 Perls. EU:C should be amended to work around this itself. +if("$]" < 5.008002) { + require ExtUtils::Constant::ProxySubs; + no warnings "once"; + $ExtUtils::Constant::ProxySubs::type_to_C_value{$_} = sub { () } + foreach qw(YES NO UNDEF), ""; +} + +WriteConstants( + PROXYSUBS => {autoload => 1}, + NAME => 'Socket', + NAMES => \@names, +); diff --git a/Socket.pm b/Socket.pm new file mode 100644 index 0000000..370deef --- /dev/null +++ b/Socket.pm @@ -0,0 +1,1138 @@ +package Socket; + +use strict; +{ use 5.006001; } + +our $VERSION = '2.027'; + +=head1 NAME + +C - networking constants and support functions + +=head1 SYNOPSIS + +C a low-level module used by, among other things, the L +family of modules. The following examples demonstrate some low-level uses but +a practical program would likely use the higher-level API provided by +C or similar instead. + + use Socket qw(PF_INET SOCK_STREAM pack_sockaddr_in inet_aton); + + socket(my $socket, PF_INET, SOCK_STREAM, 0) + or die "socket: $!"; + + my $port = getservbyname "echo", "tcp"; + connect($socket, pack_sockaddr_in($port, inet_aton("localhost"))) + or die "connect: $!"; + + print $socket "Hello, world!\n"; + print <$socket>; + +See also the L section. + +=head1 DESCRIPTION + +This module provides a variety of constants, structure manipulators and other +functions related to socket-based networking. The values and functions +provided are useful when used in conjunction with Perl core functions such as +socket(), setsockopt() and bind(). It also provides several other support +functions, mostly for dealing with conversions of network addresses between +human-readable and native binary forms, and for hostname resolver operations. + +Some constants and functions are exported by default by this module; but for +backward-compatibility any recently-added symbols are not exported by default +and must be requested explicitly. When an import list is provided to the +C line, the default exports are not automatically imported. It is +therefore best practice to always to explicitly list all the symbols required. + +Also, some common socket "newline" constants are provided: the constants +C, C, and C, as well as C<$CR>, C<$LF>, and C<$CRLF>, which map +to C<\015>, C<\012>, and C<\015\012>. If you do not want to use the literal +characters in your programs, then use the constants provided here. They are +not exported by default, but can be imported individually, and with the +C<:crlf> export tag: + + use Socket qw(:DEFAULT :crlf); + + $sock->print("GET / HTTP/1.0$CRLF"); + +The entire getaddrinfo() subsystem can be exported using the tag C<:addrinfo>; +this exports the getaddrinfo() and getnameinfo() functions, and all the +C, C, C and C constants. + +=cut + +=head1 CONSTANTS + +In each of the following groups, there may be many more constants provided +than just the ones given as examples in the section heading. If the heading +ends C<...> then this means there are likely more; the exact constants +provided will depend on the OS and headers found at compile-time. + +=cut + +=head2 PF_INET, PF_INET6, PF_UNIX, ... + +Protocol family constants to use as the first argument to socket() or the +value of the C or C socket option. + +=head2 AF_INET, AF_INET6, AF_UNIX, ... + +Address family constants used by the socket address structures, to pass to +such functions as inet_pton() or getaddrinfo(), or are returned by such +functions as sockaddr_family(). + +=head2 SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, ... + +Socket type constants to use as the second argument to socket(), or the value +of the C socket option. + +=head2 SOCK_NONBLOCK. SOCK_CLOEXEC + +Linux-specific shortcuts to specify the C and C flags +during a C call. + + socket( my $sockh, PF_INET, SOCK_DGRAM|SOCK_NONBLOCK, 0 ) + +=head2 SOL_SOCKET + +Socket option level constant for setsockopt() and getsockopt(). + +=head2 SO_ACCEPTCONN, SO_BROADCAST, SO_ERROR, ... + +Socket option name constants for setsockopt() and getsockopt() at the +C level. + +=head2 IP_OPTIONS, IP_TOS, IP_TTL, ... + +Socket option name constants for IPv4 socket options at the C +level. + +=head2 IP_PMTUDISC_WANT, IP_PMTUDISC_DONT, ... + +Socket option value contants for C socket option. + +=head2 IPTOS_LOWDELAY, IPTOS_THROUGHPUT, IPTOS_RELIABILITY, ... + +Socket option value constants for C socket option. + +=head2 MSG_BCAST, MSG_OOB, MSG_TRUNC, ... + +Message flag constants for send() and recv(). + +=head2 SHUT_RD, SHUT_RDWR, SHUT_WR + +Direction constants for shutdown(). + +=head2 INADDR_ANY, INADDR_BROADCAST, INADDR_LOOPBACK, INADDR_NONE + +Constants giving the special C addresses for wildcard, broadcast, +local loopback, and invalid addresses. + +Normally equivalent to inet_aton('0.0.0.0'), inet_aton('255.255.255.255'), +inet_aton('localhost') and inet_aton('255.255.255.255') respectively. + +=head2 IPPROTO_IP, IPPROTO_IPV6, IPPROTO_TCP, ... + +IP protocol constants to use as the third argument to socket(), the level +argument to getsockopt() or setsockopt(), or the value of the C +socket option. + +=head2 TCP_CORK, TCP_KEEPALIVE, TCP_NODELAY, ... + +Socket option name constants for TCP socket options at the C +level. + +=head2 IN6ADDR_ANY, IN6ADDR_LOOPBACK + +Constants giving the special C addresses for wildcard and local +loopback. + +Normally equivalent to inet_pton(AF_INET6, "::") and +inet_pton(AF_INET6, "::1") respectively. + +=head2 IPV6_ADD_MEMBERSHIP, IPV6_MTU, IPV6_V6ONLY, ... + +Socket option name constants for IPv6 socket options at the C +level. + +=cut + +# Still undocumented: SCM_*, SOMAXCONN, IOV_MAX, UIO_MAXIOV + +=head1 STRUCTURE MANIPULATORS + +The following functions convert between lists of Perl values and packed binary +strings representing structures. + +=cut + +=head2 $family = sockaddr_family $sockaddr + +Takes a packed socket address (as returned by pack_sockaddr_in(), +pack_sockaddr_un() or the perl builtin functions getsockname() and +getpeername()). Returns the address family tag. This will be one of the +C constants, such as C for a C addresses or +C for a C. It can be used to figure out what unpack to +use for a sockaddr of unknown type. + +=head2 $sockaddr = pack_sockaddr_in $port, $ip_address + +Takes two arguments, a port number and an opaque string (as returned by +inet_aton(), or a v-string). Returns the C structure with those +arguments packed in and C filled in. For Internet domain sockets, +this structure is normally what you need for the arguments in bind(), +connect(), and send(). + +An undefined $port argument is taken as zero; an undefined $ip_address is +considered a fatal error. + +=head2 ($port, $ip_address) = unpack_sockaddr_in $sockaddr + +Takes a C structure (as returned by pack_sockaddr_in(), +getpeername() or recv()). Returns a list of two elements: the port and an +opaque string representing the IP address (you can use inet_ntoa() to convert +the address to the four-dotted numeric format). Will croak if the structure +does not represent an C address. + +In scalar context will return just the IP address. + +=head2 $sockaddr = sockaddr_in $port, $ip_address + +=head2 ($port, $ip_address) = sockaddr_in $sockaddr + +A wrapper of pack_sockaddr_in() or unpack_sockaddr_in(). In list context, +unpacks its argument and returns a list consisting of the port and IP address. +In scalar context, packs its port and IP address arguments as a C +and returns it. + +Provided largely for legacy compatibility; it is better to use +pack_sockaddr_in() or unpack_sockaddr_in() explicitly. + +=head2 $sockaddr = pack_sockaddr_in6 $port, $ip6_address, [$scope_id, [$flowinfo]] + +Takes two to four arguments, a port number, an opaque string (as returned by +inet_pton()), optionally a scope ID number, and optionally a flow label +number. Returns the C structure with those arguments packed in +and C filled in. IPv6 equivalent of pack_sockaddr_in(). + +An undefined $port argument is taken as zero; an undefined $ip6_address is +considered a fatal error. + +=head2 ($port, $ip6_address, $scope_id, $flowinfo) = unpack_sockaddr_in6 $sockaddr + +Takes a C structure. Returns a list of four elements: the port +number, an opaque string representing the IPv6 address, the scope ID, and the +flow label. (You can use inet_ntop() to convert the address to the usual +string format). Will croak if the structure does not represent an C +address. + +In scalar context will return just the IP address. + +=head2 $sockaddr = sockaddr_in6 $port, $ip6_address, [$scope_id, [$flowinfo]] + +=head2 ($port, $ip6_address, $scope_id, $flowinfo) = sockaddr_in6 $sockaddr + +A wrapper of pack_sockaddr_in6() or unpack_sockaddr_in6(). In list context, +unpacks its argument according to unpack_sockaddr_in6(). In scalar context, +packs its arguments according to pack_sockaddr_in6(). + +Provided largely for legacy compatibility; it is better to use +pack_sockaddr_in6() or unpack_sockaddr_in6() explicitly. + +=head2 $sockaddr = pack_sockaddr_un $path + +Takes one argument, a pathname. Returns the C structure with that +path packed in with C filled in. For C sockets, this +structure is normally what you need for the arguments in bind(), connect(), +and send(). + +=head2 ($path) = unpack_sockaddr_un $sockaddr + +Takes a C structure (as returned by pack_sockaddr_un(), +getpeername() or recv()). Returns a list of one element: the pathname. Will +croak if the structure does not represent an C address. + +=head2 $sockaddr = sockaddr_un $path + +=head2 ($path) = sockaddr_un $sockaddr + +A wrapper of pack_sockaddr_un() or unpack_sockaddr_un(). In a list context, +unpacks its argument and returns a list consisting of the pathname. In a +scalar context, packs its pathname as a C and returns it. + +Provided largely for legacy compatibility; it is better to use +pack_sockaddr_un() or unpack_sockaddr_un() explicitly. + +These are only supported if your system has EFE. + +=head2 $ip_mreq = pack_ip_mreq $multiaddr, $interface + +Takes an IPv4 multicast address and optionally an interface address (or +C). Returns the C structure with those arguments packed +in. Suitable for use with the C and C +sockopts. + +=head2 ($multiaddr, $interface) = unpack_ip_mreq $ip_mreq + +Takes an C structure. Returns a list of two elements; the IPv4 +multicast address and interface address. + +=head2 $ip_mreq_source = pack_ip_mreq_source $multiaddr, $source, $interface + +Takes an IPv4 multicast address, source address, and optionally an interface +address (or C). Returns the C structure with those +arguments packed in. Suitable for use with the C +and C sockopts. + +=head2 ($multiaddr, $source, $interface) = unpack_ip_mreq_source $ip_mreq + +Takes an C structure. Returns a list of three elements; the +IPv4 multicast address, source address and interface address. + +=head2 $ipv6_mreq = pack_ipv6_mreq $multiaddr6, $ifindex + +Takes an IPv6 multicast address and an interface number. Returns the +C structure with those arguments packed in. Suitable for use with +the C and C sockopts. + +=head2 ($multiaddr6, $ifindex) = unpack_ipv6_mreq $ipv6_mreq + +Takes an C structure. Returns a list of two elements; the IPv6 +address and an interface number. + +=cut + +=head1 FUNCTIONS + +=cut + +=head2 $ip_address = inet_aton $string + +Takes a string giving the name of a host, or a textual representation of an IP +address and translates that to an packed binary address structure suitable to +pass to pack_sockaddr_in(). If passed a hostname that cannot be resolved, +returns C. For multi-homed hosts (hosts with more than one address), +the first address found is returned. + +For portability do not assume that the result of inet_aton() is 32 bits wide, +in other words, that it would contain only the IPv4 address in network order. + +This IPv4-only function is provided largely for legacy reasons. Newly-written +code should use getaddrinfo() or inet_pton() instead for IPv6 support. + +=head2 $string = inet_ntoa $ip_address + +Takes a packed binary address structure such as returned by +unpack_sockaddr_in() (or a v-string representing the four octets of the IPv4 +address in network order) and translates it into a string of the form +C where the Cs are numbers less than 256 (the normal +human-readable four dotted number notation for Internet addresses). + +This IPv4-only function is provided largely for legacy reasons. Newly-written +code should use getnameinfo() or inet_ntop() instead for IPv6 support. + +=head2 $address = inet_pton $family, $string + +Takes an address family (such as C or C) and a string +containing a textual representation of an address in that family and +translates that to an packed binary address structure. + +See also getaddrinfo() for a more powerful and flexible function to look up +socket addresses given hostnames or textual addresses. + +=head2 $string = inet_ntop $family, $address + +Takes an address family and a packed binary address structure and translates +it into a human-readable textual representation of the address; typically in +C form for C or C form for C. + +See also getnameinfo() for a more powerful and flexible function to turn +socket addresses into human-readable textual representations. + +=head2 ($err, @result) = getaddrinfo $host, $service, [$hints] + +Given both a hostname and service name, this function attempts to resolve the +host name into a list of network addresses, and the service name into a +protocol and port number, and then returns a list of address structures +suitable to connect() to it. + +Given just a host name, this function attempts to resolve it to a list of +network addresses, and then returns a list of address structures giving these +addresses. + +Given just a service name, this function attempts to resolve it to a protocol +and port number, and then returns a list of address structures that represent +it suitable to bind() to. This use should be combined with the C +flag; see below. + +Given neither name, it generates an error. + +If present, $hints should be a reference to a hash, where the following keys +are recognised: + +=over 4 + +=item flags => INT + +A bitfield containing C constants; see below. + +=item family => INT + +Restrict to only generating addresses in this address family + +=item socktype => INT + +Restrict to only generating addresses of this socket type + +=item protocol => INT + +Restrict to only generating addresses for this protocol + +=back + +The return value will be a list; the first value being an error indication, +followed by a list of address structures (if no error occurred). + +The error value will be a dualvar; comparable to the C error constants, +or printable as a human-readable error message string. If no error occurred it +will be zero numerically and an empty string. + +Each value in the results list will be a hash reference containing the following +fields: + +=over 4 + +=item family => INT + +The address family (e.g. C) + +=item socktype => INT + +The socket type (e.g. C) + +=item protocol => INT + +The protocol (e.g. C) + +=item addr => STRING + +The address in a packed string (such as would be returned by +pack_sockaddr_in()) + +=item canonname => STRING + +The canonical name for the host if the C flag was provided, or +C otherwise. This field will only be present on the first returned +address. + +=back + +The following flag constants are recognised in the $hints hash. Other flag +constants may exist as provided by the OS. + +=over 4 + +=item AI_PASSIVE + +Indicates that this resolution is for a local bind() for a passive (i.e. +listening) socket, rather than an active (i.e. connecting) socket. + +=item AI_CANONNAME + +Indicates that the caller wishes the canonical hostname (C) field +of the result to be filled in. + +=item AI_NUMERICHOST + +Indicates that the caller will pass a numeric address, rather than a hostname, +and that getaddrinfo() must not perform a resolve operation on this name. This +flag will prevent a possibly-slow network lookup operation, and instead return +an error if a hostname is passed. + +=back + +=head2 ($err, $hostname, $servicename) = getnameinfo $sockaddr, [$flags, [$xflags]] + +Given a packed socket address (such as from getsockname(), getpeername(), or +returned by getaddrinfo() in a C field), returns the hostname and +symbolic service name it represents. $flags may be a bitmask of C +constants, or defaults to 0 if unspecified. + +The return value will be a list; the first value being an error condition, +followed by the hostname and service name. + +The error value will be a dualvar; comparable to the C error constants, +or printable as a human-readable error message string. The host and service +names will be plain strings. + +The following flag constants are recognised as $flags. Other flag constants may +exist as provided by the OS. + +=over 4 + +=item NI_NUMERICHOST + +Requests that a human-readable string representation of the numeric address be +returned directly, rather than performing a name resolve operation that may +convert it into a hostname. This will also avoid potentially-blocking network +IO. + +=item NI_NUMERICSERV + +Requests that the port number be returned directly as a number representation +rather than performing a name resolve operation that may convert it into a +service name. + +=item NI_NAMEREQD + +If a name resolve operation fails to provide a name, then this flag will cause +getnameinfo() to indicate an error, rather than returning the numeric +representation as a human-readable string. + +=item NI_DGRAM + +Indicates that the socket address relates to a C socket, for the +services whose name differs between TCP and UDP protocols. + +=back + +The following constants may be supplied as $xflags. + +=over 4 + +=item NIx_NOHOST + +Indicates that the caller is not interested in the hostname of the result, so +it does not have to be converted. C will be returned as the hostname. + +=item NIx_NOSERV + +Indicates that the caller is not interested in the service name of the result, +so it does not have to be converted. C will be returned as the service +name. + +=back + +=head1 getaddrinfo() / getnameinfo() ERROR CONSTANTS + +The following constants may be returned by getaddrinfo() or getnameinfo(). +Others may be provided by the OS. + +=over 4 + +=item EAI_AGAIN + +A temporary failure occurred during name resolution. The operation may be +successful if it is retried later. + +=item EAI_BADFLAGS + +The value of the C hint to getaddrinfo(), or the $flags parameter to +getnameinfo() contains unrecognised flags. + +=item EAI_FAMILY + +The C hint to getaddrinfo(), or the family of the socket address +passed to getnameinfo() is not supported. + +=item EAI_NODATA + +The host name supplied to getaddrinfo() did not provide any usable address +data. + +=item EAI_NONAME + +The host name supplied to getaddrinfo() does not exist, or the address +supplied to getnameinfo() is not associated with a host name and the +C flag was supplied. + +=item EAI_SERVICE + +The service name supplied to getaddrinfo() is not available for the socket +type given in the $hints. + +=back + +=cut + +=head1 EXAMPLES + +=head2 Lookup for connect() + +The getaddrinfo() function converts a hostname and a service name into a list +of structures, each containing a potential way to connect() to the named +service on the named host. + + use IO::Socket; + use Socket qw(SOCK_STREAM getaddrinfo); + + my %hints = (socktype => SOCK_STREAM); + my ($err, @res) = getaddrinfo("localhost", "echo", \%hints); + die "Cannot getaddrinfo - $err" if $err; + + my $sock; + + foreach my $ai (@res) { + my $candidate = IO::Socket->new(); + + $candidate->socket($ai->{family}, $ai->{socktype}, $ai->{protocol}) + or next; + + $candidate->connect($ai->{addr}) + or next; + + $sock = $candidate; + last; + } + + die "Cannot connect to localhost:echo" unless $sock; + + $sock->print("Hello, world!\n"); + print <$sock>; + +Because a list of potential candidates is returned, the C loop tries +each in turn until it finds one that succeeds both the socket() and connect() +calls. + +This function performs the work of the legacy functions gethostbyname(), +getservbyname(), inet_aton() and pack_sockaddr_in(). + +In practice this logic is better performed by L. + +=head2 Making a human-readable string out of an address + +The getnameinfo() function converts a socket address, such as returned by +getsockname() or getpeername(), into a pair of human-readable strings +representing the address and service name. + + use IO::Socket::IP; + use Socket qw(getnameinfo); + + my $server = IO::Socket::IP->new(LocalPort => 12345, Listen => 1) or + die "Cannot listen - $@"; + + my $socket = $server->accept or die "accept: $!"; + + my ($err, $hostname, $servicename) = getnameinfo($socket->peername); + die "Cannot getnameinfo - $err" if $err; + + print "The peer is connected from $hostname\n"; + +Since in this example only the hostname was used, the redundant conversion of +the port number into a service name may be omitted by passing the +C flag. + + use Socket qw(getnameinfo NIx_NOSERV); + + my ($err, $hostname) = getnameinfo($socket->peername, 0, NIx_NOSERV); + +This function performs the work of the legacy functions unpack_sockaddr_in(), +inet_ntoa(), gethostbyaddr() and getservbyport(). + +In practice this logic is better performed by L. + +=head2 Resolving hostnames into IP addresses + +To turn a hostname into a human-readable plain IP address use getaddrinfo() +to turn the hostname into a list of socket structures, then getnameinfo() on +each one to make it a readable IP address again. + + use Socket qw(:addrinfo SOCK_RAW); + + my ($err, @res) = getaddrinfo($hostname, "", {socktype => SOCK_RAW}); + die "Cannot getaddrinfo - $err" if $err; + + while( my $ai = shift @res ) { + my ($err, $ipaddr) = getnameinfo($ai->{addr}, NI_NUMERICHOST, NIx_NOSERV); + die "Cannot getnameinfo - $err" if $err; + + print "$ipaddr\n"; + } + +The C hint to getaddrinfo() filters the results to only include one +socket type and protocol. Without this most OSes return three combinations, +for C, C and C, resulting in triplicate +output of addresses. The C flag to getnameinfo() causes it to +return a string-formatted plain IP address, rather than reverse resolving it +back into a hostname. + +This combination performs the work of the legacy functions gethostbyname() +and inet_ntoa(). + +=head2 Accessing socket options + +The many C and other constants provide the socket option names for +getsockopt() and setsockopt(). + + use IO::Socket::INET; + use Socket qw(SOL_SOCKET SO_RCVBUF IPPROTO_IP IP_TTL); + + my $socket = IO::Socket::INET->new(LocalPort => 0, Proto => 'udp') + or die "Cannot create socket: $@"; + + $socket->setsockopt(SOL_SOCKET, SO_RCVBUF, 64*1024) or + die "setsockopt: $!"; + + print "Receive buffer is ", $socket->getsockopt(SOL_SOCKET, SO_RCVBUF), + " bytes\n"; + + print "IP TTL is ", $socket->getsockopt(IPPROTO_IP, IP_TTL), "\n"; + +As a convenience, L's setsockopt() method will convert a number +into a packed byte buffer, and getsockopt() will unpack a byte buffer of the +correct size back into a number. + +=cut + +=head1 AUTHOR + +This module was originally maintained in Perl core by the Perl 5 Porters. + +It was extracted to dual-life on CPAN at version 1.95 by +Paul Evans + +=cut + +use Carp; +use warnings::register; + +require Exporter; +require XSLoader; +our @ISA = qw(Exporter); + +# <@Nicholas> you can't change @EXPORT without breaking the implicit API +# Please put any new constants in @EXPORT_OK! + +# List re-ordered to match documentation above. Try to keep the ordering +# consistent so it's easier to see which ones are or aren't documented. +our @EXPORT = qw( + PF_802 PF_AAL PF_APPLETALK PF_CCITT PF_CHAOS PF_CTF PF_DATAKIT + PF_DECnet PF_DLI PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_INET6 + PF_ISO PF_KEY PF_LAST PF_LAT PF_LINK PF_MAX PF_NBS PF_NIT PF_NS PF_OSI + PF_OSINET PF_PUP PF_ROUTE PF_SNA PF_UNIX PF_UNSPEC PF_USER PF_WAN + PF_X25 + + AF_802 AF_AAL AF_APPLETALK AF_CCITT AF_CHAOS AF_CTF AF_DATAKIT + AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK AF_INET AF_INET6 + AF_ISO AF_KEY AF_LAST AF_LAT AF_LINK AF_MAX AF_NBS AF_NIT AF_NS AF_OSI + AF_OSINET AF_PUP AF_ROUTE AF_SNA AF_UNIX AF_UNSPEC AF_USER AF_WAN + AF_X25 + + SOCK_DGRAM SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM + + SOL_SOCKET + + SO_ACCEPTCONN SO_ATTACH_FILTER SO_BACKLOG SO_BROADCAST SO_CHAMELEON + SO_DEBUG SO_DETACH_FILTER SO_DGRAM_ERRIND SO_DOMAIN SO_DONTLINGER + SO_DONTROUTE SO_ERROR SO_FAMILY SO_KEEPALIVE SO_LINGER SO_OOBINLINE + SO_PASSCRED SO_PASSIFNAME SO_PEERCRED SO_PROTOCOL SO_PROTOTYPE + SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO SO_REUSEADDR SO_REUSEPORT + SO_SECURITY_AUTHENTICATION SO_SECURITY_ENCRYPTION_NETWORK + SO_SECURITY_ENCRYPTION_TRANSPORT SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO + SO_STATE SO_TYPE SO_USELOOPBACK SO_XOPEN SO_XSE + + IP_HDRINCL IP_OPTIONS IP_RECVOPTS IP_RECVRETOPTS IP_RETOPTS IP_TOS + IP_TTL + + MSG_BCAST MSG_BTAG MSG_CTLFLAGS MSG_CTLIGNORE MSG_CTRUNC MSG_DONTROUTE + MSG_DONTWAIT MSG_EOF MSG_EOR MSG_ERRQUEUE MSG_ETAG MSG_FASTOPEN MSG_FIN + MSG_MAXIOVLEN MSG_MCAST MSG_NOSIGNAL MSG_OOB MSG_PEEK MSG_PROXY MSG_RST + MSG_SYN MSG_TRUNC MSG_URG MSG_WAITALL MSG_WIRE + + SHUT_RD SHUT_RDWR SHUT_WR + + INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE + + SCM_CONNECT SCM_CREDENTIALS SCM_CREDS SCM_RIGHTS SCM_TIMESTAMP + + SOMAXCONN + + IOV_MAX + UIO_MAXIOV + + sockaddr_family + pack_sockaddr_in unpack_sockaddr_in sockaddr_in + pack_sockaddr_in6 unpack_sockaddr_in6 sockaddr_in6 + pack_sockaddr_un unpack_sockaddr_un sockaddr_un + + inet_aton inet_ntoa +); + +# List re-ordered to match documentation above. Try to keep the ordering +# consistent so it's easier to see which ones are or aren't documented. +our @EXPORT_OK = qw( + CR LF CRLF $CR $LF $CRLF + + SOCK_NONBLOCK SOCK_CLOEXEC + + IP_ADD_MEMBERSHIP IP_ADD_SOURCE_MEMBERSHIP IP_BIND_ADDRESS_NO_PORT + IP_DROP_MEMBERSHIP IP_DROP_SOURCE_MEMBERSHIP IP_FREEBIND + IP_MULTICAST_ALL IP_MULTICAST_IF IP_MULTICAST_LOOP IP_MULTICAST_TTL + IP_MTU IP_MTU_DISCOVER IP_NODEFRAG IP_RECVERR IP_TRANSPARENT + + IPPROTO_IP IPPROTO_IPV6 IPPROTO_RAW IPPROTO_ICMP IPPROTO_IGMP + IPPROTO_TCP IPPROTO_UDP IPPROTO_GRE IPPROTO_ESP IPPROTO_AH + IPPROTO_ICMPV6 IPPROTO_SCTP + + IP_PMTUDISC_DO IP_PMTUDISC_DONT IP_PMTUDISC_PROBE IP_PMTUDISC_WANT + + IPTOS_LOWDELAY IPTOS_THROUGHPUT IPTOS_RELIABILITY IPTOS_MINCOST + + TCP_CONGESTION TCP_CONNECTIONTIMEOUT TCP_CORK TCP_DEFER_ACCEPT + TCP_FASTOPEN TCP_INFO TCP_INIT_CWND TCP_KEEPALIVE TCP_KEEPCNT + TCP_KEEPIDLE TCP_KEEPINTVL TCP_LINGER2 TCP_MAXRT TCP_MAXSEG + TCP_MD5SIG TCP_NODELAY TCP_NOOPT TCP_NOPUSH TCP_QUICKACK + TCP_SACK_ENABLE TCP_STDURG TCP_SYNCNT TCP_USER_TIMEOUT + TCP_WINDOW_CLAMP + + IN6ADDR_ANY IN6ADDR_LOOPBACK + + IPV6_ADDRFROM IPV6_ADD_MEMBERSHIP IPV6_DROP_MEMBERSHIP IPV6_JOIN_GROUP + IPV6_LEAVE_GROUP IPV6_MTU IPV6_MTU_DISCOVER IPV6_MULTICAST_HOPS + IPV6_MULTICAST_IF IPV6_MULTICAST_LOOP IPV6_RECVERR IPV6_ROUTER_ALERT + IPV6_UNICAST_HOPS IPV6_V6ONLY + + SO_LOCK_FILTER SO_RCVBUFFORCE SO_SNDBUFFORCE + + pack_ip_mreq unpack_ip_mreq pack_ip_mreq_source unpack_ip_mreq_source + + pack_ipv6_mreq unpack_ipv6_mreq + + inet_pton inet_ntop + + getaddrinfo getnameinfo + + AI_ADDRCONFIG AI_ALL AI_CANONIDN AI_CANONNAME AI_IDN + AI_IDN_ALLOW_UNASSIGNED AI_IDN_USE_STD3_ASCII_RULES AI_NUMERICHOST + AI_NUMERICSERV AI_PASSIVE AI_V4MAPPED + + NI_DGRAM NI_IDN NI_IDN_ALLOW_UNASSIGNED NI_IDN_USE_STD3_ASCII_RULES + NI_NAMEREQD NI_NOFQDN NI_NUMERICHOST NI_NUMERICSERV + + NIx_NOHOST NIx_NOSERV + + EAI_ADDRFAMILY EAI_AGAIN EAI_BADFLAGS EAI_BADHINTS EAI_FAIL EAI_FAMILY + EAI_NODATA EAI_NONAME EAI_PROTOCOL EAI_SERVICE EAI_SOCKTYPE EAI_SYSTEM +); + +our %EXPORT_TAGS = ( + crlf => [qw(CR LF CRLF $CR $LF $CRLF)], + addrinfo => [qw(getaddrinfo getnameinfo), grep m/^(?:AI|NI|NIx|EAI)_/, @EXPORT_OK], + all => [@EXPORT, @EXPORT_OK], +); + +BEGIN { + sub CR () {"\015"} + sub LF () {"\012"} + sub CRLF () {"\015\012"} + + # These are not gni() constants; they're extensions for the perl API + # The definitions in Socket.pm and Socket.xs must match + sub NIx_NOHOST() {1 << 0} + sub NIx_NOSERV() {1 << 1} +} + +*CR = \CR(); +*LF = \LF(); +*CRLF = \CRLF(); + +sub sockaddr_in { + if (@_ == 6 && !wantarray) { # perl5.001m compat; use this && die + my($af, $port, @quad) = @_; + warnings::warn "6-ARG sockaddr_in call is deprecated" + if warnings::enabled(); + pack_sockaddr_in($port, inet_aton(join('.', @quad))); + } elsif (wantarray) { + croak "usage: (port,iaddr) = sockaddr_in(sin_sv)" unless @_ == 1; + unpack_sockaddr_in(@_); + } else { + croak "usage: sin_sv = sockaddr_in(port,iaddr))" unless @_ == 2; + pack_sockaddr_in(@_); + } +} + +sub sockaddr_in6 { + if (wantarray) { + croak "usage: (port,in6addr,scope_id,flowinfo) = sockaddr_in6(sin6_sv)" unless @_ == 1; + unpack_sockaddr_in6(@_); + } + else { + croak "usage: sin6_sv = sockaddr_in6(port,in6addr,[scope_id,[flowinfo]])" unless @_ >= 2 and @_ <= 4; + pack_sockaddr_in6(@_); + } +} + +sub sockaddr_un { + if (wantarray) { + croak "usage: (filename) = sockaddr_un(sun_sv)" unless @_ == 1; + unpack_sockaddr_un(@_); + } else { + croak "usage: sun_sv = sockaddr_un(filename)" unless @_ == 1; + pack_sockaddr_un(@_); + } +} + +XSLoader::load(__PACKAGE__, $VERSION); + +my %errstr; + +if( defined &getaddrinfo ) { + # These are not part of the API, nothing uses them, and deleting them + # reduces the size of %Socket:: by about 12K + delete $Socket::{fake_getaddrinfo}; + delete $Socket::{fake_getnameinfo}; +} else { + require Scalar::Util; + + *getaddrinfo = \&fake_getaddrinfo; + *getnameinfo = \&fake_getnameinfo; + + # These numbers borrowed from GNU libc's implementation, but since + # they're only used by our emulation, it doesn't matter if the real + # platform's values differ + my %constants = ( + AI_PASSIVE => 1, + AI_CANONNAME => 2, + AI_NUMERICHOST => 4, + AI_V4MAPPED => 8, + AI_ALL => 16, + AI_ADDRCONFIG => 32, + # RFC 2553 doesn't define this but Linux does - lets be nice and + # provide it since we can + AI_NUMERICSERV => 1024, + + EAI_BADFLAGS => -1, + EAI_NONAME => -2, + EAI_NODATA => -5, + EAI_FAMILY => -6, + EAI_SERVICE => -8, + + NI_NUMERICHOST => 1, + NI_NUMERICSERV => 2, + NI_NOFQDN => 4, + NI_NAMEREQD => 8, + NI_DGRAM => 16, + + # Constants we don't support. Export them, but croak if anyone tries to + # use them + AI_IDN => 64, + AI_CANONIDN => 128, + AI_IDN_ALLOW_UNASSIGNED => 256, + AI_IDN_USE_STD3_ASCII_RULES => 512, + NI_IDN => 32, + NI_IDN_ALLOW_UNASSIGNED => 64, + NI_IDN_USE_STD3_ASCII_RULES => 128, + + # Error constants we'll never return, so it doesn't matter what value + # these have, nor that we don't provide strings for them + EAI_SYSTEM => -11, + EAI_BADHINTS => -1000, + EAI_PROTOCOL => -1001 + ); + + foreach my $name ( keys %constants ) { + my $value = $constants{$name}; + + no strict 'refs'; + defined &$name or *$name = sub () { $value }; + } + + %errstr = ( + # These strings from RFC 2553 + EAI_BADFLAGS() => "invalid value for ai_flags", + EAI_NONAME() => "nodename nor servname provided, or not known", + EAI_NODATA() => "no address associated with nodename", + EAI_FAMILY() => "ai_family not supported", + EAI_SERVICE() => "servname not supported for ai_socktype", + ); +} + +# The following functions are used if the system does not have a +# getaddrinfo(3) function in libc; and are used to emulate it for the AF_INET +# family + +# Borrowed from Regexp::Common::net +my $REGEXP_IPv4_DECIMAL = qr/25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}/; +my $REGEXP_IPv4_DOTTEDQUAD = qr/$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL/; + +sub fake_makeerr +{ + my ( $errno ) = @_; + my $errstr = $errno == 0 ? "" : ( $errstr{$errno} || $errno ); + return Scalar::Util::dualvar( $errno, $errstr ); +} + +sub fake_getaddrinfo +{ + my ( $node, $service, $hints ) = @_; + + $node = "" unless defined $node; + + $service = "" unless defined $service; + + my ( $family, $socktype, $protocol, $flags ) = @$hints{qw( family socktype protocol flags )}; + + $family ||= Socket::AF_INET(); # 0 == AF_UNSPEC, which we want too + $family == Socket::AF_INET() or return fake_makeerr( EAI_FAMILY() ); + + $socktype ||= 0; + + $protocol ||= 0; + + $flags ||= 0; + + my $flag_passive = $flags & AI_PASSIVE(); $flags &= ~AI_PASSIVE(); + my $flag_canonname = $flags & AI_CANONNAME(); $flags &= ~AI_CANONNAME(); + my $flag_numerichost = $flags & AI_NUMERICHOST(); $flags &= ~AI_NUMERICHOST(); + my $flag_numericserv = $flags & AI_NUMERICSERV(); $flags &= ~AI_NUMERICSERV(); + + # These constants don't apply to AF_INET-only lookups, so we might as well + # just ignore them. For AI_ADDRCONFIG we just presume the host has ability + # to talk AF_INET. If not we'd have to return no addresses at all. :) + $flags &= ~(AI_V4MAPPED()|AI_ALL()|AI_ADDRCONFIG()); + + $flags & (AI_IDN()|AI_CANONIDN()|AI_IDN_ALLOW_UNASSIGNED()|AI_IDN_USE_STD3_ASCII_RULES()) and + croak "Socket::getaddrinfo() does not support IDN"; + + $flags == 0 or return fake_makeerr( EAI_BADFLAGS() ); + + $node eq "" and $service eq "" and return fake_makeerr( EAI_NONAME() ); + + my $canonname; + my @addrs; + if( $node ne "" ) { + return fake_makeerr( EAI_NONAME() ) if( $flag_numerichost and $node !~ m/^$REGEXP_IPv4_DOTTEDQUAD$/ ); + ( $canonname, undef, undef, undef, @addrs ) = gethostbyname( $node ); + defined $canonname or return fake_makeerr( EAI_NONAME() ); + + undef $canonname unless $flag_canonname; + } + else { + $addrs[0] = $flag_passive ? Socket::inet_aton( "0.0.0.0" ) + : Socket::inet_aton( "127.0.0.1" ); + } + + my @ports; # Actually ARRAYrefs of [ socktype, protocol, port ] + my $protname = ""; + if( $protocol ) { + $protname = eval { getprotobynumber( $protocol ) }; + } + + if( $service ne "" and $service !~ m/^\d+$/ ) { + return fake_makeerr( EAI_NONAME() ) if( $flag_numericserv ); + getservbyname( $service, $protname ) or return fake_makeerr( EAI_SERVICE() ); + } + + foreach my $this_socktype ( Socket::SOCK_STREAM(), Socket::SOCK_DGRAM(), Socket::SOCK_RAW() ) { + next if $socktype and $this_socktype != $socktype; + + my $this_protname = "raw"; + $this_socktype == Socket::SOCK_STREAM() and $this_protname = "tcp"; + $this_socktype == Socket::SOCK_DGRAM() and $this_protname = "udp"; + + next if $protname and $this_protname ne $protname; + + my $port; + if( $service ne "" ) { + if( $service =~ m/^\d+$/ ) { + $port = "$service"; + } + else { + ( undef, undef, $port, $this_protname ) = getservbyname( $service, $this_protname ); + next unless defined $port; + } + } + else { + $port = 0; + } + + push @ports, [ $this_socktype, eval { scalar getprotobyname( $this_protname ) } || 0, $port ]; + } + + my @ret; + foreach my $addr ( @addrs ) { + foreach my $portspec ( @ports ) { + my ( $socktype, $protocol, $port ) = @$portspec; + push @ret, { + family => $family, + socktype => $socktype, + protocol => $protocol, + addr => Socket::pack_sockaddr_in( $port, $addr ), + canonname => undef, + }; + } + } + + # Only supply canonname for the first result + if( defined $canonname ) { + $ret[0]->{canonname} = $canonname; + } + + return ( fake_makeerr( 0 ), @ret ); +} + +sub fake_getnameinfo +{ + my ( $addr, $flags, $xflags ) = @_; + + my ( $port, $inetaddr ); + eval { ( $port, $inetaddr ) = Socket::unpack_sockaddr_in( $addr ) } + or return fake_makeerr( EAI_FAMILY() ); + + my $family = Socket::AF_INET(); + + $flags ||= 0; + + my $flag_numerichost = $flags & NI_NUMERICHOST(); $flags &= ~NI_NUMERICHOST(); + my $flag_numericserv = $flags & NI_NUMERICSERV(); $flags &= ~NI_NUMERICSERV(); + my $flag_nofqdn = $flags & NI_NOFQDN(); $flags &= ~NI_NOFQDN(); + my $flag_namereqd = $flags & NI_NAMEREQD(); $flags &= ~NI_NAMEREQD(); + my $flag_dgram = $flags & NI_DGRAM() ; $flags &= ~NI_DGRAM(); + + $flags & (NI_IDN()|NI_IDN_ALLOW_UNASSIGNED()|NI_IDN_USE_STD3_ASCII_RULES()) and + croak "Socket::getnameinfo() does not support IDN"; + + $flags == 0 or return fake_makeerr( EAI_BADFLAGS() ); + + $xflags ||= 0; + + my $node; + if( $xflags & NIx_NOHOST ) { + $node = undef; + } + elsif( $flag_numerichost ) { + $node = Socket::inet_ntoa( $inetaddr ); + } + else { + $node = gethostbyaddr( $inetaddr, $family ); + if( !defined $node ) { + return fake_makeerr( EAI_NONAME() ) if $flag_namereqd; + $node = Socket::inet_ntoa( $inetaddr ); + } + elsif( $flag_nofqdn ) { + my ( $shortname ) = split m/\./, $node; + my ( $fqdn ) = gethostbyname $shortname; + $node = $shortname if defined $fqdn and $fqdn eq $node; + } + } + + my $service; + if( $xflags & NIx_NOSERV ) { + $service = undef; + } + elsif( $flag_numericserv ) { + $service = "$port"; + } + else { + my $protname = $flag_dgram ? "udp" : ""; + $service = getservbyport( $port, $protname ); + if( !defined $service ) { + $service = "$port"; + } + } + + return ( fake_makeerr( 0 ), $node, $service ); +} + +1; diff --git a/Socket.xs b/Socket.xs new file mode 100644 index 0000000..b11ea75 --- /dev/null +++ b/Socket.xs @@ -0,0 +1,1397 @@ +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include + +#ifdef I_SYS_TYPES +# include +#endif +#if !defined(ultrix) /* Avoid double definition. */ +# include +#endif +#if defined(USE_SOCKS) && defined(I_SOCKS) +# include +#endif +#ifdef MPE +# define PF_INET AF_INET +# define PF_UNIX AF_UNIX +# define SOCK_RAW 3 +#endif +#ifdef I_SYS_UN +# include +#endif +/* XXX Configure test for +#endif +#if defined(__sgi) && !defined(AF_LINK) && defined(PF_LINK) && PF_LINK == AF_LNK +# undef PF_LINK +#endif +#if defined(I_NETINET_IN) || defined(__ultrix__) +# include +#endif +#if defined(I_NETINET_IP) +# include +#endif +#ifdef I_NETDB +# if !defined(ultrix) /* Avoid double definition. */ +# include +# endif +#endif +#ifdef I_ARPA_INET +# include +#endif +#ifdef I_NETINET_TCP +# include +#endif + +#if defined(WIN32) && !defined(UNDER_CE) +# include +#endif + +#ifdef WIN32 + +/* VC 6 with its original headers doesn't know about sockaddr_storage, VC 2003 does*/ +#ifndef _SS_MAXSIZE + +# define _SS_MAXSIZE 128 +# define _SS_ALIGNSIZE (sizeof(__int64)) + +# define _SS_PAD1SIZE (_SS_ALIGNSIZE - sizeof (short)) +# define _SS_PAD2SIZE (_SS_MAXSIZE - (sizeof (short) + _SS_PAD1SIZE \ + + _SS_ALIGNSIZE)) + +struct sockaddr_storage { + short ss_family; + char __ss_pad1[_SS_PAD1SIZE]; + __int64 __ss_align; + char __ss_pad2[_SS_PAD2SIZE]; +}; + +typedef int socklen_t; + +#define in6_addr in_addr6 + +#define INET_ADDRSTRLEN 22 +#define INET6_ADDRSTRLEN 65 + +#endif + +static int inet_pton(int af, const char *src, void *dst) +{ + struct sockaddr_storage ss; + int size = sizeof(ss); + ss.ss_family = af; /* per MSDN */ + + if (WSAStringToAddress((char*)src, af, NULL, (struct sockaddr *)&ss, &size) != 0) + return 0; + + switch(af) { + case AF_INET: + *(struct in_addr *)dst = ((struct sockaddr_in *)&ss)->sin_addr; + return 1; + case AF_INET6: + *(struct in6_addr *)dst = ((struct sockaddr_in6 *)&ss)->sin6_addr; + return 1; + default: + WSASetLastError(WSAEAFNOSUPPORT); + return -1; + } +} + +static const char *inet_ntop(int af, const void *src, char *dst, socklen_t size) +{ + struct sockaddr_storage ss; + unsigned long s = size; + + ZeroMemory(&ss, sizeof(ss)); + ss.ss_family = af; + + switch(af) { + case AF_INET: + ((struct sockaddr_in *)&ss)->sin_addr = *(struct in_addr *)src; + break; + case AF_INET6: + ((struct sockaddr_in6 *)&ss)->sin6_addr = *(struct in6_addr *)src; + break; + default: + return NULL; + } + + /* cannot directly use &size because of strict aliasing rules */ + if (WSAAddressToString((struct sockaddr *)&ss, sizeof(ss), NULL, dst, &s) != 0) + return NULL; + else + return dst; +} + +#define HAS_INETPTON +#define HAS_INETNTOP +#endif + +#ifdef NETWARE +NETDB_DEFINE_CONTEXT +NETINET_DEFINE_CONTEXT +#endif + +#ifdef I_SYSUIO +# include +#endif + +#ifndef AF_NBS +# undef PF_NBS +#endif + +#ifndef AF_X25 +# undef PF_X25 +#endif + +#ifndef INADDR_NONE +# define INADDR_NONE 0xffffffff +#endif /* INADDR_NONE */ +#ifndef INADDR_BROADCAST +# define INADDR_BROADCAST 0xffffffff +#endif /* INADDR_BROADCAST */ +#ifndef INADDR_LOOPBACK +# define INADDR_LOOPBACK 0x7F000001 +#endif /* INADDR_LOOPBACK */ + +#ifndef INET_ADDRSTRLEN +#define INET_ADDRSTRLEN 16 +#endif + +#ifndef C_ARRAY_LENGTH +#define C_ARRAY_LENGTH(arr) (sizeof(arr) / sizeof(*(arr))) +#endif /* !C_ARRAY_LENGTH */ + +#ifndef PERL_UNUSED_VAR +# define PERL_UNUSED_VAR(x) ((void)x) +#endif /* !PERL_UNUSED_VAR */ + +#ifndef PERL_UNUSED_ARG +# define PERL_UNUSED_ARG(x) PERL_UNUSED_VAR(x) +#endif /* !PERL_UNUSED_ARG */ + +#ifndef Newx +# define Newx(v,n,t) New(0,v,n,t) +#endif /* !Newx */ + +#ifndef SvPVx_nolen +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +# define SvPVx_nolen(sv) ({SV *_sv = (sv); SvPV_nolen(_sv); }) +#else /* __GNUC__ */ +# define SvPVx_nolen(sv) ((PL_Sv = (sv)), SvPV_nolen(PL_Sv)) +#endif /* __GNU__ */ +#endif /* !SvPVx_nolen */ + +#ifndef croak_sv +# define croak_sv(sv) croak("%s", SvPVx_nolen(sv)) +#endif + +#ifndef hv_stores +# define hv_stores(hv, keystr, val) \ + hv_store(hv, ""keystr"", sizeof(keystr)-1, val, 0) +#endif /* !hv_stores */ + +#ifndef newSVpvn_flags +# define newSVpvn_flags(s,len,flags) my_newSVpvn_flags(aTHX_ s,len,flags) +static SV *my_newSVpvn_flags(pTHX_ const char *s, STRLEN len, U32 flags) +{ + SV *sv = newSVpvn(s, len); + SvFLAGS(sv) |= (flags & SVf_UTF8); + return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; +} +#endif /* !newSVpvn_flags */ + +#ifndef SvRV_set +# define SvRV_set(sv, val) (SvRV(sv) = (val)) +#endif /* !SvRV_set */ + +#ifndef SvPV_nomg +# define SvPV_nomg SvPV +#endif /* !SvPV_nomg */ + +#ifndef HEK_FLAGS +# define HEK_FLAGS(hek) 0 +# define HVhek_UTF8 1 +#endif /* !HEK_FLAGS */ + +#ifndef hv_common +/* These magic numbers are arbitrarily chosen (copied from perl core in fact) + * and only have to match between this definition and the code that uses them + */ +# define HV_FETCH_ISSTORE 0x04 +# define HV_FETCH_LVALUE 0x10 +# define hv_common(hv, keysv, key, klen, flags, act, val, hash) \ + my_hv_common(aTHX_ hv, keysv, key, klen, flags, act, val, hash) +static void *my_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, + int flags, int act, SV *val, U32 hash) +{ + /* + * This only handles the usage actually made by the code + * generated by ExtUtils::Constant. EU:C really ought to arrange + * portability of its generated code itself. + */ + if (!keysv) { + keysv = sv_2mortal(newSVpvn(key, klen)); + if (flags & HVhek_UTF8) + SvUTF8_on(keysv); + } + if (act == HV_FETCH_LVALUE) { + return (void*)hv_fetch_ent(hv, keysv, 1, hash); + } else if (act == HV_FETCH_ISSTORE) { + return (void*)hv_store_ent(hv, keysv, val, hash); + } else { + croak("panic: my_hv_common: act=0x%x", act); + } +} +#endif /* !hv_common */ + +#ifndef hv_common_key_len +# define hv_common_key_len(hv, key, kl, act, val, hash) \ + my_hv_common_key_len(aTHX_ hv, key, kl, act, val, hash) +static void *my_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 kl, + int act, SV *val, U32 hash) +{ + STRLEN klen; + int flags; + if (kl < 0) { + klen = -kl; + flags = HVhek_UTF8; + } else { + klen = kl; + flags = 0; + } + return hv_common(hv, NULL, key, klen, flags, act, val, hash); +} +#endif /* !hv_common_key_len */ + +#ifndef mPUSHi +# define mPUSHi(i) sv_setiv_mg(PUSHs(sv_newmortal()), (IV)(i)) +#endif /* !mPUSHi */ +#ifndef mPUSHp +# define mPUSHp(p,l) sv_setpvn_mg(PUSHs(sv_newmortal()), (p), (l)) +#endif /* !mPUSHp */ +#ifndef mPUSHs +# define mPUSHs(s) PUSHs(sv_2mortal(s)) +#endif /* !mPUSHs */ + +#ifndef CvCONST_on +# undef newCONSTSUB +# define newCONSTSUB(stash, name, val) my_newCONSTSUB(aTHX_ stash, name, val) +static CV *my_newCONSTSUB(pTHX_ HV *stash, char *name, SV *val) +{ + /* + * This has to satisfy code generated by ExtUtils::Constant. + * It depends on the 5.8+ layout of constant subs. It has + * two calls to newCONSTSUB(): one for real constants, and one + * for undefined constants. In the latter case, it turns the + * initially-generated constant subs into something else, and + * it needs the return value from newCONSTSUB() which Perl 5.6 + * doesn't provide. + */ + GV *gv; + CV *cv; + Perl_newCONSTSUB(aTHX_ stash, name, val); + ENTER; + SAVESPTR(PL_curstash); + PL_curstash = stash; + gv = gv_fetchpv(name, 0, SVt_PVCV); + cv = GvCV(gv); + LEAVE; + CvXSUBANY(cv).any_ptr = &PL_sv_undef; + return cv; +} +# define CvCONST_off(cv) my_CvCONST_off(aTHX_ cv) +static void my_CvCONST_off(pTHX_ CV *cv) +{ + op_free(CvROOT(cv)); + CvROOT(cv) = NULL; + CvSTART(cv) = NULL; +} +#endif /* !CvCONST_on */ + +#ifndef HAS_INET_ATON + +/* + * Check whether "cp" is a valid ascii representation + * of an Internet address and convert to a binary address. + * Returns 1 if the address is valid, 0 if not. + * This replaces inet_addr, the return value from which + * cannot distinguish between failure and a local broadcast address. + */ +static int +my_inet_aton(register const char *cp, struct in_addr *addr) +{ + dTHX; + register U32 val; + register int base; + register char c; + int nparts; + const char *s; + unsigned int parts[4]; + register unsigned int *pp = parts; + + if (!cp || !*cp) + return 0; + for (;;) { + /* + * Collect number up to ".". + * Values are specified as for C: + * 0x=hex, 0=octal, other=decimal. + */ + val = 0; base = 10; + if (*cp == '0') { + if (*++cp == 'x' || *cp == 'X') + base = 16, cp++; + else + base = 8; + } + while ((c = *cp) != '\0') { + if (isDIGIT(c)) { + val = (val * base) + (c - '0'); + cp++; + continue; + } + if (base == 16 && (s=strchr(PL_hexdigit,c))) { + val = (val << 4) + + ((s - PL_hexdigit) & 15); + cp++; + continue; + } + break; + } + if (*cp == '.') { + /* + * Internet format: + * a.b.c.d + * a.b.c (with c treated as 16-bits) + * a.b (with b treated as 24 bits) + */ + if (pp >= parts + 3 || val > 0xff) + return 0; + *pp++ = val, cp++; + } else + break; + } + /* + * Check for trailing characters. + */ + if (*cp && !isSPACE(*cp)) + return 0; + /* + * Concoct the address according to + * the number of parts specified. + */ + nparts = pp - parts + 1; /* force to an int for switch() */ + switch (nparts) { + + case 1: /* a -- 32 bits */ + break; + + case 2: /* a.b -- 8.24 bits */ + if (val > 0xffffff) + return 0; + val |= parts[0] << 24; + break; + + case 3: /* a.b.c -- 8.8.16 bits */ + if (val > 0xffff) + return 0; + val |= (parts[0] << 24) | (parts[1] << 16); + break; + + case 4: /* a.b.c.d -- 8.8.8.8 bits */ + if (val > 0xff) + return 0; + val |= (parts[0] << 24) | (parts[1] << 16) | (parts[2] << 8); + break; + } + addr->s_addr = htonl(val); + return 1; +} + +#undef inet_aton +#define inet_aton my_inet_aton + +#endif /* ! HAS_INET_ATON */ + +/* These are not gni() constants; they're extensions for the perl API */ +/* The definitions in Socket.pm and Socket.xs must match */ +#define NIx_NOHOST (1 << 0) +#define NIx_NOSERV (1 << 1) + +/* On Windows, ole2.h defines a macro called "interface". We don't need that, + * and it will complicate the variables in pack_ip_mreq() etc. (RT87389) + */ +#undef interface + +/* STRUCT_OFFSET should have come from from perl.h, but if not, + * roll our own (not using offsetof() since that is C99). */ +#ifndef STRUCT_OFFSET +# define STRUCT_OFFSET(s,m) (Size_t)(&(((s *)0)->m)) +#endif + +static int +not_here(const char *s) +{ + croak("Socket::%s not implemented on this architecture", s); + return -1; +} + +#define PERL_IN_ADDR_S_ADDR_SIZE 4 + +/* +* Bad assumptions possible here. +* +* Bad Assumption 1: struct in_addr has no other fields +* than the s_addr (which is the field we care about +* in here, really). However, we can be fed either 4-byte +* addresses (from pack("N", ...), or va.b.c.d, or ...), +* or full struct in_addrs (from e.g. pack_sockaddr_in()), +* which may or may not be 4 bytes in size. +* +* Bad Assumption 2: the s_addr field is a simple type +* (such as an int, u_int32_t). It can be a bit field, +* in which case using & (address-of) on it or taking sizeof() +* wouldn't go over too well. (Those are not attempted +* now but in case someone thinks to change the below code +* to use addr.s_addr instead of addr, you have been warned.) +* +* Bad Assumption 3: the s_addr is the first field in +* an in_addr, or that its bytes are the first bytes in +* an in_addr. +* +* These bad assumptions are wrong in UNICOS which has +* struct in_addr { struct { u_long st_addr:32; } s_da }; +* #define s_addr s_da.st_addr +* and u_long is 64 bits. +* +* --jhi */ + +#include "const-c.inc" + +#if defined(HAS_GETADDRINFO) && !defined(HAS_GAI_STRERROR) +static const char *gai_strerror(int err) +{ + switch (err) + { +#ifdef EAI_ADDRFAMILY + case EAI_ADDRFAMILY: + return "Address family for hostname is not supported."; +#endif +#ifdef EAI_AGAIN + case EAI_AGAIN: + return "The name could not be resolved at this time."; +#endif +#ifdef EAI_BADFLAGS + case EAI_BADFLAGS: + return "The flags parameter has an invalid value."; +#endif +#ifdef EAI_FAIL + case EAI_FAIL: + return "A non-recoverable error occurred while resolving the name."; +#endif +#ifdef EAI_FAMILY + case EAI_FAMILY: + return "The address family was not recognized or length is invalid."; +#endif +#ifdef EAI_MEMORY + case EAI_MEMORY: + return "A memory allocation failure occurred."; +#endif +#ifdef EAI_NODATA + case EAI_NODATA: + return "No address is associated with the hostname."; +#endif +#ifdef EAI_NONAME + case EAI_NONAME: + return "The name does not resolve for the supplied parameters."; +#endif +#ifdef EAI_OVERFLOW + case EAI_OVERFLOW: + return "An argument buffer overflowed."; +#endif +#ifdef EAI_SERVICE + case EAI_SERVICE: + return "The service parameter was not recognized for the specified socket type."; +#endif +#ifdef EAI_SOCKTYPE + case EAI_SOCKTYPE: + return "The specified socket type was not recognized."; +#endif +#ifdef EAI_SYSTEM + case EAI_SYSTEM: + return "A system error occurred - see errno."; +#endif + default: + return "Unknown error in getaddrinfo()."; + } +} +#endif + +#ifdef HAS_GETADDRINFO +static SV *err_to_SV(pTHX_ int err) +{ + SV *ret = sv_newmortal(); + (void) SvUPGRADE(ret, SVt_PVNV); + + if(err) { + const char *error = gai_strerror(err); + sv_setpv(ret, error); + } + else { + sv_setpv(ret, ""); + } + + SvIV_set(ret, err); SvIOK_on(ret); + + return ret; +} + +static void xs_getaddrinfo(pTHX_ CV *cv) +{ + dXSARGS; + + SV *host; + SV *service; + SV *hints; + + char *hostname = NULL; + char *servicename = NULL; + STRLEN len; + struct addrinfo hints_s; + struct addrinfo *res; + struct addrinfo *res_iter; + int err; + int n_res; + + PERL_UNUSED_ARG(cv); + if(items > 3) + croak("Usage: Socket::getaddrinfo(host, service, hints)"); + + SP -= items; + + if(items < 1) + host = &PL_sv_undef; + else + host = ST(0); + + if(items < 2) + service = &PL_sv_undef; + else + service = ST(1); + + if(items < 3) + hints = NULL; + else + hints = ST(2); + + SvGETMAGIC(host); + if(SvOK(host)) { + hostname = SvPV_nomg(host, len); + if (!len) + hostname = NULL; + } + + SvGETMAGIC(service); + if(SvOK(service)) { + servicename = SvPV_nomg(service, len); + if (!len) + servicename = NULL; + } + + Zero(&hints_s, sizeof(hints_s), char); + hints_s.ai_family = PF_UNSPEC; + + if(hints && SvOK(hints)) { + HV *hintshash; + SV **valp; + + if(!SvROK(hints) || SvTYPE(SvRV(hints)) != SVt_PVHV) + croak("hints is not a HASH reference"); + + hintshash = (HV*)SvRV(hints); + + if((valp = hv_fetch(hintshash, "flags", 5, 0)) != NULL && SvOK(*valp)) + hints_s.ai_flags = SvIV(*valp); + if((valp = hv_fetch(hintshash, "family", 6, 0)) != NULL && SvOK(*valp)) + hints_s.ai_family = SvIV(*valp); + if((valp = hv_fetch(hintshash, "socktype", 8, 0)) != NULL && SvOK(*valp)) + hints_s.ai_socktype = SvIV(*valp); + if((valp = hv_fetch(hintshash, "protocol", 8, 0)) != NULL && SvOK(*valp)) + hints_s.ai_protocol = SvIV(*valp); + } + + err = getaddrinfo(hostname, servicename, &hints_s, &res); + + XPUSHs(err_to_SV(aTHX_ err)); + + if(err) + XSRETURN(1); + + n_res = 0; + for(res_iter = res; res_iter; res_iter = res_iter->ai_next) { + HV *res_hv = newHV(); + + (void)hv_stores(res_hv, "family", newSViv(res_iter->ai_family)); + (void)hv_stores(res_hv, "socktype", newSViv(res_iter->ai_socktype)); + (void)hv_stores(res_hv, "protocol", newSViv(res_iter->ai_protocol)); + + (void)hv_stores(res_hv, "addr", newSVpvn((char*)res_iter->ai_addr, res_iter->ai_addrlen)); + + if(res_iter->ai_canonname) + (void)hv_stores(res_hv, "canonname", newSVpv(res_iter->ai_canonname, 0)); + else + (void)hv_stores(res_hv, "canonname", newSV(0)); + + XPUSHs(sv_2mortal(newRV_noinc((SV*)res_hv))); + n_res++; + } + + freeaddrinfo(res); + + XSRETURN(1 + n_res); +} +#endif + +#ifdef HAS_GETNAMEINFO +static void xs_getnameinfo(pTHX_ CV *cv) +{ + dXSARGS; + + SV *addr; + int flags; + int xflags; + + char host[1024]; + char serv[256]; + char *sa; /* we'll cast to struct sockaddr * when necessary */ + STRLEN addr_len; + int err; + + int want_host, want_serv; + + PERL_UNUSED_ARG(cv); + if(items < 1 || items > 3) + croak("Usage: Socket::getnameinfo(addr, flags=0, xflags=0)"); + + SP -= items; + + addr = ST(0); + SvGETMAGIC(addr); + + if(items < 2) + flags = 0; + else + flags = SvIV(ST(1)); + + if(items < 3) + xflags = 0; + else + xflags = SvIV(ST(2)); + + want_host = !(xflags & NIx_NOHOST); + want_serv = !(xflags & NIx_NOSERV); + + if(!SvPOKp(addr)) + croak("addr is not a string"); + + addr_len = SvCUR(addr); + + /* We need to ensure the sockaddr is aligned, because a random SvPV might + * not be due to SvOOK */ + Newx(sa, addr_len, char); + Copy(SvPV_nolen(addr), sa, addr_len, char); +#ifdef HAS_SOCKADDR_SA_LEN + ((struct sockaddr *)sa)->sa_len = addr_len; +#endif + + err = getnameinfo((struct sockaddr *)sa, addr_len, + want_host ? host : NULL, want_host ? sizeof(host) : 0, + want_serv ? serv : NULL, want_serv ? sizeof(serv) : 0, + flags); + + Safefree(sa); + + XPUSHs(err_to_SV(aTHX_ err)); + + if(err) + XSRETURN(1); + + XPUSHs(want_host ? sv_2mortal(newSVpv(host, 0)) : &PL_sv_undef); + XPUSHs(want_serv ? sv_2mortal(newSVpv(serv, 0)) : &PL_sv_undef); + + XSRETURN(3); +} +#endif + +MODULE = Socket PACKAGE = Socket + +INCLUDE: const-xs.inc + +BOOT: +#ifdef HAS_GETADDRINFO + newXS("Socket::getaddrinfo", xs_getaddrinfo, __FILE__); +#endif +#ifdef HAS_GETNAMEINFO + newXS("Socket::getnameinfo", xs_getnameinfo, __FILE__); +#endif + +void +inet_aton(host) + char * host + CODE: + { + struct in_addr ip_address; + struct hostent * phe; + + if ((*host != '\0') && inet_aton(host, &ip_address)) { + ST(0) = sv_2mortal(newSVpvn((char *)&ip_address, sizeof(ip_address))); + XSRETURN(1); + } +#ifdef HAS_GETHOSTBYNAME + phe = gethostbyname(host); + if (phe && phe->h_addrtype == AF_INET && phe->h_length == 4) { + ST(0) = sv_2mortal(newSVpvn((char *)phe->h_addr, phe->h_length)); + XSRETURN(1); + } +#endif + XSRETURN_UNDEF; + } + +void +inet_ntoa(ip_address_sv) + SV * ip_address_sv + CODE: + { + STRLEN addrlen; + struct in_addr addr; + char * ip_address; + if (DO_UTF8(ip_address_sv) && !sv_utf8_downgrade(ip_address_sv, 1)) + croak("Wide character in %s", "Socket::inet_ntoa"); + ip_address = SvPVbyte(ip_address_sv, addrlen); + if (addrlen == sizeof(addr) || addrlen == 4) + addr.s_addr = + (ip_address[0] & 0xFF) << 24 | + (ip_address[1] & 0xFF) << 16 | + (ip_address[2] & 0xFF) << 8 | + (ip_address[3] & 0xFF); + else + croak("Bad arg length for %s, length is %" UVuf + ", should be %" UVuf, + "Socket::inet_ntoa", (UV)addrlen, (UV)sizeof(addr)); + /* We could use inet_ntoa() but that is broken + * in HP-UX + GCC + 64bitint (returns "0.0.0.0"), + * so let's use this sprintf() workaround everywhere. + * This is also more threadsafe than using inet_ntoa(). */ + ST(0) = sv_2mortal(Perl_newSVpvf(aTHX_ "%d.%d.%d.%d", /* IPv6? */ + (int)((addr.s_addr >> 24) & 0xFF), + (int)((addr.s_addr >> 16) & 0xFF), + (int)((addr.s_addr >> 8) & 0xFF), + (int)( addr.s_addr & 0xFF))); + } + +void +sockaddr_family(sockaddr) + SV * sockaddr + PREINIT: + STRLEN sockaddr_len; + char *sockaddr_pv = SvPVbyte(sockaddr, sockaddr_len); + CODE: + if (sockaddr_len < STRUCT_OFFSET(struct sockaddr, sa_data)) + croak("Bad arg length for %s, length is %" UVuf + ", should be at least %" UVuf, + "Socket::sockaddr_family", (UV)sockaddr_len, + (UV)STRUCT_OFFSET(struct sockaddr, sa_data)); + ST(0) = sv_2mortal(newSViv(((struct sockaddr*)sockaddr_pv)->sa_family)); + +void +pack_sockaddr_un(pathname) + SV * pathname + CODE: + { +#ifdef I_SYS_UN + struct sockaddr_un sun_ad; /* fear using sun */ + STRLEN len; + char * pathname_pv; + int addr_len; + + if (!SvOK(pathname)) + croak("Undefined path for %s", "Socket::pack_sockaddr_un"); + + Zero(&sun_ad, sizeof(sun_ad), char); + sun_ad.sun_family = AF_UNIX; + pathname_pv = SvPV(pathname,len); + if (len > sizeof(sun_ad.sun_path)) { + warn("Path length (%" UVuf ") is longer than maximum supported length" + " (%" UVuf ") and will be truncated", + (UV)len, (UV)sizeof(sun_ad.sun_path)); + len = sizeof(sun_ad.sun_path); + } +# ifdef OS2 /* Name should start with \socket\ and contain backslashes! */ + { + int off; + char *s, *e; + + if (pathname_pv[0] != '/' && pathname_pv[0] != '\\') + croak("Relative UNIX domain socket name '%s' unsupported", + pathname_pv); + else if (len < 8 + || pathname_pv[7] != '/' && pathname_pv[7] != '\\' + || !strnicmp(pathname_pv + 1, "socket", 6)) + off = 7; + else + off = 0; /* Preserve names starting with \socket\ */ + Copy("\\socket", sun_ad.sun_path, off, char); + Copy(pathname_pv, sun_ad.sun_path + off, len, char); + + s = sun_ad.sun_path + off - 1; + e = s + len + 1; + while (++s < e) + if (*s = '/') + *s = '\\'; + } +# else /* !( defined OS2 ) */ + Copy(pathname_pv, sun_ad.sun_path, len, char); +# endif + if (0) not_here("dummy"); + if (len > 1 && sun_ad.sun_path[0] == '\0') { + /* Linux-style abstract-namespace socket. + * The name is not a file name, but an array of arbitrary + * character, starting with \0 and possibly including \0s, + * therefore the length of the structure must denote the + * end of that character array */ + addr_len = (char *)&(sun_ad.sun_path) - (char *)&sun_ad + len; + } else { + addr_len = sizeof(sun_ad); + } +# ifdef HAS_SOCKADDR_SA_LEN + sun_ad.sun_len = addr_len; +# endif + ST(0) = sv_2mortal(newSVpvn((char *)&sun_ad, addr_len)); +#else + ST(0) = (SV*)not_here("pack_sockaddr_un"); +#endif + + } + +void +unpack_sockaddr_un(sun_sv) + SV * sun_sv + CODE: + { +#ifdef I_SYS_UN + struct sockaddr_un addr; + STRLEN sockaddrlen; + char * sun_ad; + int addr_len = 0; + if (!SvOK(sun_sv)) + croak("Undefined address for %s", "Socket::unpack_sockaddr_un"); + sun_ad = SvPVbyte(sun_sv,sockaddrlen); +# if defined(__linux__) || defined(HAS_SOCKADDR_SA_LEN) + /* On Linux or *BSD sockaddrlen on sockets returned by accept, recvfrom, + getpeername and getsockname is not equal to sizeof(addr). */ + if (sockaddrlen < sizeof(addr)) { + Copy(sun_ad, &addr, sockaddrlen, char); + Zero(((char*)&addr) + sockaddrlen, sizeof(addr) - sockaddrlen, char); + } else { + Copy(sun_ad, &addr, sizeof(addr), char); + } +# ifdef HAS_SOCKADDR_SA_LEN + /* In this case, sun_len must be checked */ + if (sockaddrlen != addr.sun_len) + croak("Invalid arg sun_len field for %s, length is %" UVuf + ", but sun_len is %" UVuf, + "Socket::unpack_sockaddr_un", (UV)sockaddrlen, (UV)addr.sun_len); +# endif +# else + if (sockaddrlen != sizeof(addr)) + croak("Bad arg length for %s, length is %" UVuf + ", should be %" UVuf, + "Socket::unpack_sockaddr_un", (UV)sockaddrlen, (UV)sizeof(addr)); + Copy(sun_ad, &addr, sizeof(addr), char); +# endif + + if (addr.sun_family != AF_UNIX) + croak("Bad address family for %s, got %d, should be %d", + "Socket::unpack_sockaddr_un", addr.sun_family, AF_UNIX); +# ifdef __linux__ + if (addr.sun_path[0] == '\0') { + /* Linux-style abstract socket address begins with a nul + * and can contain nuls. */ + addr_len = (char *)&addr - (char *)&(addr.sun_path) + sockaddrlen; + } else +# endif + { +# if defined(HAS_SOCKADDR_SA_LEN) + /* On *BSD sun_path not always ends with a '\0' */ + int maxlen = addr.sun_len - 2; /* should use STRUCT_OFFSET(struct sockaddr_un, sun_path) instead of 2 */ + if (maxlen > (int)sizeof(addr.sun_path)) + maxlen = (int)sizeof(addr.sun_path); +# else + const int maxlen = (int)sizeof(addr.sun_path); +# endif + while (addr_len < maxlen && addr.sun_path[addr_len]) + addr_len++; + } + + ST(0) = sv_2mortal(newSVpvn(addr.sun_path, addr_len)); +#else + ST(0) = (SV*)not_here("unpack_sockaddr_un"); +#endif + } + +void +pack_sockaddr_in(port_sv, ip_address_sv) + SV * port_sv + SV * ip_address_sv + CODE: + { + struct sockaddr_in sin; + struct in_addr addr; + STRLEN addrlen; + unsigned short port = 0; + char * ip_address; + if (SvOK(port_sv)) + port = SvUV(port_sv); + if (!SvOK(ip_address_sv)) + croak("Undefined address for %s", "Socket::pack_sockaddr_in"); + if (DO_UTF8(ip_address_sv) && !sv_utf8_downgrade(ip_address_sv, 1)) + croak("Wide character in %s", "Socket::pack_sockaddr_in"); + ip_address = SvPVbyte(ip_address_sv, addrlen); + if (addrlen == sizeof(addr) || addrlen == 4) + addr.s_addr = + (unsigned int)(ip_address[0] & 0xFF) << 24 | + (unsigned int)(ip_address[1] & 0xFF) << 16 | + (unsigned int)(ip_address[2] & 0xFF) << 8 | + (unsigned int)(ip_address[3] & 0xFF); + else + croak("Bad arg length for %s, length is %" UVuf + ", should be %" UVuf, + "Socket::pack_sockaddr_in", + (UV)addrlen, (UV)sizeof(addr)); + Zero(&sin, sizeof(sin), char); + sin.sin_family = AF_INET; + sin.sin_port = htons(port); + sin.sin_addr.s_addr = htonl(addr.s_addr); +# ifdef HAS_SOCKADDR_SA_LEN + sin.sin_len = sizeof(sin); +# endif + ST(0) = sv_2mortal(newSVpvn((char *)&sin, sizeof(sin))); + } + +void +unpack_sockaddr_in(sin_sv) + SV * sin_sv + PPCODE: + { + STRLEN sockaddrlen; + struct sockaddr_in addr; + SV *ip_address_sv; + char * sin; + if (!SvOK(sin_sv)) + croak("Undefined address for %s", "Socket::unpack_sockaddr_in"); + sin = SvPVbyte(sin_sv,sockaddrlen); + if (sockaddrlen != sizeof(addr)) { + croak("Bad arg length for %s, length is %" UVuf + ", should be %" UVuf, + "Socket::unpack_sockaddr_in", (UV)sockaddrlen, (UV)sizeof(addr)); + } + Copy(sin, &addr, sizeof(addr), char); + if (addr.sin_family != AF_INET) { + croak("Bad address family for %s, got %d, should be %d", + "Socket::unpack_sockaddr_in", addr.sin_family, AF_INET); + } + ip_address_sv = newSVpvn((char *)&addr.sin_addr, sizeof(addr.sin_addr)); + + if(GIMME_V == G_ARRAY) { + EXTEND(SP, 2); + mPUSHi(ntohs(addr.sin_port)); + mPUSHs(ip_address_sv); + } + else { + mPUSHs(ip_address_sv); + } + } + +void +pack_sockaddr_in6(port_sv, sin6_addr, scope_id=0, flowinfo=0) + SV * port_sv + SV * sin6_addr + unsigned long scope_id + unsigned long flowinfo + CODE: + { +#ifdef HAS_SOCKADDR_IN6 + unsigned short port = 0; + struct sockaddr_in6 sin6; + char * addrbytes; + STRLEN addrlen; + if (SvOK(port_sv)) + port = SvUV(port_sv); + if (!SvOK(sin6_addr)) + croak("Undefined address for %s", "Socket::pack_sockaddr_in6"); + if (DO_UTF8(sin6_addr) && !sv_utf8_downgrade(sin6_addr, 1)) + croak("Wide character in %s", "Socket::pack_sockaddr_in6"); + addrbytes = SvPVbyte(sin6_addr, addrlen); + if (addrlen != sizeof(sin6.sin6_addr)) + croak("Bad arg length %s, length is %" UVuf + ", should be %" UVuf, + "Socket::pack_sockaddr_in6", (UV)addrlen, (UV)sizeof(sin6.sin6_addr)); + Zero(&sin6, sizeof(sin6), char); + sin6.sin6_family = AF_INET6; + sin6.sin6_port = htons(port); + sin6.sin6_flowinfo = htonl(flowinfo); + Copy(addrbytes, &sin6.sin6_addr, sizeof(sin6.sin6_addr), char); +# ifdef HAS_SIN6_SCOPE_ID + sin6.sin6_scope_id = scope_id; +# else + if (scope_id != 0) + warn("%s cannot represent non-zero scope_id %d", + "Socket::pack_sockaddr_in6", scope_id); +# endif +# ifdef HAS_SOCKADDR_SA_LEN + sin6.sin6_len = sizeof(sin6); +# endif + ST(0) = sv_2mortal(newSVpvn((char *)&sin6, sizeof(sin6))); +#else + PERL_UNUSED_VAR(port_sv); + PERL_UNUSED_VAR(sin6_addr); + ST(0) = (SV*)not_here("pack_sockaddr_in6"); +#endif + } + +void +unpack_sockaddr_in6(sin6_sv) + SV * sin6_sv + PPCODE: + { +#ifdef HAS_SOCKADDR_IN6 + STRLEN addrlen; + struct sockaddr_in6 sin6; + char * addrbytes; + SV *ip_address_sv; + if (!SvOK(sin6_sv)) + croak("Undefined address for %s", "Socket::unpack_sockaddr_in6"); + addrbytes = SvPVbyte(sin6_sv, addrlen); + if (addrlen != sizeof(sin6)) + croak("Bad arg length for %s, length is %" UVuf + ", should be %" UVuf, + "Socket::unpack_sockaddr_in6", (UV)addrlen, (UV)sizeof(sin6)); + Copy(addrbytes, &sin6, sizeof(sin6), char); + if (sin6.sin6_family != AF_INET6) + croak("Bad address family for %s, got %d, should be %d", + "Socket::unpack_sockaddr_in6", sin6.sin6_family, AF_INET6); + ip_address_sv = newSVpvn((char *)&sin6.sin6_addr, sizeof(sin6.sin6_addr)); + + if(GIMME_V == G_ARRAY) { + EXTEND(SP, 4); + mPUSHi(ntohs(sin6.sin6_port)); + mPUSHs(ip_address_sv); +# ifdef HAS_SIN6_SCOPE_ID + mPUSHi(sin6.sin6_scope_id); +# else + mPUSHi(0); +# endif + mPUSHi(ntohl(sin6.sin6_flowinfo)); + } + else { + mPUSHs(ip_address_sv); + } +#else + PERL_UNUSED_VAR(sin6_sv); + ST(0) = (SV*)not_here("pack_sockaddr_in6"); +#endif + } + +void +inet_ntop(af, ip_address_sv) + int af + SV * ip_address_sv + CODE: +#ifdef HAS_INETNTOP + STRLEN addrlen; +#ifdef AF_INET6 + struct in6_addr addr; + char str[INET6_ADDRSTRLEN]; +#else + struct in_addr addr; + char str[INET_ADDRSTRLEN]; +#endif + char *ip_address; + + if (DO_UTF8(ip_address_sv) && !sv_utf8_downgrade(ip_address_sv, 1)) + croak("Wide character in %s", "Socket::inet_ntop"); + + ip_address = SvPV(ip_address_sv, addrlen); + + switch(af) { + case AF_INET: + if(addrlen != 4) + croak("Bad address length for Socket::inet_ntop on AF_INET;" + " got %" UVuf ", should be 4", (UV)addrlen); + break; +#ifdef AF_INET6 + case AF_INET6: + if(addrlen != 16) + croak("Bad address length for Socket::inet_ntop on AF_INET6;" + " got %" UVuf ", should be 16", (UV)addrlen); + break; +#endif + default: + croak("Bad address family for %s, got %d, should be" +#ifdef AF_INET6 + " either AF_INET or AF_INET6", +#else + " AF_INET", +#endif + "Socket::inet_ntop", af); + } + + if(addrlen < sizeof(addr)) { + Copy(ip_address, &addr, addrlen, char); + Zero(((char*)&addr) + addrlen, sizeof(addr) - addrlen, char); + } + else { + Copy(ip_address, &addr, sizeof addr, char); + } + inet_ntop(af, &addr, str, sizeof str); + + ST(0) = sv_2mortal(newSVpvn(str, strlen(str))); +#else + PERL_UNUSED_VAR(af); + PERL_UNUSED_VAR(ip_address_sv); + ST(0) = (SV*)not_here("inet_ntop"); +#endif + +void +inet_pton(af, host) + int af + const char * host + CODE: +#ifdef HAS_INETPTON + int ok; + int addrlen = 0; +#ifdef AF_INET6 + struct in6_addr ip_address; +#else + struct in_addr ip_address; +#endif + + switch(af) { + case AF_INET: + addrlen = 4; + break; +#ifdef AF_INET6 + case AF_INET6: + addrlen = 16; + break; +#endif + default: + croak("Bad address family for %s, got %d, should be" +#ifdef AF_INET6 + " either AF_INET or AF_INET6", +#else + " AF_INET", +#endif + "Socket::inet_pton", af); + } + ok = (*host != '\0') && inet_pton(af, host, &ip_address); + + ST(0) = sv_newmortal(); + if (ok) { + sv_setpvn( ST(0), (char *)&ip_address, addrlen); + } +#else + PERL_UNUSED_VAR(af); + PERL_UNUSED_VAR(host); + ST(0) = (SV*)not_here("inet_pton"); +#endif + +void +pack_ip_mreq(multiaddr, interface=&PL_sv_undef) + SV * multiaddr + SV * interface + CODE: + { +#ifdef HAS_IP_MREQ + struct ip_mreq mreq; + char * multiaddrbytes; + char * interfacebytes; + STRLEN len; + if (DO_UTF8(multiaddr) && !sv_utf8_downgrade(multiaddr, 1)) + croak("Wide character in %s", "Socket::pack_ip_mreq"); + multiaddrbytes = SvPVbyte(multiaddr, len); + if (len != sizeof(mreq.imr_multiaddr)) + croak("Bad arg length %s, length is %" UVuf + ", should be %" UVuf, + "Socket::pack_ip_mreq", (UV)len, (UV)sizeof(mreq.imr_multiaddr)); + Zero(&mreq, sizeof(mreq), char); + Copy(multiaddrbytes, &mreq.imr_multiaddr, sizeof(mreq.imr_multiaddr), char); + if(SvOK(interface)) { + if (DO_UTF8(interface) && !sv_utf8_downgrade(interface, 1)) + croak("Wide character in %s", "Socket::pack_ip_mreq"); + interfacebytes = SvPVbyte(interface, len); + if (len != sizeof(mreq.imr_interface)) + croak("Bad arg length %s, length is %" UVuf + ", should be %" UVuf, + "Socket::pack_ip_mreq", (UV)len, (UV)sizeof(mreq.imr_interface)); + Copy(interfacebytes, &mreq.imr_interface, sizeof(mreq.imr_interface), char); + } + else + mreq.imr_interface.s_addr = INADDR_ANY; + ST(0) = sv_2mortal(newSVpvn((char *)&mreq, sizeof(mreq))); +#else + not_here("pack_ip_mreq"); +#endif + } + +void +unpack_ip_mreq(mreq_sv) + SV * mreq_sv + PPCODE: + { +#ifdef HAS_IP_MREQ + struct ip_mreq mreq; + STRLEN mreqlen; + char * mreqbytes = SvPVbyte(mreq_sv, mreqlen); + if (mreqlen != sizeof(mreq)) + croak("Bad arg length for %s, length is %" UVuf + ", should be %" UVuf, + "Socket::unpack_ip_mreq", (UV)mreqlen, (UV)sizeof(mreq)); + Copy(mreqbytes, &mreq, sizeof(mreq), char); + EXTEND(SP, 2); + mPUSHp((char *)&mreq.imr_multiaddr, sizeof(mreq.imr_multiaddr)); + mPUSHp((char *)&mreq.imr_interface, sizeof(mreq.imr_interface)); +#else + not_here("unpack_ip_mreq"); +#endif + } + +void +pack_ip_mreq_source(multiaddr, source, interface=&PL_sv_undef) + SV * multiaddr + SV * source + SV * interface + CODE: + { +#if defined(HAS_IP_MREQ_SOURCE) && defined (IP_ADD_SOURCE_MEMBERSHIP) + struct ip_mreq_source mreq; + char * multiaddrbytes; + char * sourcebytes; + char * interfacebytes; + STRLEN len; + if (DO_UTF8(multiaddr) && !sv_utf8_downgrade(multiaddr, 1)) + croak("Wide character in %s", "Socket::pack_ip_mreq_source"); + multiaddrbytes = SvPVbyte(multiaddr, len); + if (len != sizeof(mreq.imr_multiaddr)) + croak("Bad arg length %s, length is %" UVuf + ", should be %" UVuf, + "Socket::pack_ip_mreq", (UV)len, (UV)sizeof(mreq.imr_multiaddr)); + if (DO_UTF8(source) && !sv_utf8_downgrade(source, 1)) + croak("Wide character in %s", "Socket::pack_ip_mreq_source"); + if (len != sizeof(mreq.imr_sourceaddr)) + croak("Bad arg length %s, length is %" UVuf + ", should be %" UVuf, + "Socket::pack_ip_mreq", (UV)len, (UV)sizeof(mreq.imr_sourceaddr)); + sourcebytes = SvPVbyte(source, len); + Zero(&mreq, sizeof(mreq), char); + Copy(multiaddrbytes, &mreq.imr_multiaddr, sizeof(mreq.imr_multiaddr), char); + Copy(sourcebytes, &mreq.imr_sourceaddr, sizeof(mreq.imr_sourceaddr), char); + if(SvOK(interface)) { + if (DO_UTF8(interface) && !sv_utf8_downgrade(interface, 1)) + croak("Wide character in %s", "Socket::pack_ip_mreq"); + interfacebytes = SvPVbyte(interface, len); + if (len != sizeof(mreq.imr_interface)) + croak("Bad arg length %s, length is %" UVuf + ", should be %" UVuf, + "Socket::pack_ip_mreq", (UV)len, (UV)sizeof(mreq.imr_interface)); + Copy(interfacebytes, &mreq.imr_interface, sizeof(mreq.imr_interface), char); + } + else + mreq.imr_interface.s_addr = INADDR_ANY; + ST(0) = sv_2mortal(newSVpvn((char *)&mreq, sizeof(mreq))); +#else + PERL_UNUSED_VAR(multiaddr); + PERL_UNUSED_VAR(source); + not_here("pack_ip_mreq_source"); +#endif + } + +void +unpack_ip_mreq_source(mreq_sv) + SV * mreq_sv + PPCODE: + { +#if defined(HAS_IP_MREQ_SOURCE) && defined (IP_ADD_SOURCE_MEMBERSHIP) + struct ip_mreq_source mreq; + STRLEN mreqlen; + char * mreqbytes = SvPVbyte(mreq_sv, mreqlen); + if (mreqlen != sizeof(mreq)) + croak("Bad arg length for %s, length is %" UVuf + ", should be %" UVuf, + "Socket::unpack_ip_mreq_source", (UV)mreqlen, (UV)sizeof(mreq)); + Copy(mreqbytes, &mreq, sizeof(mreq), char); + EXTEND(SP, 3); + mPUSHp((char *)&mreq.imr_multiaddr, sizeof(mreq.imr_multiaddr)); + mPUSHp((char *)&mreq.imr_sourceaddr, sizeof(mreq.imr_sourceaddr)); + mPUSHp((char *)&mreq.imr_interface, sizeof(mreq.imr_interface)); +#else + PERL_UNUSED_VAR(mreq_sv); + not_here("unpack_ip_mreq_source"); +#endif + } + +void +pack_ipv6_mreq(multiaddr, ifindex) + SV * multiaddr + unsigned int ifindex + CODE: + { +#ifdef HAS_IPV6_MREQ + struct ipv6_mreq mreq; + char * multiaddrbytes; + STRLEN len; + if (DO_UTF8(multiaddr) && !sv_utf8_downgrade(multiaddr, 1)) + croak("Wide character in %s", "Socket::pack_ipv6_mreq"); + multiaddrbytes = SvPVbyte(multiaddr, len); + if (len != sizeof(mreq.ipv6mr_multiaddr)) + croak("Bad arg length %s, length is %" UVuf + ", should be %" UVuf, + "Socket::pack_ipv6_mreq", (UV)len, (UV)sizeof(mreq.ipv6mr_multiaddr)); + Zero(&mreq, sizeof(mreq), char); + Copy(multiaddrbytes, &mreq.ipv6mr_multiaddr, sizeof(mreq.ipv6mr_multiaddr), char); + mreq.ipv6mr_interface = ifindex; + ST(0) = sv_2mortal(newSVpvn((char *)&mreq, sizeof(mreq))); +#else + PERL_UNUSED_VAR(multiaddr); + PERL_UNUSED_VAR(ifindex); + not_here("pack_ipv6_mreq"); +#endif + } + +void +unpack_ipv6_mreq(mreq_sv) + SV * mreq_sv + PPCODE: + { +#ifdef HAS_IPV6_MREQ + struct ipv6_mreq mreq; + STRLEN mreqlen; + char * mreqbytes = SvPVbyte(mreq_sv, mreqlen); + if (mreqlen != sizeof(mreq)) + croak("Bad arg length for %s, length is %" UVuf + ", should be %" UVuf, + "Socket::unpack_ipv6_mreq", (UV)mreqlen, (UV)sizeof(mreq)); + Copy(mreqbytes, &mreq, sizeof(mreq), char); + EXTEND(SP, 2); + mPUSHp((char *)&mreq.ipv6mr_multiaddr, sizeof(mreq.ipv6mr_multiaddr)); + mPUSHi(mreq.ipv6mr_interface); +#else + PERL_UNUSED_VAR(mreq_sv); + not_here("unpack_ipv6_mreq"); +#endif + } diff --git a/t/Socket.t b/t/Socket.t new file mode 100644 index 0000000..a73f6d4 --- /dev/null +++ b/t/Socket.t @@ -0,0 +1,102 @@ +#!./perl + +BEGIN { + require Config; import Config; + if ($Config{'extensions'} !~ /\bSocket\b/ && + !(($^O eq 'VMS') && $Config{d_socket})) { + print "1..0\n"; + exit 0; + } + $has_alarm = $Config{d_alarm}; +} + +use Socket qw(:all); +use Test::More tests => 6; + +$has_echo = $^O ne 'MSWin32'; +$alarmed = 0; +sub arm { $alarmed = 0; alarm(shift) if $has_alarm } +sub alarmed { $alarmed = 1 } +$SIG{ALRM} = 'alarmed' if $has_alarm; + +SKIP: { + unless(socket(T, PF_INET, SOCK_STREAM, IPPROTO_TCP)) { + skip "No PF_INET", 3; + } + + pass "socket(PF_INET)"; + + arm(5); + my $host = $^O eq 'MacOS' || ($^O eq 'irix' && $Config{osvers} == 5) ? + '127.0.0.1' : 'localhost'; + my $localhost = inet_aton($host); + + SKIP: { + unless($has_echo && defined $localhost && connect(T,pack_sockaddr_in(7,$localhost))) { + skip "Unable to connect to localhost:7", 2; + } + + arm(0); + + pass "PF_INET echo localhost connected"; + + diag "Connected to " . + inet_ntoa((unpack_sockaddr_in(getpeername(T)))[1])."\n"; + + arm(5); + syswrite(T,"hello",5); + arm(0); + + arm(5); + $read = sysread(T,$buff,10); # Connection may be granted, then closed! + arm(0); + + while ($read > 0 && length($buff) < 5) { + # adjust for fact that TCP doesn't guarantee size of reads/writes + arm(5); + $read = sysread(T,$buff,10,length($buff)); + arm(0); + } + + ok(($read == 0 || $buff eq "hello"), "PF_INET echo localhost reply"); + } +} + +SKIP: { + unless(socket(S, PF_INET, SOCK_STREAM, IPPROTO_TCP)) { + skip "No PF_INET", 3; + } + + pass "socket(PF_INET)"; + + SKIP: { + arm(5); + unless($has_echo && connect(S,pack_sockaddr_in(7,INADDR_LOOPBACK))) { + skip "Unable to connect to localhost:7", 2; + } + + arm(0); + + pass "PF_INET echo INADDR_LOOPBACK connected"; + + diag "Connected to " . + inet_ntoa((unpack_sockaddr_in(getpeername(S)))[1])."\n"; + + arm(5); + syswrite(S,"olleh",5); + arm(0); + + arm(5); + $read = sysread(S,$buff,10); # Connection may be granted, then closed! + arm(0); + + while ($read > 0 && length($buff) < 5) { + # adjust for fact that TCP doesn't guarantee size of reads/writes + arm(5); + $read = sysread(S,$buff,10,length($buff)); + arm(0); + } + + ok(($read == 0 || $buff eq "olleh"), "PF_INET echo INADDR_LOOPBACK reply"); + } +} diff --git a/t/getaddrinfo.t b/t/getaddrinfo.t new file mode 100644 index 0000000..b33a3e7 --- /dev/null +++ b/t/getaddrinfo.t @@ -0,0 +1,147 @@ +use strict; +use warnings; +use Test::More tests => 31; + +use Socket qw(:addrinfo AF_INET SOCK_STREAM IPPROTO_TCP unpack_sockaddr_in inet_aton); + +my ( $err, @res ); + +( $err, @res ) = getaddrinfo( "127.0.0.1", "80", { socktype => SOCK_STREAM } ); +cmp_ok( $err, "==", 0, '$err == 0 for host=127.0.0.1/service=80/socktype=STREAM' ); +cmp_ok( $err, "eq", "", '$err eq "" for host=127.0.0.1/service=80/socktype=STREAM' ); +is( scalar @res, 1, + '@res has 1 result' ); + +is( $res[0]->{family}, AF_INET, + '$res[0] family is AF_INET' ); +is( $res[0]->{socktype}, SOCK_STREAM, + '$res[0] socktype is SOCK_STREAM' ); +ok( $res[0]->{protocol} == 0 || $res[0]->{protocol} == IPPROTO_TCP, + '$res[0] protocol is 0 or IPPROTO_TCP' ); +ok( defined $res[0]->{addr}, + '$res[0] addr is defined' ); +if (length $res[0]->{addr}) { + is_deeply( [ unpack_sockaddr_in $res[0]->{addr} ], + [ 80, inet_aton( "127.0.0.1" ) ], + '$res[0] addr is {"127.0.0.1", 80}' ); +} else { + fail( '$res[0] addr is empty: check $socksizetype' ); +} + +# Check actual IV integers work just as well as PV strings +( $err, @res ) = getaddrinfo( "127.0.0.1", 80, { socktype => SOCK_STREAM } ); +cmp_ok( $err, "==", 0, '$err == 0 for host=127.0.0.1/service=80/socktype=STREAM' ); +is_deeply( [ unpack_sockaddr_in $res[0]->{addr} ], + [ 80, inet_aton( "127.0.0.1" ) ], + '$res[0] addr is {"127.0.0.1", 80}' ); + +( $err, @res ) = getaddrinfo( "127.0.0.1", "" ); +cmp_ok( $err, "==", 0, '$err == 0 for host=127.0.0.1' ); +# Might get more than one; e.g. different socktypes +ok( scalar @res > 0, '@res has results' ); + +( $err, @res ) = getaddrinfo( "127.0.0.1", undef ); +cmp_ok( $err, "==", 0, '$err == 0 for host=127.0.0.1/service=undef' ); + +# Test GETMAGIC +{ + "127.0.0.1" =~ /(.+)/; + ( $err, @res ) = getaddrinfo($1, undef); + cmp_ok( $err, "==", 0, '$err == 0 for host=$1' ); + ok( scalar @res > 0, '@res has results' ); + is( (unpack_sockaddr_in $res[0]->{addr})[1], + inet_aton( "127.0.0.1" ), + '$res[0] addr is {"127.0.0.1", ??}' ); +} + +( $err, @res ) = getaddrinfo( "", "80", { family => AF_INET, socktype => SOCK_STREAM, protocol => IPPROTO_TCP } ); +cmp_ok( $err, "==", 0, '$err == 0 for service=80/family=AF_INET/socktype=STREAM/protocol=IPPROTO_TCP' ); +is( scalar @res, 1, '@res has 1 result' ); + +# Just pick the first one +is( $res[0]->{family}, AF_INET, + '$res[0] family is AF_INET' ); +is( $res[0]->{socktype}, SOCK_STREAM, + '$res[0] socktype is SOCK_STREAM' ); +ok( $res[0]->{protocol} == 0 || $res[0]->{protocol} == IPPROTO_TCP, + '$res[0] protocol is 0 or IPPROTO_TCP' ); + +# Now some tests of a few well-known internet hosts +my $goodhost = "cpan.perl.org"; + +SKIP: { + skip "Resolver has no answer for $goodhost", 2 unless gethostbyname( $goodhost ); + + ( $err, @res ) = getaddrinfo( "cpan.perl.org", "ftp", { socktype => SOCK_STREAM } ); + cmp_ok( $err, "==", 0, '$err == 0 for host=cpan.perl.org/service=ftp/socktype=STREAM' ); + # Might get more than one; e.g. different families + ok( scalar @res > 0, '@res has results' ); +} + +# Now something I hope doesn't exist - we put it in a known-missing TLD +my $missinghost = "TbK4jM2M0OS.lm57DWIyu4i"; + +# Some CPAN testing machines seem to have wildcard DNS servers that reply to +# any request. We'd better check for them + +SKIP: { + skip "Resolver has an answer for $missinghost", 1 if gethostbyname( $missinghost ); + + # Some OSes return $err == 0 but no results + ( $err, @res ) = getaddrinfo( $missinghost, "ftp", { socktype => SOCK_STREAM } ); + ok( $err != 0 || ( $err == 0 && @res == 0 ), + '$err != 0 or @res == 0 for host=TbK4jM2M0OS.lm57DWIyu4i/service=ftp/socktype=SOCK_STREAM' ); + if( @res ) { + # Diagnostic that might help + while( my $r = shift @res ) { + diag( "family=$r->{family} socktype=$r->{socktype} protocol=$r->{protocol} addr=[" . length( $r->{addr} ) . " bytes]" ); + diag( " addr=" . join( ", ", map { sprintf '0x%02x', ord $_ } split m//, $r->{addr} ) ); + } + } +} + +# Numeric addresses with AI_NUMERICHOST should pass (RT95758) +AI_NUMERICHOST: { + # Here we need a port that is open to the world. Not all places have all + # the ports. For example Solaris by default doesn't have http/80 in + # /etc/services, and that would fail. Let's try a couple of commonly open + # ports, and hope one of them will succeed. Conversely this means that + # sometimes this will fail. + # + # An alternative method would be to manually parse /etc/services and look + # for enabled services but that's kind of yuck, too. + my @port = (80, 7, 22, 25, 88, 123, 110, 389, 443, 445, 873, 2049, 3306); + foreach my $port ( @port ) { + ( $err, @res ) = getaddrinfo( "127.0.0.1", $port, { flags => AI_NUMERICHOST, socktype => SOCK_STREAM } ); + if( $err == 0 ) { + ok( $err == 0, "\$err == 0 for 127.0.0.1/$port/flags=AI_NUMERICHOST" ); + last AI_NUMERICHOST; + } + } + fail( "$err for 127.0.0.1/$port[-1]/flags=AI_NUMERICHOST (failed for ports @port)" ); +} + +# Now check that names with AI_NUMERICHOST fail + +SKIP: { + skip "Resolver has no answer for $goodhost", 1 unless gethostbyname( $goodhost ); + + ( $err, @res ) = getaddrinfo( $goodhost, "ftp", { flags => AI_NUMERICHOST, socktype => SOCK_STREAM } ); + ok( $err != 0, "\$err != 0 for host=$goodhost/service=ftp/flags=AI_NUMERICHOST/socktype=SOCK_STREAM" ); +} + +# Some sanity checking on the hints hash +ok( defined eval { getaddrinfo( "127.0.0.1", "80", undef ); 1 }, + 'getaddrinfo() with undef hints works' ); +ok( !defined eval { getaddrinfo( "127.0.0.1", "80", "hints" ); 1 }, + 'getaddrinfo() with string hints dies' ); +ok( !defined eval { getaddrinfo( "127.0.0.1", "80", [] ); 1 }, + 'getaddrinfo() with ARRAY hints dies' ); + +# Ensure it doesn't segfault if args are missing + +( $err, @res ) = getaddrinfo(); +ok( defined $err, '$err defined for getaddrinfo()' ); + +( $err, @res ) = getaddrinfo( "127.0.0.1" ); +ok( defined $err, '$err defined for getaddrinfo("127.0.0.1")' ); diff --git a/t/getnameinfo.t b/t/getnameinfo.t new file mode 100644 index 0000000..c5655bc --- /dev/null +++ b/t/getnameinfo.t @@ -0,0 +1,39 @@ +use strict; +use warnings; +use Test::More tests => 13; + +use Socket qw(:addrinfo AF_INET pack_sockaddr_in inet_aton); + +my ( $err, $host, $service ); + +( $err, $host, $service ) = getnameinfo( pack_sockaddr_in( 80, inet_aton( "127.0.0.1" ) ), NI_NUMERICHOST|NI_NUMERICSERV ); +cmp_ok( $err, "==", 0, '$err == 0 for {family=AF_INET,port=80,sinaddr=127.0.0.1}/NI_NUMERICHOST|NI_NUMERICSERV' ); +cmp_ok( $err, "eq", "", '$err eq "" for {family=AF_INET,port=80,sinaddr=127.0.0.1}/NI_NUMERICHOST|NI_NUMERICSERV' ); + +is( $host, "127.0.0.1", '$host is 127.0.0.1 for NH/NS' ); +is( $service, "80", '$service is 80 for NH/NS' ); + +( $err, $host, $service ) = getnameinfo( pack_sockaddr_in( 80, inet_aton( "127.0.0.1" ) ), NI_NUMERICHOST|NI_NUMERICSERV, NIx_NOHOST ); +is( $host, undef, '$host is undef for NIx_NOHOST' ); +is( $service, "80", '$service is 80 for NS, NIx_NOHOST' ); + +( $err, $host, $service ) = getnameinfo( pack_sockaddr_in( 80, inet_aton( "127.0.0.1" ) ), NI_NUMERICHOST|NI_NUMERICSERV, NIx_NOSERV ); +is( $host, "127.0.0.1", '$host is undef for NIx_NOSERV' ); +is( $service, undef, '$service is 80 for NS, NIx_NOSERV' ); + +( $err, $host, $service ) = getnameinfo( pack_sockaddr_in( 80, inet_aton( "127.0.0.1" ) ), NI_NUMERICSERV ); +cmp_ok( $err, "==", 0, '$err == 0 for {family=AF_INET,port=80,sinaddr=127.0.0.1}/NI_NUMERICSERV' ); + +# We can't meaningfully compare '$host' with anything specific, all we can be +# sure is it's not empty +ok( length $host, '$host is nonzero length for NS' ); + +( $err, $host, $service ) = getnameinfo( pack_sockaddr_in( 80, inet_aton( "127.0.0.1" ) ), NI_NUMERICHOST | NI_NUMERICSERV ); +cmp_ok( $err, "==", 0, '$err == 0 for {family=AF_INET,port=80,sinaddr=127.0.0.1}/NI_NUMERICHOST' ); + +ok( length $service, '$service is nonzero length for NH' ); + +# RT79557 +pack_sockaddr_in( 80, inet_aton( "127.0.0.1" ) ) =~ m/^(.*)$/s; +( $err, $host, $service ) = getnameinfo( $1, NI_NUMERICHOST|NI_NUMERICSERV ); +cmp_ok( $err, "==", 0, '$err == 0 for $1' ) or diag( '$err was: ' . $err ); diff --git a/t/ip_mreq.t b/t/ip_mreq.t new file mode 100644 index 0000000..2ed7606 --- /dev/null +++ b/t/ip_mreq.t @@ -0,0 +1,41 @@ +use strict; +use warnings; +use Test::More; + +use Socket qw( + INADDR_ANY + pack_ip_mreq unpack_ip_mreq + pack_ip_mreq_source unpack_ip_mreq_source +); + +# Check that pack/unpack_ip_mreq either croak with "Not implemented", or +# roundtrip as identity + +my $packed; +eval { + $packed = pack_ip_mreq "\xe0\0\0\1", INADDR_ANY; +}; +if( !defined $packed ) { + plan skip_all => "No pack_ip_mreq" if $@ =~ m/ not implemented /; + die $@; +} + +plan tests => 6; + +my @unpacked = unpack_ip_mreq $packed; + +is( $unpacked[0], "\xe0\0\0\1", 'unpack_ip_mreq multiaddr' ); +is( $unpacked[1], INADDR_ANY, 'unpack_ip_mreq interface' ); + +is( (unpack_ip_mreq pack_ip_mreq "\xe0\0\0\1")[1], INADDR_ANY, 'pack_ip_mreq interface defaults to INADDR_ANY' ); + +SKIP: { + my $mreq; + skip "No pack_ip_mreq_source", 3 unless defined eval { $mreq = pack_ip_mreq_source "\xe0\0\0\2", "\x0a\0\0\1", INADDR_ANY }; + + @unpacked = unpack_ip_mreq_source $mreq; + + is( $unpacked[0], "\xe0\0\0\2", 'unpack_ip_mreq_source multiaddr' ); + is( $unpacked[1], "\x0a\0\0\1", 'unpack_ip_mreq_source source' ); + is( $unpacked[2], INADDR_ANY, 'unpack_ip_mreq_source interface' ); +} diff --git a/t/ipv6_mreq.t b/t/ipv6_mreq.t new file mode 100644 index 0000000..1f0e122 --- /dev/null +++ b/t/ipv6_mreq.t @@ -0,0 +1,26 @@ +use strict; +use warnings; +use Test::More; + +use Socket qw( + pack_ipv6_mreq unpack_ipv6_mreq +); + +# Check that pack/unpack_ipv6_mreq either croak with "Not implemented", or +# roundtrip as identity + +my $packed; +eval { + $packed = pack_ipv6_mreq "ANADDRESSIN16CHR", 123; +}; +if( !defined $packed ) { + plan skip_all => "No pack_ipv6_mreq" if $@ =~ m/ not implemented /; + die $@; +} + +plan tests => 2; + +my @unpacked = unpack_ipv6_mreq $packed; + +is( $unpacked[0], "ANADDRESSIN16CHR", 'unpack_ipv6_mreq multiaddr' ); +is( $unpacked[1], 123, 'unpack_ipv6_mreq ifindex' ); diff --git a/t/sockaddr.t b/t/sockaddr.t new file mode 100644 index 0000000..9f17afb --- /dev/null +++ b/t/sockaddr.t @@ -0,0 +1,175 @@ +#!./perl + +use strict; +use warnings; + +use Socket qw( + AF_INET + inet_ntoa inet_aton inet_ntop inet_pton + pack_sockaddr_in unpack_sockaddr_in sockaddr_in + pack_sockaddr_un unpack_sockaddr_un + sockaddr_family + sockaddr_un +); +use Test::More tests => 46; + +# inet_aton, inet_ntoa +{ + is(join(".", unpack("C*",inet_aton("10.20.30.40"))), "10.20.30.40", 'inet_aton returns packed bytes'); + + is(inet_ntoa(v10.20.30.40), "10.20.30.40", 'inet_ntoa from v-string'); + + is(inet_ntoa(inet_aton("10.20.30.40")), "10.20.30.40", 'inet_aton->inet_ntoa roundtrip'); + + local $@; + eval { inet_ntoa(v10.20.30.400) }; + like($@, qr/^Wide character in Socket::inet_ntoa at/, 'inet_ntoa warns about wide characters'); +} + +# inet_ntop, inet_pton +SKIP: { + skip "No inet_ntop", 5 unless defined eval { inet_pton(AF_INET, "10.20.30.40") }; + + is(join(".", unpack("C*",inet_pton(AF_INET, "10.20.30.40"))), "10.20.30.40", 'inet_pton AF_INET returns packed bytes'); + + is(inet_ntop(AF_INET, v10.20.30.40), "10.20.30.40", 'inet_ntop AF_INET from v-string'); + + is(inet_ntop(AF_INET, inet_pton(AF_INET, "10.20.30.40")), "10.20.30.40", 'inet_pton->inet_ntop AF_INET roundtrip'); + is(inet_ntop(AF_INET, inet_aton("10.20.30.40")), "10.20.30.40", 'inet_aton->inet_ntop AF_INET roundtrip'); + + local $@; + eval { inet_ntop(AF_INET, v10.20.30.400) }; + like($@, qr/^Wide character in Socket::inet_ntop at/, 'inet_ntop warns about wide characters'); +} + +SKIP: { + skip "No AF_INET6", 3 unless my $AF_INET6 = eval { Socket::AF_INET6() }; + skip "No inet_ntop", 3 unless defined eval { inet_pton($AF_INET6, "2460::1") }; + + is(uc unpack("H*",inet_pton($AF_INET6, "2001:503:BA3E::2:30")), "20010503BA3E00000000000000020030", + 'inet_pton AF_INET6 returns packed bytes'); + + is(uc inet_ntop($AF_INET6, "\x20\x01\x05\x03\xBA\x3E\x00\x00\x00\x00\x00\x00\x00\x02\x00\x30"), "2001:503:BA3E::2:30", + 'inet_ntop AF_INET6 from octet string'); + + is(lc inet_ntop($AF_INET6, inet_pton($AF_INET6, "2001:503:BA3E::2:30")), "2001:503:ba3e::2:30", + 'inet_pton->inet_ntop AF_INET6 roundtrip'); +} + +# sockaddr_family +{ + local $@; + eval { sockaddr_family("") }; + like($@, qr/^Bad arg length for Socket::sockaddr_family, length is 0, should be at least \d+/, 'sockaddr_family warns about argument length'); +} + +# pack_sockaddr_in, unpack_sockaddr_in +# sockaddr_in +{ + my $sin = pack_sockaddr_in 100, inet_aton("10.20.30.40"); + ok(defined $sin, 'pack_sockaddr_in defined'); + + is(sockaddr_family($sin), AF_INET, 'sockaddr_family of pack_sockaddr_in' ); + + is( (unpack_sockaddr_in($sin))[0] , 100, 'pack_sockaddr_in->unpack_sockaddr_in port'); + is(inet_ntoa((unpack_sockaddr_in($sin))[1]), "10.20.30.40", 'pack_sockaddr_in->unpack_sockaddr_in addr'); + + is(inet_ntoa(scalar unpack_sockaddr_in($sin)), "10.20.30.40", 'unpack_sockaddr_in in scalar context yields addr'); + + is_deeply( [ sockaddr_in($sin) ], [ unpack_sockaddr_in($sin) ], + 'sockaddr_in in list context unpacks' ); + + is(sockaddr_family(scalar sockaddr_in(200,v10.30.50.70)), AF_INET, + 'sockaddr_in in scalar context packs'); + + my $warnings = 0; + local $SIG{__WARN__} = sub { $warnings++ }; + ok( !eval { pack_sockaddr_in 0, undef; 1 }, + 'pack_sockaddr_in undef addr is fatal' ); + ok( !eval { unpack_sockaddr_in undef; 1 }, + 'unpack_sockaddr_in undef is fatal' ); + + ok( eval { pack_sockaddr_in undef, "\0\0\0\0"; 1 }, + 'pack_sockaddr_in undef port is allowed' ); + + is( $warnings, 0, 'undefined values produced no warnings' ); +} + +# pack_sockaddr_in6, unpack_sockaddr_in6 +# sockaddr_in6 +SKIP: { + skip "No AF_INET6", 13 unless my $AF_INET6 = eval { Socket::AF_INET6() }; + skip "Cannot pack_sockaddr_in6()", 13 unless my $sin6 = eval { Socket::pack_sockaddr_in6(0x1234, "0123456789abcdef", 0, 89) }; + + ok(defined $sin6, 'pack_sockaddr_in6 defined'); + + is(sockaddr_family($sin6), $AF_INET6, 'sockaddr_family of pack_sockaddr_in6'); + + is((Socket::unpack_sockaddr_in6($sin6))[0], 0x1234, 'pack_sockaddr_in6->unpack_sockaddr_in6 port'); + is((Socket::unpack_sockaddr_in6($sin6))[1], "0123456789abcdef", 'pack_sockaddr_in6->unpack_sockaddr_in6 addr'); + is((Socket::unpack_sockaddr_in6($sin6))[2], 0, 'pack_sockaddr_in6->unpack_sockaddr_in6 scope_id'); + is((Socket::unpack_sockaddr_in6($sin6))[3], 89, 'pack_sockaddr_in6->unpack_sockaddr_in6 flowinfo'); + + is(scalar Socket::unpack_sockaddr_in6($sin6), "0123456789abcdef", 'unpack_sockaddr_in6 in scalar context yields addr'); + + is_deeply( [ Socket::sockaddr_in6($sin6) ], [ Socket::unpack_sockaddr_in6($sin6) ], + 'sockaddr_in6 in list context unpacks' ); + + is(sockaddr_family(scalar Socket::sockaddr_in6(0x1357, "02468ace13579bdf")), $AF_INET6, + 'sockaddr_in6 in scalar context packs' ); + + my $warnings = 0; + local $SIG{__WARN__} = sub { $warnings++ }; + ok( !eval { Socket::pack_sockaddr_in6( 0, undef ); 1 }, + 'pack_sockaddr_in6 undef addr is fatal' ); + ok( !eval { Socket::unpack_sockaddr_in6( undef ); 1 }, + 'unpack_sockaddr_in6 undef is fatal' ); + + ok( eval { Socket::pack_sockaddr_in6( undef, "\0"x16 ); 1 }, + 'pack_sockaddr_in6 undef port is allowed' ); + + is( $warnings, 0, 'undefined values produced no warnings' ); +} + +# sockaddr_un on abstract paths +SKIP: { + # see if we can handle abstract sockets + skip "Abstract AF_UNIX paths unsupported", 7 unless $^O eq "linux"; + + my $test_abstract_socket = chr(0) . '/org/perl/hello'. chr(0) . 'world'; + my $addr = sockaddr_un ($test_abstract_socket); + my ($path) = sockaddr_un ($addr); + is($path, $test_abstract_socket, 'sockaddr_un can handle abstract AF_UNIX paths'); + + # see if we calculate the address structure length correctly + is(length ($test_abstract_socket) + 2, length $addr, 'sockaddr_un abstract address length'); + + my $warnings = 0; + local $SIG{__WARN__} = sub { $warnings++ }; + ok( !eval { pack_sockaddr_un( undef ); 1 }, + 'pack_sockaddr_un undef path is fatal' ); + ok( !eval { unpack_sockaddr_un( undef ); 1 }, + 'unpack_sockaddr_un undef is fatal' ); + + is( $warnings, 0, 'undefined values produced no warnings' ); + + ok( eval { pack_sockaddr_un( "x" x 0x10000 ); 1 }, + 'pack_sockaddr_un(very long path) succeeds' ) or diag( "Died: $@" ); + is( $warnings, 1, 'pack_sockaddr_in(very long path) warns' ); +} + +# warnings +{ + my $w = 0; + local $SIG{__WARN__} = sub { + ++ $w if $_[0] =~ /^6-ARG sockaddr_in call is deprecated/ ; + }; + + no warnings 'Socket'; + sockaddr_in(1,2,3,4,5,6) ; + is($w, 0, "sockaddr_in deprecated form doesn't warn without lexical warnings"); + + use warnings 'Socket'; + sockaddr_in(1,2,3,4,5,6) ; + is($w, 1, "sockaddr_in deprecated form warns with lexical warnings"); +} diff --git a/t/socketpair.t b/t/socketpair.t new file mode 100644 index 0000000..cb11e26 --- /dev/null +++ b/t/socketpair.t @@ -0,0 +1,249 @@ +#!./perl -w + +my $child; +my $can_fork; +my $has_perlio; + +BEGIN { + require Config; import Config; + $can_fork = $Config{'d_fork'} || $Config{'d_pseudofork'}; + + if ($^O eq "hpux" or $Config{'extensions'} !~ /\bSocket\b/ && + !(($^O eq 'VMS') && $Config{d_socket})) { + print "1..0\n"; + exit 0; + } +} + +{ + # This was in the BEGIN block, but since Test::More 0.47 added support to + # detect forking, we don't need to fork before Test::More initialises. + + # Too many things in this test will hang forever if something is wrong, + # so we need a self destruct timer. And IO can hang despite an alarm. + + if( $can_fork) { + my $parent = $$; + $child = fork; + die "Fork failed" unless defined $child; + if (!$child) { + $SIG{INT} = sub {exit 0}; # You have 60 seconds. Your time starts now. + my $must_finish_by = time + 60; + my $remaining; + while (($remaining = $must_finish_by - time) > 0) { + sleep $remaining; + } + warn "Something unexpectedly hung during testing"; + kill "INT", $parent or die "Kill failed: $!"; + if( $^O eq "cygwin" ) { + # sometimes the above isn't enough on cygwin + sleep 1; # wait a little, it might have worked after all + system( "/bin/kill -f $parent; echo die $parent" ); + } + exit 1; + } + } + unless ($has_perlio = PerlIO::Layer->can("find") && PerlIO::Layer->find('perlio')) { + print < "alarm() not implemented on this platform"; +} elsif( !$can_fork ) { + plan skip_all => "fork() not implemented on this platform"; +} else { + # This should fail but not die if there is real socketpair + eval {socketpair LEFT, RIGHT, -1, -1, -1}; + if ($@ =~ /^Unsupported socket function "socketpair" called/ || + $! =~ /^The operation requested is not supported./) { # Stratus VOS + plan skip_all => 'No socketpair (real or emulated)'; + } else { + eval {AF_UNIX}; + if ($@ =~ /^Your vendor has not defined Socket macro AF_UNIX/) { + plan skip_all => 'No AF_UNIX'; + } else { + plan tests => 45; + } + } +} + +# But we'll install an alarm handler in case any of the races below fail. +$SIG{ALRM} = sub {die "Unexpected alarm during testing"}; + +ok (socketpair (LEFT, RIGHT, AF_UNIX, SOCK_STREAM, PF_UNSPEC), + "socketpair (LEFT, RIGHT, AF_UNIX, SOCK_STREAM, PF_UNSPEC)") + or print STDERR "# \$\! = $!\n"; + +if ($has_perlio) { + binmode(LEFT, ":bytes"); + binmode(RIGHT, ":bytes"); +} + +my @left = ("hello ", "world\n"); +my @right = ("perl ", "rules!"); # Not like I'm trying to bias any survey here. + +foreach (@left) { + # is (syswrite (LEFT, $_), length $_, "write " . _qq ($_) . " to left"); + is (syswrite (LEFT, $_), length $_, "syswrite to left"); +} +foreach (@right) { + # is (syswrite (RIGHT, $_), length $_, "write " . _qq ($_) . " to right"); + is (syswrite (RIGHT, $_), length $_, "syswrite to right"); +} + +# stream socket, so our writes will become joined: +my ($buffer, $expect); +$expect = join '', @right; +undef $buffer; +is (read (LEFT, $buffer, length $expect), length $expect, "read on left"); +is ($buffer, $expect, "content what we expected?"); +$expect = join '', @left; +undef $buffer; +is (read (RIGHT, $buffer, length $expect), length $expect, "read on right"); +is ($buffer, $expect, "content what we expected?"); + +ok (shutdown(LEFT, SHUT_WR), "shutdown left for writing"); +# This will hang forever if eof is buggy, and alarm doesn't interrupt system +# Calls. Hence the child process minder. +SKIP: { + skip "SCO Unixware / OSR have a bug with shutdown",2 if $^O =~ /^(?:svr|sco)/; + local $SIG{ALRM} = sub { warn "EOF on right took over 3 seconds" }; + local $TODO = "Known problems with unix sockets on $^O" + if $^O eq 'hpux' || $^O eq 'super-ux'; + alarm 3; + $! = 0; + ok (eof RIGHT, "right is at EOF"); + local $TODO = "Known problems with unix sockets on $^O" + if $^O eq 'unicos' || $^O eq 'unicosmk'; + is ($!, '', 'and $! should report no error'); + alarm 60; +} + +my $err = $!; +$SIG{PIPE} = 'IGNORE'; +{ + local $SIG{ALRM} = + sub { warn "syswrite to left didn't fail within 3 seconds" }; + alarm 3; + # Split the system call from the is() - is() does IO so + # (say) a flush may do a seek which on a pipe may disturb errno + my $ans = syswrite (LEFT, "void"); + $err = $!; + is ($ans, undef, "syswrite to shutdown left should fail"); + alarm 60; +} +{ + # This may need skipping on some OSes - restoring value saved above + # should help + $! = $err; + ok (($!{EPIPE} or $!{ESHUTDOWN}), '$! should be EPIPE or ESHUTDOWN') + or printf STDERR "# \$\! = %d (%s)\n", $err, $err; +} + +my @gripping = (chr 255, chr 127); +foreach (@gripping) { + is (syswrite (RIGHT, $_), length $_, "syswrite to right"); +} + +ok (!eof LEFT, "left is not at EOF"); + +$expect = join '', @gripping; +undef $buffer; +is (read (LEFT, $buffer, length $expect), length $expect, "read on left"); +is ($buffer, $expect, "content what we expected?"); + +ok (close LEFT, "close left"); +ok (close RIGHT, "close right"); + + +# And now datagrams +# I suspect we also need a self destruct time-bomb for these, as I don't see any +# guarantee that the stack won't drop a UDP packet, even if it is for localhost. + +SKIP: { + skip "No usable SOCK_DGRAM for socketpair", 24 if ($^O =~ /^(MSWin32|os2)\z/); + skip "alarm doesn't interrupt I/O on this Perl", 24 if "$]" < 5.008; + local $TODO = "socketpair not supported on $^O" if $^O eq 'nto'; + + ok (socketpair (LEFT, RIGHT, AF_UNIX, SOCK_DGRAM, PF_UNSPEC), + "socketpair (LEFT, RIGHT, AF_UNIX, SOCK_DGRAM, PF_UNSPEC)") + or print STDERR "# \$\! = $!\n"; + + if ($has_perlio) { + binmode(LEFT, ":bytes"); + binmode(RIGHT, ":bytes"); + } + + foreach (@left) { + # is (syswrite (LEFT, $_), length $_, "write " . _qq ($_) . " to left"); + is (syswrite (LEFT, $_), length $_, "syswrite to left"); + } + foreach (@right) { + # is (syswrite (RIGHT, $_), length $_, "write " . _qq ($_) . " to right"); + is (syswrite (RIGHT, $_), length $_, "syswrite to right"); + } + + # stream socket, so our writes will become joined: + my ($total); + $total = join '', @right; + foreach $expect (@right) { + undef $buffer; + is (sysread (LEFT, $buffer, length $total), length $expect, "read on left"); + is ($buffer, $expect, "content what we expected?"); + } + $total = join '', @left; + foreach $expect (@left) { + undef $buffer; + is (sysread (RIGHT, $buffer, length $total), length $expect, "read on right"); + is ($buffer, $expect, "content what we expected?"); + } + + ok (shutdown(LEFT, 1), "shutdown left for writing"); + + # eof uses buffering. eof is indicated by a sysread of zero. + # but for a datagram socket there's no way it can know nothing will ever be + # sent + SKIP: { + skip "$^O does length 0 udp reads", 2 if ($^O eq 'os390'); + + my $alarmed = 0; + local $SIG{ALRM} = sub { $alarmed = 1; }; + print "# Approximate forever as 3 seconds. Wait 'forever'...\n"; + alarm 3; + undef $buffer; + is (sysread (RIGHT, $buffer, 1), undef, + "read on right should be interrupted"); + is ($alarmed, 1, "alarm should have fired"); + } + + alarm 30; + + foreach (@gripping) { + is (syswrite (RIGHT, $_), length $_, "syswrite to right"); + } + + $total = join '', @gripping; + foreach $expect (@gripping) { + undef $buffer; + is (sysread (LEFT, $buffer, length $total), length $expect, "read on left"); + is ($buffer, $expect, "content what we expected?"); + } + + ok (close LEFT, "close left"); + ok (close RIGHT, "close right"); + +} # end of DGRAM SKIP + +kill "INT", $child or warn "Failed to kill child process $child: $!"; +exit 0; diff --git a/typemap b/typemap new file mode 100644 index 0000000..e884838 --- /dev/null +++ b/typemap @@ -0,0 +1,2 @@ +TYPEMAP +const char * T_PV