Protocol-IRC-0.12000755001750001750 013056415115 12372 5ustar00leoleo000000000000Protocol-IRC-0.12/Build.PL000444001750001750 77613056415115 14015 0ustar00leoleo000000000000use strict; use warnings; use Module::Build; my $build = Module::Build->new( module_name => 'Protocol::IRC', requires => { 'perl' => '5.010', # //, mro c3 }, test_requires => { 'Future' => 0, '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; Protocol-IRC-0.12/Changes000444001750001750 561713056415115 14033 0ustar00leoleo000000000000Revision history for Protocol-IRC 0.12 [CHANGES] * Add WATCH-related server numerics * Add RPL_WHOISSECURE as most networks use it now * Allow construction of Protocol::IRC::Message instance using kvlist of named arguments * Recognise a 'join' gate for joining channels * A very initial hack at gate futures 0.11 [CHANGES] * Split out from Net-Async-IRC * Set an '_is_me' hint key for every _name or _nick, not just the fixed ones * Updated method documentation style to =head2 barename [BUGFIXES] * Local'ise $_ before readline'ing using it Prior to 0.11, this was bundled as part of Net-Async-IRC 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. Protocol-IRC-0.12/LICENSE000444001750001750 4376213056415115 13570 0ustar00leoleo000000000000This software is copyright (c) 2017 by Paul Evans . 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 . 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. 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! --- The Artistic License 1.0 --- This software is Copyright (c) 2017 by Paul Evans . 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 Protocol-IRC-0.12/MANIFEST000444001750001750 77113056415115 13645 0ustar00leoleo000000000000Build.PL Changes lib/Protocol/IRC.pm lib/Protocol/IRC/Client.pm lib/Protocol/IRC/Message.pm LICENSE Makefile.PL MANIFEST This list of files META.json META.yml README t/00use.t t/01message.t t/02message-splitprefix.t t/03message-argnames.t t/04message-from-named.t t/10protocol-sendrecv.t t/11protocol-isupport.t t/12protocol-hints.t t/13protocol-text.t t/14protocol-encoding.t t/20client.t t/21client-isupport.t t/22client-chanmodes.t t/23client-cap.t t/24client-gates.t t/25client-commands.t t/99pod.t Protocol-IRC-0.12/META.json000444001750001750 227213056415115 14153 0ustar00leoleo000000000000{ "abstract" : "IRC protocol handling", "author" : [ "Paul Evans " ], "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" : "Protocol-IRC", "prereqs" : { "runtime" : { "requires" : { "perl" : "5.010" } }, "test" : { "requires" : { "Future" : "0", "Test::Fatal" : "0", "Test::More" : "0.88" } } }, "provides" : { "Protocol::IRC" : { "file" : "lib/Protocol/IRC.pm", "version" : "0.12" }, "Protocol::IRC::Client" : { "file" : "lib/Protocol/IRC/Client.pm", "version" : "0.12" }, "Protocol::IRC::Message" : { "file" : "lib/Protocol/IRC/Message.pm", "version" : "0.12" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.12", "x_serialization_backend" : "JSON::PP version 2.27400" } Protocol-IRC-0.12/META.yml000444001750001750 141313056415115 13777 0ustar00leoleo000000000000--- abstract: 'IRC protocol handling' author: - 'Paul Evans ' build_requires: Future: '0' 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: Protocol-IRC provides: Protocol::IRC: file: lib/Protocol/IRC.pm version: '0.12' Protocol::IRC::Client: file: lib/Protocol/IRC/Client.pm version: '0.12' Protocol::IRC::Message: file: lib/Protocol/IRC/Message.pm version: '0.12' requires: perl: '5.010' resources: license: http://dev.perl.org/licenses/ version: '0.12' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Protocol-IRC-0.12/Makefile.PL000444001750001750 45113056415115 14461 0ustar00leoleo000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.4220 require 5.010; use ExtUtils::MakeMaker; WriteMakefile ( 'NAME' => 'Protocol::IRC', 'VERSION_FROM' => 'lib/Protocol/IRC.pm', 'PREREQ_PM' => {}, 'INSTALLDIRS' => 'site', 'EXE_FILES' => [], 'PL_FILES' => {} ) ; Protocol-IRC-0.12/README000444001750001750 3247113056415115 13436 0ustar00leoleo000000000000NAME Protocol::IRC - IRC protocol handling DESCRIPTION This mix-in class provides a base layer of IRC message handling logic. It allows reading of IRC messages from a string buffer and dispatching them to handler methods on its instance. Protocol::IRC::Client provides an extension to this logic that may be more convenient for IRC client implementations. Much of the code provided here is still useful in client applications, so the reader should be familiar with both modules. 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 COMMAND will try handlers in following places: 1. A method called on_message_COMMAND $irc->on_message_COMMAND( $message, \%hints ) 2. A method called on_message $irc->on_message( 'COMMAND', $message, \%hints ) For server numeric replies, if the numeric reply has a known name, it will be attempted first at its known name, before falling back to the numeric if it was not handled. Unrecognised numerics will be attempted only at their numeric value. Because of the wide variety of messages in IRC involving various types of data the message handling specific cases for certain types of message, including adding extra hints hash items, or invoking extra message handler stages. These details are noted here. Many of these messages create new events; called synthesized messages. These are messages created by the Protocol::IRC object itself, to better represent some of the details derived from the primary ones from the server. These events all take lower-case command names, rather than capitals, and will have a synthesized key in the hints hash, set to a true value. These are dispatched and handled identically to regular primary events, detailed above. If any handler of the synthesized message returns true, then this marks the primary message handled as well. If a message is received that has a gating disposition, extra processing is applied to it before the processing above. The effect on its gate is given as a string (one of more, done, fail) to handlers in the following places: 1. A method called on_message_gate_EFFECT_GATE $irc->on_message_gate_EFFECT_GATE( $message, \%hints ) 2. A method called on_message_gate_EFFECT $irc->on_message_gate_EFFECT( 'GATE', $message, \%hints ) 3. A method called on_message_gate $irc->on_message_gate( 'EFFECT', 'GATE', $message, \%hints ) Message Hints When messages arrive they are passed to the appropriate message handling method, which the implementation may define. As well as the message, a hash of extra information derived from or relating to the message is also given. The following keys will be present in any message hint hash: handled => BOOL Initially false. Will be set to true the first time a handler returns a true value. prefix_nick => STRING prefix_user => STRING prefix_host => STRING Values split from the message prefix; see the Protocol::IRC::Message prefix_split method. prefix_name => STRING Usually the prefix nick, or the hostname in case the nick isn't defined (usually on server messages). prefix_is_me => BOOL True if the nick mentioned in the prefix refers to this connection. Added to this set, will be all the values returned by the message's named_args method. Some of these values may cause yet more values to be generated. If the message type defines a target_name: * target_type => STRING Either channel or user, as returned by classify_name. * target_is_me => BOOL True if the target name is a user and refers to this connection. Any key whose name ends in _nick or _name will have a corresponding key added with _folded suffixed on its name, containing the value casefolded using casefold_name. This is for the convenience of string comparisons, hash keys, etc.. Any of these keys that are not the prefix_name will additionally have a corresponding key with _is_me replacing the _nick or _name, containing the boolean result of calling the is_nick_me method on that name. This makes it simpler to detect commands or results affecting the user the connection represents. METHODS on_read $irc->on_read( $buffer ) Informs the protocol implementation that more bytes have been read from the peer. This method will modify the $buffer directly, and remove from it the prefix of bytes it has consumed. Any bytes remaining should be stored by the caller for next time. Any messages found in the buffer will be passed, in sequence, to the incoming_message method. incoming_message $irc->incoming_message( $message ) Invoked by the on_read method for every incoming IRC message. This method implements the actual dispatch into various handler methods as described in the "MESSAGE HANDLING" section above. This method is exposed so that subclasses can override it, primarily to wrap extra logic before or after the main dispatch (e.g. for logging or other processing). send_message This method takes arguments in three different forms, depending on their number and type. If the first argument is a reference then it must contain a Protocol::IRC::Message instance which will be sent directly: $irc->send_message( $message ) Otherwise, the first argument must be a plain string that gives the command name. If the second argument is a hash, it provides named arguments in a form similar to "new_from_named_args" in Protocol::IRC::Message, otherwise the remaining arguments must be the prefix string and other positional arguments, as plain strings: $irc->send_message( $command, { %args } ) $irc->send_message( $command, $prefix, @args ) Named Argument Mangling For symmetry with incoming message processing, this method applies some adjustment of named arguments for convenience of callers. * Callers may define a named argument of target; it will be renamed to target_name. * If a named argument of text is defined and an "encoder" exists, the argument value will be encoded using this encoder. send_ctcp $irc->send_ctcp( $prefix, $target, $verb, $argstr ) Shortcut to sending a CTCP message. Sends a PRIVMSG to the given target, containing the given verb and argument string. send_ctcprely $irc->send_ctcprely( $prefix, $target, $verb, $argstr ) Shortcut to sending a CTCP reply. As send_ctcp but using a NOTICE instead. ISUPPORT-DRIVEN UTILITIES The following methods are controlled by the server information given in the ISUPPORT settings. They use the isupport required method to query the information required. casefold_name $name_folded = $irc->casefold_name( $name ) Returns the $name, folded in case according to the server's CASEMAPPING ISUPPORT. Such a folded name will compare using eq according to whether the server would consider it the same name. Useful for use in hash keys or similar. cmp_prefix_flags $cmp = $irc->cmp_prefix_flags( $lhs, $rhs ) Compares two channel occupant prefix flags, and returns a signed integer to indicate which of them has higher priviledge, according to the server's ISUPPORT declaration. Suitable for use in a sort() function or similar. cmp_prefix_modes $cmp = $irc->cmp_prefix_modes( $lhs, $rhs ) Similar to cmp_prefix_flags, but compares channel occupant MODE command flags. prefix_mode2flag $flag = $irc->prefix_mode2flag( $mode ) Converts a channel occupant MODE flag (such as o) into a name prefix flag (such as @). prefix_flag2mode $mode = $irc->prefix_flag2mode( $flag ) The inverse of prefix_mode2flag. classify_name $classification = $irc->classify_name( $name ) Returns channel if the given name matches the pattern of names allowed for channels according to the server's CHANTYPES ISUPPORT. Returns user if not. is_nick_me $me = $irc->is_nick_me( $nick ) Returns true if the given nick refers to that in use by the connection. INTERNAL MESSAGE HANDLING The following messages are handled internally by Protocol::IRC. PING PING messages are automatically replied to with PONG. NOTICE and PRIVMSG Because NOTICE and PRIVMSG are so similar, they are handled together by synthesized events called text, ctcp and ctcpreply. Depending on the contents of the text, and whether it was supplied in a PRIVMSG or a NOTICE, one of these three events will be created. In all cases, the hints hash will contain a is_notice key being true or false, depending on whether the original messages was a NOTICE or a PRIVMSG, a target_name key containing the message target name, a case-folded version of the name in a target_name_folded key, and a classification of the target type in a target_type key. For the user target type, it will contain a boolean in target_is_me to indicate if the target of the message is the user represented by this connection. For the channel target type, it will contain a restriction key containing the channel message restriction, if present. For normal text messages, it will contain a key text containing the actual message text. For either CTCP message type, it will contain keys ctcp_verb and ctcp_args with the parsed message. The ctcp_verb will contain the first space-separated token, and ctcp_args will be a string containing the rest of the line, otherwise unmodified. This type of message is also subject to a special stage of handler dispatch, involving the CTCP verb string. For messages with VERB as the verb, the following are tried. CTCP may stand for either ctcp or ctcpreply. 1. A method called on_message_CTCP_VERB $irc->on_message_CTCP_VERB( $message, \%hints ) 2. A method called on_message_CTCP $irc->on_message_CTCP( 'VERB', $message, \%hintss ) 3. A method called on_message $irc->on_message( 'CTCP VERB', $message, \%hints ) REQUIRED METHODS As this class is an abstract base class, a concrete implementation must provide the following methods to complete it and make it useable. write $irc->write( $string ) Requests the byte string to be sent to the peer encoder $encoder = $irc->encoder Optional. If supplied, returns an Encode object used to encode or decode the bytes appearing in a text field of a message. If set, all text strings will be returned, and should be given, as Unicode strings. They will be encoded or decoded using this object. invoke $result = $irc->invoke( $name, @args ) Optional. If provided, invokes the message handling routine called $name with the given arguments. A default implementation is provided which simply attempts to invoke a method of the given name, or return false if no method of that name exists. If an implementation does override this method, care should be taken to ensure that methods are tested for and invoked if present, in addition to any other work the method wishes to perform, as this is the basis by which derived message handling works. isupport $value = $irc->isupport( $field ) Should return the value of the given ISUPPORT field. As well as the all-capitals server-supplied fields, the following fields may be requested. Their names are all lowercase and contain underscores, to distinguish them from server-supplied fields. prefix_modes => STRING The mode characters from PREFIX (e.g. ohv) prefix_flags => STRING The flag characters from PREFIX (e.g. @%+) prefixflag_re => Regexp A precompiled regexp that matches any of the prefix flags prefix_map_m2f => HASH A map from mode characters to flag characters prefix_map_f2m => HASH A map from flag characters to mode characters chanmodes_list => ARRAY A 4-element array containing the split portions of CHANMODES; [ $listmodes, $argmodes, $argsetmodes, $boolmodes ] channame_re => Regexp A precompiled regexp that matches any string beginning with a channel prefix character in CHANTYPES. nick $nick = $irc->nick Should return the current nick in use by the connection. nick_folded $nick_folded = $irc->nick_folded Optional. If supplied, should return the current nick as case-folded by the casefold_name method. If not provided, this will be performed by case-folding the result from nick. AUTHOR Paul Evans Protocol-IRC-0.12/lib000755001750001750 013056415115 13140 5ustar00leoleo000000000000Protocol-IRC-0.12/lib/Protocol000755001750001750 013056415115 14741 5ustar00leoleo000000000000Protocol-IRC-0.12/lib/Protocol/IRC.pm000444001750001750 5506613056415115 16105 0ustar00leoleo000000000000# 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-2017 -- leonerd@leonerd.org.uk package Protocol::IRC; use strict; use warnings; our $VERSION = '0.12'; use Carp; use Scalar::Util qw( blessed ); use Protocol::IRC::Message; # This should be mixed in MI-style =head1 NAME C - IRC protocol handling =head1 DESCRIPTION This mix-in class provides a base layer of IRC message handling logic. It allows reading of IRC messages from a string buffer and dispatching them to handler methods on its instance. L provides an extension to this logic that may be more convenient for IRC client implementations. Much of the code provided here is still useful in client applications, so the reader should be familiar with both modules. =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 will try handlers in following places: =over 4 =item 1. A method called C $irc->on_message_COMMAND( $message, \%hints ) =item 2. A method called C $irc->on_message( 'COMMAND', $message, \%hints ) =back For server numeric replies, if the numeric reply has a known name, it will be attempted first at its known name, before falling back to the numeric if it was not handled. Unrecognised numerics will be attempted only at their numeric value. Because of the wide variety of messages in IRC involving various types of data the message handling specific cases for certain types of message, including adding extra hints hash items, or invoking extra message handler stages. These details are noted here. Many of these messages create new events; called synthesized messages. These are messages created by the C object itself, to better represent some of the details derived from the primary ones from the server. These events all take lower-case command names, rather than capitals, and will have a C key in the hints hash, set to a true value. These are dispatched and handled identically to regular primary events, detailed above. If any handler of the synthesized message returns true, then this marks the primary message handled as well. If a message is received that has a gating disposition, extra processing is applied to it before the processing above. The effect on its gate is given as a string (one of C, C, C) to handlers in the following places: =over 4 =item 1. A method called C $irc->on_message_gate_EFFECT_GATE( $message, \%hints ) =item 2. A method called C $irc->on_message_gate_EFFECT( 'GATE', $message, \%hints ) =item 3. A method called C $irc->on_message_gate( 'EFFECT', 'GATE', $message, \%hints ) =back =head2 Message Hints When messages arrive they are passed to the appropriate message handling method, which the implementation may define. As well as the message, a hash of extra information derived from or relating to the message is also given. The following keys will be present in any message hint hash: =over 8 =item handled => BOOL Initially false. Will be set to true the first time a handler returns a true value. =item prefix_nick => STRING =item prefix_user => STRING =item prefix_host => STRING Values split from the message prefix; see the C C method. =item prefix_name => STRING Usually the prefix nick, or the hostname in case the nick isn't defined (usually on server messages). =item prefix_is_me => BOOL True if the nick mentioned in the prefix refers to this connection. =back Added to this set, will be all the values returned by the message's C method. Some of these values may cause yet more values to be generated. If the message type defines a C: =over 8 =item * target_type => STRING Either C or C, as returned by C. =item * target_is_me => BOOL True if the target name is a user and refers to this connection. =back Any key whose name ends in C<_nick> or C<_name> will have a corresponding key added with C<_folded> suffixed on its name, containing the value casefolded using C. This is for the convenience of string comparisons, hash keys, etc.. Any of these keys that are not the C will additionally have a corresponding key with C<_is_me> replacing the C<_nick> or C<_name>, containing the boolean result of calling the C method on that name. This makes it simpler to detect commands or results affecting the user the connection represents. =cut =head1 METHODS =cut =head2 on_read $irc->on_read( $buffer ) Informs the protocol implementation that more bytes have been read from the peer. This method will modify the C<$buffer> directly, and remove from it the prefix of bytes it has consumed. Any bytes remaining should be stored by the caller for next time. Any messages found in the buffer will be passed, in sequence, to the C method. =cut sub on_read { my $self = shift; # buffer in $_[0] while( $_[0] =~ s/^(.*)\x0d\x0a// ) { my $line = $1; # Ignore blank lines next if !length $line; $self->incoming_message( Protocol::IRC::Message->new_from_line( $line ) ); } } =head2 incoming_message $irc->incoming_message( $message ) Invoked by the C method for every incoming IRC message. This method implements the actual dispatch into various handler methods as described in the L section above. This method is exposed so that subclasses can override it, primarily to wrap extra logic before or after the main dispatch (e.g. for logging or other processing). =cut sub incoming_message { my $self = shift; my ( $message ) = @_; my $command = $message->command_name; my ( $prefix_nick, $prefix_user, $prefix_host ) = $message->prefix_split; my $hints = { handled => 0, prefix_nick => $prefix_nick, prefix_user => $prefix_user, prefix_host => $prefix_host, # Most of the time this will be "nick", except for special messages from the server prefix_name => defined $prefix_nick ? $prefix_nick : $prefix_host, }; if( my $named_args = $message->named_args ) { $hints->{$_} = $named_args->{$_} for keys %$named_args; } if( defined $hints->{text} and my $encoder = $self->encoder ) { $hints->{text} = $encoder->decode( $hints->{text} ); } if( defined( my $target_name = $hints->{target_name} ) ) { my $target_type = $self->classify_name( $target_name ); $hints->{target_type} = $target_type; } my $prepare_method = "prepare_hints_$command"; $self->$prepare_method( $message, $hints ) if $self->can( $prepare_method ); foreach my $k ( grep { m/_nick$/ or m/_name$/ } keys %$hints ) { $hints->{"${k}_folded"} = $self->casefold_name( my $name = $hints->{$k} ); defined $name or next; $k eq "prefix_name" and next; ( my $knew = $k ) =~ s/_name$|_nick$/_is_me/; $hints->{$knew} = $self->is_nick_me( $name ); } if( my $disp = $message->gate_disposition ) { my ( $type, $gate ) = $disp =~ m/^([-+!*])(.*)$/; my $effect = ( $type eq "-" ? "more" : $type eq "+" ? "done" : $type eq "!" ? "fail" : $type eq "*" ? ( $hints->{prefix_is_me} ? "done" : undef ) : die "TODO" ); if( defined $effect ) { $self->invoke( "on_message_gate_${effect}_$gate", $message, $hints ) and $hints->{handled} = 1; $self->invoke( "on_message_gate_$effect", $gate, $message, $hints ) and $hints->{handled} = 1; $self->invoke( "on_message_gate", $effect, $gate, $message, $hints ) and $hints->{handled} = 1; } } $self->invoke( "on_message_$command", $message, $hints ) and $hints->{handled} = 1; $self->invoke( "on_message", $command, $message, $hints ) and $hints->{handled} = 1; if( !$hints->{handled} and $message->command ne $command ) { # numerics my $numeric = $message->command; $self->invoke( "on_message_$numeric", $message, $hints ) and $hints->{handled} = 1; $self->invoke( "on_message", $numeric, $message, $hints ) and $hints->{handled} = 1; } } =head2 send_message This method takes arguments in three different forms, depending on their number and type. If the first argument is a reference then it must contain a C instance which will be sent directly: $irc->send_message( $message ) Otherwise, the first argument must be a plain string that gives the command name. If the second argument is a hash, it provides named arguments in a form similar to L, otherwise the remaining arguments must be the prefix string and other positional arguments, as plain strings: $irc->send_message( $command, { %args } ) $irc->send_message( $command, $prefix, @args ) =head3 Named Argument Mangling For symmetry with incoming message processing, this method applies some adjustment of named arguments for convenience of callers. =over 4 =item * Callers may define a named argument of C; it will be renamed to C. =item * If a named argument of C is defined and an L exists, the argument value will be encoded using this encoder. =back =cut sub send_message { my $self = shift; my $message; if( @_ == 1 ) { $message = shift; blessed $message and $message->isa( "Protocol::IRC::Message" ) or croak "Expected an instance of Protocol::IRC::Message"; } else { my $command = shift; ref $command and croak "Expected \$command to be a plain string"; if( @_ == 1 and ref $_[0] ) { my %args = %{ $_[0] }; $args{target_name} = delete $args{target} if defined $args{target}; if( defined $args{text} and my $encoder = $self->encoder ) { $args{text} = $encoder->encode( $args{text} ); } $message = Protocol::IRC::Message->new_from_named_args( $command, %args ); } else { my ( $prefix, @args ) = @_; if( my $encoder = $self->encoder ) { my $argnames = Protocol::IRC::Message->arg_names( $command ); if( defined( my $i = $argnames->{text} ) ) { $args[$i] = $encoder->encode( $args[$i] ) if defined $args[$i]; } } $message = Protocol::IRC::Message->new( $command, $prefix, @args ); } } $self->write( $message->stream_to_line . "\x0d\x0a" ); } =head2 send_ctcp $irc->send_ctcp( $prefix, $target, $verb, $argstr ) Shortcut to sending a CTCP message. Sends a PRIVMSG to the given target, containing the given verb and argument string. =cut sub send_ctcp { my $self = shift; my ( $prefix, $target, $verb, $argstr ) = @_; $self->send_message( "PRIVMSG", undef, $target, "\001$verb $argstr\001" ); } =head2 send_ctcprely $irc->send_ctcprely( $prefix, $target, $verb, $argstr ) Shortcut to sending a CTCP reply. As C but using a NOTICE instead. =cut sub send_ctcpreply { my $self = shift; my ( $prefix, $target, $verb, $argstr ) = @_; $self->send_message( "NOTICE", undef, $target, "\001$verb $argstr\001" ); } =head1 ISUPPORT-DRIVEN UTILITIES The following methods are controlled by the server information given in the C settings. They use the C required method to query the information required. =cut =head2 casefold_name $name_folded = $irc->casefold_name( $name ) Returns the C<$name>, folded in case according to the server's C C. Such a folded name will compare using C according to whether the server would consider it the same name. Useful for use in hash keys or similar. =cut sub casefold_name { my $self = shift; my ( $nick ) = @_; return undef unless defined $nick; my $mapping = lc( $self->isupport( "CASEMAPPING" ) || "" ); # Squash the 'capital' [\] into lowercase {|} $nick =~ tr/[\\]/{|}/ if $mapping ne "ascii"; # Most RFC 1459 implementations also squash ^ to ~, even though the RFC # didn't mention it $nick =~ tr/^/~/ unless $mapping eq "strict-rfc1459"; return lc $nick; } =head2 cmp_prefix_flags $cmp = $irc->cmp_prefix_flags( $lhs, $rhs ) Compares two channel occupant prefix flags, and returns a signed integer to indicate which of them has higher priviledge, according to the server's ISUPPORT declaration. Suitable for use in a C function or similar. =cut sub cmp_prefix_flags { my $self = shift; my ( $lhs, $rhs ) = @_; return undef unless defined $lhs and defined $rhs; # As a special case, compare emptystring as being lower than voice return 0 if $lhs eq "" and $rhs eq ""; return 1 if $rhs eq ""; return -1 if $lhs eq ""; my $PREFIX_FLAGS = $self->isupport( 'prefix_flags' ); ( my $lhs_index = index $PREFIX_FLAGS, $lhs ) > -1 or return undef; ( my $rhs_index = index $PREFIX_FLAGS, $rhs ) > -1 or return undef; # IRC puts these in greatest-first, so we need to swap the ordering here return $rhs_index <=> $lhs_index; } =head2 cmp_prefix_modes $cmp = $irc->cmp_prefix_modes( $lhs, $rhs ) Similar to C, but compares channel occupant C command flags. =cut sub cmp_prefix_modes { my $self = shift; my ( $lhs, $rhs ) = @_; return undef unless defined $lhs and defined $rhs; my $PREFIX_MODES = $self->isupport( "prefix_modes" ); ( my $lhs_index = index $PREFIX_MODES, $lhs ) > -1 or return undef; ( my $rhs_index = index $PREFIX_MODES, $rhs ) > -1 or return undef; # IRC puts these in greatest-first, so we need to swap the ordering here return $rhs_index <=> $lhs_index; } =head2 prefix_mode2flag $flag = $irc->prefix_mode2flag( $mode ) Converts a channel occupant C flag (such as C) into a name prefix flag (such as C<@>). =cut sub prefix_mode2flag { my $self = shift; my ( $mode ) = @_; return $self->isupport( 'prefix_map_m2f' )->{$mode}; } =head2 prefix_flag2mode $mode = $irc->prefix_flag2mode( $flag ) The inverse of C. =cut sub prefix_flag2mode { my $self = shift; my ( $flag ) = @_; return $self->isupport( 'prefix_map_f2m' )->{$flag}; } =head2 classify_name $classification = $irc->classify_name( $name ) Returns C if the given name matches the pattern of names allowed for channels according to the server's C C. Returns C if not. =cut sub classify_name { my $self = shift; my ( $name ) = @_; return "channel" if $name =~ $self->isupport( "channame_re" ); return "user"; # TODO: Perhaps we can be a bit stricter - only check for valid nick chars? } =head2 is_nick_me $me = $irc->is_nick_me( $nick ) Returns true if the given nick refers to that in use by the connection. =cut sub is_nick_me { my $self = shift; my ( $nick ) = @_; return $self->casefold_name( $nick ) eq $self->nick_folded; } =head1 INTERNAL MESSAGE HANDLING The following messages are handled internally by C. =cut =head2 PING C messages are automatically replied to with C. =cut sub on_message_PING { my $self = shift; my ( $message, $hints ) = @_; $self->send_message( "PONG", undef, $message->named_args->{text} ); return 1; } =head2 NOTICE and PRIVMSG Because C and C are so similar, they are handled together by synthesized events called C, C and C. Depending on the contents of the text, and whether it was supplied in a C or a C, one of these three events will be created. In all cases, the hints hash will contain a C key being true or false, depending on whether the original messages was a C or a C, a C key containing the message target name, a case-folded version of the name in a C key, and a classification of the target type in a C key. For the C target type, it will contain a boolean in C to indicate if the target of the message is the user represented by this connection. For the C target type, it will contain a C key containing the channel message restriction, if present. For normal C messages, it will contain a key C containing the actual message text. For either CTCP message type, it will contain keys C and C with the parsed message. The C will contain the first space-separated token, and C will be a string containing the rest of the line, otherwise unmodified. This type of message is also subject to a special stage of handler dispatch, involving the CTCP verb string. For messages with C as the verb, the following are tried. C may stand for either C or C. =over 4 =item 1. A method called C $irc->on_message_CTCP_VERB( $message, \%hints ) =item 2. A method called C $irc->on_message_CTCP( 'VERB', $message, \%hintss ) =item 3. A method called C $irc->on_message( 'CTCP VERB', $message, \%hints ) =back =cut sub on_message_NOTICE { my $self = shift; my ( $message, $hints ) = @_; return $self->_on_message_text( $message, $hints, 1 ); } sub on_message_PRIVMSG { my $self = shift; my ( $message, $hints ) = @_; return $self->_on_message_text( $message, $hints, 0 ); } sub _on_message_text { my $self = shift; my ( $message, $hints, $is_notice ) = @_; my %hints = ( %$hints, synthesized => 1, is_notice => $is_notice, ); # TODO: In client->server messages this might be a comma-separated list my $target = delete $hints{targets}; my $prefixflag_re = $self->isupport( 'prefixflag_re' ); my $restriction = ""; while( $target =~ m/^$prefixflag_re/ ) { $restriction .= substr( $target, 0, 1, "" ); } $hints{target_name} = $target; $hints{target_name_folded} = $self->casefold_name( $target ); my $type = $hints{target_type} = $self->classify_name( $target ); if( $type eq "channel" ) { $hints{restriction} = $restriction; $hints{target_is_me} = ''; } elsif( $type eq "user" ) { # TODO: user messages probably can't have restrictions. What to do # if we got one? $hints{target_is_me} = $self->is_nick_me( $target ); } my $text = $hints->{text}; if( $text =~ m/^\x01(.*)\x01$/ ) { ( my $verb, $text ) = split( m/ /, $1, 2 ); $hints{ctcp_verb} = $verb; $hints{ctcp_args} = $text; my $ctcptype = $is_notice ? "ctcpreply" : "ctcp"; $self->invoke( "on_message_${ctcptype}_$verb", $message, \%hints ) and $hints{handled} = 1; $self->invoke( "on_message_${ctcptype}", $verb, $message, \%hints ) and $hints{handled} = 1; $self->invoke( "on_message", "$ctcptype $verb", $message, \%hints ) and $hints{handled} = 1; } else { $hints{text} = $text; $self->invoke( "on_message_text", $message, \%hints ) and $hints{handled} = 1; $self->invoke( "on_message", "text", $message, \%hints ) and $hints{handled} = 1; } return $hints{handled}; } =head1 REQUIRED METHODS As this class is an abstract base class, a concrete implementation must provide the following methods to complete it and make it useable. =cut =head2 write $irc->write( $string ) Requests the byte string to be sent to the peer =cut sub write { croak "Attemped to invoke abstract ->write on " . ref $_[0] } =head2 encoder $encoder = $irc->encoder Optional. If supplied, returns an L object used to encode or decode the bytes appearing in a C field of a message. If set, all text strings will be returned, and should be given, as Unicode strings. They will be encoded or decoded using this object. =cut sub encoder { undef } =head2 invoke $result = $irc->invoke( $name, @args ) Optional. If provided, invokes the message handling routine called C<$name> with the given arguments. A default implementation is provided which simply attempts to invoke a method of the given name, or return false if no method of that name exists. If an implementation does override this method, care should be taken to ensure that methods are tested for and invoked if present, in addition to any other work the method wishes to perform, as this is the basis by which derived message handling works. =cut sub invoke { my $self = shift; my ( $name, @args ) = @_; return unless $self->can( $name ); return $self->$name( @args ); } =head2 isupport $value = $irc->isupport( $field ) Should return the value of the given C field. As well as the all-capitals server-supplied fields, the following fields may be requested. Their names are all lowercase and contain underscores, to distinguish them from server-supplied fields. =over 8 =item prefix_modes => STRING The mode characters from C (e.g. C) =item prefix_flags => STRING The flag characters from C (e.g. C<@%+>) =item prefixflag_re => Regexp A precompiled regexp that matches any of the prefix flags =item prefix_map_m2f => HASH A map from mode characters to flag characters =item prefix_map_f2m => HASH A map from flag characters to mode characters =item chanmodes_list => ARRAY A 4-element array containing the split portions of C; [ $listmodes, $argmodes, $argsetmodes, $boolmodes ] =item channame_re => Regexp A precompiled regexp that matches any string beginning with a channel prefix character in C. =back =cut sub isupport { croak "Attempted to invoke abstract ->isupport on " . ref $_[0] } =head2 nick $nick = $irc->nick Should return the current nick in use by the connection. =head2 nick_folded $nick_folded = $irc->nick_folded Optional. If supplied, should return the current nick as case-folded by the C method. If not provided, this will be performed by case-folding the result from C. =cut sub nick { croak "Attempted to invoke abstract ->nick on " . ref $_[0] } sub nick_folded { $_[0]->casefold_name( $_[0]->nick ) } =head1 AUTHOR Paul Evans =cut 0x55AA; Protocol-IRC-0.12/lib/Protocol/IRC000755001750001750 013056415115 15356 5ustar00leoleo000000000000Protocol-IRC-0.12/lib/Protocol/IRC/Client.pm000444001750001750 3750313056415115 17317 0ustar00leoleo000000000000# 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-2017 -- leonerd@leonerd.org.uk package Protocol::IRC::Client; use strict; use warnings; use 5.010; # // use base qw( Protocol::IRC ); our $VERSION = '0.12'; use Carp; =head1 NAME C - IRC protocol handling for a client =head1 DESCRIPTION This mix-in class provides a layer of IRC message handling logic suitable for an IRC client. It builds upon L to provide extra message processing useful to IRC clients, such as handling inbound server numerics. It provides some of the methods required by C: =over 4 =item * isupport =back =cut =head1 INHERITED METHODS The following methods, inherited from L, are notable here as being particularly useful for a client. =head2 send_message $irc->send_message( $message ) $irc->send_message( $command, { %args } ) $irc->send_message( $command, $prefix, @args ) See L =cut =head1 METHODS =cut =head2 isupport $value = $irc->isupport( $key ) Returns an item of information from the server's C<005 ISUPPORT> lines. Traditionally IRC servers use all-capital names for keys. =cut # A few hardcoded defaults from RFC 2812 my %ISUPPORT = ( channame_re => qr/^[#&]/, prefixflag_re => qr/^[\@+]/, chanmodes_list => [qw( b k l imnpst )], # TODO: ov ); sub isupport { my $self = shift; my ( $field ) = @_; return $self->{Protocol_IRC_isupport}->{$field} // $ISUPPORT{$field}; } sub on_message_RPL_ISUPPORT { my $self = shift; my ( $message, $hints ) = @_; my $isupport = $self->{Protocol_IRC_isupport} ||= {}; foreach my $entry ( @{ $hints->{isupport} } ) { my ( $name, $value ) = $entry =~ m/^([A-Z]+)(?:=(.*))?$/; $value = 1 if !defined $value; $isupport->{$name} = $value; if( $name eq "PREFIX" ) { my $prefix = $value; my ( $prefix_modes, $prefix_flags ) = $prefix =~ m/^\(([a-z]+)\)(.+)$/i or warn( "Unable to parse PREFIX=$value" ), next; $isupport->{prefix_modes} = $prefix_modes; $isupport->{prefix_flags} = $prefix_flags; $isupport->{prefixflag_re} = qr/[$prefix_flags]/; my %prefix_map; $prefix_map{substr $prefix_modes, $_, 1} = substr $prefix_flags, $_, 1 for ( 0 .. length($prefix_modes) - 1 ); $isupport->{prefix_map_m2f} = \%prefix_map; $isupport->{prefix_map_f2m} = { reverse %prefix_map }; } elsif( $name eq "CHANMODES" ) { $isupport->{chanmodes_list} = [ split( m/,/, $value ) ]; } elsif( $name eq "CASEMAPPING" ) { # TODO # $self->{nick_folded} = $self->casefold_name( $self->{nick} ); } elsif( $name eq "CHANTYPES" ) { $isupport->{channame_re} = qr/^[$value]/; } } return 0; } =head2 server_info $info = $irc->server_info( $key ) Returns an item of information from the server's C<004> line. C<$key> should one of =over 8 =item * host =item * version =item * usermodes =item * channelmodes =back =cut sub server_info { my $self = shift; my ( $key ) = @_; return $self->{Protocol_IRC_server_info}{$key}; } sub on_message_RPL_MYINFO { my $self = shift; my ( $message, $hints ) = @_; @{$self->{Protocol_IRC_server_info}}{qw( host version usermodes channelmodes )} = @{$hints}{qw( serverhost serverversion usermodes channelmodes )}; return 0; } =head1 GATING MESSAGES If messages with a gating disposition are received, extra processing is applied. Messages whose gating effect is C are simply collected up by pushing the hints hash to an array. Added to this hash is the command name itself, so that in the case of multiple message types (for example C replies) the individual messages can still be identified. When the effect of C or C is eventually received, this collected array is passed as C<$data> to a handler in one of the following places: =over 4 =item 1. A method called C $client->on_gate_EFFECT_GATE( $message, $hints, $data ) =item 2. A method called C $client->on_gate_EFFECT( 'GATE', $message, $hints, $data ) =item 3. A method called C $client->on_gate( 'EFFECT, 'GATE', $message, $hints, $data ) =item 4. If the gate effect is C, two more places are tried; looking like regular event handling on a command whose name is the (lowercase) gate name $client->on_message_GATE( $message, $hints ) $client->on_message( 'GATE', $message, $hints ) =back For the following types of gate, the C<$data> is further processed in the following way to provide extra hints fields. =cut sub on_message_gate { my $self = shift; my ( $effect, $gate, $message, $hints ) = @_; my $target = $hints->{target_name_folded} // "*"; if( $effect eq "more" ) { push @{ $self->{Protocol_IRC_gate}{$gate}{$target} }, { %$hints, command => $message->command_name, }; return 1; } my $data = delete $self->{Protocol_IRC_gate}{$gate}{$target}; my @morehints; if( $effect eq "done" and my $code = $self->can( "prepare_gatehints_$gate" ) ) { @morehints = $self->$code( $data ); } my %hints = ( %$hints, synthesized => 1, @morehints, ); my $futures; if( $futures = $self->{Protocol_IRC_gate_futures}{$gate}{$target} and @$futures ) { my $f = shift @$futures; if( $effect eq "done" ) { $f->done( $message, \%hints, $data ); } else { $f->fail( $hints->{text}, irc_gate => $message, \%hints ); } } $self->invoke( "on_gate_${effect}_$gate", $message, \%hints, $data ) and $hints{handled} = 1; $self->invoke( "on_gate_$effect", $gate, $message, \%hints, $data ) and $hints{handled} = 1; $self->invoke( "on_gate", $effect, $gate, $message, \%hints, $data ) and $hints{handled} = 1; if( $effect eq "done" ) { $self->invoke( "on_message_$gate", $message, \%hints ) and $hints{handled} = 1; $self->invoke( "on_message", $gate, $message, \%hints ) and $hints{handled} = 1; } return $hints{handled}; } =head2 who The hints hash will contain an extra key, C, which will be an ARRAY ref containing the lines of the WHO reply. Each line will be a HASH reference containing: =over 8 =item user_ident =item user_host =item user_server =item user_nick =item user_nick_folded =item user_flags =back =cut sub prepare_gatehints_who { my $self = shift; my ( $data ) = @_; my @who = map { my $b = $_; +{ map { $_ => $b->{$_} } qw( user_ident user_host user_server user_nick user_nick_folded user_flags ) } } @$data; return who => \@who; } =head2 names The hints hash will contain an extra key, C, which will be an ARRAY ref containing the usernames in the channel. Each will be a HASH reference containing: =over 8 =item nick =item flag =back =cut sub prepare_gatehints_names { my $self = shift; my ( $data ) = @_; my @names = map { @{ $_->{names} } } @$data; my $prefixflag_re = $self->isupport( 'prefixflag_re' ); my $re = qr/^($prefixflag_re)?(.*)$/; my %names; foreach my $name ( @names ) { my ( $flag, $nick ) = $name =~ $re or next; $flag ||= ''; # make sure it's defined $names{ $self->casefold_name( $nick ) } = { nick => $nick, flag => $flag }; } return names => \%names; } =head2 bans The hints hash will contain an extra key, C, which will be an ARRAY ref containing the ban lines. Each line will be a HASH reference containing: =over 8 =item mask User mask of the ban =item by_nick =item by_nick_folded Nickname of the user who set the ban =item timestamp UNIX timestamp the ban was created =back =cut sub prepare_gatehints_bans { my $self = shift; my ( $data ) = @_; my @bans = map { my $b = $_; +{ map { $_ => $b->{$_} } qw( mask by_nick by_nick_folded timestamp ) } } @$data; return bans => \@bans; } =head2 motd The hints hash will contain an extra key, C, which will be an ARRAY ref containing the lines of the MOTD. =cut sub prepare_gatehints_motd { my $self = shift; my ( $data ) = @_; return motd => [ map { $_->{text} } @$data ]; } =head2 whois The hints hash will contain an extra key, C, which will be an ARRAY ref of entries that mostly relate to the received C numerics. Each C reply will be stripped of the standard hints hash keys, leaving whatever remains. Added to this will be a key called C, whose value will be the command name, minus the leading C, and converted to lowercase. =cut use constant STANDARD_HINTS => qw( prefix_nick prefix_nick_folded prefix_name prefix_name_folded prefix_user prefix_host target_name target_name_folded target_is_me target_type handled ); sub prepare_gatehints_whois { my $self = shift; my ( $data ) = @_; my @whois; my $channels; foreach my $h ( @$data ) { # Just delete all the standard hints from each one delete @{$h}{STANDARD_HINTS()}; ( $h->{whois} = lc delete $h->{command} ) =~ s/^rpl_whois//; # Combine all the 'channels' results into one list if( $h->{whois} eq "channels" ) { if( $channels ) { push @{$channels->{channels}}, @{$h->{channels}}; next; } $channels = $h; } push @whois, $h; } return whois => \@whois; } =head2 join No additional keys. =cut # TODO: maybe JOIN gate should wait for initial events? =head2 next_gate_future $f = $client->next_gate_future( $gate, $target ) As an alternative to using the event handlers above, a client can instead obtain a L that will succeed or fail the next time a result on a given gate is received for a given target. This is often more convenient to use in a client, as it represents the result of running a command. If the gate completes successfully, then so will the future, yielding the same values as would be passed to the C event; namely that ( $message, $hints, $data ) = $f->get If the gate fails, then so will the future, containing the text message from the error numeric as its failure message, C as its category, and the full message and hints for it as the details. =cut sub next_gate_future { my $self = shift; my ( $gate, $target ) = @_; $target = $self->casefold_name( $target // "*" ); my $futures = $self->{Protocol_IRC_gate_futures}{$gate}{$target} //= []; my $f = $self->new_future; push @$futures, $f; $f->on_cancel( sub { my ( $f ) = @_; @$futures = grep { $_ != $f } @$futures }); return $f; } =head1 INTERNAL MESSAGE HANDLING The following messages are handled internally by C. =cut =head2 CAP This message takes a sub-verb as its second argument, and a list of capability names as its third. On receipt of a C message, the verb is extracted and set as the C hint, and the list capabilities set as the keys of a hash given as the C hint. These are then passed to an event called $irc->on_message_cap_VERB( $message, \%hints ) or $irc->on_message_cap( 'VERB', $message, \%hints ) =cut sub on_message_CAP { my $self = shift; my ( $message, $hints ) = @_; my $verb = $message->arg(1); my %hints = ( %$hints, verb => $verb, caps => { map { $_ => 1 } split m/ /, $message->arg(2) }, ); $self->invoke( "on_message_cap_$verb", $message, \%hints ) and $hints{handled} = 1; $self->invoke( "on_message_cap", $verb, $message, \%hints ) and $hints{handled} = 1; return $hints{handled}; } =head2 MODE (on channels) and 324 (RPL_CHANNELMODEIS) These messages involve channel modes. The raw list of channel modes is parsed into an array containing one entry per affected piece of data. Each entry will contain at least a C key, indicating what sort of mode or mode change it is: =over 8 =item list The mode relates to a list; bans, invites, etc.. =item value The mode sets a value about the channel =item bool The mode is a simple boolean flag about the channel =item occupant The mode relates to a user in the channel =back Every mode type then provides a C key, containing the mode character itself, and a C key which is an empty string, C<+>, or C<->. For C and C types, the C key gives the actual list entry or value being set. For C types, a C key gives the mode converted into an occupant flag (by the C method), C and C store the user name affected. C types do not create any extra keys. =cut sub prepare_hints_channelmode { my $self = shift; my ( $message, $hints ) = @_; my ( $listmodes, $argmodes, $argsetmodes, $boolmodes ) = @{ $self->isupport( 'chanmodes_list' ) }; my $modechars = $hints->{modechars}; my @modeargs = @{ $hints->{modeargs} }; my @modes; # [] -> { type => $, sense => $, mode => $, arg => $ } my $sense = 0; foreach my $modechar ( split( m//, $modechars ) ) { $sense = 1, next if $modechar eq "+"; $sense = -1, next if $modechar eq "-"; my $hasarg; my $mode = { mode => $modechar, sense => $sense, }; if( index( $listmodes, $modechar ) > -1 ) { $mode->{type} = 'list'; $mode->{value} = shift @modeargs if ( $sense != 0 ); } elsif( index( $argmodes, $modechar ) > -1 ) { $mode->{type} = 'value'; $mode->{value} = shift @modeargs if ( $sense != 0 ); } elsif( index( $argsetmodes, $modechar ) > -1 ) { $mode->{type} = 'value'; $mode->{value} = shift @modeargs if ( $sense > 0 ); } elsif( index( $boolmodes, $modechar ) > -1 ) { $mode->{type} = 'bool'; } elsif( my $flag = $self->prefix_mode2flag( $modechar ) ) { $mode->{type} = 'occupant'; $mode->{flag} = $flag; $mode->{nick} = shift @modeargs if ( $sense != 0 ); $mode->{nick_folded} = $self->casefold_name( $mode->{nick} ); } else { # TODO: Err... not recognised ... what do I do? } # TODO: Consider a per-mode event here... push @modes, $mode; } $hints->{modes} = \@modes; } sub prepare_hints_MODE { my $self = shift; my ( $message, $hints ) = @_; if( $hints->{target_type} eq "channel" ) { $self->prepare_hints_channelmode( $message, $hints ); } } sub prepare_hints_RPL_CHANNELMODEIS { my $self = shift; my ( $message, $hints ) = @_; $self->prepare_hints_channelmode( $message, $hints ); } =head1 COMMAND-SENDING METHODS The following methods actually send IRC commands. Each is named after the underlying IRC command it sends, using capital letters for methods that simply send that command. =cut =head2 do_PRIVMSG =head2 do_NOTICE Sends a C or C command. For convenience, a single C argument may be provided which will be renamed to C. If C is an ARRAY reference, it will be turned into a comma-separated string. =cut sub _do_pmlike { my $self = shift; my $command = shift; my %args = @_; my $targets = ( ref $args{targets} eq "ARRAY" ) ? join( ",", @{ $args{targets} } ) : ( defined $args{target} ) ? delete $args{target} : $args{targets}; $self->send_message( $command => { @_, targets => $targets } ); } sub do_PRIVMSG { shift->_do_pmlike( PRIVMSG => @_ ) } sub do_NOTICE { shift->_do_pmlike( NOTICE => @_ ) } =head1 REQUIRED METHODS As this class is an abstract base class, a concrete implementation must provide the following methods to complete it and make it useable. =cut =head2 new_future $f = $client->new_future Returns a new L instance or subclass thereof. =cut =head1 AUTHOR Paul Evans =cut 0x55AA; Protocol-IRC-0.12/lib/Protocol/IRC/Message.pm000444001750001750 4420113056415115 17456 0ustar00leoleo000000000000# 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-2016 -- leonerd@leonerd.org.uk package Protocol::IRC::Message; use strict; use warnings; our $VERSION = '0.12'; use Carp; our @CARP_NOT = qw( Net::Async::IRC ); =head1 NAME C - encapsulates a single IRC message =head1 SYNOPSIS use Protocol::IRC::Message; my $hello = Protocol::IRC::Message->new( "PRIVMSG", undef, "World", "Hello, world!" ); printf "The command is %s and the final argument is %s\n", $hello->command, $hello->arg( -1 ); =head1 DESCRIPTION An object in this class represents a single IRC message, either received from or to be sent to the server. These objects are immutable once constructed, but provide a variety of methods to access the contained information. This class also understands IRCv3 message tags. =cut =head1 CONSTRUCTOR =cut =head2 new_from_line $message = Protocol::IRC::Message->new_from_line( $line ) Returns a new C object, constructed by parsing the given IRC line. Most typically used to create a new object to represent a message received from the server. =cut sub new_from_line { my $class = shift; my ( $line ) = @_; my %tags; if( $line =~ s/^\@([^ ]+) +// ) { foreach ( split m/;/, $1 ) { if( m/^([^=]+)=(.*)$/ ) { $tags{$1} = $2; } else { $tags{$_} = undef; } } } my $prefix; if( $line =~ s/^:([^ ]+) +// ) { $prefix = $1; } my ( $mid, $final ) = split( m/ +:/, $line, 2 ); my @args = split( m/ +/, $mid ); push @args, $final if defined $final; my $command = shift @args; return $class->new_with_tags( $command, \%tags, $prefix, @args ); } =head2 new $message = Protocol::IRC::Message->new( $command, $prefix, @args ) Returns a new C object, intialised from the given components. Most typically used to create a new object to send to the server using C. The message will contain no IRCv3 tags. =cut sub new { my $class = shift; return $class->new_with_tags( $_[0], {}, $_[1], @_[2..$#_] ); } =head2 new_from_named_args $message = Protocol::IRC::Message->new_from_named_args( $command, %args ) Returns a new C object, initialised from the given named argmuents. The argument names must match those required by the given command. =cut sub new_from_named_args { my $class = shift; my ( $command, %args ) = @_; my $argnames = $class->arg_names( $command ); my @args; foreach my $name ( keys %$argnames ) { my $idx = $argnames->{$name}; # Clients don't get to set prefix nick # TODO: servers do next if $idx eq "pn"; defined( my $value = $args{$name} ) or croak "$command requires a named argmuent of '$name'"; if( $idx =~ m/^\d+$/ ) { $args[$idx] = $args{$name}; } else { die "TODO: not sure what to do with argname idx $idx\n"; } } return $class->new( $command, undef, @args ); } =head2 new_with_tags $mesage = Protocol::IRC::Message->new_with_tags( $command, \%tags, $prefix, @args ) Returns a new C object, as with C but also containing the given IRCv3 tags. =cut sub new_with_tags { my $class = shift; my ( $command, $tags, $prefix, @args ) = @_; # IRC is case-insensitive for commands, but we'd like them in uppercase # to keep things simpler $command = uc $command; # Less strict checking than RFC 2812 because a lot of servers lately seem # to be more flexible than that. $command =~ m/^[A-Z]+$/ or $command =~ m/^\d\d\d$/ or croak "Command must be just letters or three digits"; foreach my $key ( keys %$tags ) { $key =~ m{^[a-zA-Z0-9./-]+$} or croak "Tag key '$key' is invalid"; my $value = $tags->{$key}; defined $value and $value =~ m{[ ;]} and croak "Tag value '$value' for key '$key' is invalid"; } if( defined $prefix ) { $prefix =~ m/[ \t\x0d\x0a]/ and croak "Prefix must not contain whitespace"; } foreach ( @args[0 .. $#args-1] ) { # Not the final defined or croak "Argument must be defined"; m/[ \t\x0d\x0a]/ and croak "Argument must not contain whitespace"; } if( @args ) { defined $args[-1] or croak "Final argument must be defined"; $args[-1] =~ m/[\x0d\x0a]/ and croak "Final argument must not contain a linefeed"; } my $self = { command => $command, prefix => $prefix, args => \@args, tags => { %$tags }, }; return bless $self, $class; } =head1 METHODS =cut =head2 STRING $str = $message->STRING $str = "$message" Returns a string representing the message, suitable for use in a debugging message or similar. I: This is not the same as the IRC wire form, to send to the IRC server; for that see C. =cut use overload '""' => "STRING"; sub STRING { my $self = shift; my $class = ref $self; return $class . "[" . ( defined $self->{prefix} ? "prefix=$self->{prefix}," : "" ) . "cmd=$self->{command}," . "args=(" . join( ",", @{ $self->{args} } ) . ")]"; } =head2 command $command = $message->command Returns the command name or numeric stored in the message object. =cut sub command { my $self = shift; return $self->{command}; } =head2 command_name $name = $message->command_name For named commands, returns the command name directly. For server numeric replies, returns the name of the numeric. =cut my %NUMERIC_NAMES; sub command_name { my $self = shift; return $NUMERIC_NAMES{ $self->command } || $self->command; } =head2 tags $tags = $message->tags Returns a HASH reference containing IRCv3 message tags. This is a reference to the hash stored directly by the object itself, so the caller should be careful not to modify it. =cut sub tags { my $self = shift; return $self->{tags} } =head2 prefix $prefix = $message->prefix Returns the line prefix stored in the object, or the empty string if one was not supplied. =cut sub prefix { my $self = shift; return defined $self->{prefix} ? $self->{prefix} : ""; } =head2 prefix_split ( $nick, $ident, $host ) = $message->prefix_split Splits the prefix into its nick, ident and host components. If the prefix contains only a hostname (such as the server name), the first two components will be returned as C. =cut sub prefix_split { my $self = shift; my $prefix = $self->prefix; return ( $1, $2, $3 ) if $prefix =~ m/^(.*?)!(.*?)@(.*)$/; # $prefix doesn't split into nick!ident@host so presume host only return ( undef, undef, $prefix ); } =head2 arg $arg = $message->arg( $index ) Returns the argument at the given index. Uses normal perl array indexing, so negative indices work as expected. =cut sub arg { my $self = shift; my ( $index ) = @_; return $self->{args}[$index]; } =head2 args @args = $message->args Returns a list containing all the message arguments. =cut sub args { my $self = shift; return @{$self->{args}}; } =head2 stream_to_line $line = $message->stream_to_line Returns a string suitable for sending the message to the IRC server. =cut sub stream_to_line { my $self = shift; my $line = ""; if( keys %{ $self->{tags} } ) { my $tags = $self->{tags}; $line .= "\@" . join( ";", map { defined $tags->{$_} ? "$_=$tags->{$_}" : $_ } keys %$tags ) . " "; } if( defined $self->{prefix} ) { $line .= ":$self->{prefix} "; } $line .= $self->{command}; foreach ( @{$self->{args}} ) { if( m/ / or m/^:/ ) { $line .= " :$_"; } else { $line .= " $_"; } } return $line; } # Argument naming information # This hash holds HASH refs giving the names of the positional arguments of # any message. The hash keys store the argument names, and the values store # an argument index, the string "pn" meaning prefix nick, or "$n~$m" meaning # an index range. Endpoint can be absent. my %ARG_NAMES = ( INVITE => { inviter_nick => "pn", invited_nick => 0, target_name => 1 }, KICK => { kicker_nick => "pn", target_name => 0, kicked_nick => 1, text => 2 }, MODE => { target_name => 0, modechars => 1, modeargs => "2.." }, NICK => { old_nick => "pn", new_nick => 0 }, NOTICE => { targets => 0, text => 1 }, PING => { text => 0 }, PONG => { text => 0 }, QUIT => { text => 0 }, PART => { target_name => 0, text => 1 }, PRIVMSG => { targets => 0, text => 1 }, TOPIC => { target_name => 0, text => 1 }, ); # Misc. named commands $ARG_NAMES{$_} = { target_name => 0 } for qw( LIST NAMES WHO WHOIS WHOWAS ); # TODO: 472 ERR_UNKNOWNMODE: :is unknown mode char to me for # How to parse this one?? =head2 arg_names $names = $message->arg_names Returns a HASH reference giving details on how to parse named arguments for the command given in this message. This will be a hash whose keys give the names of the arguments, and the values of these keys indicate how that argument is derived from the simple positional arguments. Normally this method is only called internally by the C method, but is documented here for the benefit of completeness, and in case extension modules wish to define parsing of new message types. Each value should be one of the following: =over 4 =item * String literal C The value is a string, the nickname given in the message prefix =item * NUMBER..NUMBER The value is an ARRAY ref, containing a list of all the numbered arguments between the (inclusive) given limits. Either or both limits may be negative; they will count backwards from the end. =item * NUMBER The value is the argument at that numeric index. May be negative to count backwards from the end. =item * NUMBER@ The value is the argument at that numeric index as for C, except that the result will be split on spaces and stored in an ARRAY ref. =back =head2 arg_names (class method) $names = Protocol::IRC::Message->arg_names( $command ) This method may also be invoked as a class method by passing in the command name or numeric. This allows inspection of what arguments would be required or returned before a message object itself is constructed. =cut sub arg_names { my $command; if( ref $_[0] ) { my $self = shift; $command = $self->{command}; } else { my $class = shift; # ignore ( $command ) = @_; defined $command or croak 'Usage: '.__PACKAGE__.'->arg_names($command)'; } return $ARG_NAMES{$command}; } =head2 named_args $args = $message->named_args Parses arguments in the message according to the specification given by the C method. Returns a hash of parsed arguments. TODO: More complete documentation on the exact arg names/values per message type. =cut sub named_args { my $self = shift; my $argnames = $self->arg_names or return; my %named_args; foreach my $name ( keys %$argnames ) { my $argindex = $argnames->{$name}; my $value; if( $argindex eq "pn" ) { ( $value, undef, undef ) = $self->prefix_split; } elsif( $argindex =~ m/^(-?\d+)?\.\.(-?\d+)?$/ ) { my ( $start, $end ) = ( $1, $2 ); my @args = $self->args; defined $start or $start = 0; defined $end or $end = $#args; $end += @args if $end < 0; $value = [ splice( @args, $start, $end-$start+1 ) ]; } elsif( $argindex =~ m/^-?\d+$/ ) { $value = $self->arg( $argindex ); } elsif( $argindex =~ m/^(-?\d+)\@$/ ) { $value = [ split ' ', $self->arg( $1 ) ]; } else { die "Unrecognised argument specification $argindex"; } $named_args{$name} = $value; } return \%named_args; } =head2 gate_disposition $disp = $message->gate_disposition Returns the "gating disposition" of the message. This defines how a reply message from the server combines with other messages in response of a command sent by the client. The disposition is either C, or a string consisting of a type symbol and a gate name. If defined, the symbol defines what effect it has on the gate name. =over 4 =item -GATE Adds more information to the response for that gate, but doesn't yet complete it. =item +GATE Completes the gate with a successful result. =item *GATE Completes the gate with a successful result, but only if the nick in the message prefix relates to the connection it is received on. =item !GATE Completes the gate with a failure result. =back =cut my %GATE_DISPOSITIONS; sub gate_disposition { my $self = shift; return $GATE_DISPOSITIONS{ $self->command }; } =head1 AUTHOR Paul Evans =cut local $_; while( ) { chomp; m/^\s*#/ and next; # ignore comments my ( $cmdname, $args, $gating ) = split m/\s*\|\s*/, $_ or next; my ( $cmd, $name ) = split m/=/, $cmdname; my $index = 0; my %args = map { if( m/^(.*)=(.*)$/ ) { $index = $1; ( $2 => $1 ) } else { ( $_ => ++$index ); } } split m/,/, $args; $NUMERIC_NAMES{$cmd} = $name; $ARG_NAMES{$cmd} = \%args; $GATE_DISPOSITIONS{$cmd} = $gating if defined $gating; } close DATA; 0x55AA; # And now the actual numeric definitions, given in columns # number=NAME | argname,argname,argname # arg may be position=argname # See also # http://www.alien.net.au/irc/irc2numerics.html __DATA__ JOIN | 0=target_name | *join 001=RPL_WELCOME | text 002=RPL_YOURHOST | text 003=RPL_CREATED | text 004=RPL_MYINFO | serverhost,serverversion,usermodes,channelmodes 005=RPL_ISUPPORT | 1..-2=isupport,-1=text 250=RPL_STATSCONN | text 251=RPL_LUSERCLIENT | text 252=RPL_LUSEROP | count,text 253=RPL_LUSERUNKNOWN | count,text 254=RPL_LUSERCHANNELS | count,text 255=RPL_LUSERME | text 265=RPL_LOCALUSERS | count,max_count,text 266=RPL_GLOBALUSERS | count,max_count,text 301=RPL_AWAY | target_name,text 305=RPL_UNAWAY | text 306=RPL_NOWAWAY | text 307=RPL_USERIP | target_name 311=RPL_WHOISUSER | target_name,ident,host,flags,realname | -whois 312=RPL_WHOISSERVER | target_name,server,serverinfo | -whois 313=RPL_WHOISOPERATOR | target_name,text | -whois 315=RPL_ENDOFWHO | target_name | +who 314=RPL_WHOWASUSER | target_name,ident,host,flags,realname 317=RPL_WHOISIDLE | target_name,idle_time | -whois 318=RPL_ENDOFWHOIS | target_name | +whois 319=RPL_WHOISCHANNELS | target_name,2@=channels | -whois 320=RPL_WHOISSPECIAL | target_name | -whois 324=RPL_CHANNELMODEIS | target_name,modechars,3..=modeargs 328=RPL_CHANNEL_URL | target_name,text 329=RPL_CHANNELCREATED | target_name,timestamp 330=RPL_WHOISACCOUNT | target_name,whois_nick,login_name | -whois 331=RPL_NOTOPIC | target_name 332=RPL_TOPIC | target_name,text 333=RPL_TOPICWHOTIME | target_name,topic_nick,timestamp 341=RPL_INVITING | target_name,channel_name 346=RPL_INVITELIST | target_name,invite_mask 347=RPL_ENDOFINVITELIST | target_name 348=RPL_EXCEPTLIST | target_name,except_mask 349=RPL_ENDOFEXCEPTLIST | target_name 352=RPL_WHOREPLY | target_name,user_ident,user_host,user_server,user_nick,user_flags,text | -who 353=RPL_NAMEREPLY | 2=target_name,3@=names | -names 366=RPL_ENDOFNAMES | target_name | +names 367=RPL_BANLIST | target_name,mask,by_nick,timestamp | -bans 368=RPL_ENDOFBANLIST | target_name | +bans 369=RPL_ENDOFWHOWAS | target_name 372=RPL_MOTD | text | -motd 375=RPL_MOTDSTART | text | -motd 376=RPL_ENDOFMOTD | | +motd 378=RPL_WHOISHOST | target_name,text | -whois 401=ERR_NOSUCHNICK | target_name,text 402=ERR_NOSUCHSERVER | server_name,text 403=ERR_NOSUCHCHANNEL | target_name,text | !join 404=ERR_CANNOTSENDTOCHAN | target_name,text 405=ERR_TOOMANYCHANNELS | target_name,text 406=ERR_WASNOSUCHNICK | target_name,text 408=ERR_NOSUCHSERVICE | target_name,text 432=ERR_ERRONEUSNICKNAME | nick,text 433=ERR_NICKNAMEINUSE | nick,text 436=ERR_NICKCOLLISION | nick,text 441=ERR_USERNOTINCHANNEL | user_nick,target_name,text 442=ERR_NOTONCHANNEL | target_name,text 443=ERR_USERONCHANNEL | user_nick,target_name,text 444=ERR_NOLOGIN | target_name,text 467=ERR_KEYSET | target_name,text 471=ERR_CHANNELISFULL | target_name,text | !join 473=ERR_INVITEONLYCHAN | target_name,text | !join 474=ERR_BANNEDFROMCHAN | target_name,text | !join 475=ERR_BADCHANNELKEY | target_name,text | !join 476=ERR_BADCHANMASK | target_name,text | !join 477=ERR_NEEDREGGEDNICK | target_name,text 478=ERR_BANLISTFULL | target_name,text 482=ERR_CHANOPRIVSNEEDED | target_name,text # WATCH related - see # http://archives.darenet.org/irc/misc/irc-docs-master/misc/irc-documentation-jilles/reference/draft-meglio-irc-watch-00.txt 598=RPL_GONEAWAY | target_name,ident,host,timestamp,text 599=RPL_NOTAWAY | target_name,ident,host,timestamp,text 600=RPL_LOGON | target_name,ident,host,timestamp,text 601=RPL_LOGOFF | target_name,ident,host,timestamp,text 602=RPL_WATCHOFF | target_name,ident,host,timestamp,text 603=RPL_WATCHSTAT | text 604=RPL_NOWON | target_name,ident,host,timestamp,text 605=RPL_NOWOFF | target_name,ident,host,timestamp,text 606=RPL_WATCHLIST | 1@=nicks 607=RPL_ENDOFWATCHLIST | text 609=RPL_NOWISAWAY | target_name,ident,host,timestamp,text 671=RPL_WHOISSECURE | target_name,text | -whois Protocol-IRC-0.12/t000755001750001750 013056415115 12635 5ustar00leoleo000000000000Protocol-IRC-0.12/t/00use.t000444001750001750 25613056415115 14076 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use_ok( "Protocol::IRC" ); use_ok( "Protocol::IRC::Client" ); use_ok( "Protocol::IRC::Message" ); done_testing; Protocol-IRC-0.12/t/01message.t000444001750001750 1101713056415115 14764 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Protocol::IRC::Message; sub test_line { my $testname = shift; my $line = shift; my %asserts = @_; my $msg = Protocol::IRC::Message->new_from_line( $line ); exists $asserts{command} and is( $msg->command, $asserts{command}, "$testname command" ); exists $asserts{prefix} and is( $msg->prefix, $asserts{prefix}, "$testname prefix" ); exists $asserts{args} and is_deeply( [ $msg->args ], $asserts{args}, "$testname args" ); exists $asserts{stream} and is( $msg->stream_to_line, $asserts{stream}, "$testname restream" ); exists $asserts{tags} and is_deeply( $msg->tags, $asserts{tags}, "$testname tags" ); } my $msg = Protocol::IRC::Message->new( "command", "prefix", "arg1", "arg2" ); ok( defined $msg, 'defined $msg' ); isa_ok( $msg, "Protocol::IRC::Message", '$msg isa Protocol::IRC::Message' ); is( $msg->command, "COMMAND", '$msg->command' ); is( $msg->prefix, "prefix", '$msg->prefix' ); is( $msg->arg(0), "arg1", '$msg->arg(0)' ); is( $msg->arg(1), "arg2", '$msg->arg(1)' ); is_deeply( [ $msg->args ], [qw( arg1 arg2 )], '$msg->args' ); is( $msg->stream_to_line, ":prefix COMMAND arg1 arg2", '$msg->stream_to_line' ); $msg = Protocol::IRC::Message->new( "001", undef, ":Welcome to IRC User!ident\@host" ); is( $msg->command, "001", '$msg->command for 001' ); is( $msg->command_name, "RPL_WELCOME", '$msg->command_name for 001' ); $msg = Protocol::IRC::Message->new_with_tags( "PRIVMSG", { intent => "ACTION" }, undef, "#example", "throws a rock" ); is_deeply( $msg->tags, { intent => "ACTION" }, '$msg->tags' ); is( $msg->stream_to_line, "\@intent=ACTION PRIVMSG #example :throws a rock" ); test_line "Basic", "COMMAND", command => "COMMAND", prefix => "", args => [], stream => "COMMAND"; test_line "Prefixed", ":someprefix COMMAND", command => "COMMAND", prefix => "someprefix", args => [], stream => ":someprefix COMMAND"; test_line "With one arg", "JOIN #channel", command => "JOIN", prefix => "", args => [ "#channel" ], stream => "JOIN #channel"; test_line "With one arg as :final", "WHOIS :Someone", command => "WHOIS", prefix => "", args => [ "Someone" ], stream => "WHOIS Someone"; test_line "With two args", "JOIN #foo somekey", command => "JOIN", prefix => "", args => [ "#foo", "somekey" ], stream => "JOIN #foo somekey"; test_line "With long final", "MESSAGE :Here is a long message to say", command => "MESSAGE", prefix => "", args => [ "Here is a long message to say" ], stream => "MESSAGE :Here is a long message to say"; test_line "With :final", "MESSAGE ::final", command => "MESSAGE", prefix => "", args => [ ":final" ], stream => "MESSAGE ::final"; test_line "With \@tags", "\@intent=ACTION;znc.in/extension=value;foo PRIVMSG #example :throws a rock", command => "PRIVMSG", prefix => "", args => [ "#example", "throws a rock" ], tags => { intent => "ACTION", 'znc.in/extension' => "value", foo => undef, }; like( exception { Protocol::IRC::Message->new( "some command" ) }, qr/^Command must be just letters or three digits/, 'Command with spaces fails' ); like( exception { Protocol::IRC::Message->new( "cmd", "prefix with spaces" ) }, qr/^Prefix must not contain whitespace/, 'Command with spaces fails' ); like( exception { Protocol::IRC::Message->new( "cmd", undef, "foo\x0d\x{0d}bar" ) }, qr/^Final argument must not contain a linefeed/, 'Final with linefeed fails' ); like( exception { Protocol::IRC::Message->new( "cmd", undef, undef ) }, qr/^Final argument must be defined/, 'Final undef fails' ); like( exception { Protocol::IRC::Message->new( "cmd", undef, "foo bar", "splot wibble" ) }, qr/^Argument must not contain whitespace/, 'Argument with whitespace fails' ); like( exception { Protocol::IRC::Message->new( "cmd", undef, undef, "last" ) }, qr/^Argument must be defined/, 'Argument undef fails' ); like( exception { Protocol::IRC::Message->new_with_tags( "command", { 'invalid_key' => 1 }, undef ) }, qr/^Tag key 'invalid_key' is invalid/, 'attempt to add invalid key fails'); like( exception { Protocol::IRC::Message->new_with_tags( "command", { 'valid-key' => 'invalid;value' }, undef ) }, qr/^Tag value 'invalid;value' for key 'valid-key' is invalid/, 'attempt to add key with invalid value fails'); done_testing; Protocol-IRC-0.12/t/02message-splitprefix.t000444001750001750 123013056415115 17310 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Protocol::IRC::Message; sub test_prefix { my $testname = shift; my $line = shift; my ( $expect ) = @_; my $msg = Protocol::IRC::Message->new_from_line( $line ); is_deeply( [ $msg->prefix_split ], $expect, "prefix_split for $testname" ); } test_prefix "simple", ':nick!user@host COMMAND', [ "nick", "user", "host" ]; test_prefix "fully qualified host", ':nick!user@fully.qualified.host COMMAND', [ "nick", "user", "fully.qualified.host" ]; test_prefix "servername", ':irc.example.com NOTICE YourNick :Hello', [ undef, undef, "irc.example.com" ]; done_testing; Protocol-IRC-0.12/t/03message-argnames.t000444001750001750 421113056415115 16537 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Protocol::IRC::Message; sub test_argnames { my $testname = shift; my $line = shift; my %asserts = @_; my $msg = Protocol::IRC::Message->new_from_line( $line ); exists $asserts{names} and is_deeply( $msg->arg_names, $asserts{names}, "$testname arg_names" ); exists $asserts{args} and is_deeply( $msg->named_args, $asserts{args}, "$testname named_args" ); } test_argnames "PING", ":server PING 1234", names => { text => 0 }, args => { text => "1234" }; test_argnames "PRIVMSG", ":TheirNick!user\@server PRIVMSG YourNick :A message", names => { targets => 0, text => 1 }, args => { targets => "YourNick", text => "A message" }; test_argnames "MODE", ":TheirNick!user\@server MODE #somechannel +oo Some Friends", names => { target_name => 0, modechars => "1", modeargs => "2.." }, args => { target_name => "#somechannel", modechars => "+oo", modeargs => [ "Some", "Friends" ] }; test_argnames "PART", ":TheirNick!user\@server PART #somechannel :A leaving message", names => { target_name => 0, text => 1 }, args => { target_name => "#somechannel", text => "A leaving message" }; test_argnames "005", ":server 005 YourNick RED=red BLUE=blue :are supported by this server", names => { isupport => "1..-2", text => -1 }, args => { isupport => [qw( RED=red BLUE=blue )], text => "are supported by this server" }; test_argnames "324", ":server 324 YourNick #somechannel +ntl 300", names => { target_name => 1, modechars => "2", modeargs => "3.." }, args => { target_name => "#somechannel", modechars => "+ntl", modeargs => [ "300" ] }; test_argnames "319", ":server 319 YourNick Someone :#foo #bar #splot #wibble", args => { target_name => 'Someone', channels => ['#foo', '#bar', '#splot', '#wibble'] }; { my $msg = Protocol::IRC::Message->new_from_line( ":server 372 YourNick :- message here -" ); is( $msg->gate_disposition, "-motd", '372 gate_disposition' ); } is_deeply( Protocol::IRC::Message->arg_names( "PING" ), { text => 0 }, 'Protocol::IRC::Message->arg_names as a class method' ); done_testing; Protocol-IRC-0.12/t/04message-from-named.t000444001750001750 116213056415115 16772 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Protocol::IRC::Message; sub test_named { my ( $command, $args, $line ) = @_; my $message = Protocol::IRC::Message->new_from_named_args( $command, %$args ); is( $message->stream_to_line, $line, "\$message->line for $command" ); } test_named PING => { text => "123" }, "PING 123"; test_named PRIVMSG => { text => "the message", targets => "#channel" }, "PRIVMSG #channel :the message"; test_named KICK => { text => "go away", target_name => "#channel", kicked_nick => "BadUser" }, "KICK #channel BadUser :go away"; done_testing; Protocol-IRC-0.12/t/10protocol-sendrecv.t000444001750001750 316513056415115 16775 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal qw( lives_ok ); my $CRLF = "\x0d\x0a"; # because \r\n isn't portable my $written = ""; my @messages; my $foo_received; my $irc = TestIRC->new; $irc->send_message( "USER", undef, "me", "0", "*", "My real name" ); is( $written, "USER me 0 * :My real name$CRLF", 'Written stream after ->send_message' ); my $buffer = ':irc.example.com 001 YourNameHere :Welcome to IRC YourNameHere!me@your.host' . $CRLF; $irc->on_read( $buffer ); is( length $buffer, 0, '->on_read consumes the entire line' ); is( scalar @messages, 1, 'Received 1 message after server reply' ); my $msg = shift @messages; isa_ok( $msg, "Protocol::IRC::Message", '$msg isa Protocol::IRC::Message' ); is( $msg->command, "001", '$msg->command' ); is( $msg->prefix, "irc.example.com", '$msg->prefix' ); is_deeply( [ $msg->args ], [ "YourNameHere", "Welcome to IRC YourNameHere!me\@your.host" ], '$msg->args' ); $buffer = ":irc.example.com FOO$CRLF"; $irc->on_read( $buffer ); ok( $foo_received, '$foo_received after FOO message' ); $buffer = "$CRLF$CRLF"; lives_ok { $irc->on_read( $buffer ) } 'Blank lines does not die'; is( length $buffer, 0, 'Blank lines still eat all buffer' ); done_testing; package TestIRC; use base qw( Protocol::IRC ); sub new { return bless [], shift } sub write { $written .= $_[1] } sub on_message { return if $_[3]->{handled}; Test::More::is( $_[1], $_[2]->command_name, '$command is $message->command_name' ); push @messages, $_[2]; return 1; } sub on_message_FOO { $foo_received++ } sub isupport { return "ascii" if $_[1] eq "CASEMAPPING"; } Protocol-IRC-0.12/t/11protocol-isupport.t000444001750001750 562113056415115 17051 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; my $irc = TestIRC->new; my %isupport = ( MAXCHANNELS => "10", NICKLEN => "30", PREFIX => "(ohv)@%+", prefix_modes => 'ohv', prefix_flags => '@%+', prefix_map_m2f => { 'o' => '@', 'h' => '%', 'v' => '+' }, prefix_map_f2m => { '@' => 'o', '%' => 'h', '+' => 'v' }, CASEMAPPING => "rfc1459", CHANMODES => "beI,k,l,imnpsta", chanmodes_list => [qw( beI k l imnpsta )], CHANTYPES => "#&", channame_re => qr/^[#&]/, ); is( $irc->isupport( "MAXCHANNELS" ), "10", 'ISUPPORT MAXCHANNELS is 10' ); is( $irc->isupport( "PREFIX" ), "(ohv)\@\%+", 'ISUPPORT PREFIX is (ohv)@%+' ); is( $irc->isupport( "CHANMODES" ), "beI,k,l,imnpsta", 'ISUPPORT CHANMODES is beI,k,l,imnpsta' ); is( $irc->isupport( "CHANTYPES" ), "#&", 'ISUPPORT CHANTYPES is #&' ); # Now the generated ones from PREFIX is( $irc->isupport( "prefix_modes" ), "ohv", 'ISUPPORT PREFIX_MODES is ohv' ); is( $irc->isupport( "prefix_flags" ), "\@\%+", 'ISUPPORT PREFIX_FLAGS is @%+' ); is( $irc->prefix_mode2flag( "o" ), "\@", 'prefix_mode2flag o -> @' ); is( $irc->prefix_flag2mode( "\@" ), "o", 'prefix_flag2mode @ -> o' ); is( $irc->cmp_prefix_flags( "\@", "\%" ), 1, 'cmp_prefix_flags @ % -> 1' ); is( $irc->cmp_prefix_flags( "\%", "\@" ), -1, 'cmp_prefix_flags % @ -> -1' ); is( $irc->cmp_prefix_flags( "\%", "\%" ), 0, 'cmp_prefix_flags % % -> 0' ); is( $irc->cmp_prefix_flags( "\%", "\$" ), undef, 'cmp_prefix_flags % $ -> undef' ); is( $irc->cmp_prefix_modes( "o", "h" ), 1, 'cmp_prefix_modes o h -> 1' ); is( $irc->cmp_prefix_modes( "h", "o" ), -1, 'cmp_prefix_modes h o -> -1' ); is( $irc->cmp_prefix_modes( "h", "h" ), 0, 'cmp_prefix_modes h h -> 0' ); is( $irc->cmp_prefix_modes( "h", "b" ), undef, 'cmp_prefix_modes h b -> undef' ); is( $irc->casefold_name( "NAME" ), "name", 'casefold_name NAME' ); is( $irc->casefold_name( "FOO[AWAY]" ), "foo{away}", 'casefold_name FOO[AWAY]' ); is( $irc->casefold_name( "user^name" ), "user~name", 'casefold_name user^name' ); is( $irc->classify_name( "UserName" ), "user", 'classify_name UserName' ); is( $irc->classify_name( "#somewhere" ), "channel", 'classify_name #somewhere' ); { local $isupport{CASEMAPPING} = "strict-rfc1459"; is( $irc->casefold_name( "FOO[AWAY]" ), "foo{away}", 'casefold_name FOO[AWAY] under strict' ); is( $irc->casefold_name( "user^name" ), "user^name", 'casefold_name user^name under strict' ); local $isupport{CASEMAPPING} = "ascii"; is( $irc->casefold_name( "FOO[AWAY]" ), "foo[away]", 'casefold_name FOO[AWAY] under ascii' ); } # Now the generated ones from CHANMODES is_deeply( $irc->isupport( "chanmodes_list" ), [qw( beI k l imnpsta )], 'ISUPPORT chanmodes_list is [qw( beI k l imnpsta )]' ); done_testing; package TestIRC; use base qw( Protocol::IRC ); sub new { return bless [], shift } sub isupport { return $isupport{$_[1]} } Protocol-IRC-0.12/t/12protocol-hints.t000444001750001750 1775313056415115 16343 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; my $CRLF = "\x0d\x0a"; # because \r\n isn't portable my @messages; my $irc = TestIRC->new; sub write_irc { my $line = $_[0]; $irc->on_read( $line ); length $line == 0 or die '$irc failed to read all of the line'; } # 001 { write_irc( ':irc.example.com 001 MyNick :Welcome to IRC MyNick!me@your.host' . $CRLF ); my $m = shift @messages; ok( defined $m, '$m defined after server reply' ); my ( $command, $msg, $hints ) = @$m; is( $command, "RPL_WELCOME", '$command' ); isa_ok( $msg, "Protocol::IRC::Message", '$msg isa Protocol::IRC::Message' ); is( $msg->command, "001", '$msg->command for 001' ); is( $msg->prefix, "irc.example.com", '$msg->prefix for 001' ); is_deeply( [ $msg->args ], [ "MyNick", "Welcome to IRC MyNick!me\@your.host" ], '$msg->args for 001' ); is_deeply( $hints, { prefix_nick => undef, prefix_nick_folded => undef, prefix_user => undef, prefix_host => "irc.example.com", prefix_name => "irc.example.com", prefix_name_folded => "irc.example.com", text => "Welcome to IRC MyNick!me\@your.host", handled => 1 }, '$hints for 001' ); } # PRIVMSG { write_irc( ':Someone!theiruser@their.host PRIVMSG MyNick :Their message here' . $CRLF ); my ( $command, $msg, $hints ) = @{ shift @messages }; is( $msg->command, "PRIVMSG", '$msg->command for PRIVMSG' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg->prefix for PRIVMSG' ); is_deeply( $hints, { prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', targets => "MyNick", text => "Their message here", handled => 1 }, '$hints for PRIVMSG' ); write_irc( ':MyNick!me@your.host PRIVMSG MyNick :Hello to me' . $CRLF ); ( $command, $msg, $hints ) = @{ shift @messages }; is( $msg->command, "PRIVMSG", '$msg->command for PRIVMSG to self' ); is( $msg->prefix, 'MyNick!me@your.host', '$msg->prefix for PRIVMSG to self' ); is_deeply( $hints, { prefix_nick => "MyNick", prefix_nick_folded => "mynick", prefix_user => "me", prefix_host => "your.host", prefix_name => "MyNick", prefix_name_folded => "mynick", prefix_is_me => 1, targets => "MyNick", text => "Hello to me", handled => 1 }, '$hints for PRIVMSG to self' ); } # TOPIC { write_irc( ':Someone!theiruser@their.host TOPIC #channel :Message of the day' . $CRLF ); my ( $command, $msg, $hints ) = @{ shift @messages }; is( $msg->command, "TOPIC", '$msg->command for TOPIC' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg->prefix for TOPIC' ); is_deeply( $hints, { prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', target_name => "#channel", target_name_folded => "#channel", target_is_me => '', target_type => "channel", text => "Message of the day", handled => 1 }, '$hints for TOPIC' ); } # NOTICE { write_irc( ':Someone!theiruser@their.host NOTICE #channel :Please ignore me' . $CRLF ); my ( $command, $msg, $hints ) = @{ shift @messages }; is( $msg->command, "NOTICE", '$msg->command for NOTICE' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg->prefix for NOTICE' ); is_deeply( $hints, { prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', targets => "#channel", text => "Please ignore me", handled => 0 }, '$hints for NOTICE' ); write_irc( ':Someone!theiruser@their.host NICK NewName' . $CRLF ); ( $command, $msg, $hints ) = @{ shift @messages }; is( $msg->command, "NICK", '$msg->command for NICK' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg->prefix for NICK' ); is_deeply( $hints, { prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', old_nick => "Someone", old_nick_folded => "someone", old_is_me => '', new_nick => "NewName", new_nick_folded => "newname", new_is_me => '', handled => 1 }, '$hints for NICK' ); } # KICK { write_irc( ':Someone!theiruser@their.host KICK #a-channel MyNick :Go away' . $CRLF ); my ( $command, $msg, $hints ) = @{ shift @messages }; is( $msg->command, "KICK", '$msg->command for KICK' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg->prefix for KICK' ); is_deeply( $hints, { prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', target_name => "#a-channel", target_name_folded => "#a-channel", target_is_me => '', target_type => "channel", kicker_nick => "Someone", kicker_nick_folded => "someone", kicker_is_me => '', kicked_nick => "MyNick", kicked_nick_folded => "mynick", kicked_is_me => 1, text => "Go away", handled => 1 }, '$hints for KICK' ); } done_testing; package TestIRC; use base qw( Protocol::IRC ); sub new { return bless [], shift } my %isupport; BEGIN { %isupport = ( CHANTYPES => "#&", channame_re => qr/^[#&]/, PREFIX => "(ohv)@%+", prefix_modes => 'ohv', prefix_flags => '@%+', prefixflag_re => qr/^[@%+]/, prefix_map_m2f => { 'o' => '@', 'h' => '%', 'v' => '+' }, prefix_map_f2m => { '@' => 'o', '%' => 'h', '+' => 'v' }, ); } sub isupport { return $isupport{$_[1]} } sub nick { return "MyNick" } sub on_message { my $self = shift; my ( $command, $message, $hints ) = @_; # Only care about real events, not synthesized ones return 0 if $hints->{synthesized}; # Ignore numerics return 0 if $command =~ m/^\d\d\d$/; push @messages, [ $command, $message, $hints ]; return $command ne "NOTICE"; } Protocol-IRC-0.12/t/13protocol-text.t000444001750001750 3264113056415115 16174 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; my $CRLF = "\x0d\x0a"; # because \r\n isn't portable # We don't care what order we get these messages in, and we know we'll only # get one of each type at once. Hash them my %messages; my $serverstream; my $irc = TestIRC->new; sub write_irc { my $line = $_[0]; $irc->on_read( $line ); length $line == 0 or die '$irc failed to read all of the line'; } write_irc( ':Someone!theiruser@their.host PRIVMSG MyNick :Their message here' . $CRLF ); is_deeply( [ sort keys %messages ], [qw( PRIVMSG text )], 'keys %messages for PRIVMSG' ); my ( $msg, $hints ); ( $msg, $hints ) = @{ $messages{PRIVMSG} }; is( $msg->command, "PRIVMSG", '$msg[PRIVMSG]->command for PRIVMSG' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg[PRIVMSG]->prefix for PRIVMSG' ); is_deeply( $hints, { prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', targets => "MyNick", text => "Their message here", handled => 1 }, '$hints[PRIVMSG] for PRIVMSG' ); ( $msg, $hints ) = @{ $messages{text} }; is( $msg->command, "PRIVMSG", '$msg[text]->command for PRIVMSG' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg[text]->prefix for PRIVMSG' ); is_deeply( $hints, { synthesized => 1, prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', target_name => "MyNick", target_name_folded => "mynick", target_is_me => 1, target_type => "user", is_notice => 0, text => "Their message here", handled => 1 }, '$hints[text] for PRIVMSG' ); undef %messages; write_irc( ':Someone!theiruser@their.host PRIVMSG #channel :Message to all' . $CRLF ); is_deeply( [ sort keys %messages ], [qw( PRIVMSG text )], 'keys %messages for PRIVMSG to channel' ); ( $msg, $hints ) = @{ $messages{PRIVMSG} }; is( $msg->command, "PRIVMSG", '$msg[PRIVMSG]->command for PRIVMSG to channel' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg[PRIVMSG]->prefix for PRIVMSG to channel' ); is_deeply( $hints, { prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', targets => "#channel", text => "Message to all", handled => 1 }, '$hints[PRIVMSG] for PRIVMSG to channel' ); ( $msg, $hints ) = @{ $messages{text} }; is( $msg->command, "PRIVMSG", '$msg[text]->command for PRIVMSG to channel' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg[text]->prefix for PRIVMSG to channel' ); is_deeply( $hints, { synthesized => 1, prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', target_name => "#channel", target_name_folded => "#channel", target_is_me => '', target_type => "channel", is_notice => 0, restriction => '', text => "Message to all", handled => 1 }, '$hints[text] for PRIVMSG to channel' ); undef %messages; write_irc( ':Someone!theiruser@their.host NOTICE #channel :Is anyone listening?' . $CRLF ); is_deeply( [ sort keys %messages ], [qw( NOTICE text )], 'keys %messages for NOTICE to channel' ); ( $msg, $hints ) = @{ $messages{NOTICE} }; is( $msg->command, "NOTICE", '$msg[NOTICE]->command for NOTICE to channel' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg[NOTICE]->prefix for NOTICE to channel' ); is_deeply( $hints, { prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', targets => "#channel", text => "Is anyone listening?", handled => 1 }, '$hints[NOTICE] for NOTICE to channel' ); ( $msg, $hints ) = @{ $messages{text} }; is( $msg->command, "NOTICE", '$msg[text]->command for NOTICE to channel' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg[text]->prefix for NOTICE to channel' ); is_deeply( $hints, { synthesized => 1, prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', target_name => "#channel", target_name_folded => "#channel", target_is_me => '', target_type => "channel", is_notice => 1, restriction => '', text => "Is anyone listening?", handled => 1 }, '$hints[text] for NOTICE to channel' ); undef %messages; write_irc( ':Someone!theiruser@their.host PRIVMSG @#channel :To only the important people' . $CRLF ); is_deeply( [ sort keys %messages ], [qw( PRIVMSG text )], 'keys %messages for PRIVMSG to channel ops' ); ( $msg, $hints ) = @{ $messages{PRIVMSG} }; is( $msg->command, "PRIVMSG", '$msg[PRIVMSG]->command for PRIVMSG to channel ops' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg[PRIVMSG]->prefix for PRIVMSG to channel ops' ); is_deeply( $hints, { prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', targets => "@#channel", text => "To only the important people", handled => 1 }, '$hints[PRIVMSG] for PRIVMSG to channel ops' ); ( $msg, $hints ) = @{ $messages{text} }; is( $msg->command, "PRIVMSG", '$msg[text]->command for PRIVMSG to channel ops' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg[text]->prefix for PRIVMSG to channel ops' ); is_deeply( $hints, { synthesized => 1, prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', target_name => "#channel", target_name_folded => "#channel", target_is_me => '', target_type => "channel", is_notice => 0, restriction => '@', text => "To only the important people", handled => 1 }, '$hints[text] for PRIVMSG to channel ops' ); undef %messages; write_irc( ":Someone!theiruser\@their.host PRIVMSG MyNick :\001ACTION does something\001" . $CRLF ); is_deeply( [ sort keys %messages ], ["PRIVMSG", "ctcp ACTION"], 'keys %messages for CTCP ACTION' ); ( $msg, $hints ) = @{ $messages{PRIVMSG} }; is( $msg->command, "PRIVMSG", '$msg[PRIVMSG]->command for CTCP ACTION' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg[PRIVMSG]->prefix for CTCP ACTION' ); is_deeply( $hints, { prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', targets => "MyNick", text => "\001ACTION does something\001", handled => 1 }, '$hints[PRIVMSG] for CTCP ACTION' ); ( $msg, $hints ) = @{ $messages{"ctcp ACTION"} }; is( $msg->command, "PRIVMSG", '$msg[ctcp]->command for CTCP ACTION' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg[ctcp]->prefix for CTCP ACTION' ); is_deeply( $hints, { synthesized => 1, prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', target_name => "MyNick", target_name_folded => "mynick", target_is_me => 1, target_type => "user", is_notice => 0, text => "\001ACTION does something\001", ctcp_verb => "ACTION", ctcp_args => "does something", handled => 1 }, '$hints[ctcp] for CTCP ACTION' ); undef %messages; $serverstream = ""; $irc->send_ctcp( undef, "target", "ACTION", "replies" ); is( $serverstream, "PRIVMSG target :\001ACTION replies\001$CRLF", 'server stream after send_ctcp' ); write_irc( ":Someone!theiruser\@their.host NOTICE MyNick :\001VERSION foo/1.2.3\001" . $CRLF ); is_deeply( [ sort keys %messages ], ["NOTICE", "ctcpreply VERSION"], 'keys %messages for CTCPREPLY VERSION' ); ( $msg, $hints ) = @{ $messages{NOTICE} }; is( $msg->command, "NOTICE", '$msg[NOTICE]->command for CTCPREPLY VERSION' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg[NOTICE]->prefix for CTCPREPLY VERSION' ); is_deeply( $hints, { prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', targets => "MyNick", text => "\001VERSION foo/1.2.3\001", handled => 1 }, '$hints[NOTICE] for CTCPREPLY VERSION' ); ( $msg, $hints ) = @{ $messages{"ctcpreply VERSION"} }; is( $msg->command, "NOTICE", '$msg[ctcpreply]->command for CTCPREPLY VERSION' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg[ctcpreply]->prefix for CTCPREPLY VERSION' ); is_deeply( $hints, { synthesized => 1, prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', target_name => "MyNick", target_name_folded => "mynick", target_is_me => 1, target_type => "user", is_notice => 1, text => "\001VERSION foo/1.2.3\001", ctcp_verb => "VERSION", ctcp_args => "foo/1.2.3", handled => 1 }, '$hints[ctcpreply] for CTCPREPLY VERSION' ); undef %messages; $serverstream = ""; $irc->send_ctcpreply( undef, "target", "ACTION", "replies" ); is( $serverstream, "NOTICE target :\001ACTION replies\001$CRLF", 'server stream after send_ctcp' ); done_testing; package TestIRC; use base qw( Protocol::IRC ); sub new { return bless [], shift } sub write { $serverstream .= $_[1] } my %isupport; BEGIN { %isupport = ( CHANTYPES => "#&", channame_re => qr/^[#&]/, PREFIX => "(ohv)@%+", prefix_modes => 'ohv', prefix_flags => '@%+', prefixflag_re => qr/^[@%+]/, prefix_map_m2f => { 'o' => '@', 'h' => '%', 'v' => '+' }, prefix_map_f2m => { '@' => 'o', '%' => 'h', '+' => 'v' }, ); } sub isupport { return $isupport{$_[1]} } sub nick { return "MyNick" } sub on_message { my $self = shift; my ( $command, $message, $hints ) = @_; $messages{$command} = [ $message, $hints ]; return 1; } Protocol-IRC-0.12/t/14protocol-encoding.t000444001750001750 550713056415115 16760 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use utf8; use Test::More; use Encode qw( encode_utf8 ); my $CRLF = "\x0d\x0a"; # because \r\n isn't portable my @textmessages; my @quitmessages; my $serverstream; my $irc = TestIRC->new; sub write_irc { my $line = $_[0]; $irc->on_read( $line ); length $line == 0 or die '$irc failed to read all of the line'; } my $helloworld = "مرحبا العالم"; # Hello World in Arabic, according to Google translate my $octets = encode_utf8( $helloworld ); write_irc( ':Someone!theiruser@their.host PRIVMSG #arabic :' . $octets . $CRLF ); my ( $msg, $hints ) = @{ shift @textmessages }; is( $msg->command, "PRIVMSG", '$msg->command for PRIVMSG with encoding' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg->prefix for PRIVMSG with encoding' ); is_deeply( $hints, { synthesized => 1, prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', target_name => "#arabic", target_name_folded => "#arabic", target_is_me => '', target_type => "channel", is_notice => 0, restriction => '', text => "مرحبا العالم", handled => 1 }, '$hints for PRIVMSG with encoding' ); $serverstream = ""; $irc->send_message( "PRIVMSG", undef, "#arabic", "مرحبا العالم" ); is( $serverstream, "PRIVMSG #arabic :$octets$CRLF", "Server stream after sending PRIVMSG with encoding" ); write_irc( ':Someone!theiruser@their.host QUIT :' . $octets . $CRLF ); ( $msg, $hints ) = @{ shift @quitmessages }; is( $msg->command, "QUIT", '$msg->command for QUIT with encoding' ); is( $hints->{text}, "مرحبا العالم", '$hints->{text} for QUIT with encoding' ); done_testing; package TestIRC; use base qw( Protocol::IRC ); sub new { return bless [], shift } sub write { $serverstream .= $_[1] } use constant encoder => Encode::find_encoding("UTF-8"); my %isupport; BEGIN { %isupport = ( CHANTYPES => "#&", channame_re => qr/^[#&]/, PREFIX => "(ohv)@%+", prefix_modes => 'ohv', prefix_flags => '@%+', prefixflag_re => qr/^[@%+]/, prefix_map_m2f => { 'o' => '@', 'h' => '%', 'v' => '+' }, prefix_map_f2m => { '@' => 'o', '%' => 'h', '+' => 'v' }, ); } sub isupport { return $isupport{$_[1]} } sub nick { return "MyNick" } sub on_message_text { push @textmessages, [ $_[1], $_[2] ] } sub on_message_QUIT { push @quitmessages, [ $_[1], $_[2] ] } Protocol-IRC-0.12/t/20client.t000444001750001750 306713056415115 14605 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; my $CRLF = "\x0d\x0a"; # because \r\n isn't portable my @messages; my @written; my $irc = TestIRC->new; sub write_irc { my $line = $_[0]; $irc->on_read( $line ); length $line == 0 or die '$irc failed to read all of the line'; } ok( defined $irc, 'defined $irc' ); # receiving { write_irc( ':irc.example.com COMMAND arg1 arg2 :here is arg3' . $CRLF ); my ( $command, $msg, $hints ); ( $command, $msg, $hints ) = @{ shift @messages }; is( $command, "COMMAND", '$command' ); is( $msg->command, "COMMAND", '$msg->command' ); is_deeply( [ $msg->args ], [ 'arg1', 'arg2', 'here is arg3' ], '$msg->args' ); } # sending { $irc->send_message( Protocol::IRC::Message->new( CMDA => ) ); is( shift @written, "CMDA", '->send_message( P:I::Message )' ); $irc->send_message( PING => { text => "12345" } ); is( shift @written, "PING 12345", '->send_message( $command, { %namedargs } )' ); $irc->send_message( CMDB => undef ); is( shift @written, "CMDB", '->send_message( $command, $prefix, @args )' ); # Name mangling $irc->send_message( JOIN => { target => "#channel" } ); is( shift @written, "JOIN #channel", 'target to target_name mangling' ); } done_testing; package TestIRC; use base qw( Protocol::IRC::Client ); sub new { return bless {}, shift } sub nick { return "MyNick" } sub on_message { my $self = shift; my ( $command, $message, $hints ) = @_; push @messages, [ $command, $message, $hints ]; } sub write { $_[1] =~ s/\x0d\x0a$//; push @written, $_[1] } Protocol-IRC-0.12/t/21client-isupport.t000444001750001750 303113056415115 16460 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; my $CRLF = "\x0d\x0a"; # because \r\n isn't portable my $irc = TestIRC->new; sub write_irc { my $line = $_[0]; $irc->on_read( $line ); length $line == 0 or die '$irc failed to read all of the line'; } write_irc( ":server 004 YourNick irc.example.com TestIRC iow lvhopsmntikr$CRLF" ); write_irc( ':server 005 YourNick MAXCHANNELS=10 NICKLEN=30 PREFIX=(ohv)@%+ CASEMAPPING=rfc1459 CHANMODES=beI,k,l,imnpsta CHANTYPES=#& :are supported by this server' . $CRLF ); is( $irc->server_info( "channelmodes" ), "lvhopsmntikr", 'server_info channelmodes' ); is( $irc->isupport( "MAXCHANNELS" ), "10", 'ISUPPORT MAXCHANNELS is 10' ); is( $irc->isupport( "PREFIX" ), "(ohv)\@\%+", 'ISUPPORT PREFIX is (ohv)@%+' ); is( $irc->isupport( "CHANMODES" ), "beI,k,l,imnpsta", 'ISUPPORT CHANMODES is beI,k,l,imnpsta' ); is( $irc->isupport( "CHANTYPES" ), "#&", 'ISUPPORT CHANTYPES is #&' ); # Now the generated ones from PREFIX is( $irc->isupport( "prefix_modes" ), "ohv", 'ISUPPORT PREFIX_MODES is ohv' ); is( $irc->isupport( "prefix_flags" ), "\@\%+", 'ISUPPORT PREFIX_FLAGS is @%+' ); is( $irc->prefix_mode2flag( "o" ), "\@", 'prefix_mode2flag o -> @' ); is( $irc->prefix_flag2mode( "\@" ), "o", 'prefix_flag2mode @ -> o' ); # Now the generated ones from CHANMODES is_deeply( $irc->isupport( "chanmodes_list" ), [qw( beI k l imnpsta )], 'ISUPPORT chanmodes_list is [qw( beI k l imnpsta )]' ); done_testing; package TestIRC; use base qw( Protocol::IRC::Client ); sub new { return bless {}, shift } Protocol-IRC-0.12/t/22client-chanmodes.t000444001750001750 1312413056415115 16561 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; my $CRLF = "\x0d\x0a"; # because \r\n isn't portable my @messages; my $irc = TestIRC->new; sub write_irc { my $line = $_[0]; $irc->on_read( $line ); length $line == 0 or die '$irc failed to read all of the line'; } ok( defined $irc, 'defined $irc' ); write_irc( ':irc.example.com 005 MyNick NAMESX PREFIX=(ohv)@%+ CHANMODES=beI,k,l,imnpst :are supported by this server' . $CRLF ); undef @messages; write_irc( ':Someone!theiruser@their.host MODE #chan +i' . $CRLF ); my ( $command, $msg, $hints ); my $modes; ( $command, $msg, $hints ) = @{ shift @messages }; is( $msg->command, "MODE", '$msg->command for +i' ); is( $msg->prefix, 'Someone!theiruser@their.host', '$msg->prefix for +i' ); is_deeply( [ $msg->args ], [ "#chan", "+i" ], '$msg->args for +i' ); is_deeply( $hints, { prefix_nick => "Someone", prefix_nick_folded => "someone", prefix_user => "theiruser", prefix_host => "their.host", prefix_name => "Someone", prefix_name_folded => "someone", prefix_is_me => '', target_name => "#chan", target_name_folded => "#chan", target_is_me => '', target_type => "channel", modechars => "+i", modeargs => [ ], modes => [ { type => 'bool', sense => 1, mode => "i" } ], handled => 1 }, '$hints for +i' ); write_irc( ':Someone!theiruser@their.host MODE #chan -i' . $CRLF ); ( $command, $msg, $hints ) = @{ shift @messages }; $modes = $hints->{modes}; is_deeply( $modes, [ { type => 'bool', sense => -1, mode => "i" } ], '$modes for -i' ); write_irc( ':Someone!theiruser@their.host MODE #chan +b *!bad@bad.host' . $CRLF ); ( $command, $msg, $hints ) = @{ shift @messages }; $modes = $hints->{modes}; is_deeply( $modes, [ { type => 'list', sense => 1, mode => "b", value => "*!bad\@bad.host" } ], '$modes for +b ...' ); write_irc( ':Someone!theiruser@their.host MODE #chan -b *!less@bad.host' . $CRLF ); ( $command, $msg, $hints ) = @{ shift @messages }; $modes = $hints->{modes}; is_deeply( $modes, [ { type => 'list', sense => -1, mode => "b", value => "*!less\@bad.host" }, ], '$hints for -b ...' ); write_irc( ':Someone!theiruser@their.host MODE #chan +o OpUser' . $CRLF ); ( $command, $msg, $hints ) = @{ shift @messages }; $modes = $hints->{modes}; is_deeply( $modes, [ { type => 'occupant', sense => 1, mode => "o", flag => '@', nick => "OpUser", nick_folded => "opuser" } ], '$modes[chanmode] for +o OpUser' ); write_irc( ':Someone!theiruser@their.host MODE #chan -o OpUser' . $CRLF ); ( $command, $msg, $hints ) = @{ shift @messages }; $modes = $hints->{modes}; is_deeply( $modes, [ { type => 'occupant', sense => -1, mode => "o", flag => '@', nick => "OpUser", nick_folded => "opuser" } ], '$modes[chanmode] for -o OpUser' ); write_irc( ':Someone!theiruser@their.host MODE #chan +k joinkey' . $CRLF ); ( $command, $msg, $hints ) = @{ shift @messages }; $modes = $hints->{modes}; is_deeply( $modes, [ { type => 'value', sense => 1, mode => "k", value => "joinkey" } ], '$modes[chanmode] for +k joinkey' ); write_irc( ':Someone!theiruser@their.host MODE #chan -k joinkey' . $CRLF ); ( $command, $msg, $hints ) = @{ shift @messages }; $modes = $hints->{modes}; is_deeply( $modes, [ { type => 'value', sense => -1, mode => "k", value => "joinkey" } ], '$modes[chanmode] for -k joinkey' ); write_irc( ':Someone!theiruser@their.host MODE #chan +l 30' . $CRLF ); ( $command, $msg, $hints ) = @{ shift @messages }; $modes = $hints->{modes}; is_deeply( $modes, [ { type => 'value', sense => 1, mode => "l", value => "30" } ], '$modes[chanmode] for +l 30' ); write_irc( ':Someone!theiruser@their.host MODE #chan -l' . $CRLF ); ( $command, $msg, $hints ) = @{ shift @messages }; $modes = $hints->{modes}; is_deeply( $modes, [ { type => 'value', sense => -1, mode => "l" } ], '$modes[chanmode] for -l' ); write_irc( ':Someone!theiruser@their.host MODE #chan +shl HalfOp 123' . $CRLF ); ( $command, $msg, $hints ) = @{ shift @messages }; $modes = $hints->{modes}; is_deeply( $modes, [ { type => 'bool', sense => 1, mode => "s" }, { type => 'occupant', sense => 1, mode => "h", flag => '%', nick => "HalfOp", nick_folded => "halfop" }, { type => 'value', sense => 1, mode => "l", value => "123" } ], '$modes[chanmode] for +shl HalfOp 123' ); write_irc( ':Someone!theiruser@their.host MODE #chan -lh+o HalfOp FullOp' . $CRLF ); ( $command, $msg, $hints ) = @{ shift @messages }; $modes = $hints->{modes}; is_deeply( $modes, [ { type => 'value', sense => -1, mode => "l" }, { type => 'occupant', sense => -1, mode => "h", flag => '%', nick => "HalfOp", nick_folded => "halfop", }, { type => 'occupant', sense => 1, mode => "o", flag => '@', nick => "FullOp", nick_folded => "fullop" } ], '$modes[chanmode] for -lh+o HalfOp FullOp' ); done_testing; package TestIRC; use base qw( Protocol::IRC::Client ); sub new { return bless {}, shift } sub nick { return "MyNick" } sub on_message { my $self = shift; my ( $command, $message, $hints ) = @_; push @messages, [ $command, $message, $hints ]; } Protocol-IRC-0.12/t/23client-cap.t000444001750001750 166413056415115 15352 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; my $CRLF = "\x0d\x0a"; # because \r\n isn't portable my @messages; my $irc = TestIRC->new; sub write_irc { my $line = $_[0]; $irc->on_read( $line ); length $line == 0 or die '$irc failed to read all of the line'; } write_irc( ':irc.example.com CAP * LS :multi-prefix sasl' . $CRLF ); my ( $verb, $msg, $hints ) = @{ shift @messages }; is( $msg->command, "CAP", '$msg->command' ); is( $msg->arg(1), "LS", '$msg->arg' ); is( $verb, "LS", '$verb' ); is( $hints->{verb}, "LS", '$hints->{verb}' ); is_deeply( $hints->{caps}, { "multi-prefix" => 1, "sasl" => 1 }, '$hints->{caps}' ); done_testing; package TestIRC; use base qw( Protocol::IRC::Client ); sub new { return bless {}, shift } sub on_message_cap { my $self = shift; my ( $verb, $message, $hints ) = @_; push @messages, [ $verb, $message, $hints ]; } Protocol-IRC-0.12/t/24client-gates.t000444001750001750 1451313056415115 15730 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; my $CRLF = "\x0d\x0a"; # because \r\n isn't portable my @gates; my @messages; my $irc = TestIRC->new; sub write_irc { my $line = $_[0]; $irc->on_read( $line ); length $line == 0 or die '$irc failed to read all of the line'; } # motd { write_irc( ':irc.example.com 375 MyNick :- Here is the Message Of The Day -' . $CRLF ); write_irc( ':irc.example.com 372 MyNick :- some more of the message -' . $CRLF ); write_irc( ':irc.example.com 376 MyNick :End of /MOTD command.' . $CRLF ); my ( $kind, $gate, $message, $hints, $data ) = @{ shift @gates }; is( $kind, "done", 'Gate $kind is done' ); is( $gate, "motd", 'Gate $gate is motd' ); is( ref $data, "ARRAY", 'Gate $data is an ARRAY' ); ( my $command, $message, $hints ) = @{ shift @messages }; is_deeply( $hints->{motd}, [ '- Here is the Message Of The Day -', '- some more of the message -', ], '$hints->{motd}' ); } # names { my $f = $irc->next_gate_future( names => "#channel" ); write_irc( ':irc.example.com 353 MyNick = #channel :@Some +Users Here' . $CRLF ); write_irc( ':irc.example.com 366 MyNick #channel :End of NAMES list' . $CRLF ); my ( $kind, $gate, $message, $hints, $data ) = @{ shift @gates }; is( $kind, "done", 'Gate $kind is done' ); is( $gate, "names", 'Gate $gate is names' ); is( ref $data, "ARRAY", 'Gate $data is an ARRAY' ); ( my $command, $message, $hints ) = @{ shift @messages }; is( $hints->{target_name}, "#channel", '$hints->{target_name}' ); is_deeply( $hints->{names}, { some => { nick => "Some", flag => '@' }, users => { nick => "Users", flag => '+' }, here => { nick => "Here", flag => '' }, }, '$hints->{names}' ); ok( $f->is_ready, '$f is now ready' ); is_deeply( [ $f->get ], [ $message, $hints, $data ], '$f->get' ); } # bans { write_irc( ':irc.example.com 367 MyNick #channel a*!a@a.com Banner 12345' . $CRLF ); write_irc( ':irc.example.com 367 MyNick #channel b*!b@b.com Banner 12346' . $CRLF ); write_irc( ':irc.example.com 368 MyNick #channel :End of BANS' . $CRLF ); my ( $kind, $gate, $message, $hints, $data ) = @{ shift @gates }; is( $kind, "done", 'Gate $kind is done' ); is( $gate, "bans", 'Gate $gate is bans' ); is( ref $data, "ARRAY", 'Gate $data is an ARRAY' ); ( my $command, $message, $hints ) = @{ shift @messages }; is( $hints->{target_name}, "#channel", '$hints->{target_name}' ); is_deeply( $hints->{bans}, [ { mask => 'a*!a@a.com', by_nick => "Banner", by_nick_folded => "banner", timestamp => 12345 }, { mask => 'b*!b@b.com', by_nick => "Banner", by_nick_folded => "banner", timestamp => 12346 }, ], '$hints->{bans}' ); } # who { write_irc( ':irc.example.com 352 MyNick #channel ident host.com irc.example.com OtherNick H@ :2 hops Real Name' . $CRLF ); write_irc( ':irc.example.com 315 MyNick #channel :End of WHO' . $CRLF ); my ( $kind, $gate, $message, $hints, $data ) = @{ shift @gates }; is( $kind, "done", 'Gate $kind is done' ); is( $gate, "who", 'Gate $gate is who' ); is( ref $data, "ARRAY", 'Gate $data is an ARRAY' ); ( my $command, $message, $hints ) = @{ shift @messages }; is( $hints->{target_name}, "#channel", '$hints->{target_name}' ); is_deeply( $hints->{who}, [ { user_nick => "OtherNick", user_nick_folded => "othernick", user_ident => "ident", user_host => "host.com", user_server => "irc.example.com", user_flags => 'H@', } ], '$hints->{who}' ); } # whois { write_irc( ':irc.example.com 311 MyNick UserNick ident host.com * :Real Name Here' . $CRLF ); write_irc( ':irc.example.com 312 MyNick UserNick irc.example.com :IRC Server for Unit Tests' . $CRLF ); write_irc( ':irc.example.com 319 MyNick UserNick :#channel #names #here' . $CRLF ); write_irc( ':irc.example.com 319 MyNick UserNick :#more #channels' . $CRLF ); write_irc( ':irc.example.com 318 MyNick UserNick :End of WHOIS' . $CRLF ); my ( $kind, $gate, $message, $hints, $data ) = @{ shift @gates }; is( $kind, "done", 'Gate $kind is done' ); is( $gate, "whois", 'Gate $gate is whois' ); is( ref $data, "ARRAY", 'Gate $data is an ARRAY' ); ( my $command, $message, $hints ) = @{ shift @messages }; is( $hints->{target_name}, "UserNick", '$hints->{target_name}' ); is_deeply( $hints->{whois}, [ { whois => "user", ident => "ident", host => "host.com", flags => "*", realname => "Real Name Here" }, { whois => "server", server => "irc.example.com", serverinfo => "IRC Server for Unit Tests" }, { whois => "channels", channels => [ "#channel", "#names", "#here", "#more", "#channels" ] }, ], '$hints->{whois}' ); } # join { write_irc( ':MyNick!myuser@myhost.com JOIN #newchannel' . $CRLF ); my ( $kind, $gate, $message, $hints, $data ) = @{ shift @gates }; is( $kind, "done", 'Gate $kind is done' ); is( $gate, "join", 'Gate $gate is join' ); is( $hints->{target_name}, "#newchannel", '$hints->{target_name}' ); ok( $hints->{prefix_is_me}, '$hints->{prefix_is_me}' ); shift @messages; } # join fails { write_irc( ':irc.example.com 473 MyNick #private :That channel is invite-only' . $CRLF ); my ( $kind, $gate, $message, $hints, $data ) = @{ shift @gates }; is( $kind, "fail", 'Gate $kind is fail' ); is( $gate, "join", 'Gate $gate is join' ); is( $hints->{target_name}, "#private", '$hints->{target_name}' ); } done_testing; package TestIRC; use base qw( Protocol::IRC::Client ); use Future; sub new { return bless {}, shift } sub new_future { return Future->new } sub nick { "MyNick" } sub on_message { my $self = shift; my ( $command, $message, $hints ) = @_; die "$command MESSAGE UNSYNTHESIZED BUT UNHANLDED" if !$hints->{synthesized} and !$hints->{handled}; return 0 unless $hints->{synthesized}; push @messages, [ $command, $message, $hints ]; return 1; } sub on_gate { my $self = shift; push @gates, [ @_ ]; } Protocol-IRC-0.12/t/25client-commands.t000444001750001750 230113056415115 16377 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; my @written; my $irc = TestIRC->new; # PRIVMSG { $irc->do_PRIVMSG( target => "#channel", text => "message 1" ); is( shift @written, "PRIVMSG #channel :message 1", 'do_PRIVMSG renames target' ); $irc->do_PRIVMSG( targets => "#channel", text => "message 2" ); is( shift @written, "PRIVMSG #channel :message 2", 'do_PRIVMSG preserves targets' ); $irc->do_PRIVMSG( targets => [ "#a", "#b" ], text => "message 3" ); is( shift @written, "PRIVMSG #a,#b :message 3", 'do_PRIVMSG joins targets ARRAY' ); } # NOTICE { $irc->do_NOTICE( target => "#channel", text => "message 1" ); is( shift @written, "NOTICE #channel :message 1", 'do_NOTICE renames target' ); $irc->do_NOTICE( targets => "#channel", text => "message 2" ); is( shift @written, "NOTICE #channel :message 2", 'do_NOTICE preserves targets' ); $irc->do_NOTICE( targets => [ "#a", "#b" ], text => "message 3" ); is( shift @written, "NOTICE #a,#b :message 3", 'do_NOTICE joins targets ARRAY' ); } done_testing; package TestIRC; use base qw( Protocol::IRC::Client ); sub new { return bless {}, shift } sub write { $_[1] =~ s/\x0d\x0a$//; push @written, $_[1] } Protocol-IRC-0.12/t/99pod.t000444001750001750 25713056415115 14107 0ustar00leoleo000000000000#!/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();