diff options
| -rw-r--r-- | Build.PL | 28 | ||||
| -rw-r--r-- | Changes | 69 | ||||
| -rw-r--r-- | LICENSE | 379 | ||||
| -rw-r--r-- | MANIFEST | 25 | ||||
| -rw-r--r-- | META.json | 53 | ||||
| -rw-r--r-- | META.yml | 33 | ||||
| -rw-r--r-- | Makefile.PL | 18 | ||||
| -rw-r--r-- | README | 222 | ||||
| -rw-r--r-- | examples/SYNOPSIS.pl | 23 | ||||
| -rw-r--r-- | examples/client.pl | 69 | ||||
| -rw-r--r-- | examples/intro-01-helloworld.pl | 24 | ||||
| -rw-r--r-- | examples/intro-02-whatsyourname.pl | 43 | ||||
| -rw-r--r-- | lib/Net/Async/IRC.pm | 530 | ||||
| -rw-r--r-- | lib/Net/Async/IRC/Introduction.pod | 185 | ||||
| -rw-r--r-- | lib/Net/Async/IRC/Protocol.pm | 412 | ||||
| -rw-r--r-- | t/00use.t | 11 | ||||
| -rw-r--r-- | t/30client-connect.t | 107 | ||||
| -rw-r--r-- | t/31client-cap.t | 100 | ||||
| -rw-r--r-- | t/32client-encoding.t | 84 | ||||
| -rw-r--r-- | t/33client-nick.t | 100 | ||||
| -rw-r--r-- | t/40methods-basic.t | 40 | ||||
| -rw-r--r-- | t/50client-pingpong.t | 86 | ||||
| -rw-r--r-- | t/99pod.t | 11 | ||||
| -rw-r--r-- | t/privkey.pem | 15 | ||||
| -rw-r--r-- | t/server.pem | 17 |
25 files changed, 2684 insertions, 0 deletions
diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..f5be62c --- /dev/null +++ b/Build.PL @@ -0,0 +1,28 @@ +use strict; +use warnings; + +use Module::Build; + +my $build = Module::Build->new( + module_name => 'Net::Async::IRC', + requires => { + 'IO::Async::Loop' => '0.54', # ->connect Future + 'IO::Async::Stream' => '0.59', # Protocol deprecation + 'Protocol::IRC::Client' => '0.12', + 'Time::HiRes' => 0, + 'perl' => '5.010', # //, mro c3 + }, + test_requires => { + 'IO::Async::OS' => 0, + 'IO::Async::Test' => 0.14, + 'Test::Fatal' => 0, + 'Test::More' => '0.88', # done_testing + }, + auto_configure_requires => 0, # Don't add M::B to configure_requires + license => 'perl', + create_makefile_pl => 'traditional', + create_license => 1, + create_readme => 1, +); + +$build->create_build_script; @@ -0,0 +1,69 @@ +Revision history for Net-Async-IRC + +0.11 2017/03/04 11:14:11 + [CHANGES] + * Protocol::IRC is now moved to its own distribution + * Expanded documentation, including the start of an introduction + tutorial + +0.10 2014/06/12 02:02:58 + [CHANGES] + * Ignore received blank lines + * Allow capture of IRC parse errors as custom error handling + + [BUGFIXES] + * Ensure that connection close during login counts as a failure for + pending login futures + +0.09 2014/01/21 12:21:41 + [CHANGES] + * Removed now-dead NaIRC::Message subclass + + [BUGFIXES] + * Ensure that handled gated commands don't appear as unhnandled to + the default 'on_message' handler + * Fix return EXPR and EXPR operator precedence (RT87260) + * Correctly set internal nick state when logging in after an + ERR_NICKINUSE error (RT90487) + * MSWin32 lacks a getpwnam() - use Win32::LoginName() instead + +0.08 2014/01/20 01:52:18 + [CHANGES] + * Directly subclass IO::Async::Stream instead of IO::Async::Protocol + * Implement IRCv3.1 CAP negotiation + * Much improved handling of command/response gating + * Implement 'whois' message gate + * Futures-first documentation and testing + +0.07 CHANGES: + * Much splitting of non-async logic out of NaIRC into Protocol::IRC + tree + * Added name aliases for server numerics + * Dispatch message handler methods for numerics to names first, + before raw numbers + +0.06 CHANGES: + * Renamed Net::Async::IRC::Message to Protocol::IRC::Message, as the + first step of the split to Protocol::IRC + * Implement IRCv3 message tags + +0.05 CHANGES: + * Bugfix for ->connect() with service => undef + * Some more numerics + * New model for storing numerics in source code + +0.04 CHANGES: + * Split lower-level code into new Net::Async::IRC::Protocol module + * Use IO::Async::Protocol->connect from 0.34 + +0.03 BUGFIXES: + * Fix failures due to IO::Async::Test or ::Loop no longer loading + IO::Async::Stream; load it explicitly where needed + +0.02 CHANGES: + * Some more numerics + * Capture named args from more WHOIS numerics + * base on IO::Async::Protocol::Stream + +0.01 First version, released on an unsuspecting world. + @@ -0,0 +1,379 @@ +This software is copyright (c) 2017 by Paul Evans <leonerd@leonerd.org.uk>. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +Terms of the Perl programming language system itself + +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" + +--- The GNU General Public License, Version 1, February 1989 --- + +This software is Copyright (c) 2017 by Paul Evans <leonerd@leonerd.org.uk>. + +This is free software, licensed under: + + The GNU General Public License, Version 1, February 1989 + + 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. + + <one line to give the program's name and a brief idea of what it does.> + Copyright (C) 19yy <name of author> + + 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. + + <signature of Ty Coon>, 1 April 1989 + Ty Coon, President of Vice + +That's all there is to it! + + +--- The Artistic License 1.0 --- + +This software is Copyright (c) 2017 by Paul Evans <leonerd@leonerd.org.uk>. + +This is free software, licensed under: + + The Artistic License 1.0 + +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. + - "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 ftp.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) accompany any non-standard executables with their corresponding Standard + Version executables, giving the non-standard executables non-standard + names, and clearly documenting 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. + +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 whomever generated them, and may be sold +commercially, and may be aggregated with this Package. + +7. C or perl subroutines supplied by you and linked into this Package shall not +be considered part of this Package. + +8. The name of the Copyright Holder may not be used to endorse or promote +products derived from this software without specific prior written permission. + +9. 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/MANIFEST b/MANIFEST new file mode 100644 index 0000000..79703e9 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,25 @@ +Build.PL +Changes +examples/client.pl +examples/intro-01-helloworld.pl +examples/intro-02-whatsyourname.pl +examples/SYNOPSIS.pl +lib/Net/Async/IRC.pm +lib/Net/Async/IRC/Introduction.pod +lib/Net/Async/IRC/Protocol.pm +LICENSE +Makefile.PL +MANIFEST This list of files +META.json +META.yml +README +t/00use.t +t/30client-connect.t +t/31client-cap.t +t/32client-encoding.t +t/33client-nick.t +t/40methods-basic.t +t/50client-pingpong.t +t/99pod.t +t/privkey.pem +t/server.pem diff --git a/META.json b/META.json new file mode 100644 index 0000000..f7f672a --- /dev/null +++ b/META.json @@ -0,0 +1,53 @@ +{ + "abstract" : "use IRC with C<IO::Async>", + "author" : [ + "Paul Evans <leonerd@leonerd.org.uk>" + ], + "dynamic_config" : 1, + "generated_by" : "Module::Build version 0.422", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "Net-Async-IRC", + "prereqs" : { + "runtime" : { + "requires" : { + "IO::Async::Loop" : "0.54", + "IO::Async::Stream" : "0.59", + "Protocol::IRC::Client" : "0.12", + "Time::HiRes" : "0", + "perl" : "5.010" + } + }, + "test" : { + "requires" : { + "IO::Async::OS" : "0", + "IO::Async::Test" : "0.14", + "Test::Fatal" : "0", + "Test::More" : "0.88" + } + } + }, + "provides" : { + "Net::Async::IRC" : { + "file" : "lib/Net/Async/IRC.pm", + "version" : "0.11" + }, + "Net::Async::IRC::Protocol" : { + "file" : "lib/Net/Async/IRC/Protocol.pm", + "version" : "0.11" + } + }, + "release_status" : "stable", + "resources" : { + "license" : [ + "http://dev.perl.org/licenses/" + ] + }, + "version" : "0.11", + "x_serialization_backend" : "JSON::PP version 2.27400" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..eaa2d58 --- /dev/null +++ b/META.yml @@ -0,0 +1,33 @@ +--- +abstract: 'use IRC with C<IO::Async>' +author: + - 'Paul Evans <leonerd@leonerd.org.uk>' +build_requires: + IO::Async::OS: '0' + IO::Async::Test: '0.14' + Test::Fatal: '0' + Test::More: '0.88' +dynamic_config: 1 +generated_by: 'Module::Build version 0.422, CPAN::Meta::Converter version 2.150005' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Net-Async-IRC +provides: + Net::Async::IRC: + file: lib/Net/Async/IRC.pm + version: '0.11' + Net::Async::IRC::Protocol: + file: lib/Net/Async/IRC/Protocol.pm + version: '0.11' +requires: + IO::Async::Loop: '0.54' + IO::Async::Stream: '0.59' + Protocol::IRC::Client: '0.12' + Time::HiRes: '0' + perl: '5.010' +resources: + license: http://dev.perl.org/licenses/ +version: '0.11' +x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..6feaa8d --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,18 @@ +# Note: this file was auto-generated by Module::Build::Compat version 0.4220 +require 5.010; +use ExtUtils::MakeMaker; +WriteMakefile +( + 'NAME' => 'Net::Async::IRC', + 'VERSION_FROM' => 'lib/Net/Async/IRC.pm', + 'PREREQ_PM' => { + 'IO::Async::Loop' => '0.54', + 'IO::Async::Stream' => '0.59', + 'Protocol::IRC::Client' => '0.12', + 'Time::HiRes' => 0 + }, + 'INSTALLDIRS' => 'site', + 'EXE_FILES' => [], + 'PL_FILES' => {} +) +; @@ -0,0 +1,222 @@ +NAME + + Net::Async::IRC - use IRC with IO::Async + +SYNOPSIS + + use IO::Async::Loop; + use Net::Async::IRC; + + my $loop = IO::Async::Loop->new; + + my $irc = Net::Async::IRC->new( + on_message_text => sub { + my ( $self, $message, $hints ) = @_; + + print "$hints->{prefix_name} says: $hints->{text}\n"; + }, + ); + + $loop->add( $irc ); + + $irc->login( + nick => "MyName", + host => "irc.example.org", + )->get; + + $irc->do_PRIVMSG( target => "YourName", text => "Hello world!" ); + + $loop->run; + +DESCRIPTION + + This object class implements an asynchronous IRC client, for use in + programs based on IO::Async. + + Most of the actual IRC message handling behaviour is implemented by the + parent class Net::Async::IRC::Protocol. + + Most of the behaviour related to being an IRC client is implemented by + the parent class Protocol::IRC::Client. + + The following documentation may make mention of these above two parent + classes; the reader should make reference to them when required. + +PARAMETERS + + The following named parameters may be passed to new or configure: + + nick => STRING + + user => STRING + + realname => STRING + + Connection details. See also connect, login. + + If user is not supplied, it will default to either $ENV{LOGNAME} or + the current user's name as supplied by getpwuid() or + Win32::LoginName(). + + If unconnected, changing these properties will set the default values + to use when logging in. + + If logged in, changing the nick property is equivalent to calling + change_nick. Changing the other properties will not take effect until + the next login. + + use_caps => ARRAY of STRING + + Attempts to negotiate IRC v3.1 CAP at connect time. The array gives + the names of capabilities which will be requested, if the server + supports them. + +METHODS + + The following methods documented with a trailing call to ->get return + Future instances. + + connect + + $irc = $irc->connect( %args )->get + + Connects to the IRC server. This method does not perform the complete + IRC login sequence; for that see instead the login method. The returned + Future will yield the $irc instance itself, to make chaining easier. + + host => STRING + + Hostname of the IRC server. + + service => STRING or NUMBER + + Optional. Port number or service name of the IRC server. Defaults to + 6667. + + Any other arguments are passed into the underlying IO::Async::Loop + connect method. + + $irc->connect( %args ) + + The following additional arguments are used to provide continuations + when not returning a Future. + + on_connected => CODE + + Continuation to invoke once the connection has been established. + Usually used by the login method to perform the actual login + sequence. + + $on_connected->( $irc ) + + on_error => CODE + + Continuation to invoke in the case of an error preventing the + connection from taking place. + + $on_error->( $errormsg ) + + login + + $irc = $irc->login( %args )->get + + Logs in to the IRC network, connecting first using the connect method + if required. Takes the following named arguments: + + nick => STRING + + user => STRING + + realname => STRING + + IRC connection details. Defaults can be set with the new or configure + methods. + + pass => STRING + + Server password to connect with. + + Any other arguments that are passed, are forwarded to the connect + method if it is required; i.e. if login is invoked when not yet + connected to the server. + + $irc->login( %args ) + + The following additional arguments are used to provide continuations + when not returning a Future. + + on_login => CODE + + A continuation to invoke once login is successful. + + $on_login->( $irc ) + + change_nick + + $irc->change_nick( $newnick ) + + Requests to change the nick. If unconnected, the change happens + immediately to the stored defaults. If logged in, sends a NICK command + to the server, which may suceed or fail at a later point. + +IRC v3.1 CAPABILITIES + + The following methods relate to IRC v3.1 capabilities negotiations. + + caps_supported + + $caps = $irc->caps_supported + + Returns a HASH whose keys give the capabilities listed by the server as + supported in its CAP LS response. If the server ignored the CAP + negotiation then this method returns undef. + + cap_supported + + $supported = $irc->cap_supported( $cap ) + + Returns a boolean indicating if the server supports the named + capability. + + caps_enabled + + $caps = $irc->caps_enabled + + Returns a HASH whose keys give the capabilities successfully enabled by + the server as part of the CAP REQ login sequence. If the server ignored + the CAP negotiation then this method returns undef. + + cap_enabled + + $enabled = $irc->cap_enabled( $cap ) + + Returns a boolean indicating if the client successfully enabled the + named capability. + +MESSAGE-WRAPPING METHODS + + The following methods are all inherited from Protocol::IRC::Client but + are mentioned again for convenient. For further details see the + documentation in the parent module. + + In particular, each method returns a Future instance. + + do_PRIVMSG + + do_NOTICE + + $irc->do_PRIVMSG( target => $target, text => $text )->get + + $irc->do_NOTICE( target => $target, text => $text )->get + + Sends a PRIVMSG or NOITICE command. + +SEE ALSO + + * http://tools.ietf.org/html/rfc2812 - Internet Relay Chat: Client + Protocol + +AUTHOR + + Paul Evans <leonerd@leonerd.org.uk> + diff --git a/examples/SYNOPSIS.pl b/examples/SYNOPSIS.pl new file mode 100644 index 0000000..6349599 --- /dev/null +++ b/examples/SYNOPSIS.pl @@ -0,0 +1,23 @@ +use IO::Async::Loop; +use Net::Async::IRC; + +my $loop = IO::Async::Loop->new; + +my $irc = Net::Async::IRC->new( + on_message_text => sub { + my ( $self, $message, $hints ) = @_; + + print "$hints->{prefix_name} says: $hints->{text}\n"; + }, +); + +$loop->add( $irc ); + +$irc->login( + nick => "MyName", + host => "irc.example.org", +)->get; + +$irc->do_PRIVMSG( target => "YourName", text => "Hello world!" ); + +$loop->run; diff --git a/examples/client.pl b/examples/client.pl new file mode 100644 index 0000000..3296713 --- /dev/null +++ b/examples/client.pl @@ -0,0 +1,69 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Data::Dump 'pp'; +use Getopt::Long; + +use Future::Utils qw( repeat ); +use IO::Async::Loop; +use Net::Async::IRC; + +GetOptions( + 'server|s=s' => \my $SERVER, + 'nick|n=s' => \my $NICK, + 'port|p=i' => \my $PORT, + 'SSL|S' => \my $SSL, +) or exit 1; + +require IO::Async::SSL if $SSL; + +my $loop = IO::Async::Loop->new; + +my $irc = Net::Async::IRC->new( + on_message => sub { + my ( $self, $command, $message, $hints ) = @_; + return if $hints->{handled}; + + printf "<<%s>>: %s\n", $command, join( " ", $message->args ); + print "| $_\n" for split m/\n/, pp( $hints ); + + return 1; + }, +); +$loop->add( $irc ); + +$PORT //= ( $SSL ? 6697 : 6667 ); + +$irc->connect( + host => $SERVER, + service => $PORT, + ( $SSL ? + ( extensions => ['SSL'], + SSL_verify_mode => 0 ) : + () ), +)->get; + +print "Connected...\n"; + +$irc->login( + nick => $NICK, +)->get; + +print "Now logged in...\n"; + +my $stdin = IO::Async::Stream->new_for_stdin( on_read => sub {} ); +$loop->add( $stdin ); + +my $eof; +( repeat { + $stdin->read_until( "\n" )->on_done( sub { + ( my $line, $eof ) = @_; + return if $eof; + + chomp $line; + my $message = Protocol::IRC::Message->new_from_line( $line ); + $irc->send_message( $message ); + }); +} while => sub { !$_[0]->failure and !$eof } )->get; diff --git a/examples/intro-01-helloworld.pl b/examples/intro-01-helloworld.pl new file mode 100644 index 0000000..85dd867 --- /dev/null +++ b/examples/intro-01-helloworld.pl @@ -0,0 +1,24 @@ +use strict; +use warnings; + +use IO::Async::Loop; +use Net::Async::IRC; + +my $loop = IO::Async::Loop->new; + +my $irc = Net::Async::IRC->new; +$loop->add( $irc ); + +my $SERVER = "irc.example.net"; +my $NICK = "MyNick"; +my $TARGET = "TargetNick"; + +$irc->login( + host => $SERVER, + nick => $NICK, +)->then( sub { + $irc->do_PRIVMSG( + target => $TARGET, + text => "Hello, World" + ); +})->get; diff --git a/examples/intro-02-whatsyourname.pl b/examples/intro-02-whatsyourname.pl new file mode 100644 index 0000000..fc1a4b3 --- /dev/null +++ b/examples/intro-02-whatsyourname.pl @@ -0,0 +1,43 @@ +use strict; +use warnings; + +use IO::Async::Loop; +use Net::Async::IRC; + +my $loop = IO::Async::Loop->new; + +my $irc = Net::Async::IRC->new; +$loop->add( $irc ); + +my $SERVER = "irc.example.net"; +my $NICK = "MyNick"; +my $TARGET = "TargetNick"; + +$irc->login( + host => $SERVER, + nick => $NICK, +)->get; + +my $target_folded = $irc->casefold_name( $TARGET ); + +$irc->configure( + on_message_text => sub { + my ( undef, $message, $hints ) = @_; + return unless $hints->{prefix_nick_folded} eq $target_folded; + + print "The user said: $hints->{text}\n"; + }, + on_message_ctcp_ACTION => sub { + my ( undef, $message, $hints ) = @_; + return unless $hints->{prefix_nick_folded} eq $target_folded; + + print "The user acted: $hints->{ctcp_args}\n"; + }, +); + +$irc->do_PRIVMSG( + target => $TARGET, + text => "Hello, what's your name?" +); + +$loop->run; diff --git a/lib/Net/Async/IRC.pm b/lib/Net/Async/IRC.pm new file mode 100644 index 0000000..8ae539f --- /dev/null +++ b/lib/Net/Async/IRC.pm @@ -0,0 +1,530 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2008-2017 -- leonerd@leonerd.org.uk + +package Net::Async::IRC; + +use strict; +use warnings; + +our $VERSION = '0.11'; + +# We need to use C3 MRO to make the ->isupport etc.. methods work properly +use mro 'c3'; +use base qw( Net::Async::IRC::Protocol Protocol::IRC::Client ); + +use Carp; + +use Socket qw( SOCK_STREAM ); + +use constant HAVE_MSWIN32 => ( $^O eq "MSWin32" ); + +=head1 NAME + +C<Net::Async::IRC> - use IRC with C<IO::Async> + +=head1 SYNOPSIS + + use IO::Async::Loop; + use Net::Async::IRC; + + my $loop = IO::Async::Loop->new; + + my $irc = Net::Async::IRC->new( + on_message_text => sub { + my ( $self, $message, $hints ) = @_; + + print "$hints->{prefix_name} says: $hints->{text}\n"; + }, + ); + + $loop->add( $irc ); + + $irc->login( + nick => "MyName", + host => "irc.example.org", + )->get; + + $irc->do_PRIVMSG( target => "YourName", text => "Hello world!" ); + + $loop->run; + +=head1 DESCRIPTION + +This object class implements an asynchronous IRC client, for use in programs +based on L<IO::Async>. + +Most of the actual IRC message handling behaviour is implemented by the parent +class L<Net::Async::IRC::Protocol>. + +Most of the behaviour related to being an IRC client is implemented by the +parent class L<Protocol::IRC::Client>. + +The following documentation may make mention of these above two parent +classes; the reader should make reference to them when required. + +=cut + +sub new +{ + my $class = shift; + my %args = @_; + + my $on_closed = delete $args{on_closed}; + + return $class->SUPER::new( + %args, + + on_closed => sub { + my $self = shift; + + if( $self->{on_login_f} ) { + $_->fail( "Closed" ) for @{ $self->{on_login_f} }; + undef $self->{on_login_f}; + } + + $on_closed->( $self ) if $on_closed; + }, + ); +} + +sub _init +{ + my $self = shift; + $self->SUPER::_init( @_ ); + + $self->{user} = $ENV{LOGNAME} || + ( HAVE_MSWIN32 ? Win32::LoginName() : getpwuid($>) ); + + $self->{realname} = "Net::Async::IRC client $VERSION"; +} + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=over 8 + +=item nick => STRING + +=item user => STRING + +=item realname => STRING + +Connection details. See also C<connect>, C<login>. + +If C<user> is not supplied, it will default to either C<$ENV{LOGNAME}> or the +current user's name as supplied by C<getpwuid()> or C<Win32::LoginName()>. + +If unconnected, changing these properties will set the default values to use +when logging in. + +If logged in, changing the C<nick> property is equivalent to calling +C<change_nick>. Changing the other properties will not take effect until the +next login. + +=item use_caps => ARRAY of STRING + +Attempts to negotiate IRC v3.1 CAP at connect time. The array gives the names +of capabilities which will be requested, if the server supports them. + +=back + +=cut + +sub configure +{ + my $self = shift; + my %args = @_; + + for (qw( user realname use_caps )) { + $self->{$_} = delete $args{$_} if exists $args{$_}; + } + + if( exists $args{nick} ) { + $self->_set_nick( delete $args{nick} ); + } + + $self->SUPER::configure( %args ); +} + +=head1 METHODS + +The following methods documented with a trailing call to C<< ->get >> return +L<Future> instances. + +=cut + +=head2 connect + + $irc = $irc->connect( %args )->get + +Connects to the IRC server. This method does not perform the complete IRC +login sequence; for that see instead the C<login> method. The returned +L<Future> will yield the C<$irc> instance itself, to make chaining easier. + +=over 8 + +=item host => STRING + +Hostname of the IRC server. + +=item service => STRING or NUMBER + +Optional. Port number or service name of the IRC server. Defaults to 6667. + +=back + +Any other arguments are passed into the underlying C<IO::Async::Loop> +C<connect> method. + + $irc->connect( %args ) + +The following additional arguments are used to provide continuations when not +returning a Future. + +=over 8 + +=item on_connected => CODE + +Continuation to invoke once the connection has been established. Usually used +by the C<login> method to perform the actual login sequence. + + $on_connected->( $irc ) + +=item on_error => CODE + +Continuation to invoke in the case of an error preventing the connection from +taking place. + + $on_error->( $errormsg ) + +=back + +=cut + +# TODO: Most of this needs to be moved into an abstract Net::Async::Connection role +sub connect +{ + my $self = shift; + my %args = @_; + + # Largely for unit testing + return $self->{connect_f} ||= Future->new->done( $self ) if + $self->read_handle; + + my $on_error = delete $args{on_error}; + + $args{service} ||= "6667"; + + return $self->{connect_f} ||= $self->SUPER::connect( + %args, + + on_resolve_error => sub { + my ( $msg ) = @_; + chomp $msg; + + if( $args{on_resolve_error} ) { + $args{on_resolve_error}->( $msg ); + } + elsif( $on_error ) { + $on_error->( "Cannot resolve - $msg" ); + } + }, + + on_connect_error => sub { + if( $args{on_connect_error} ) { + $args{on_connect_error}->( @_ ); + } + elsif( $on_error ) { + $on_error->( "Cannot connect" ); + } + }, + )->on_fail( sub { undef $self->{connect_f} } ); +} + +=head2 login + + $irc = $irc->login( %args )->get + +Logs in to the IRC network, connecting first using the C<connect> method if +required. Takes the following named arguments: + +=over 8 + +=item nick => STRING + +=item user => STRING + +=item realname => STRING + +IRC connection details. Defaults can be set with the C<new> or C<configure> +methods. + +=item pass => STRING + +Server password to connect with. + +=back + +Any other arguments that are passed, are forwarded to the C<connect> method if +it is required; i.e. if C<login> is invoked when not yet connected to the +server. + + $irc->login( %args ) + +The following additional arguments are used to provide continuations when not +returning a Future. + +=over 8 + +=item on_login => CODE + +A continuation to invoke once login is successful. + + $on_login->( $irc ) + +=back + +=cut + +sub login +{ + my $self = shift; + my %args = @_; + + my $nick = delete $args{nick} || $self->{nick} or croak "Need a login nick"; + my $user = delete $args{user} || $self->{user} or croak "Need a login user"; + my $realname = delete $args{realname} || $self->{realname}; + my $pass = delete $args{pass}; + + if( !defined $self->{nick} ) { + $self->_set_nick( $nick ); + } + + my $on_login = delete $args{on_login}; + !defined $on_login or ref $on_login eq "CODE" or + croak "Expected 'on_login' to be a CODE reference"; + + return $self->{login_f} ||= $self->connect( %args )->then( sub { + $self->send_message( "CAP", undef, "LS" ) if $self->{use_caps}; + + $self->send_message( "PASS", undef, $pass ) if defined $pass; + $self->send_message( "USER", undef, $user, "0", "*", $realname ); + $self->send_message( "NICK", undef, $nick ); + + my $f = $self->loop->new_future; + + push @{ $self->{on_login_f} }, $f; + $f->on_done( $on_login ) if $on_login; + + return $f; + })->on_fail( sub { undef $self->{login_f} } ); +} + +=head2 change_nick + + $irc->change_nick( $newnick ) + +Requests to change the nick. If unconnected, the change happens immediately +to the stored defaults. If logged in, sends a C<NICK> command to the server, +which may suceed or fail at a later point. + +=cut + +sub change_nick +{ + my $self = shift; + my ( $newnick ) = @_; + + if( !$self->is_connected ) { + $self->_set_nick( $newnick ); + } + else { + $self->send_message( "NICK", undef, $newnick ); + } +} + +############################ +# Message handling methods # +############################ + +=head1 IRC v3.1 CAPABILITIES + +The following methods relate to IRC v3.1 capabilities negotiations. + +=cut + +sub on_message_cap_LS +{ + my $self = shift; + my ( $message, $hints ) = @_; + + my $supported = $self->{caps_supported} = $hints->{caps}; + + my @request = grep { $supported->{$_} } @{$self->{use_caps}}; + + if( @request ) { + $self->{caps_enabled} = { map { $_ => undef } @request }; + $self->send_message( "CAP", undef, "REQ", join( " ", @request ) ); + } + else { + $self->send_message( "CAP", undef, "END" ); + } + + return 1; +} + +*on_message_cap_ACK = *on_message_cap_NAK = \&_on_message_cap_reply; +sub _on_message_cap_reply +{ + my $self = shift; + my ( $message, $hints ) = @_; + my $ack = $hints->{verb} eq "ACK"; + + $self->{caps_enabled}{$_} = $ack for keys %{ $hints->{caps} }; + + # Are any outstanding + !defined and return 1 for values %{ $self->{caps_enabled} }; + + $self->send_message( "CAP", undef, "END" ); + return 1; +} + +=head2 caps_supported + + $caps = $irc->caps_supported + +Returns a HASH whose keys give the capabilities listed by the server as +supported in its C<CAP LS> response. If the server ignored the C<CAP> +negotiation then this method returns C<undef>. + +=cut + +sub caps_supported +{ + my $self = shift; + return $self->{caps_supported}; +} + +=head2 cap_supported + + $supported = $irc->cap_supported( $cap ) + +Returns a boolean indicating if the server supports the named capability. + +=cut + +sub cap_supported +{ + my $self = shift; + my ( $cap ) = @_; + return !!$self->{caps_supported}{$cap}; +} + +=head2 caps_enabled + + $caps = $irc->caps_enabled + +Returns a HASH whose keys give the capabilities successfully enabled by the +server as part of the C<CAP REQ> login sequence. If the server ignored the +C<CAP> negotiation then this method returns C<undef>. + +=cut + +sub caps_enabled +{ + my $self = shift; + return $self->{caps_enabled}; +} + +=head2 cap_enabled + + $enabled = $irc->cap_enabled( $cap ) + +Returns a boolean indicating if the client successfully enabled the named +capability. + +=cut + +sub cap_enabled +{ + my $self = shift; + my ( $cap ) = @_; + return !!$self->{caps_enabled}{$cap}; +} + +sub on_message_NICK +{ + my $self = shift; + my ( $message, $hints ) = @_; + + if( $hints->{prefix_is_me} ) { + $self->_set_nick( $hints->{new_nick} ); + return 1; + } + + return 0; +} + +sub on_message_RPL_WELCOME +{ + my $self = shift; + my ( $message ) = @_; + + # set our nick to be what the server logged us in as + $self->_set_nick( $message->{args}[0] ); + + if( $self->{on_login_f} and @{ $self->{on_login_f} } ) { + my @futures = @{ $self->{on_login_f} }; + undef $self->{on_login_f}; + + foreach my $f ( @futures ) { + $f->done( $self ); + } + } + + # Don't eat it + return 0; +} + +=head1 MESSAGE-WRAPPING METHODS + +The following methods are all inherited from L<Protocol::IRC::Client> but are +mentioned again for convenient. For further details see the documentation in +the parent module. + +In particular, each method returns a L<Future> instance. + +=cut + +=head2 do_PRIVMSG + +=head2 do_NOTICE + + $irc->do_PRIVMSG( target => $target, text => $text )->get + + $irc->do_NOTICE( target => $target, text => $text )->get + +Sends a C<PRIVMSG> or C<NOITICE> command. + +=cut + +=head1 SEE ALSO + +=over 4 + +=item * + +L<http://tools.ietf.org/html/rfc2812> - Internet Relay Chat: Client Protocol + +=back + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/Net/Async/IRC/Introduction.pod b/lib/Net/Async/IRC/Introduction.pod new file mode 100644 index 0000000..cab5776 --- /dev/null +++ b/lib/Net/Async/IRC/Introduction.pod @@ -0,0 +1,185 @@ +=head1 NAME + +Net::Async::IRC::Introduction - an introduction + +=head1 INTRODUCTION + +=head2 Hello, World + +This first example is the "hello world" of IRC; a script that connects to the +server and immediately sends a hello message to a preconfigured user. + +This program starts with the usual boilerplate for any L<IO::Async>-based +program; namely loading the required modules and creating a containing +L<IO::Async::Loop> instance. It then constructs the actual L<Net::Async::IRC> +object and adds it to this containing loop. As these actions are standard to +every program, they won't be repeated in later examples; just presumed to have +already taken place: + + use strict; + use warnings; + + use IO::Async::Loop; + use Net::Async::IRC; + + my $loop = IO::Async::Loop->new; + + my $irc = Net::Async::IRC->new; + $loop->add( $irc ); + +Now this is created, we can move on to the specifics of this example. As it's +a tiny example script, we'll just hard-code the parameters for the message. A +larger program of course would read these from somewhere better - a config +file, commandline arguments, etc... + + my $SERVER = "irc.example.net"; + my $NICK = "MyNick"; + my $TARGET = "TargetNick"; + +Finally we can connect to the IRC server and send the message: + + $irc->login( + host => $SERVER, + nick => $NICK, + )->then( sub { + $irc->do_PRIVMSG( + target => $TARGET, + text => "Hello, World" + ); + })->get; + +The program calls L<Net::Async::IRC/login>, which connects the client to the +given IRC server and logs in as the given nick. This method returns a +L<Future> instance to represent its eventual completion, giving us an easy way +to sequence further code after it. After login is complete, the next task is +simply to send the message. This is done with the C<PRIVMSG> IRC command as +wrapped by L<Net::Async::IRC/do_PRIVMSG>. This takes taking the message target +name and text string. + +The trailing call to L<Future/get> makes the script stop here waiting for this +chain of futures to actually complete. Without this, the returned future would +simply be lost (as the L<Future/then> method appears in void context), and the +second stage of code within it would probably never get called. In later +examples we'll see other techniques, but for now every constructed future will +simply be forced by calling C<get> on it. If either of these stages fails, it +will cause the C<get> call to throw an exception instead. + +Once this is sent, the script terminates, closing its connection to the server. + +=head2 RECEIVING MESSAGES + +As a second example, lets now consider also how we handle messages that arrive +from IRC. + + $irc->configure( + on_message_PRIVMSG => sub { + my ( $irc, $message, $hints ) = @_; + return unless $hints->{prefix_nick_folded} eq + $irc->casefold_name( $TARGET ); + + print "The user said: $hints->{text}\n"; + } + ); + + $irc->login( + host => $SERVER, + nick => $NICK, + )->then( sub { + $irc->do_PRIVMSG( + target => $TARGET, + text => "Hello, what's your name?" + ); + })->get; + + $loop->run; + +Here we have used the C<configure> method to attach an event handler to the +C<on_message_PRIVMSG> event. This handler code ignores any messages except +from the user we are interested in, and simply prints the contents of those we +are interested in to the terminal. + +Having established this event handler, we can then log in and send a message +to the target user, similar to the first example. Instead of stopping the +script entirely afterwards, we need to ensure that the program keeps running +after this initial start so it can continue to receive messages. To do that we +enter the main L<IO::Async::Loop/run> method, which will wait indefinitely, +processing any events that are received. + +=head2 Case-folded Names + +The use of the "folded" strings ensures that this code can correctly cope with +any odd case-folding rules the IRC server has. By comparison, both of the +following lines are incorrect, and may cause missed messages on some servers: + + return unless $hints->{prefix_name} eq $TARGET; # don't do this + + return unless lc $hints->{prefix_name} eq lc $TARGET; # don't do this + +The first does not case-fold the string at all, so will fail in the case of +C<User> vs C<user>. The second attempts to solve this, but does not take +account of the odd case-folding logic most IRC servers have, in which the +characters C<[\]> are "uppercase" versions of C<{|}>. The +L<Protocol::IRC/casefold_name> method is provided as a server-aware +alternative to C<lc()>, which handles this. A correct implementation could be +written: + + return unless $irc->casefold_name( $hints->{prefix_name} ) eq + $irc->casefold_name( $TARGET ); + +However, since this is a very common pattern, the hints hash conveniently +supplies already-folded strings for any name or nick fields it finds. +Furthermore, as the case folded version of the target name won't change after +startup, we could store that initially to save re-calculating it at every +event: + + $irc->login( + host => $SERVER, + nick => $NICK, + )->get; + + my $target_folded = $irc->casefold_name( $TARGET ); + + $irc->configure( + on_message_PRIVMSG => sub { + my ( undef, $message, $hints ) = @_; + return unless $hints->{prefix_nick_folded} eq $target_folded; + + print "The user said: $hints->{text}\n"; + } + ); + +=head2 C<PRIVMSG> vs C<text> and CTCPs + +This example has used the basic C<on_message_PRIVMSG> event. A better version +would be to use C<on_message_text> instead. This is a synthesized event +created on receipt of either C<PRIVMSG> or C<NOTICE>, and itself handles +details like C<CTCP> parsing, freeing the user code from having to handle it). +For example, the plain C<PRIVMSG> event will get quite confused by an incoming +C<CTCP ACTION>, such as is created by most IRC clients by the C</me> command. +Instead, we can handle that by attaching a handler specifically for +C<CTCP ACTION>: + + $irc->configure( + on_message_text => sub { + my ( undef, $message, $hints ) = @_; + return unless $hints->{prefix_nick_folded} eq $target_folded; + + print "The user said: $hints->{text}\n"; + }, + on_message_ctcp_ACTION => sub { + my ( undef, $message, $hints ) = @_; + return unless $hints->{prefix_nick_folded} eq $target_folded; + + print "The user acted: $hints->{ctcp_args}\n"; + }, + ); + +This second handlers is invoked on receipt of a C<PRIVMSG> containing a +C<CTCP ACTION>. The first is only invoked on receipt of a plain C<PRIVMSG> +that doesn't contain a C<CTCP> subcommand. + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut diff --git a/lib/Net/Async/IRC/Protocol.pm b/lib/Net/Async/IRC/Protocol.pm new file mode 100644 index 0000000..e21c5d6 --- /dev/null +++ b/lib/Net/Async/IRC/Protocol.pm @@ -0,0 +1,412 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2010-2015 -- leonerd@leonerd.org.uk + +package Net::Async::IRC::Protocol; + +use strict; +use warnings; + +our $VERSION = '0.11'; + +use base qw( IO::Async::Stream Protocol::IRC ); + +use Carp; + +use Protocol::IRC::Message; + +use Encode qw( find_encoding ); +use Time::HiRes qw( time ); + +use IO::Async::Timer::Countdown; + +=head1 NAME + +C<Net::Async::IRC::Protocol> - send and receive IRC messages + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Stream> implements an established IRC +connection that has already completed its inital login sequence and is ready +to send and receive IRC messages. It handles base message sending and +receiving, and implements ping timers. This class provides most of the +functionality required for sending and receiving IRC commands and responses +by mixing in from L<Protocol::IRC>. + +Objects of this type would not normally be constructed directly. For IRC +clients, see L<Net::Async::IRC> which is a subclass of it. All the events, +parameters, and methods documented below are relevant there. + +=cut + +=head1 EVENTS + +The following events are invoked, either using subclass methods or C<CODE> +references in parameters: + +=head2 $handled = on_message + +=head2 $handled = on_message_MESSAGE + +Invoked on receipt of a valid IRC message. See C<MESSAGE HANDLING> below. + +=head2 on_irc_error $err + +Invoked on receipt of an invalid IRC message if parsing fails. C<$err> is the +error message text. If left unhandled, any parse error will result in the +connection being immediataely closed, followed by the exception being +re-thrown. + +=head2 on_ping_timeout + +Invoked if the peer fails to respond to a C<PING> message within the given +timeout. + +=head2 on_pong_reply $lag + +Invoked when the peer successfully sends a C<PONG> reply response to a C<PING> +message. C<$lag> is the response time in (fractional) seconds. + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=over 8 + +=item on_message => CODE + +=item on_message_MESSAGE => CODE + +=item on_irc_error => CODE + +=item on_ping_timeout => CODE + +=item on_pong_reply => CODE + +C<CODE> references for event handlers. + +=item pingtime => NUM + +Amount of quiet time, in seconds, after a message is received from the peer, +until a C<PING> will be sent to check it is still alive. + +=item pongtime => NUM + +Timeout, in seconds, after sending a C<PING> message, to wait for a C<PONG> +response. + +=item encoding => STRING + +If supplied, sets an encoding to use to encode outgoing messages and decode +incoming messages. + +=back + +=cut + +=head1 CONSTRUCTOR + +=cut + +=head2 new + + $irc = Net::Async::IRC::Protocol->new( %args ) + +Returns a new instance of a C<Net::Async::IRC::Protocol> object. This object +represents a IRC connection to a peer. + +=cut + +sub new +{ + my $class = shift; + my %args = @_; + + my $on_closed = delete $args{on_closed}; + + return $class->SUPER::new( + %args, + + on_closed => sub { + my $self = shift; + + my $loop = $self->get_loop; + + $self->{pingtimer}->stop; + $self->{pongtimer}->stop; + + $on_closed->( $self ) if $on_closed; + + undef $self->{connect_f}; + undef $self->{login_f}; + }, + ); +} + +sub _init +{ + my $self = shift; + $self->SUPER::_init( @_ ); + + my $pingtime = 60; + my $pongtime = 10; + + $self->{pingtimer} = IO::Async::Timer::Countdown->new( + delay => $pingtime, + + on_expire => sub { + my $now = time(); + + $self->send_message( "PING", undef, "$now" ); + + $self->{ping_send_time} = $now; + + $self->{pongtimer}->start; + }, + ); + $self->add_child( $self->{pingtimer} ); + + $self->{pongtimer} = IO::Async::Timer::Countdown->new( + delay => $pongtime, + + on_expire => sub { + $self->{on_ping_timeout}->( $self ) if $self->{on_ping_timeout}; + }, + ); + $self->add_child( $self->{pongtimer} ); +} + +# for Protocol::IRC +sub encoder +{ + my $self = shift; + return $self->{encoder}; +} + +sub configure +{ + my $self = shift; + my %args = @_; + + $self->{$_} = delete $args{$_} for grep m/^on_message/, keys %args; + + for (qw( on_ping_timeout on_pong_reply on_irc_error )) { + $self->{$_} = delete $args{$_} if exists $args{$_}; + } + + if( exists $args{pingtime} ) { + $self->{pingtimer}->configure( delay => delete $args{pingtime} ); + } + + if( exists $args{pongtime} ) { + $self->{pongtimer}->configure( delay => delete $args{pongtime} ); + } + + if( exists $args{encoding} ) { + my $encoding = delete $args{encoding}; + my $obj = find_encoding( $encoding ); + defined $obj or croak "Cannot handle an encoding of '$encoding'"; + $self->{encoder} = $obj; + } + + $self->SUPER::configure( %args ); +} + +sub incoming_message +{ + my $self = shift; + my ( $message ) = @_; + + my @shortargs = ( $message->arg( 0 ) ); + push @shortargs, $message->arg( 1 ) if $message->command =~ m/^\d+$/; + push @shortargs, "..." if $message->args > 1; + + $self->debug_printf( "COMMAND ${\ $message->command } @shortargs" ); + + return $self->SUPER::incoming_message( @_ ); +} + +=head1 METHODS + +=cut + +=head2 is_connected + + $connect = $irc->is_connected + +Returns true if a connection to the peer is established. Note that even +after a successful connection, the connection may not yet logged in to. See +also the C<is_loggedin> method. + +=cut + +sub is_connected +{ + my $self = shift; + return 0 unless my $connect_f = $self->{connect_f}; + return $connect_f->is_ready && !$connect_f->failure; +} + +=head2 is_loggedin + + $loggedin = $irc->is_loggedin + +Returns true if the full login sequence has been performed on the connection +and it is ready to use. + +=cut + +sub is_loggedin +{ + my $self = shift; + return 0 unless my $login_f = $self->{login_f}; + return $login_f->is_ready && !$login_f->failure; +} + +sub on_read +{ + my $self = shift; + my ( $buffref, $eof ) = @_; + + my $pingtimer = $self->{pingtimer}; + + $pingtimer->is_running ? $pingtimer->reset : $pingtimer->start; + + eval { + $self->Protocol::IRC::on_read( $$buffref ); + 1; + } and return 0; + + my $e = "$@"; chomp $e; + + $self->maybe_invoke_event( on_irc_error => $e ) + and return 0; + + $self->close_now; + die "$e\n"; +} + +=head2 nick + + $nick = $irc->nick + +Returns the current nick in use by the connection. + +=cut + +sub _set_nick +{ + my $self = shift; + ( $self->{nick} ) = @_; + $self->{nick_folded} = $self->casefold_name( $self->{nick} ); +} + +sub nick +{ + my $self = shift; + return $self->{nick}; +} + +=head2 nick_folded + + $nick_folded = $irc->nick_folded + +Returns the current nick in use by the connection, folded by C<casefold_name> +for convenience. + +=cut + +sub nick_folded +{ + my $self = shift; + return $self->{nick_folded}; +} + +=head1 MESSAGE HANDLING + +Every incoming message causes a sequence of message handling to occur. First, +the message is parsed, and a hash of data about it is created; this is called +the hints hash. The message and this hash are then passed down a sequence of +potential handlers. + +Each handler indicates by return value, whether it considers the message to +have been handled. Processing of the message is not interrupted the first time +a handler declares to have handled a message. Instead, the hints hash is +marked to say it has been handled. Later handlers can still inspect the +message or its hints, using this information to decide if they wish to take +further action. + +A message with a command of C<COMMAND> will try handlers in following places: + +=over 4 + +=item 1. + +A CODE ref in a parameter called C<on_message_COMMAND> + + $on_message_COMMAND->( $irc, $message, \%hints ) + +=item 2. + +A method called C<on_message_COMMAND> + + $irc->on_message_COMMAND( $message, \%hints ) + +=item 3. + +A CODE ref in a parameter called C<on_message> + + $on_message->( $irc, 'COMMAND', $message, \%hints ) + +=item 4. + +A method called C<on_message> + + $irc->on_message( 'COMMAND', $message, \%hints ) + +=back + +As this message handling ability is provided by C<Protocol::IRC>, more details +about how it works and how to use it can be found at +L<Protocol::IRC/MESSAGE HANDLING>. + +Additionally, some types of messages receive further processing by +C<Protocol::IRC> and in turn cause new types of events to be invoked. These +are further documented by L<Protocol::IRC/INTERNAL MESSAGE HANDLING>. + +=cut + +sub invoke +{ + my $self = shift; + my $retref = $self->maybe_invoke_event( @_ ) or return undef; + return $retref->[0]; +} + +sub on_message_PONG +{ + my $self = shift; + my ( $message, $hints ) = @_; + + return 1 unless $self->{pongtimer}->is_running; + + my $lag = time - $self->{ping_send_time}; + + $self->{current_lag} = $lag; + $self->{on_pong_reply}->( $self, $lag ) if $self->{on_pong_reply}; + + $self->{pongtimer}->stop; + + return 1; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/t/00use.t b/t/00use.t new file mode 100644 index 0000000..8bb8681 --- /dev/null +++ b/t/00use.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +use_ok( "Net::Async::IRC" ); +use_ok( "Net::Async::IRC::Protocol" ); + +done_testing; diff --git a/t/30client-connect.t b/t/30client-connect.t new file mode 100644 index 0000000..bee0327 --- /dev/null +++ b/t/30client-connect.t @@ -0,0 +1,107 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; +use IO::Async::Listener; + +use Net::Async::IRC; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $client; +my $listener = IO::Async::Listener->new( + on_stream => sub { + ( undef, $client ) = @_; + }, +); +$loop->add( $listener ); + +$listener->listen( + addr => { family => "inet" }, +)->get; + +my @errors; + +my $irc = Net::Async::IRC->new( + user => "defaultuser", + realname => "Default Real name", + + on_message => sub { "IGNORE" }, + + on_irc_error => sub { + my $self = shift; + my ( $err ) = @_; + + push @errors, $err; + }, +); + +$loop->add( $irc ); + +ok( !$irc->is_connected, 'not $irc->is_connected' ); + +$irc->connect( + addr => { + family => "inet", + ip => $listener->read_handle->sockhost, + port => $listener->read_handle->sockport, + }, +)->get; + +ok( $irc->is_connected, '$irc->is_connected' ); +ok( !$irc->is_loggedin, 'not $irc->is_loggedin' ); + +wait_for { $client }; +$client->configure( on_read => sub { 0 } ); # using read futures +$loop->add( $client ); + +# Now see if we can send a message +$irc->send_message( "HELLO", undef, "world" ); + +my $read_f; + +$read_f = $client->read_until( $CRLF ); +wait_for { $read_f->is_ready }; + +is( scalar $read_f->get, "HELLO world$CRLF", 'Server stream after initial client message' ); + +my $logged_in = 0; + +my $login_f = $irc->login( + nick => "MyNick", + + on_login => sub { $logged_in = 1 }, +); + +$read_f = $client->read_until( qr/$CRLF.*$CRLF/ ); +wait_for { $read_f->is_ready }; + +is( scalar $read_f->get, + "USER defaultuser 0 * :Default Real name$CRLF" . + "NICK MyNick$CRLF", + 'Server stream after login' ); + +$client->write( ":irc.example.com 001 MyNick :Welcome to IRC MyNick!defaultuser\@your.host.here$CRLF" ); + +wait_for { $login_f->is_ready }; + +ok( !$login_f->failure, 'Client logs in without failure' ); + +ok( $logged_in, 'Client receives logged in event' ); +ok( $irc->is_connected, '$irc->is_connected' ); +ok( $irc->is_loggedin, '$irc->is_loggedin' ); + +$client->write( ":something invalid-here$CRLF" ); + +wait_for { scalar @errors }; + +ok( defined shift @errors, 'on_error invoked' ); + +done_testing; diff --git a/t/31client-cap.t b/t/31client-cap.t new file mode 100644 index 0000000..f2035ad --- /dev/null +++ b/t/31client-cap.t @@ -0,0 +1,100 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; +use IO::Async::Stream; + +use Net::Async::IRC; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my ( $S1, $S2 ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + +# Normal CAP login +{ + my $irc = Net::Async::IRC->new( + handle => $S1, + use_caps => [qw( multi-prefix )], + ); + $loop->add( $irc ); + + my $login_f = $irc->login( + nick => "MyNick", + user => "me", + realname => "My real name", + ); + + my $serverstream = ""; + wait_for_stream { $serverstream =~ m/(?:.*$CRLF){3}/ } $S2 => $serverstream; + + is( $serverstream, "CAP LS$CRLF" . + "USER me 0 * :My real name$CRLF" . + "NICK MyNick$CRLF", 'Server stream negotiates CAP' ); + $serverstream = ""; + + $S2->syswrite( ':irc.example.com CAP * LS :multi-prefix sasl' . $CRLF ); + + wait_for_stream { $serverstream =~ m/.*$CRLF/ } $S2 => $serverstream; + + is( $serverstream, "CAP REQ multi-prefix$CRLF", 'Client requests caps' ); + $serverstream = ""; + + is_deeply( $irc->caps_supported, + { 'multi-prefix' => 1, + 'sasl' => 1 }, + '$irc->caps_supported' ); + ok( $irc->cap_supported( "multi-prefix" ), '$irc->cap_supported' ); + + $S2->syswrite( ':irc.example.com CAP * ACK :multi-prefix' . $CRLF ); + + wait_for_stream { $serverstream =~ m/.*$CRLF/ } $S2 => $serverstream; + + is( $serverstream, "CAP END$CRLF", 'Client finishes CAP' ); + + is_deeply( $irc->caps_enabled, + { 'multi-prefix' => 1 }, + '$irc->caps_enabled' ); + ok( $irc->cap_enabled( "multi-prefix" ), '$irc->cap_enabled' ); + + $S2->syswrite( ':irc.example.com 001 MyNick :Welcome to IRC MyNick!me@your.host' . $CRLF ); + + wait_for { $login_f->is_ready }; + $login_f->get; + + $loop->remove( $irc ); +} + +# CAP ignored by server +{ + my $irc = Net::Async::IRC->new( + handle => $S1, + use_caps => [qw( multi-prefix )], + ); + $loop->add( $irc ); + + my $login_f = $irc->login( + nick => "MyNick", + user => "me", + realname => "My real name", + ); + + my $serverstream = ""; + wait_for_stream { $serverstream =~ m/(?:.*$CRLF){3}/ } $S2 => $serverstream; + + $S2->syswrite( ':irc.example.com 001 MyNick :Welcome to IRC MyNick!me@your.host' . $CRLF ); + + wait_for { $login_f->is_ready }; + $login_f->get; + + is( $irc->caps_supported, undef, '$irc->caps_supported undef for CAPless server' ); + is( $irc->caps_enabled, undef, '$irc->caps_enabled undef for CAPless server' ); +} + +done_testing; diff --git a/t/32client-encoding.t b/t/32client-encoding.t new file mode 100644 index 0000000..7110ab7 --- /dev/null +++ b/t/32client-encoding.t @@ -0,0 +1,84 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use utf8; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; +use IO::Async::Listener; + +use Encode qw( encode_utf8 ); + +use Net::Async::IRC; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +SKIP: foreach my $SSL ( 0, 1 ) { + if( $SSL ) { + eval { require IO::Async::SSL } or skip "No IO::Async::SSL", 1; + } + + my $client; + my $listener = IO::Async::Listener->new( + on_stream => sub { + ( undef, $client ) = @_; + }, + ); + $loop->add( $listener ); + + $listener->listen( + addr => { family => "inet" }, + ( $SSL ? + ( extensions => [ 'SSL' ], + SSL_key_file => "t/privkey.pem", + SSL_cert_file => "t/server.pem", ) : + () ), + )->get; + + my $irc = Net::Async::IRC->new( + user => "defaultuser", + realname => "Default Real name", + + encoding => "UTF-8", + + on_message => sub { "IGNORE" }, + + on_irc_error => sub {}, + ); + $loop->add( $irc ); + + $irc->connect( + addr => { + family => "inet", + ip => $listener->read_handle->sockhost, + port => $listener->read_handle->sockport, + }, + ( $SSL ? + ( extensions => [ 'SSL' ], + SSL_verify_mode => 0 ) : + () ), + )->get; + + wait_for { $client }; + $client->configure( on_read => sub { 0 } ); # using read futures + $loop->add( $client ); + + $irc->send_message( "PRIVMSG", undef, "target", "Ĉu vi ĉi tio vidas?" ); + + my $read_f = $client->read_until( $CRLF ); + wait_for { $read_f->is_ready }; + + is( scalar $read_f->get, encode_utf8( "PRIVMSG target :Ĉu vi ĉi tio vidas?$CRLF" ), + 'Stream is encoded over ' . ( $SSL ? "SSL" : "plaintext" ) ); + + $loop->remove( $irc ); + $loop->remove( $client ); + $loop->remove( $listener ); +} + +done_testing; diff --git a/t/33client-nick.t b/t/33client-nick.t new file mode 100644 index 0000000..078f5dc --- /dev/null +++ b/t/33client-nick.t @@ -0,0 +1,100 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::OS; +use IO::Async::Loop; +use IO::Async::Stream; + +use Net::Async::IRC; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my ( $S1, $S2 ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + +my $in_use = 0; +my $err_nick = 0; +my $irc = Net::Async::IRC->new( + handle => $S1, + + user => "defaultuser", + realname => "Default Real name", + + nick => "AlreadyUsedNick", + + on_message_ERR_NICKNAMEINUSE => sub { shift->change_nick( "1stNick" ); $in_use = 1; }, + on_message_ERR_ERRONEUSNICKNAME => sub { shift->change_nick( "FirstNickTOOLONG" ); $err_nick = 1; }, + on_message => sub { "IGNORE" }, +); + +$loop->add( $irc ); + +is( $irc->nick, "AlreadyUsedNick", 'Initial nick is set' ); + +ok( $irc->is_nick_me( "AlreadyUsedNick" ), 'Client recognises initial nick' ); +ok( !$irc->is_nick_me( "SomeoneElse" ), 'Client does not recognise other nick' ); + +my $login_f = $irc->login; + +my $serverstream = ""; + +wait_for_stream { $serverstream =~ m/$CRLF.*$CRLF/ } $S2 => $serverstream; + +is( $serverstream, "USER defaultuser 0 * :Default Real name$CRLF" . + "NICK AlreadyUsedNick$CRLF", 'Server stream after attempt to login with nick already in use' ); + +$S2->syswrite( ":irc.example.com 433 * AlreadyUsedNick :Nickname is already in use$CRLF" ); + +wait_for { $in_use }; + +ok( $in_use, 'Client recieves ERR_NICKNAMEINUSE error' ); + +$S2->syswrite( ":irc.example.com 432 * 1stNick :Erroneous nickname$CRLF" ); + +wait_for { $err_nick }; + +ok( $err_nick, 'Client recieves ERR_ERRONEUSNICK error' ); + +$S2->syswrite( ":irc.example.com 001 FirstNick :Welcome to IRC FirstNick!defaultuser\@your.host.here$CRLF" ); + +wait_for { $login_f->is_ready }; +$login_f->get; + +is( $irc->nick, "FirstNick", 'Nick was updated correctly even after multiple errors' ); + +$serverstream = ""; + +wait_for_stream { $serverstream =~ m/$CRLF/ } $S2 => $serverstream; + +is( $serverstream, "NICK 1stNick$CRLF" . + "NICK FirstNickTOOLONG$CRLF", 'Server stream after login' ); + +$irc->change_nick( "SecondNick" ); + +is( $irc->nick, "FirstNick", 'Nick still old until server confirms' ); + +ok( $irc->is_nick_me( "FirstNick" ), 'Client recognises still old nick' ); +ok( !$irc->is_nick_me( "SecondNick" ), 'Client does not recognise new nick' ); + +$serverstream = ""; + +wait_for_stream { $serverstream =~ m/$CRLF/ } $S2 => $serverstream; + +is( $serverstream, "NICK SecondNick$CRLF", 'Server stream after NICK command' ); + +$S2->syswrite( ":FirstNick!defaultuser\@your.host.here NICK SecondNick$CRLF" ); + +wait_for { not $irc->is_nick_me( "FirstNick" ) }; + +is( $irc->nick, "SecondNick", 'Object now confirms new nick' ); + +ok( !$irc->is_nick_me( "FirstNick" ), 'Client no longer recognises old nick' ); +ok( $irc->is_nick_me( "SecondNick" ), 'Client now recognises new nick' ); + +done_testing; diff --git a/t/40methods-basic.t b/t/40methods-basic.t new file mode 100644 index 0000000..dd36500 --- /dev/null +++ b/t/40methods-basic.t @@ -0,0 +1,40 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; +use IO::Async::Stream; + +use Net::Async::IRC; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my ( $S1, $S2 ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + +my $irc = Net::Async::IRC->new( + handle => $S1, +); +$loop->add( $irc ); + +# privmsg +{ + my $f = $irc->do_PRIVMSG( target => "#target", text => "Your message here" ); + + isa_ok( $f, "Future", '$f' ); + + my $serverstream = ""; + wait_for_stream { $serverstream =~ m/(?:.*$CRLF)/ } $S2 => $serverstream; + + is( $serverstream, "PRIVMSG #target :Your message here$CRLF", + '->privmsg' ); + + ok( $f->is_ready, '$f is ready' ); +} + +done_testing; diff --git a/t/50client-pingpong.t b/t/50client-pingpong.t new file mode 100644 index 0000000..4f715bf --- /dev/null +++ b/t/50client-pingpong.t @@ -0,0 +1,86 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +use Time::HiRes qw(); # Empty import, just there to let IO::Async and Net::Async::IRC use it + +use IO::Async::Test; +use IO::Async::OS; +use IO::Async::Loop; +use IO::Async::Stream; + +use Net::Async::IRC; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my ( $S1, $S2 ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + +my $lag; +my $pingout; + +my $irc = Net::Async::IRC->new( + handle => $S1, + on_message => sub { "IGNORE" }, + + pingtime => 2, + pongtime => 1, + + on_pong_reply => sub { $lag = $_[1] }, + on_ping_timeout => sub { $pingout = 1 }, +); + +$loop->add( $irc ); + +# This is all tricky timing-related code. Pay attention + +# First [the server] will send three messages, separated by 1sec, and assert +# that the client didn't send a PING + +my $serverstream = ""; + +my $msgcount = 0; + +sub tick { + $msgcount++; + $S2->syswrite( "HELLO client$CRLF" ); + + $loop->enqueue_timer( + delay => 1, + code => \&tick + ) if $msgcount < 3; +} + +tick(); + +wait_for_stream { $msgcount == 3 } $S2 => $serverstream; + +is( $serverstream, "", 'client quiet after server noise' ); + +# Now [the server] will be quiet and assert that the client sends a PING + +wait_for_stream { $serverstream =~ m/$CRLF/ } $S2 => $serverstream; + +like( $serverstream, qr/^PING .*$CRLF$/, 'client sent PING after server idle' ); + +# Now lets be a good server and reply to the PING +my ( $pingarg ) = $serverstream =~ m/^PING (.*)$CRLF$/; +$S2->syswrite( ":irc.example.com PONG $pingarg$CRLF" ); + +undef $lag; +wait_for { defined $lag }; + +ok( $lag >= 0 && $lag <= 1, 'client acknowledges PONG reply' ); + +# Now [the server] won't reply to a PING at all, and hope for an event to note +# that it failed + +wait_for { defined $pingout }; +ok( $pingout, 'client reports PING timeout' ); + +done_testing; diff --git a/t/99pod.t b/t/99pod.t new file mode 100644 index 0000000..eb319fb --- /dev/null +++ b/t/99pod.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Pod 1.00"; +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; + +all_pod_files_ok(); diff --git a/t/privkey.pem b/t/privkey.pem new file mode 100644 index 0000000..a7eb3d0 --- /dev/null +++ b/t/privkey.pem @@ -0,0 +1,15 @@ +-----BEGIN RSA PRIVATE KEY----- +MIICXAIBAAKBgQDddpSdw0V5emmrozEq3LkTiILDUeUk4MiTmoug1bcfgbQwld4r +U/Dyl1oT8bonEzIcf7002HAQmhPae+9XdQOxnqyzamRBNwuypO895g5EPswTh9Rr +PohJse3qWs4yVP1PVeatBwxIvug+6+0XXAymNBVJmQfcCbLX4i/b27NtmwIDAQAB +AoGAcz93XZY1/F6oyQo21wBgS/r5WZ2vqn5TwwRk70DoeDvuQm5rXI7lT8lVthVQ +c284373V/782ql0UQdnHFvMtBPT14fPdfysBSFIwjPdAZMG6EqTtYy30o8Hk1N34 +CcBTqS4nt+MvxW3xdvQd/hVZgoWRbdCZ6p11Ky9ylmJgt6kCQQD3cRkKNjeF//8j +eG/L0OykpTivy0peDCWOZCyRIME45+L/eYaYKMdhQ4YNeaguMC2Z8GrbXf2oRZce +t2jxn6tdAkEA5R92e5jC3dT+S1SCCSzdr1+IGF8PF5EnPCGtQMl+pfCleAo/aiPK +pM2lmoUaOoMj8j655mq5gdUxxshPFl7lVwJBAJmo2D3pMU27jbt/PR263lnYaH1y +pvoEXQYx2yM8zgECr4qq8xRmrnoOLp8Ln48fSBJCpHkZwz3OCWx/xWHXH9kCQEH+ +3wTYyoBVAm42SEJWTwBdtvi2IMW8BJ4YYSwBHd60QyUhZoSvDIaNyX6JijWCYo87 +LBbHdOmFvBGyzrz11n8CQCmlyhmF2xe1xUrYnGgnfIj29KPFmJik2qeDTfxACv4Z +MzPtOWOEdZjc5h6JTnQTl0fcko35l5FaUeflvw2uBGM= +-----END RSA PRIVATE KEY----- diff --git a/t/server.pem b/t/server.pem new file mode 100644 index 0000000..54b5b51 --- /dev/null +++ b/t/server.pem @@ -0,0 +1,17 @@ +-----BEGIN CERTIFICATE----- +MIICsDCCAhmgAwIBAgIJAOLBB28kRrw6MA0GCSqGSIb3DQEBBQUAMEUxCzAJBgNV +BAYTAkFVMRMwEQYDVQQIEwpTb21lLVN0YXRlMSEwHwYDVQQKExhJbnRlcm5ldCBX +aWRnaXRzIFB0eSBMdGQwHhcNMTAxMTIxMjIwMjM5WhcNMTAxMjIxMjIwMjM5WjBF +MQswCQYDVQQGEwJBVTETMBEGA1UECBMKU29tZS1TdGF0ZTEhMB8GA1UEChMYSW50 +ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB +gQDddpSdw0V5emmrozEq3LkTiILDUeUk4MiTmoug1bcfgbQwld4rU/Dyl1oT8bon +EzIcf7002HAQmhPae+9XdQOxnqyzamRBNwuypO895g5EPswTh9RrPohJse3qWs4y +VP1PVeatBwxIvug+6+0XXAymNBVJmQfcCbLX4i/b27NtmwIDAQABo4GnMIGkMB0G +A1UdDgQWBBQKCmQV0xTMGtYoalfHFbpDr3kgszB1BgNVHSMEbjBsgBQKCmQV0xTM +GtYoalfHFbpDr3kgs6FJpEcwRTELMAkGA1UEBhMCQVUxEzARBgNVBAgTClNvbWUt +U3RhdGUxITAfBgNVBAoTGEludGVybmV0IFdpZGdpdHMgUHR5IEx0ZIIJAOLBB28k +Rrw6MAwGA1UdEwQFMAMBAf8wDQYJKoZIhvcNAQEFBQADgYEAIjrc8INv1WxIq0kV +yDEmcBeot1RRiCQJJxy3xq6eZZcTkT+YvEVrR/hOWPGL0qFInltBKcp0To0w+Esz +SQfvieWW1U/aAfcBNJ26HRyzh8N98ZST9k4LlDJbneHB8McF1G5n/D71wmHm1llh +cIX3gRpAkOW5gnjXUYpgsviJxUQ= +-----END CERTIFICATE----- |